1 /* Ada language support routines for GDB, the GNU debugger. Copyright
2 1992, 1993, 1994, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
4 This file is part of GDB.
6 This program is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2 of the License, or
9 (at your option) any later version.
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with this program; if not, write to the Free Software
18 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
21 #include "gdb_string.h"
29 #include "expression.h"
30 #include "parser-defs.h"
36 #include "breakpoint.h"
43 struct cleanup
*unresolved_names
;
45 void extract_string (CORE_ADDR addr
, char *buf
);
47 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
49 static void modify_general_field (char *, LONGEST
, int, int);
51 static struct type
*desc_base_type (struct type
*);
53 static struct type
*desc_bounds_type (struct type
*);
55 static struct value
*desc_bounds (struct value
*);
57 static int fat_pntr_bounds_bitpos (struct type
*);
59 static int fat_pntr_bounds_bitsize (struct type
*);
61 static struct type
*desc_data_type (struct type
*);
63 static struct value
*desc_data (struct value
*);
65 static int fat_pntr_data_bitpos (struct type
*);
67 static int fat_pntr_data_bitsize (struct type
*);
69 static struct value
*desc_one_bound (struct value
*, int, int);
71 static int desc_bound_bitpos (struct type
*, int, int);
73 static int desc_bound_bitsize (struct type
*, int, int);
75 static struct type
*desc_index_type (struct type
*, int);
77 static int desc_arity (struct type
*);
79 static int ada_type_match (struct type
*, struct type
*, int);
81 static int ada_args_match (struct symbol
*, struct value
**, int);
83 static struct value
*place_on_stack (struct value
*, CORE_ADDR
*);
85 static struct value
*convert_actual (struct value
*, struct type
*,
88 static struct value
*make_array_descriptor (struct type
*, struct value
*,
91 static void ada_add_block_symbols (struct block
*, const char *,
92 namespace_enum
, struct objfile
*, int);
94 static void fill_in_ada_prototype (struct symbol
*);
96 static int is_nonfunction (struct symbol
**, int);
98 static void add_defn_to_vec (struct symbol
*, struct block
*);
100 static struct partial_symbol
*ada_lookup_partial_symbol (struct partial_symtab
101 *, const char *, int,
102 namespace_enum
, int);
104 static struct symtab
*symtab_for_sym (struct symbol
*);
106 static struct value
*ada_resolve_subexp (struct expression
**, int *, int,
109 static void replace_operator_with_call (struct expression
**, int, int, int,
110 struct symbol
*, struct block
*);
112 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
114 static const char *ada_op_name (enum exp_opcode
);
116 static int numeric_type_p (struct type
*);
118 static int integer_type_p (struct type
*);
120 static int scalar_type_p (struct type
*);
122 static int discrete_type_p (struct type
*);
124 static char *extended_canonical_line_spec (struct symtab_and_line
,
127 static struct value
*evaluate_subexp (struct type
*, struct expression
*,
130 static struct value
*evaluate_subexp_type (struct expression
*, int *);
132 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
134 static int is_dynamic_field (struct type
*, int);
136 static struct type
*to_fixed_variant_branch_type (struct type
*, char *,
137 CORE_ADDR
, struct value
*);
139 static struct type
*to_fixed_range_type (char *, struct value
*,
142 static struct type
*to_static_fixed_type (struct type
*);
144 static struct value
*unwrap_value (struct value
*);
146 static struct type
*packed_array_type (struct type
*, long *);
148 static struct type
*decode_packed_array_type (struct type
*);
150 static struct value
*decode_packed_array (struct value
*);
152 static struct value
*value_subscript_packed (struct value
*, int,
155 static struct value
*coerce_unspec_val_to_type (struct value
*, long,
158 static struct value
*get_var_value (char *, char *);
160 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
162 static int equiv_types (struct type
*, struct type
*);
164 static int is_name_suffix (const char *);
166 static int wild_match (const char *, int, const char *);
168 static struct symtabs_and_lines
find_sal_from_funcs_and_line (const char *,
173 static int find_line_in_linetable (struct linetable
*, int, struct symbol
**,
176 static int find_next_line_in_linetable (struct linetable
*, int, int, int);
178 static struct symtabs_and_lines
all_sals_for_line (const char *, int,
181 static void read_all_symtabs (const char *);
183 static int is_plausible_func_for_line (struct symbol
*, int);
185 static struct value
*ada_coerce_ref (struct value
*);
187 static struct value
*value_pos_atr (struct value
*);
189 static struct value
*value_val_atr (struct type
*, struct value
*);
191 static struct symbol
*standard_lookup (const char *, namespace_enum
);
193 extern void markTimeStart (int index
);
194 extern void markTimeStop (int index
);
198 /* Maximum-sized dynamic type. */
199 static unsigned int varsize_limit
;
201 static const char *ada_completer_word_break_characters
=
202 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
204 /* The name of the symbol to use to get the name of the main subprogram */
205 #define ADA_MAIN_PROGRAM_SYMBOL_NAME "__gnat_ada_main_program_name"
211 * read the string located at ADDR from the inferior and store the
215 extract_string (CORE_ADDR addr
, char *buf
)
219 /* Loop, reading one byte at a time, until we reach the '\000'
220 end-of-string marker */
223 target_read_memory (addr
+ char_index
* sizeof (char),
224 buf
+ char_index
* sizeof (char), sizeof (char));
227 while (buf
[char_index
- 1] != '\000');
230 /* Assuming *OLD_VECT points to an array of *SIZE objects of size
231 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
232 updating *OLD_VECT and *SIZE as necessary. */
235 grow_vect (void **old_vect
, size_t * size
, size_t min_size
, int element_size
)
237 if (*size
< min_size
)
240 if (*size
< min_size
)
242 *old_vect
= xrealloc (*old_vect
, *size
* element_size
);
246 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
247 suffix of FIELD_NAME beginning "___" */
250 field_name_match (const char *field_name
, const char *target
)
252 int len
= strlen (target
);
254 STREQN (field_name
, target
, len
)
255 && (field_name
[len
] == '\0'
256 || (STREQN (field_name
+ len
, "___", 3)
257 && !STREQ (field_name
+ strlen (field_name
) - 6, "___XVN")));
261 /* The length of the prefix of NAME prior to any "___" suffix. */
264 ada_name_prefix_len (const char *name
)
270 const char *p
= strstr (name
, "___");
272 return strlen (name
);
278 /* SUFFIX is a suffix of STR. False if STR is null. */
280 is_suffix (const char *str
, const char *suffix
)
286 len2
= strlen (suffix
);
287 return (len1
>= len2
&& STREQ (str
+ len1
- len2
, suffix
));
290 /* Create a value of type TYPE whose contents come from VALADDR, if it
291 * is non-null, and whose memory address (in the inferior) is
294 value_from_contents_and_address (struct type
*type
, char *valaddr
,
297 struct value
*v
= allocate_value (type
);
301 memcpy (VALUE_CONTENTS_RAW (v
), valaddr
, TYPE_LENGTH (type
));
302 VALUE_ADDRESS (v
) = address
;
304 VALUE_LVAL (v
) = lval_memory
;
308 /* The contents of value VAL, beginning at offset OFFSET, treated as a
309 value of type TYPE. The result is an lval in memory if VAL is. */
311 static struct value
*
312 coerce_unspec_val_to_type (struct value
*val
, long offset
, struct type
*type
)
314 CHECK_TYPEDEF (type
);
315 if (VALUE_LVAL (val
) == lval_memory
)
316 return value_at_lazy (type
,
317 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
) + offset
,
321 struct value
*result
= allocate_value (type
);
322 VALUE_LVAL (result
) = not_lval
;
323 if (VALUE_ADDRESS (val
) == 0)
324 memcpy (VALUE_CONTENTS_RAW (result
), VALUE_CONTENTS (val
) + offset
,
325 TYPE_LENGTH (type
) > TYPE_LENGTH (VALUE_TYPE (val
))
326 ? TYPE_LENGTH (VALUE_TYPE (val
)) : TYPE_LENGTH (type
));
329 VALUE_ADDRESS (result
) =
330 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
) + offset
;
331 VALUE_LAZY (result
) = 1;
338 cond_offset_host (char *valaddr
, long offset
)
343 return valaddr
+ offset
;
347 cond_offset_target (CORE_ADDR address
, long offset
)
352 return address
+ offset
;
355 /* Perform execute_command on the result of concatenating all
356 arguments up to NULL. */
358 do_command (const char *arg
, ...)
369 for (; s
!= NULL
; s
= va_arg (ap
, const char *))
373 cmd1
= alloca (len
+ 1);
379 execute_command (cmd
, 0);
383 /* Language Selection */
385 /* If the main program is in Ada, return language_ada, otherwise return LANG
386 (the main program is in Ada iif the adainit symbol is found).
388 MAIN_PST is not used. */
391 ada_update_initial_language (enum language lang
,
392 struct partial_symtab
*main_pst
)
394 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
395 (struct objfile
*) NULL
) != NULL
)
396 /* return language_ada; */
397 /* FIXME: language_ada should be defined in defs.h */
398 return language_unknown
;
406 /* Table of Ada operators and their GNAT-mangled names. Last entry is pair
409 const struct ada_opname_map ada_opname_table
[] = {
410 {"Oadd", "\"+\"", BINOP_ADD
},
411 {"Osubtract", "\"-\"", BINOP_SUB
},
412 {"Omultiply", "\"*\"", BINOP_MUL
},
413 {"Odivide", "\"/\"", BINOP_DIV
},
414 {"Omod", "\"mod\"", BINOP_MOD
},
415 {"Orem", "\"rem\"", BINOP_REM
},
416 {"Oexpon", "\"**\"", BINOP_EXP
},
417 {"Olt", "\"<\"", BINOP_LESS
},
418 {"Ole", "\"<=\"", BINOP_LEQ
},
419 {"Ogt", "\">\"", BINOP_GTR
},
420 {"Oge", "\">=\"", BINOP_GEQ
},
421 {"Oeq", "\"=\"", BINOP_EQUAL
},
422 {"One", "\"/=\"", BINOP_NOTEQUAL
},
423 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
424 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
425 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
426 {"Oconcat", "\"&\"", BINOP_CONCAT
},
427 {"Oabs", "\"abs\"", UNOP_ABS
},
428 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
429 {"Oadd", "\"+\"", UNOP_PLUS
},
430 {"Osubtract", "\"-\"", UNOP_NEG
},
434 /* True if STR should be suppressed in info listings. */
436 is_suppressed_name (const char *str
)
438 if (STREQN (str
, "_ada_", 5))
440 if (str
[0] == '_' || str
[0] == '\000')
445 const char *suffix
= strstr (str
, "___");
446 if (suffix
!= NULL
&& suffix
[3] != 'X')
449 suffix
= str
+ strlen (str
);
450 for (p
= suffix
- 1; p
!= str
; p
-= 1)
454 if (p
[0] == 'X' && p
[-1] != '_')
458 for (i
= 0; ada_opname_table
[i
].mangled
!= NULL
; i
+= 1)
459 if (STREQN (ada_opname_table
[i
].mangled
, p
,
460 strlen (ada_opname_table
[i
].mangled
)))
469 /* The "mangled" form of DEMANGLED, according to GNAT conventions.
470 * The result is valid until the next call to ada_mangle. */
472 ada_mangle (const char *demangled
)
474 static char *mangling_buffer
= NULL
;
475 static size_t mangling_buffer_size
= 0;
479 if (demangled
== NULL
)
482 GROW_VECT (mangling_buffer
, mangling_buffer_size
,
483 2 * strlen (demangled
) + 10);
486 for (p
= demangled
; *p
!= '\0'; p
+= 1)
490 mangling_buffer
[k
] = mangling_buffer
[k
+ 1] = '_';
495 const struct ada_opname_map
*mapping
;
497 for (mapping
= ada_opname_table
;
498 mapping
->mangled
!= NULL
&&
499 !STREQN (mapping
->demangled
, p
, strlen (mapping
->demangled
));
502 if (mapping
->mangled
== NULL
)
503 error ("invalid Ada operator name: %s", p
);
504 strcpy (mangling_buffer
+ k
, mapping
->mangled
);
505 k
+= strlen (mapping
->mangled
);
510 mangling_buffer
[k
] = *p
;
515 mangling_buffer
[k
] = '\0';
516 return mangling_buffer
;
519 /* Return NAME folded to lower case, or, if surrounded by single
520 * quotes, unfolded, but with the quotes stripped away. Result good
523 ada_fold_name (const char *name
)
525 static char *fold_buffer
= NULL
;
526 static size_t fold_buffer_size
= 0;
528 int len
= strlen (name
);
529 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
533 strncpy (fold_buffer
, name
+ 1, len
- 2);
534 fold_buffer
[len
- 2] = '\000';
539 for (i
= 0; i
<= len
; i
+= 1)
540 fold_buffer
[i
] = tolower (name
[i
]);
547 1. Discard final __{DIGIT}+ or ${DIGIT}+
548 2. Convert other instances of embedded "__" to `.'.
549 3. Discard leading _ada_.
550 4. Convert operator names to the appropriate quoted symbols.
551 5. Remove everything after first ___ if it is followed by
553 6. Replace TK__ with __, and a trailing B or TKB with nothing.
554 7. Put symbols that should be suppressed in <...> brackets.
555 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
556 The resulting string is valid until the next call of ada_demangle.
560 ada_demangle (const char *mangled
)
567 static char *demangling_buffer
= NULL
;
568 static size_t demangling_buffer_size
= 0;
570 if (STREQN (mangled
, "_ada_", 5))
573 if (mangled
[0] == '_' || mangled
[0] == '<')
576 p
= strstr (mangled
, "___");
578 len0
= strlen (mangled
);
586 if (len0
> 3 && STREQ (mangled
+ len0
- 3, "TKB"))
588 if (len0
> 1 && STREQ (mangled
+ len0
- 1, "B"))
591 /* Make demangled big enough for possible expansion by operator name. */
592 GROW_VECT (demangling_buffer
, demangling_buffer_size
, 2 * len0
+ 1);
593 demangled
= demangling_buffer
;
595 if (isdigit (mangled
[len0
- 1]))
597 for (i
= len0
- 2; i
>= 0 && isdigit (mangled
[i
]); i
-= 1)
599 if (i
> 1 && mangled
[i
] == '_' && mangled
[i
- 1] == '_')
601 else if (mangled
[i
] == '$')
605 for (i
= 0, j
= 0; i
< len0
&& !isalpha (mangled
[i
]); i
+= 1, j
+= 1)
606 demangled
[j
] = mangled
[i
];
611 if (at_start_name
&& mangled
[i
] == 'O')
614 for (k
= 0; ada_opname_table
[k
].mangled
!= NULL
; k
+= 1)
616 int op_len
= strlen (ada_opname_table
[k
].mangled
);
618 (ada_opname_table
[k
].mangled
+ 1, mangled
+ i
+ 1,
619 op_len
- 1) && !isalnum (mangled
[i
+ op_len
]))
621 strcpy (demangled
+ j
, ada_opname_table
[k
].demangled
);
624 j
+= strlen (ada_opname_table
[k
].demangled
);
628 if (ada_opname_table
[k
].mangled
!= NULL
)
633 if (i
< len0
- 4 && STREQN (mangled
+ i
, "TK__", 4))
635 if (mangled
[i
] == 'X' && i
!= 0 && isalnum (mangled
[i
- 1]))
639 while (i
< len0
&& (mangled
[i
] == 'b' || mangled
[i
] == 'n'));
643 else if (i
< len0
- 2 && mangled
[i
] == '_' && mangled
[i
+ 1] == '_')
652 demangled
[j
] = mangled
[i
];
657 demangled
[j
] = '\000';
659 for (i
= 0; demangled
[i
] != '\0'; i
+= 1)
660 if (isupper (demangled
[i
]) || demangled
[i
] == ' ')
666 GROW_VECT (demangling_buffer
, demangling_buffer_size
, strlen (mangled
) + 3);
667 demangled
= demangling_buffer
;
668 if (mangled
[0] == '<')
669 strcpy (demangled
, mangled
);
671 sprintf (demangled
, "<%s>", mangled
);
676 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
677 * suffixes that encode debugging information or leading _ada_ on
678 * SYM_NAME (see is_name_suffix commentary for the debugging
679 * information that is ignored). If WILD, then NAME need only match a
680 * suffix of SYM_NAME minus the same suffixes. Also returns 0 if
681 * either argument is NULL. */
684 ada_match_name (const char *sym_name
, const char *name
, int wild
)
686 if (sym_name
== NULL
|| name
== NULL
)
689 return wild_match (name
, strlen (name
), sym_name
);
692 int len_name
= strlen (name
);
693 return (STREQN (sym_name
, name
, len_name
)
694 && is_name_suffix (sym_name
+ len_name
))
695 || (STREQN (sym_name
, "_ada_", 5)
696 && STREQN (sym_name
+ 5, name
, len_name
)
697 && is_name_suffix (sym_name
+ len_name
+ 5));
701 /* True (non-zero) iff in Ada mode, the symbol SYM should be
702 suppressed in info listings. */
705 ada_suppress_symbol_printing (struct symbol
*sym
)
707 if (SYMBOL_NAMESPACE (sym
) == STRUCT_NAMESPACE
)
710 return is_suppressed_name (SYMBOL_NAME (sym
));
716 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of
717 array descriptors. */
719 static char *bound_name
[] = {
720 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
721 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
724 /* Maximum number of array dimensions we are prepared to handle. */
726 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char*)))
728 /* Like modify_field, but allows bitpos > wordlength. */
731 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
733 modify_field (addr
+ sizeof (LONGEST
) * bitpos
/ (8 * sizeof (LONGEST
)),
734 fieldval
, bitpos
% (8 * sizeof (LONGEST
)), bitsize
);
738 /* The desc_* routines return primitive portions of array descriptors
741 /* The descriptor or array type, if any, indicated by TYPE; removes
742 level of indirection, if needed. */
744 desc_base_type (struct type
*type
)
748 CHECK_TYPEDEF (type
);
749 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_PTR
)
750 return check_typedef (TYPE_TARGET_TYPE (type
));
755 /* True iff TYPE indicates a "thin" array pointer type. */
757 is_thin_pntr (struct type
*type
)
760 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
761 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
764 /* The descriptor type for thin pointer type TYPE. */
766 thin_descriptor_type (struct type
*type
)
768 struct type
*base_type
= desc_base_type (type
);
769 if (base_type
== NULL
)
771 if (is_suffix (ada_type_name (base_type
), "___XVE"))
775 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
776 if (alt_type
== NULL
)
783 /* A pointer to the array data for thin-pointer value VAL. */
784 static struct value
*
785 thin_data_pntr (struct value
*val
)
787 struct type
*type
= VALUE_TYPE (val
);
788 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
789 return value_cast (desc_data_type (thin_descriptor_type (type
)),
792 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
793 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
));
796 /* True iff TYPE indicates a "thick" array pointer type. */
798 is_thick_pntr (struct type
*type
)
800 type
= desc_base_type (type
);
801 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
802 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
805 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
806 pointer to one, the type of its bounds data; otherwise, NULL. */
808 desc_bounds_type (struct type
*type
)
812 type
= desc_base_type (type
);
816 else if (is_thin_pntr (type
))
818 type
= thin_descriptor_type (type
);
821 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
823 return check_typedef (r
);
825 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
827 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
829 return check_typedef (TYPE_TARGET_TYPE (check_typedef (r
)));
834 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
835 one, a pointer to its bounds data. Otherwise NULL. */
836 static struct value
*
837 desc_bounds (struct value
*arr
)
839 struct type
*type
= check_typedef (VALUE_TYPE (arr
));
840 if (is_thin_pntr (type
))
842 struct type
*bounds_type
=
843 desc_bounds_type (thin_descriptor_type (type
));
846 if (desc_bounds_type
== NULL
)
847 error ("Bad GNAT array descriptor");
849 /* NOTE: The following calculation is not really kosher, but
850 since desc_type is an XVE-encoded type (and shouldn't be),
851 the correct calculation is a real pain. FIXME (and fix GCC). */
852 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
853 addr
= value_as_long (arr
);
855 addr
= VALUE_ADDRESS (arr
) + VALUE_OFFSET (arr
);
858 value_from_longest (lookup_pointer_type (bounds_type
),
859 addr
- TYPE_LENGTH (bounds_type
));
862 else if (is_thick_pntr (type
))
863 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
864 "Bad GNAT array descriptor");
869 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
870 position of the field containing the address of the bounds data. */
872 fat_pntr_bounds_bitpos (struct type
*type
)
874 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
877 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
878 size of the field containing the address of the bounds data. */
880 fat_pntr_bounds_bitsize (struct type
*type
)
882 type
= desc_base_type (type
);
884 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
885 return TYPE_FIELD_BITSIZE (type
, 1);
887 return 8 * TYPE_LENGTH (check_typedef (TYPE_FIELD_TYPE (type
, 1)));
890 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
891 pointer to one, the type of its array data (a
892 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
893 ada_type_of_array to get an array type with bounds data. */
895 desc_data_type (struct type
*type
)
897 type
= desc_base_type (type
);
899 /* NOTE: The following is bogus; see comment in desc_bounds. */
900 if (is_thin_pntr (type
))
901 return lookup_pointer_type
902 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
903 else if (is_thick_pntr (type
))
904 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
909 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
911 static struct value
*
912 desc_data (struct value
*arr
)
914 struct type
*type
= VALUE_TYPE (arr
);
915 if (is_thin_pntr (type
))
916 return thin_data_pntr (arr
);
917 else if (is_thick_pntr (type
))
918 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
919 "Bad GNAT array descriptor");
925 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
926 position of the field containing the address of the data. */
928 fat_pntr_data_bitpos (struct type
*type
)
930 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
933 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
934 size of the field containing the address of the data. */
936 fat_pntr_data_bitsize (struct type
*type
)
938 type
= desc_base_type (type
);
940 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
941 return TYPE_FIELD_BITSIZE (type
, 0);
943 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
946 /* If BOUNDS is an array-bounds structure (or pointer to one), return
947 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
948 bound, if WHICH is 1. The first bound is I=1. */
949 static struct value
*
950 desc_one_bound (struct value
*bounds
, int i
, int which
)
952 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
953 "Bad GNAT array descriptor bounds");
956 /* If BOUNDS is an array-bounds structure type, return the bit position
957 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
958 bound, if WHICH is 1. The first bound is I=1. */
960 desc_bound_bitpos (struct type
*type
, int i
, int which
)
962 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
965 /* If BOUNDS is an array-bounds structure type, return the bit field size
966 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
967 bound, if WHICH is 1. The first bound is I=1. */
969 desc_bound_bitsize (struct type
*type
, int i
, int which
)
971 type
= desc_base_type (type
);
973 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
974 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
976 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
979 /* If TYPE is the type of an array-bounds structure, the type of its
980 Ith bound (numbering from 1). Otherwise, NULL. */
982 desc_index_type (struct type
*type
, int i
)
984 type
= desc_base_type (type
);
986 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
987 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
992 /* The number of index positions in the array-bounds type TYPE. 0
995 desc_arity (struct type
*type
)
997 type
= desc_base_type (type
);
1000 return TYPE_NFIELDS (type
) / 2;
1005 /* Non-zero iff type is a simple array type (or pointer to one). */
1007 ada_is_simple_array (struct type
*type
)
1011 CHECK_TYPEDEF (type
);
1012 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1013 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1014 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1017 /* Non-zero iff type belongs to a GNAT array descriptor. */
1019 ada_is_array_descriptor (struct type
*type
)
1021 struct type
*data_type
= desc_data_type (type
);
1025 CHECK_TYPEDEF (type
);
1028 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1029 && TYPE_TARGET_TYPE (data_type
) != NULL
1030 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1032 TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1033 && desc_arity (desc_bounds_type (type
)) > 0;
1036 /* Non-zero iff type is a partially mal-formed GNAT array
1037 descriptor. (FIXME: This is to compensate for some problems with
1038 debugging output from GNAT. Re-examine periodically to see if it
1041 ada_is_bogus_array_descriptor (struct type
*type
)
1045 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1046 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1047 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1048 && !ada_is_array_descriptor (type
);
1052 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1053 (fat pointer) returns the type of the array data described---specifically,
1054 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1055 in from the descriptor; otherwise, they are left unspecified. If
1056 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1057 returns NULL. The result is simply the type of ARR if ARR is not
1060 ada_type_of_array (struct value
*arr
, int bounds
)
1062 if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1063 return decode_packed_array_type (VALUE_TYPE (arr
));
1065 if (!ada_is_array_descriptor (VALUE_TYPE (arr
)))
1066 return VALUE_TYPE (arr
);
1070 check_typedef (TYPE_TARGET_TYPE (desc_data_type (VALUE_TYPE (arr
))));
1073 struct type
*elt_type
;
1075 struct value
*descriptor
;
1076 struct objfile
*objf
= TYPE_OBJFILE (VALUE_TYPE (arr
));
1078 elt_type
= ada_array_element_type (VALUE_TYPE (arr
), -1);
1079 arity
= ada_array_arity (VALUE_TYPE (arr
));
1081 if (elt_type
== NULL
|| arity
== 0)
1082 return check_typedef (VALUE_TYPE (arr
));
1084 descriptor
= desc_bounds (arr
);
1085 if (value_as_long (descriptor
) == 0)
1089 struct type
*range_type
= alloc_type (objf
);
1090 struct type
*array_type
= alloc_type (objf
);
1091 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1092 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1095 create_range_type (range_type
, VALUE_TYPE (low
),
1096 (int) value_as_long (low
),
1097 (int) value_as_long (high
));
1098 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1101 return lookup_pointer_type (elt_type
);
1105 /* If ARR does not represent an array, returns ARR unchanged.
1106 Otherwise, returns either a standard GDB array with bounds set
1107 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1108 GDB array. Returns NULL if ARR is a null fat pointer. */
1110 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1112 if (ada_is_array_descriptor (VALUE_TYPE (arr
)))
1114 struct type
*arrType
= ada_type_of_array (arr
, 1);
1115 if (arrType
== NULL
)
1117 return value_cast (arrType
, value_copy (desc_data (arr
)));
1119 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1120 return decode_packed_array (arr
);
1125 /* If ARR does not represent an array, returns ARR unchanged.
1126 Otherwise, returns a standard GDB array describing ARR (which may
1127 be ARR itself if it already is in the proper form). */
1129 ada_coerce_to_simple_array (struct value
*arr
)
1131 if (ada_is_array_descriptor (VALUE_TYPE (arr
)))
1133 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1135 error ("Bounds unavailable for null array pointer.");
1136 return value_ind (arrVal
);
1138 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1139 return decode_packed_array (arr
);
1144 /* If TYPE represents a GNAT array type, return it translated to an
1145 ordinary GDB array type (possibly with BITSIZE fields indicating
1146 packing). For other types, is the identity. */
1148 ada_coerce_to_simple_array_type (struct type
*type
)
1150 struct value
*mark
= value_mark ();
1151 struct value
*dummy
= value_from_longest (builtin_type_long
, 0);
1152 struct type
*result
;
1153 VALUE_TYPE (dummy
) = type
;
1154 result
= ada_type_of_array (dummy
, 0);
1155 value_free_to_mark (dummy
);
1159 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1161 ada_is_packed_array_type (struct type
*type
)
1165 CHECK_TYPEDEF (type
);
1167 ada_type_name (type
) != NULL
1168 && strstr (ada_type_name (type
), "___XP") != NULL
;
1171 /* Given that TYPE is a standard GDB array type with all bounds filled
1172 in, and that the element size of its ultimate scalar constituents
1173 (that is, either its elements, or, if it is an array of arrays, its
1174 elements' elements, etc.) is *ELT_BITS, return an identical type,
1175 but with the bit sizes of its elements (and those of any
1176 constituent arrays) recorded in the BITSIZE components of its
1177 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1179 static struct type
*
1180 packed_array_type (struct type
*type
, long *elt_bits
)
1182 struct type
*new_elt_type
;
1183 struct type
*new_type
;
1184 LONGEST low_bound
, high_bound
;
1186 CHECK_TYPEDEF (type
);
1187 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1190 new_type
= alloc_type (TYPE_OBJFILE (type
));
1191 new_elt_type
= packed_array_type (check_typedef (TYPE_TARGET_TYPE (type
)),
1193 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1194 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1195 TYPE_NAME (new_type
) = ada_type_name (type
);
1197 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1198 &low_bound
, &high_bound
) < 0)
1199 low_bound
= high_bound
= 0;
1200 if (high_bound
< low_bound
)
1201 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1204 *elt_bits
*= (high_bound
- low_bound
+ 1);
1205 TYPE_LENGTH (new_type
) =
1206 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1209 /* TYPE_FLAGS (new_type) |= TYPE_FLAG_FIXED_INSTANCE; */
1210 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
1214 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE).
1216 static struct type
*
1217 decode_packed_array_type (struct type
*type
)
1219 struct symbol
**syms
;
1220 struct block
**blocks
;
1221 const char *raw_name
= ada_type_name (check_typedef (type
));
1222 char *name
= (char *) alloca (strlen (raw_name
) + 1);
1223 char *tail
= strstr (raw_name
, "___XP");
1224 struct type
*shadow_type
;
1228 memcpy (name
, raw_name
, tail
- raw_name
);
1229 name
[tail
- raw_name
] = '\000';
1231 /* NOTE: Use ada_lookup_symbol_list because of bug in some versions
1232 * of gcc (Solaris, e.g.). FIXME when compiler is fixed. */
1233 n
= ada_lookup_symbol_list (name
, get_selected_block (NULL
),
1234 VAR_NAMESPACE
, &syms
, &blocks
);
1235 for (i
= 0; i
< n
; i
+= 1)
1236 if (syms
[i
] != NULL
&& SYMBOL_CLASS (syms
[i
]) == LOC_TYPEDEF
1237 && STREQ (name
, ada_type_name (SYMBOL_TYPE (syms
[i
]))))
1241 warning ("could not find bounds information on packed array");
1244 shadow_type
= SYMBOL_TYPE (syms
[i
]);
1246 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1248 warning ("could not understand bounds information on packed array");
1252 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1254 warning ("could not understand bit size information on packed array");
1258 return packed_array_type (shadow_type
, &bits
);
1261 /* Given that ARR is a struct value* indicating a GNAT packed array,
1262 returns a simple array that denotes that array. Its type is a
1263 standard GDB array type except that the BITSIZEs of the array
1264 target types are set to the number of bits in each element, and the
1265 type length is set appropriately. */
1267 static struct value
*
1268 decode_packed_array (struct value
*arr
)
1270 struct type
*type
= decode_packed_array_type (VALUE_TYPE (arr
));
1274 error ("can't unpack array");
1278 return coerce_unspec_val_to_type (arr
, 0, type
);
1282 /* The value of the element of packed array ARR at the ARITY indices
1283 given in IND. ARR must be a simple array. */
1285 static struct value
*
1286 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1289 int bits
, elt_off
, bit_off
;
1290 long elt_total_bit_offset
;
1291 struct type
*elt_type
;
1295 elt_total_bit_offset
= 0;
1296 elt_type
= check_typedef (VALUE_TYPE (arr
));
1297 for (i
= 0; i
< arity
; i
+= 1)
1299 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1300 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1302 ("attempt to do packed indexing of something other than a packed array");
1305 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1306 LONGEST lowerbound
, upperbound
;
1309 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1311 warning ("don't know bounds of array");
1312 lowerbound
= upperbound
= 0;
1315 idx
= value_as_long (value_pos_atr (ind
[i
]));
1316 if (idx
< lowerbound
|| idx
> upperbound
)
1317 warning ("packed array index %ld out of bounds", (long) idx
);
1318 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1319 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1320 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
1323 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1324 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1326 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1328 if (VALUE_LVAL (arr
) == lval_internalvar
)
1329 VALUE_LVAL (v
) = lval_internalvar_component
;
1331 VALUE_LVAL (v
) = VALUE_LVAL (arr
);
1335 /* Non-zero iff TYPE includes negative integer values. */
1338 has_negatives (struct type
*type
)
1340 switch (TYPE_CODE (type
))
1345 return !TYPE_UNSIGNED (type
);
1346 case TYPE_CODE_RANGE
:
1347 return TYPE_LOW_BOUND (type
) < 0;
1352 /* Create a new value of type TYPE from the contents of OBJ starting
1353 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1354 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1355 assigning through the result will set the field fetched from. OBJ
1356 may also be NULL, in which case, VALADDR+OFFSET must address the
1357 start of storage containing the packed value. The value returned
1358 in this case is never an lval.
1359 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1362 ada_value_primitive_packed_val (struct value
*obj
, char *valaddr
, long offset
,
1363 int bit_offset
, int bit_size
,
1367 int src
, /* Index into the source area. */
1368 targ
, /* Index into the target area. */
1369 i
, srcBitsLeft
, /* Number of source bits left to move. */
1370 nsrc
, ntarg
, /* Number of source and target bytes. */
1371 unusedLS
, /* Number of bits in next significant
1372 * byte of source that are unused. */
1373 accumSize
; /* Number of meaningful bits in accum */
1374 unsigned char *bytes
; /* First byte containing data to unpack. */
1375 unsigned char *unpacked
;
1376 unsigned long accum
; /* Staging area for bits being transferred */
1378 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1379 /* Transmit bytes from least to most significant; delta is the
1380 * direction the indices move. */
1381 int delta
= BITS_BIG_ENDIAN
? -1 : 1;
1383 CHECK_TYPEDEF (type
);
1387 v
= allocate_value (type
);
1388 bytes
= (unsigned char *) (valaddr
+ offset
);
1390 else if (VALUE_LAZY (obj
))
1393 VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
, NULL
);
1394 bytes
= (unsigned char *) alloca (len
);
1395 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
1399 v
= allocate_value (type
);
1400 bytes
= (unsigned char *) VALUE_CONTENTS (obj
) + offset
;
1405 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
1406 if (VALUE_LVAL (obj
) == lval_internalvar
)
1407 VALUE_LVAL (v
) = lval_internalvar_component
;
1408 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
;
1409 VALUE_BITPOS (v
) = bit_offset
+ VALUE_BITPOS (obj
);
1410 VALUE_BITSIZE (v
) = bit_size
;
1411 if (VALUE_BITPOS (v
) >= HOST_CHAR_BIT
)
1413 VALUE_ADDRESS (v
) += 1;
1414 VALUE_BITPOS (v
) -= HOST_CHAR_BIT
;
1418 VALUE_BITSIZE (v
) = bit_size
;
1419 unpacked
= (unsigned char *) VALUE_CONTENTS (v
);
1421 srcBitsLeft
= bit_size
;
1423 ntarg
= TYPE_LENGTH (type
);
1427 memset (unpacked
, 0, TYPE_LENGTH (type
));
1430 else if (BITS_BIG_ENDIAN
)
1433 if (has_negatives (type
) &&
1434 ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
1438 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
1441 switch (TYPE_CODE (type
))
1443 case TYPE_CODE_ARRAY
:
1444 case TYPE_CODE_UNION
:
1445 case TYPE_CODE_STRUCT
:
1446 /* Non-scalar values must be aligned at a byte boundary. */
1448 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
1449 /* And are placed at the beginning (most-significant) bytes
1455 targ
= TYPE_LENGTH (type
) - 1;
1461 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
1464 unusedLS
= bit_offset
;
1467 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
1474 /* Mask for removing bits of the next source byte that are not
1475 * part of the value. */
1476 unsigned int unusedMSMask
=
1477 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
1479 /* Sign-extend bits for this byte. */
1480 unsigned int signMask
= sign
& ~unusedMSMask
;
1482 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
1483 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
1484 if (accumSize
>= HOST_CHAR_BIT
)
1486 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1487 accumSize
-= HOST_CHAR_BIT
;
1488 accum
>>= HOST_CHAR_BIT
;
1492 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
1499 accum
|= sign
<< accumSize
;
1500 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1501 accumSize
-= HOST_CHAR_BIT
;
1502 accum
>>= HOST_CHAR_BIT
;
1510 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1511 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
1514 move_bits (char *target
, int targ_offset
, char *source
, int src_offset
, int n
)
1516 unsigned int accum
, mask
;
1517 int accum_bits
, chunk_size
;
1519 target
+= targ_offset
/ HOST_CHAR_BIT
;
1520 targ_offset
%= HOST_CHAR_BIT
;
1521 source
+= src_offset
/ HOST_CHAR_BIT
;
1522 src_offset
%= HOST_CHAR_BIT
;
1523 if (BITS_BIG_ENDIAN
)
1525 accum
= (unsigned char) *source
;
1527 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1532 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
1533 accum_bits
+= HOST_CHAR_BIT
;
1535 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1538 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
1539 mask
= ((1 << chunk_size
) - 1) << unused_right
;
1542 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
1544 accum_bits
-= chunk_size
;
1551 accum
= (unsigned char) *source
>> src_offset
;
1553 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1557 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
1558 accum_bits
+= HOST_CHAR_BIT
;
1560 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1563 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
1564 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
1566 accum_bits
-= chunk_size
;
1567 accum
>>= chunk_size
;
1575 /* Store the contents of FROMVAL into the location of TOVAL.
1576 Return a new value with the location of TOVAL and contents of
1577 FROMVAL. Handles assignment into packed fields that have
1578 floating-point or non-scalar types. */
1580 static struct value
*
1581 ada_value_assign (struct value
*toval
, struct value
*fromval
)
1583 struct type
*type
= VALUE_TYPE (toval
);
1584 int bits
= VALUE_BITSIZE (toval
);
1586 if (!toval
->modifiable
)
1587 error ("Left operand of assignment is not a modifiable lvalue.");
1591 if (VALUE_LVAL (toval
) == lval_memory
1593 && (TYPE_CODE (type
) == TYPE_CODE_FLT
1594 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
1597 (VALUE_BITPOS (toval
) + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1598 char *buffer
= (char *) alloca (len
);
1601 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
1602 fromval
= value_cast (type
, fromval
);
1604 read_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
, len
);
1605 if (BITS_BIG_ENDIAN
)
1606 move_bits (buffer
, VALUE_BITPOS (toval
),
1607 VALUE_CONTENTS (fromval
),
1608 TYPE_LENGTH (VALUE_TYPE (fromval
)) * TARGET_CHAR_BIT
-
1611 move_bits (buffer
, VALUE_BITPOS (toval
), VALUE_CONTENTS (fromval
),
1613 write_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
,
1616 val
= value_copy (toval
);
1617 memcpy (VALUE_CONTENTS_RAW (val
), VALUE_CONTENTS (fromval
),
1618 TYPE_LENGTH (type
));
1619 VALUE_TYPE (val
) = type
;
1624 return value_assign (toval
, fromval
);
1628 /* The value of the element of array ARR at the ARITY indices given in IND.
1629 ARR may be either a simple array, GNAT array descriptor, or pointer
1633 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
1637 struct type
*elt_type
;
1639 elt
= ada_coerce_to_simple_array (arr
);
1641 elt_type
= check_typedef (VALUE_TYPE (elt
));
1642 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
1643 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
1644 return value_subscript_packed (elt
, arity
, ind
);
1646 for (k
= 0; k
< arity
; k
+= 1)
1648 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
1649 error ("too many subscripts (%d expected)", k
);
1650 elt
= value_subscript (elt
, value_pos_atr (ind
[k
]));
1655 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
1656 value of the element of *ARR at the ARITY indices given in
1657 IND. Does not read the entire array into memory. */
1660 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
1665 for (k
= 0; k
< arity
; k
+= 1)
1670 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1671 error ("too many subscripts (%d expected)", k
);
1672 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
1674 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
1678 idx
= value_sub (ind
[k
], value_from_longest (builtin_type_int
, lwb
));
1679 arr
= value_add (arr
, idx
);
1680 type
= TYPE_TARGET_TYPE (type
);
1683 return value_ind (arr
);
1686 /* If type is a record type in the form of a standard GNAT array
1687 descriptor, returns the number of dimensions for type. If arr is a
1688 simple array, returns the number of "array of"s that prefix its
1689 type designation. Otherwise, returns 0. */
1692 ada_array_arity (struct type
*type
)
1699 type
= desc_base_type (type
);
1702 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1703 return desc_arity (desc_bounds_type (type
));
1705 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
1708 type
= check_typedef (TYPE_TARGET_TYPE (type
));
1714 /* If TYPE is a record type in the form of a standard GNAT array
1715 descriptor or a simple array type, returns the element type for
1716 TYPE after indexing by NINDICES indices, or by all indices if
1717 NINDICES is -1. Otherwise, returns NULL. */
1720 ada_array_element_type (struct type
*type
, int nindices
)
1722 type
= desc_base_type (type
);
1724 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1727 struct type
*p_array_type
;
1729 p_array_type
= desc_data_type (type
);
1731 k
= ada_array_arity (type
);
1735 /* Initially p_array_type = elt_type(*)[]...(k times)...[] */
1736 if (nindices
>= 0 && k
> nindices
)
1738 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
1739 while (k
> 0 && p_array_type
!= NULL
)
1741 p_array_type
= check_typedef (TYPE_TARGET_TYPE (p_array_type
));
1744 return p_array_type
;
1746 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
1748 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
1750 type
= TYPE_TARGET_TYPE (type
);
1759 /* The type of nth index in arrays of given type (n numbering from 1). Does
1760 not examine memory. */
1763 ada_index_type (struct type
*type
, int n
)
1765 type
= desc_base_type (type
);
1767 if (n
> ada_array_arity (type
))
1770 if (ada_is_simple_array (type
))
1774 for (i
= 1; i
< n
; i
+= 1)
1775 type
= TYPE_TARGET_TYPE (type
);
1777 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
1780 return desc_index_type (desc_bounds_type (type
), n
);
1783 /* Given that arr is an array type, returns the lower bound of the
1784 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
1785 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1786 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
1787 bounds type. It works for other arrays with bounds supplied by
1788 run-time quantities other than discriminants. */
1791 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
1792 struct type
** typep
)
1795 struct type
*index_type_desc
;
1797 if (ada_is_packed_array_type (arr_type
))
1798 arr_type
= decode_packed_array_type (arr_type
);
1800 if (arr_type
== NULL
|| !ada_is_simple_array (arr_type
))
1803 *typep
= builtin_type_int
;
1804 return (LONGEST
) - which
;
1807 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
1808 type
= TYPE_TARGET_TYPE (arr_type
);
1812 index_type_desc
= ada_find_parallel_type (type
, "___XA");
1813 if (index_type_desc
== NULL
)
1815 struct type
*range_type
;
1816 struct type
*index_type
;
1820 type
= TYPE_TARGET_TYPE (type
);
1824 range_type
= TYPE_INDEX_TYPE (type
);
1825 index_type
= TYPE_TARGET_TYPE (range_type
);
1826 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
1827 index_type
= builtin_type_long
;
1829 *typep
= index_type
;
1831 (LONGEST
) (which
== 0
1832 ? TYPE_LOW_BOUND (range_type
)
1833 : TYPE_HIGH_BOUND (range_type
));
1837 struct type
*index_type
=
1838 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
1839 NULL
, TYPE_OBJFILE (arr_type
));
1841 *typep
= TYPE_TARGET_TYPE (index_type
);
1843 (LONGEST
) (which
== 0
1844 ? TYPE_LOW_BOUND (index_type
)
1845 : TYPE_HIGH_BOUND (index_type
));
1849 /* Given that arr is an array value, returns the lower bound of the
1850 nth index (numbering from 1) if which is 0, and the upper bound if
1851 which is 1. This routine will also work for arrays with bounds
1852 supplied by run-time quantities other than discriminants. */
1855 ada_array_bound (arr
, n
, which
)
1860 struct type
*arr_type
= VALUE_TYPE (arr
);
1862 if (ada_is_packed_array_type (arr_type
))
1863 return ada_array_bound (decode_packed_array (arr
), n
, which
);
1864 else if (ada_is_simple_array (arr_type
))
1867 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
1868 return value_from_longest (type
, v
);
1871 return desc_one_bound (desc_bounds (arr
), n
, which
);
1874 /* Given that arr is an array value, returns the length of the
1875 nth index. This routine will also work for arrays with bounds
1876 supplied by run-time quantities other than discriminants. Does not
1877 work for arrays indexed by enumeration types with representation
1878 clauses at the moment. */
1881 ada_array_length (struct value
*arr
, int n
)
1883 struct type
*arr_type
= check_typedef (VALUE_TYPE (arr
));
1884 struct type
*index_type_desc
;
1886 if (ada_is_packed_array_type (arr_type
))
1887 return ada_array_length (decode_packed_array (arr
), n
);
1889 if (ada_is_simple_array (arr_type
))
1893 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
1894 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
1895 return value_from_longest (type
, v
);
1899 value_from_longest (builtin_type_ada_int
,
1900 value_as_long (desc_one_bound (desc_bounds (arr
),
1902 - value_as_long (desc_one_bound (desc_bounds (arr
),
1907 /* Name resolution */
1909 /* The "demangled" name for the user-definable Ada operator corresponding
1913 ada_op_name (enum exp_opcode op
)
1917 for (i
= 0; ada_opname_table
[i
].mangled
!= NULL
; i
+= 1)
1919 if (ada_opname_table
[i
].op
== op
)
1920 return ada_opname_table
[i
].demangled
;
1922 error ("Could not find operator name for opcode");
1926 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
1927 references (OP_UNRESOLVED_VALUES) and converts operators that are
1928 user-defined into appropriate function calls. If CONTEXT_TYPE is
1929 non-null, it provides a preferred result type [at the moment, only
1930 type void has any effect---causing procedures to be preferred over
1931 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
1932 return type is preferred. The variable unresolved_names contains a list
1933 of character strings referenced by expout that should be freed.
1934 May change (expand) *EXP. */
1937 ada_resolve (struct expression
**expp
, struct type
*context_type
)
1941 ada_resolve_subexp (expp
, &pc
, 1, context_type
);
1944 /* Resolve the operator of the subexpression beginning at
1945 position *POS of *EXPP. "Resolving" consists of replacing
1946 OP_UNRESOLVED_VALUE with an appropriate OP_VAR_VALUE, replacing
1947 built-in operators with function calls to user-defined operators,
1948 where appropriate, and (when DEPROCEDURE_P is non-zero), converting
1949 function-valued variables into parameterless calls. May expand
1950 EXP. The CONTEXT_TYPE functions as in ada_resolve, above. */
1952 static struct value
*
1953 ada_resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
1954 struct type
*context_type
)
1958 struct expression
*exp
; /* Convenience: == *expp */
1959 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
1960 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
1961 int nargs
; /* Number of operands */
1967 /* Pass one: resolve operands, saving their types and updating *pos. */
1971 /* case OP_UNRESOLVED_VALUE: */
1972 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
1977 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
1978 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
1979 /* if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
1983 argvec = (struct value* *) alloca (sizeof (struct value*) * (nargs + 1));
1984 for (i = 0; i < nargs-1; i += 1)
1985 argvec[i] = ada_resolve_subexp (expp, pos, 1, NULL);
1991 ada_resolve_subexp (expp, pos, 0, NULL);
1992 for (i = 1; i < nargs; i += 1)
1993 ada_resolve_subexp (expp, pos, 1, NULL);
1999 /* FIXME: UNOP_QUAL should be defined in expression.h */
2003 ada_resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
2007 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
2008 /* case OP_ATTRIBUTE:
2009 nargs = longest_to_int (exp->elts[pc + 1].longconst) + 1;
2011 for (i = 0; i < nargs; i += 1)
2012 ada_resolve_subexp (expp, pos, 1, NULL);
2019 ada_resolve_subexp (expp
, pos
, 0, NULL
);
2028 arg1
= ada_resolve_subexp (expp
, pos
, 0, NULL
);
2030 ada_resolve_subexp (expp
, pos
, 1, NULL
);
2032 ada_resolve_subexp (expp
, pos
, 1, VALUE_TYPE (arg1
));
2040 error ("Unexpected operator during name resolution");
2055 case BINOP_LOGICAL_AND
:
2056 case BINOP_LOGICAL_OR
:
2057 case BINOP_BITWISE_AND
:
2058 case BINOP_BITWISE_IOR
:
2059 case BINOP_BITWISE_XOR
:
2062 case BINOP_NOTEQUAL
:
2069 case BINOP_SUBSCRIPT
:
2077 case UNOP_LOGICAL_NOT
:
2094 case OP_INTERNALVAR
:
2103 case STRUCTOP_STRUCT
:
2106 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2111 nargs
= longest_to_int (exp
->elts
[pc
+ 2].longconst
) + 1;
2112 nargs
-= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2113 /* A null array contains one dummy element to give the type. */
2119 /* FIXME: TERNOP_MBR should be defined in expression.h */
2125 /* FIXME: BINOP_MBR should be defined in expression.h */
2133 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2134 for (i
= 0; i
< nargs
; i
+= 1)
2135 argvec
[i
] = ada_resolve_subexp (expp
, pos
, 1, NULL
);
2141 /* Pass two: perform any resolution on principal operator. */
2147 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2148 /* case OP_UNRESOLVED_VALUE:
2150 struct symbol** candidate_syms;
2151 struct block** candidate_blocks;
2154 n_candidates = ada_lookup_symbol_list (exp->elts[pc + 2].name,
2155 exp->elts[pc + 1].block,
2160 if (n_candidates > 1)
2162 /* Types tend to get re-introduced locally, so if there
2163 are any local symbols that are not types, first filter
2166 for (j = 0; j < n_candidates; j += 1)
2167 switch (SYMBOL_CLASS (candidate_syms[j]))
2173 case LOC_REGPARM_ADDR:
2177 case LOC_BASEREG_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_NAMESPACE
,
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 (ftype
, atype
, may_deref
)
2342 CHECK_TYPEDEF (ftype
);
2343 CHECK_TYPEDEF (atype
);
2345 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2346 ftype
= TYPE_TARGET_TYPE (ftype
);
2347 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2348 atype
= TYPE_TARGET_TYPE (atype
);
2350 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2351 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2354 switch (TYPE_CODE (ftype
))
2359 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2360 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2361 TYPE_TARGET_TYPE (atype
), 0);
2363 return (may_deref
&&
2364 ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2366 case TYPE_CODE_ENUM
:
2367 case TYPE_CODE_RANGE
:
2368 switch (TYPE_CODE (atype
))
2371 case TYPE_CODE_ENUM
:
2372 case TYPE_CODE_RANGE
:
2378 case TYPE_CODE_ARRAY
:
2379 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2380 || ada_is_array_descriptor (atype
));
2382 case TYPE_CODE_STRUCT
:
2383 if (ada_is_array_descriptor (ftype
))
2384 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2385 || ada_is_array_descriptor (atype
));
2387 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2388 && !ada_is_array_descriptor (atype
));
2390 case TYPE_CODE_UNION
:
2392 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2396 /* Return non-zero if the formals of FUNC "sufficiently match" the
2397 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2398 may also be an enumeral, in which case it is treated as a 0-
2399 argument function. */
2402 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
2405 struct type
*func_type
= SYMBOL_TYPE (func
);
2407 if (SYMBOL_CLASS (func
) == LOC_CONST
&&
2408 TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2409 return (n_actuals
== 0);
2410 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2413 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2416 for (i
= 0; i
< n_actuals
; i
+= 1)
2418 struct type
*ftype
= check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2419 struct type
*atype
= check_typedef (VALUE_TYPE (actuals
[i
]));
2421 if (!ada_type_match (TYPE_FIELD_TYPE (func_type
, i
),
2422 VALUE_TYPE (actuals
[i
]), 1))
2428 /* False iff function type FUNC_TYPE definitely does not produce a value
2429 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2430 FUNC_TYPE is not a valid function type with a non-null return type
2431 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2434 return_match (struct type
*func_type
, struct type
*context_type
)
2436 struct type
*return_type
;
2438 if (func_type
== NULL
)
2441 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2442 /* if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
2443 return_type = base_type (TYPE_TARGET_TYPE (func_type));
2445 return_type = base_type (func_type); */
2446 if (return_type
== NULL
)
2449 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2450 /* context_type = base_type (context_type); */
2452 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2453 return context_type
== NULL
|| return_type
== context_type
;
2454 else if (context_type
== NULL
)
2455 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2457 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
2461 /* Return the index in SYMS[0..NSYMS-1] of symbol for the
2462 function (if any) that matches the types of the NARGS arguments in
2463 ARGS. If CONTEXT_TYPE is non-null, and there is at least one match
2464 that returns type CONTEXT_TYPE, then eliminate other matches. If
2465 CONTEXT_TYPE is null, prefer a non-void-returning function.
2466 Asks the user if there is more than one match remaining. Returns -1
2467 if there is no such symbol or none is selected. NAME is used
2468 solely for messages. May re-arrange and modify SYMS in
2469 the process; the index returned is for the modified vector. BLOCKS
2470 is modified in parallel to SYMS. */
2473 ada_resolve_function (struct symbol
*syms
[], struct block
*blocks
[],
2474 int nsyms
, struct value
**args
, int nargs
,
2475 const char *name
, struct type
*context_type
)
2478 int m
; /* Number of hits */
2479 struct type
*fallback
;
2480 struct type
*return_type
;
2482 return_type
= context_type
;
2483 if (context_type
== NULL
)
2484 fallback
= builtin_type_void
;
2491 for (k
= 0; k
< nsyms
; k
+= 1)
2493 struct type
*type
= check_typedef (SYMBOL_TYPE (syms
[k
]));
2495 if (ada_args_match (syms
[k
], args
, nargs
)
2496 && return_match (SYMBOL_TYPE (syms
[k
]), return_type
))
2500 blocks
[m
] = blocks
[k
];
2504 if (m
> 0 || return_type
== fallback
)
2507 return_type
= fallback
;
2514 printf_filtered ("Multiple matches for %s\n", name
);
2515 user_select_syms (syms
, blocks
, m
, 1);
2521 /* Returns true (non-zero) iff demangled name N0 should appear before N1 */
2522 /* in a listing of choices during disambiguation (see sort_choices, below). */
2523 /* The idea is that overloadings of a subprogram name from the */
2524 /* same package should sort in their source order. We settle for ordering */
2525 /* such symbols by their trailing number (__N or $N). */
2527 mangled_ordered_before (char *N0
, char *N1
)
2531 else if (N0
== NULL
)
2536 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
2538 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
2540 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
2541 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
2545 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
2548 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
2550 if (n0
== n1
&& STREQN (N0
, N1
, n0
))
2551 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
2553 return (strcmp (N0
, N1
) < 0);
2557 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by their */
2558 /* mangled names, rearranging BLOCKS[0..NSYMS-1] according to the same */
2561 sort_choices (struct symbol
*syms
[], struct block
*blocks
[], int nsyms
)
2564 for (i
= 1; i
< nsyms
; i
+= 1)
2566 struct symbol
*sym
= syms
[i
];
2567 struct block
*block
= blocks
[i
];
2570 for (j
= i
- 1; j
>= 0; j
-= 1)
2572 if (mangled_ordered_before (SYMBOL_NAME (syms
[j
]),
2575 syms
[j
+ 1] = syms
[j
];
2576 blocks
[j
+ 1] = blocks
[j
];
2579 blocks
[j
+ 1] = block
;
2583 /* Given a list of NSYMS symbols in SYMS and corresponding blocks in */
2584 /* BLOCKS, select up to MAX_RESULTS>0 by asking the user (if */
2585 /* necessary), returning the number selected, and setting the first */
2586 /* elements of SYMS and BLOCKS to the selected symbols and */
2587 /* corresponding blocks. Error if no symbols selected. BLOCKS may */
2588 /* be NULL, in which case it is ignored. */
2590 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
2591 to be re-integrated one of these days. */
2594 user_select_syms (struct symbol
*syms
[], struct block
*blocks
[], int nsyms
,
2598 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
2600 int first_choice
= (max_results
== 1) ? 1 : 2;
2602 if (max_results
< 1)
2603 error ("Request to select 0 symbols!");
2607 printf_unfiltered ("[0] cancel\n");
2608 if (max_results
> 1)
2609 printf_unfiltered ("[1] all\n");
2611 sort_choices (syms
, blocks
, nsyms
);
2613 for (i
= 0; i
< nsyms
; i
+= 1)
2615 if (syms
[i
] == NULL
)
2618 if (SYMBOL_CLASS (syms
[i
]) == LOC_BLOCK
)
2620 struct symtab_and_line sal
= find_function_start_sal (syms
[i
], 1);
2621 printf_unfiltered ("[%d] %s at %s:%d\n",
2623 SYMBOL_SOURCE_NAME (syms
[i
]),
2625 ? "<no source file available>"
2626 : sal
.symtab
->filename
, sal
.line
);
2632 (SYMBOL_CLASS (syms
[i
]) == LOC_CONST
2633 && SYMBOL_TYPE (syms
[i
]) != NULL
2634 && TYPE_CODE (SYMBOL_TYPE (syms
[i
])) == TYPE_CODE_ENUM
);
2635 struct symtab
*symtab
= symtab_for_sym (syms
[i
]);
2637 if (SYMBOL_LINE (syms
[i
]) != 0 && symtab
!= NULL
)
2638 printf_unfiltered ("[%d] %s at %s:%d\n",
2640 SYMBOL_SOURCE_NAME (syms
[i
]),
2641 symtab
->filename
, SYMBOL_LINE (syms
[i
]));
2642 else if (is_enumeral
&& TYPE_NAME (SYMBOL_TYPE (syms
[i
])) != NULL
)
2644 printf_unfiltered ("[%d] ", i
+ first_choice
);
2645 ada_print_type (SYMBOL_TYPE (syms
[i
]), NULL
, gdb_stdout
, -1, 0);
2646 printf_unfiltered ("'(%s) (enumeral)\n",
2647 SYMBOL_SOURCE_NAME (syms
[i
]));
2649 else if (symtab
!= NULL
)
2650 printf_unfiltered (is_enumeral
2651 ? "[%d] %s in %s (enumeral)\n"
2652 : "[%d] %s at %s:?\n",
2654 SYMBOL_SOURCE_NAME (syms
[i
]),
2657 printf_unfiltered (is_enumeral
2658 ? "[%d] %s (enumeral)\n"
2661 SYMBOL_SOURCE_NAME (syms
[i
]));
2665 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
2668 for (i
= 0; i
< n_chosen
; i
+= 1)
2670 syms
[i
] = syms
[chosen
[i
]];
2672 blocks
[i
] = blocks
[chosen
[i
]];
2678 /* Read and validate a set of numeric choices from the user in the
2679 range 0 .. N_CHOICES-1. Place the results in increasing
2680 order in CHOICES[0 .. N-1], and return N.
2682 The user types choices as a sequence of numbers on one line
2683 separated by blanks, encoding them as follows:
2685 + A choice of 0 means to cancel the selection, throwing an error.
2686 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
2687 + The user chooses k by typing k+IS_ALL_CHOICE+1.
2689 The user is not allowed to choose more than MAX_RESULTS values.
2691 ANNOTATION_SUFFIX, if present, is used to annotate the input
2692 prompts (for use with the -f switch). */
2695 get_selections (int *choices
, int n_choices
, int max_results
,
2696 int is_all_choice
, char *annotation_suffix
)
2702 int first_choice
= is_all_choice
? 2 : 1;
2704 prompt
= getenv ("PS2");
2708 printf_unfiltered ("%s ", prompt
);
2709 gdb_flush (gdb_stdout
);
2711 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
2714 error_no_arg ("one or more choice numbers");
2718 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
2719 order, as given in args. Choices are validated. */
2725 while (isspace (*args
))
2727 if (*args
== '\0' && n_chosen
== 0)
2728 error_no_arg ("one or more choice numbers");
2729 else if (*args
== '\0')
2732 choice
= strtol (args
, &args2
, 10);
2733 if (args
== args2
|| choice
< 0
2734 || choice
> n_choices
+ first_choice
- 1)
2735 error ("Argument must be choice number");
2739 error ("cancelled");
2741 if (choice
< first_choice
)
2743 n_chosen
= n_choices
;
2744 for (j
= 0; j
< n_choices
; j
+= 1)
2748 choice
-= first_choice
;
2750 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
2754 if (j
< 0 || choice
!= choices
[j
])
2757 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
2758 choices
[k
+ 1] = choices
[k
];
2759 choices
[j
+ 1] = choice
;
2764 if (n_chosen
> max_results
)
2765 error ("Select no more than %d of the above", max_results
);
2770 /* Replace the operator of length OPLEN at position PC in *EXPP with a call */
2771 /* on the function identified by SYM and BLOCK, and taking NARGS */
2772 /* arguments. Update *EXPP as needed to hold more space. */
2775 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
2776 int oplen
, struct symbol
*sym
,
2777 struct block
*block
)
2779 /* A new expression, with 6 more elements (3 for funcall, 4 for function
2780 symbol, -oplen for operator being replaced). */
2781 struct expression
*newexp
= (struct expression
*)
2782 xmalloc (sizeof (struct expression
)
2783 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
2784 struct expression
*exp
= *expp
;
2786 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
2787 newexp
->language_defn
= exp
->language_defn
;
2788 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
2789 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
2790 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
2792 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
2793 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
2795 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
2796 newexp
->elts
[pc
+ 4].block
= block
;
2797 newexp
->elts
[pc
+ 5].symbol
= sym
;
2803 /* Type-class predicates */
2805 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type), or */
2809 numeric_type_p (struct type
*type
)
2815 switch (TYPE_CODE (type
))
2820 case TYPE_CODE_RANGE
:
2821 return (type
== TYPE_TARGET_TYPE (type
)
2822 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
2829 /* True iff TYPE is integral (an INT or RANGE of INTs). */
2832 integer_type_p (struct type
*type
)
2838 switch (TYPE_CODE (type
))
2842 case TYPE_CODE_RANGE
:
2843 return (type
== TYPE_TARGET_TYPE (type
)
2844 || integer_type_p (TYPE_TARGET_TYPE (type
)));
2851 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
2854 scalar_type_p (struct type
*type
)
2860 switch (TYPE_CODE (type
))
2863 case TYPE_CODE_RANGE
:
2864 case TYPE_CODE_ENUM
:
2873 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
2876 discrete_type_p (struct type
*type
)
2882 switch (TYPE_CODE (type
))
2885 case TYPE_CODE_RANGE
:
2886 case TYPE_CODE_ENUM
:
2894 /* Returns non-zero if OP with operatands in the vector ARGS could be
2895 a user-defined function. Errs on the side of pre-defined operators
2896 (i.e., result 0). */
2899 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
2901 struct type
*type0
= check_typedef (VALUE_TYPE (args
[0]));
2902 struct type
*type1
=
2903 (args
[1] == NULL
) ? NULL
: check_typedef (VALUE_TYPE (args
[1]));
2914 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
2918 case BINOP_BITWISE_AND
:
2919 case BINOP_BITWISE_IOR
:
2920 case BINOP_BITWISE_XOR
:
2921 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
2924 case BINOP_NOTEQUAL
:
2929 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
2932 return ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
&&
2933 (TYPE_CODE (type0
) != TYPE_CODE_PTR
||
2934 TYPE_CODE (TYPE_TARGET_TYPE (type0
))
2935 != TYPE_CODE_ARRAY
))
2936 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
&&
2937 (TYPE_CODE (type1
) != TYPE_CODE_PTR
||
2938 TYPE_CODE (TYPE_TARGET_TYPE (type1
)) != TYPE_CODE_ARRAY
)));
2941 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
2945 case UNOP_LOGICAL_NOT
:
2947 return (!numeric_type_p (type0
));
2954 /** NOTE: In the following, we assume that a renaming type's name may
2955 * have an ___XD suffix. It would be nice if this went away at some
2958 /* If TYPE encodes a renaming, returns the renaming suffix, which
2959 * is XR for an object renaming, XRP for a procedure renaming, XRE for
2960 * an exception renaming, and XRS for a subprogram renaming. Returns
2961 * NULL if NAME encodes none of these. */
2963 ada_renaming_type (struct type
*type
)
2965 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
2967 const char *name
= type_name_no_tag (type
);
2968 const char *suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
2970 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
2979 /* Return non-zero iff SYM encodes an object renaming. */
2981 ada_is_object_renaming (struct symbol
*sym
)
2983 const char *renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
2984 return renaming_type
!= NULL
2985 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
2988 /* Assuming that SYM encodes a non-object renaming, returns the original
2989 * name of the renamed entity. The name is good until the end of
2992 ada_simple_renamed_entity (struct symbol
*sym
)
2995 const char *raw_name
;
2999 type
= SYMBOL_TYPE (sym
);
3000 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
3001 error ("Improperly encoded renaming.");
3003 raw_name
= TYPE_FIELD_NAME (type
, 0);
3004 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
3006 error ("Improperly encoded renaming.");
3008 result
= xmalloc (len
+ 1);
3009 /* FIXME: add_name_string_cleanup should be defined in parse.c */
3010 /* add_name_string_cleanup (result); */
3011 strncpy (result
, raw_name
, len
);
3012 result
[len
] = '\000';
3017 /* Evaluation: Function Calls */
3019 /* Copy VAL onto the stack, using and updating *SP as the stack
3020 pointer. Return VAL as an lvalue. */
3022 static struct value
*
3023 place_on_stack (struct value
*val
, CORE_ADDR
*sp
)
3025 CORE_ADDR old_sp
= *sp
;
3028 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3029 STACK_ALIGN (TYPE_LENGTH
3030 (check_typedef (VALUE_TYPE (val
)))));
3032 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3033 TYPE_LENGTH (check_typedef (VALUE_TYPE (val
))));
3036 VALUE_LVAL (val
) = lval_memory
;
3037 if (INNER_THAN (1, 2))
3038 VALUE_ADDRESS (val
) = *sp
;
3040 VALUE_ADDRESS (val
) = old_sp
;
3045 /* Return the value ACTUAL, converted to be an appropriate value for a
3046 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3047 allocating any necessary descriptors (fat pointers), or copies of
3048 values not residing in memory, updating it as needed. */
3050 static struct value
*
3051 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3054 struct type
*actual_type
= check_typedef (VALUE_TYPE (actual
));
3055 struct type
*formal_type
= check_typedef (formal_type0
);
3056 struct type
*formal_target
=
3057 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3058 ? check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3059 struct type
*actual_target
=
3060 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3061 ? check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3063 if (ada_is_array_descriptor (formal_target
)
3064 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3065 return make_array_descriptor (formal_type
, actual
, sp
);
3066 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3068 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3069 && ada_is_array_descriptor (actual_target
))
3070 return desc_data (actual
);
3071 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3073 if (VALUE_LVAL (actual
) != lval_memory
)
3076 actual_type
= check_typedef (VALUE_TYPE (actual
));
3077 val
= allocate_value (actual_type
);
3078 memcpy ((char *) VALUE_CONTENTS_RAW (val
),
3079 (char *) VALUE_CONTENTS (actual
),
3080 TYPE_LENGTH (actual_type
));
3081 actual
= place_on_stack (val
, sp
);
3083 return value_addr (actual
);
3086 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3087 return ada_value_ind (actual
);
3093 /* Push a descriptor of type TYPE for array value ARR on the stack at
3094 *SP, updating *SP to reflect the new descriptor. Return either
3095 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3096 to-descriptor type rather than a descriptor type), a struct value*
3097 representing a pointer to this descriptor. */
3099 static struct value
*
3100 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3102 struct type
*bounds_type
= desc_bounds_type (type
);
3103 struct type
*desc_type
= desc_base_type (type
);
3104 struct value
*descriptor
= allocate_value (desc_type
);
3105 struct value
*bounds
= allocate_value (bounds_type
);
3106 CORE_ADDR bounds_addr
;
3109 for (i
= ada_array_arity (check_typedef (VALUE_TYPE (arr
))); i
> 0; i
-= 1)
3111 modify_general_field (VALUE_CONTENTS (bounds
),
3112 value_as_long (ada_array_bound (arr
, i
, 0)),
3113 desc_bound_bitpos (bounds_type
, i
, 0),
3114 desc_bound_bitsize (bounds_type
, i
, 0));
3115 modify_general_field (VALUE_CONTENTS (bounds
),
3116 value_as_long (ada_array_bound (arr
, i
, 1)),
3117 desc_bound_bitpos (bounds_type
, i
, 1),
3118 desc_bound_bitsize (bounds_type
, i
, 1));
3121 bounds
= place_on_stack (bounds
, sp
);
3123 modify_general_field (VALUE_CONTENTS (descriptor
),
3125 fat_pntr_data_bitpos (desc_type
),
3126 fat_pntr_data_bitsize (desc_type
));
3127 modify_general_field (VALUE_CONTENTS (descriptor
),
3128 VALUE_ADDRESS (bounds
),
3129 fat_pntr_bounds_bitpos (desc_type
),
3130 fat_pntr_bounds_bitsize (desc_type
));
3132 descriptor
= place_on_stack (descriptor
, sp
);
3134 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3135 return value_addr (descriptor
);
3141 /* Assuming a dummy frame has been established on the target, perform any
3142 conversions needed for calling function FUNC on the NARGS actual
3143 parameters in ARGS, other than standard C conversions. Does
3144 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3145 does not match the number of arguments expected. Use *SP as a
3146 stack pointer for additional data that must be pushed, updating its
3150 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3155 if (TYPE_NFIELDS (VALUE_TYPE (func
)) == 0
3156 || nargs
!= TYPE_NFIELDS (VALUE_TYPE (func
)))
3159 for (i
= 0; i
< nargs
; i
+= 1)
3161 convert_actual (args
[i
], TYPE_FIELD_TYPE (VALUE_TYPE (func
), i
), sp
);
3168 /* The vectors of symbols and blocks ultimately returned from */
3169 /* ada_lookup_symbol_list. */
3171 /* Current size of defn_symbols and defn_blocks */
3172 static size_t defn_vector_size
= 0;
3174 /* Current number of symbols found. */
3175 static int ndefns
= 0;
3177 static struct symbol
**defn_symbols
= NULL
;
3178 static struct block
**defn_blocks
= NULL
;
3180 /* Return the result of a standard (literal, C-like) lookup of NAME in
3181 * given NAMESPACE. */
3183 static struct symbol
*
3184 standard_lookup (const char *name
, namespace_enum
namespace)
3187 struct symtab
*symtab
;
3188 sym
= lookup_symbol (name
, (struct block
*) NULL
, namespace, 0, &symtab
);
3193 /* Non-zero iff there is at least one non-function/non-enumeral symbol */
3194 /* in SYMS[0..N-1]. We treat enumerals as functions, since they */
3195 /* contend in overloading in the same way. */
3197 is_nonfunction (struct symbol
*syms
[], int n
)
3201 for (i
= 0; i
< n
; i
+= 1)
3202 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
])) != TYPE_CODE_FUNC
3203 && TYPE_CODE (SYMBOL_TYPE (syms
[i
])) != TYPE_CODE_ENUM
)
3209 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3210 struct types. Otherwise, they may not. */
3213 equiv_types (struct type
*type0
, struct type
*type1
)
3217 if (type0
== NULL
|| type1
== NULL
3218 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3220 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3221 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3222 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3223 && STREQ (ada_type_name (type0
), ada_type_name (type1
)))
3229 /* True iff SYM0 represents the same entity as SYM1, or one that is
3230 no more defined than that of SYM1. */
3233 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3237 if (SYMBOL_NAMESPACE (sym0
) != SYMBOL_NAMESPACE (sym1
)
3238 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3241 switch (SYMBOL_CLASS (sym0
))
3247 struct type
*type0
= SYMBOL_TYPE (sym0
);
3248 struct type
*type1
= SYMBOL_TYPE (sym1
);
3249 char *name0
= SYMBOL_NAME (sym0
);
3250 char *name1
= SYMBOL_NAME (sym1
);
3251 int len0
= strlen (name0
);
3253 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3254 && (equiv_types (type0
, type1
)
3255 || (len0
< strlen (name1
) && STREQN (name0
, name1
, len0
)
3256 && STREQN (name1
+ len0
, "___XV", 5)));
3259 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3260 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3266 /* Append SYM to the end of defn_symbols, and BLOCK to the end of
3267 defn_blocks, updating ndefns, and expanding defn_symbols and
3268 defn_blocks as needed. Do not include SYM if it is a duplicate. */
3271 add_defn_to_vec (struct symbol
*sym
, struct block
*block
)
3276 if (SYMBOL_TYPE (sym
) != NULL
)
3277 CHECK_TYPEDEF (SYMBOL_TYPE (sym
));
3278 for (i
= 0; i
< ndefns
; i
+= 1)
3280 if (lesseq_defined_than (sym
, defn_symbols
[i
]))
3282 else if (lesseq_defined_than (defn_symbols
[i
], sym
))
3284 defn_symbols
[i
] = sym
;
3285 defn_blocks
[i
] = block
;
3290 tmp
= defn_vector_size
;
3291 GROW_VECT (defn_symbols
, tmp
, ndefns
+ 2);
3292 GROW_VECT (defn_blocks
, defn_vector_size
, ndefns
+ 2);
3294 defn_symbols
[ndefns
] = sym
;
3295 defn_blocks
[ndefns
] = block
;
3299 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3300 Check the global symbols if GLOBAL, the static symbols if not. Do
3301 wild-card match if WILD. */
3303 static struct partial_symbol
*
3304 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
3305 int global
, namespace_enum
namespace, int wild
)
3307 struct partial_symbol
**start
;
3308 int name_len
= strlen (name
);
3309 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
3318 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
3319 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
3323 for (i
= 0; i
< length
; i
+= 1)
3325 struct partial_symbol
*psym
= start
[i
];
3327 if (SYMBOL_NAMESPACE (psym
) == namespace &&
3328 wild_match (name
, name_len
, SYMBOL_NAME (psym
)))
3342 int M
= (U
+ i
) >> 1;
3343 struct partial_symbol
*psym
= start
[M
];
3344 if (SYMBOL_NAME (psym
)[0] < name
[0])
3346 else if (SYMBOL_NAME (psym
)[0] > name
[0])
3348 else if (strcmp (SYMBOL_NAME (psym
), name
) < 0)
3359 struct partial_symbol
*psym
= start
[i
];
3361 if (SYMBOL_NAMESPACE (psym
) == namespace)
3363 int cmp
= strncmp (name
, SYMBOL_NAME (psym
), name_len
);
3371 && is_name_suffix (SYMBOL_NAME (psym
) + name_len
))
3384 int M
= (U
+ i
) >> 1;
3385 struct partial_symbol
*psym
= start
[M
];
3386 if (SYMBOL_NAME (psym
)[0] < '_')
3388 else if (SYMBOL_NAME (psym
)[0] > '_')
3390 else if (strcmp (SYMBOL_NAME (psym
), "_ada_") < 0)
3401 struct partial_symbol
*psym
= start
[i
];
3403 if (SYMBOL_NAMESPACE (psym
) == namespace)
3407 cmp
= (int) '_' - (int) SYMBOL_NAME (psym
)[0];
3410 cmp
= strncmp ("_ada_", SYMBOL_NAME (psym
), 5);
3412 cmp
= strncmp (name
, SYMBOL_NAME (psym
) + 5, name_len
);
3421 && is_name_suffix (SYMBOL_NAME (psym
) + name_len
+ 5))
3432 /* Find a symbol table containing symbol SYM or NULL if none. */
3433 static struct symtab
*
3434 symtab_for_sym (struct symbol
*sym
)
3437 struct objfile
*objfile
;
3439 struct symbol
*tmp_sym
;
3442 ALL_SYMTABS (objfile
, s
)
3444 switch (SYMBOL_CLASS (sym
))
3452 case LOC_CONST_BYTES
:
3453 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
3454 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
) if (sym
== tmp_sym
)
3456 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
3457 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
) if (sym
== tmp_sym
)
3463 switch (SYMBOL_CLASS (sym
))
3469 case LOC_REGPARM_ADDR
:
3474 case LOC_BASEREG_ARG
:
3475 for (j
= FIRST_LOCAL_BLOCK
;
3476 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
3478 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
3479 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
) if (sym
== tmp_sym
)
3490 /* Return a minimal symbol matching NAME according to Ada demangling
3491 rules. Returns NULL if there is no such minimal symbol. */
3493 struct minimal_symbol
*
3494 ada_lookup_minimal_symbol (const char *name
)
3496 struct objfile
*objfile
;
3497 struct minimal_symbol
*msymbol
;
3498 int wild_match
= (strstr (name
, "__") == NULL
);
3500 ALL_MSYMBOLS (objfile
, msymbol
)
3502 if (ada_match_name (SYMBOL_NAME (msymbol
), name
, wild_match
)
3503 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
3510 /* For all subprograms that statically enclose the subprogram of the
3511 * selected frame, add symbols matching identifier NAME in NAMESPACE
3512 * and their blocks to vectors *defn_symbols and *defn_blocks, as for
3513 * ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
3514 * wildcard prefix. At the moment, this function uses a heuristic to
3515 * find the frames of enclosing subprograms: it treats the
3516 * pointer-sized value at location 0 from the local-variable base of a
3517 * frame as a static link, and then searches up the call stack for a
3518 * frame with that same local-variable base. */
3520 add_symbols_from_enclosing_procs (const char *name
, namespace_enum
namespace,
3524 static struct symbol static_link_sym
;
3525 static struct symbol
*static_link
;
3527 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
3528 struct frame_info
*frame
;
3529 struct frame_info
*target_frame
;
3531 if (static_link
== NULL
)
3533 /* Initialize the local variable symbol that stands for the
3534 * static link (when it exists). */
3535 static_link
= &static_link_sym
;
3536 SYMBOL_NAME (static_link
) = "";
3537 SYMBOL_LANGUAGE (static_link
) = language_unknown
;
3538 SYMBOL_CLASS (static_link
) = LOC_LOCAL
;
3539 SYMBOL_NAMESPACE (static_link
) = VAR_NAMESPACE
;
3540 SYMBOL_TYPE (static_link
) = lookup_pointer_type (builtin_type_void
);
3541 SYMBOL_VALUE (static_link
) =
3542 -(long) TYPE_LENGTH (SYMBOL_TYPE (static_link
));
3545 frame
= selected_frame
;
3546 while (frame
!= NULL
&& ndefns
== 0)
3548 struct block
*block
;
3549 struct value
*target_link_val
= read_var_value (static_link
, frame
);
3550 CORE_ADDR target_link
;
3552 if (target_link_val
== NULL
)
3556 target_link
= target_link_val
;
3560 frame
= get_prev_frame (frame
);
3562 while (frame
!= NULL
&& FRAME_LOCALS_ADDRESS (frame
) != target_link
);
3567 block
= get_frame_block (frame
, 0);
3568 while (block
!= NULL
&& block_function (block
) != NULL
&& ndefns
== 0)
3570 ada_add_block_symbols (block
, name
, namespace, NULL
, wild_match
);
3572 block
= BLOCK_SUPERBLOCK (block
);
3576 do_cleanups (old_chain
);
3580 /* True if TYPE is definitely an artificial type supplied to a symbol
3581 * for which no debugging information was given in the symbol file. */
3583 is_nondebugging_type (struct type
*type
)
3585 char *name
= ada_type_name (type
);
3586 return (name
!= NULL
&& STREQ (name
, "<variable, no debug info>"));
3589 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
3590 * duplicate other symbols in the list. (The only case I know of where
3591 * this happens is when object files containing stabs-in-ecoff are
3592 * linked with files containing ordinary ecoff debugging symbols (or no
3593 * debugging symbols)). Modifies SYMS to squeeze out deleted symbols,
3594 * and applies the same modification to BLOCKS to maintain the
3595 * correspondence between SYMS[i] and BLOCKS[i]. Returns the number
3596 * of symbols in the modified list. */
3598 remove_extra_symbols (struct symbol
**syms
, struct block
**blocks
, int nsyms
)
3605 if (SYMBOL_NAME (syms
[i
]) != NULL
3606 && SYMBOL_CLASS (syms
[i
]) == LOC_STATIC
3607 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
])))
3609 for (j
= 0; j
< nsyms
; j
+= 1)
3612 && SYMBOL_NAME (syms
[j
]) != NULL
3613 && STREQ (SYMBOL_NAME (syms
[i
]), SYMBOL_NAME (syms
[j
]))
3614 && SYMBOL_CLASS (syms
[i
]) == SYMBOL_CLASS (syms
[j
])
3615 && SYMBOL_VALUE_ADDRESS (syms
[i
])
3616 == SYMBOL_VALUE_ADDRESS (syms
[j
]))
3619 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
3621 syms
[k
- 1] = syms
[k
];
3622 blocks
[k
- 1] = blocks
[k
];
3636 /* Find symbols in NAMESPACE matching NAME, in BLOCK0 and enclosing
3637 scope and in global scopes, returning the number of matches. Sets
3638 *SYMS to point to a vector of matching symbols, with *BLOCKS
3639 pointing to the vector of corresponding blocks in which those
3640 symbols reside. These two vectors are transient---good only to the
3641 next call of ada_lookup_symbol_list. Any non-function/non-enumeral symbol
3642 match within the nest of blocks whose innermost member is BLOCK0,
3643 is the outermost match returned (no other matches in that or
3644 enclosing blocks is returned). If there are any matches in or
3645 surrounding BLOCK0, then these alone are returned. */
3648 ada_lookup_symbol_list (const char *name
, struct block
*block0
,
3649 namespace_enum
namespace, struct symbol
***syms
,
3650 struct block
***blocks
)
3654 struct partial_symtab
*ps
;
3655 struct blockvector
*bv
;
3656 struct objfile
*objfile
;
3658 struct block
*block
;
3659 struct minimal_symbol
*msymbol
;
3660 int wild_match
= (strstr (name
, "__") == NULL
);
3670 /* Search specified block and its superiors. */
3673 while (block
!= NULL
)
3675 ada_add_block_symbols (block
, name
, namespace, NULL
, wild_match
);
3677 /* If we found a non-function match, assume that's the one. */
3678 if (is_nonfunction (defn_symbols
, ndefns
))
3681 block
= BLOCK_SUPERBLOCK (block
);
3684 /* If we found ANY matches in the specified BLOCK, we're done. */
3691 /* Now add symbols from all global blocks: symbol tables, minimal symbol
3692 tables, and psymtab's */
3694 ALL_SYMTABS (objfile
, s
)
3699 bv
= BLOCKVECTOR (s
);
3700 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3701 ada_add_block_symbols (block
, name
, namespace, objfile
, wild_match
);
3704 if (namespace == VAR_NAMESPACE
)
3706 ALL_MSYMBOLS (objfile
, msymbol
)
3708 if (ada_match_name (SYMBOL_NAME (msymbol
), name
, wild_match
))
3710 switch (MSYMBOL_TYPE (msymbol
))
3712 case mst_solib_trampoline
:
3715 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
3718 int old_ndefns
= ndefns
;
3720 bv
= BLOCKVECTOR (s
);
3721 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3722 ada_add_block_symbols (block
,
3723 SYMBOL_NAME (msymbol
),
3724 namespace, objfile
, wild_match
);
3725 if (ndefns
== old_ndefns
)
3727 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3728 ada_add_block_symbols (block
,
3729 SYMBOL_NAME (msymbol
),
3739 ALL_PSYMTABS (objfile
, ps
)
3743 && ada_lookup_partial_symbol (ps
, name
, 1, namespace, wild_match
))
3745 s
= PSYMTAB_TO_SYMTAB (ps
);
3748 bv
= BLOCKVECTOR (s
);
3749 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3750 ada_add_block_symbols (block
, name
, namespace, objfile
, wild_match
);
3754 /* Now add symbols from all per-file blocks if we've gotten no hits.
3755 (Not strictly correct, but perhaps better than an error).
3756 Do the symtabs first, then check the psymtabs */
3761 ALL_SYMTABS (objfile
, s
)
3766 bv
= BLOCKVECTOR (s
);
3767 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3768 ada_add_block_symbols (block
, name
, namespace, objfile
, wild_match
);
3771 ALL_PSYMTABS (objfile
, ps
)
3775 && ada_lookup_partial_symbol (ps
, name
, 0, namespace, wild_match
))
3777 s
= PSYMTAB_TO_SYMTAB (ps
);
3778 bv
= BLOCKVECTOR (s
);
3781 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3782 ada_add_block_symbols (block
, name
, namespace,
3783 objfile
, wild_match
);
3788 /* Finally, we try to find NAME as a local symbol in some lexically
3789 enclosing block. We do this last, expecting this case to be
3793 add_symbols_from_enclosing_procs (name
, namespace, wild_match
);
3799 ndefns
= remove_extra_symbols (defn_symbols
, defn_blocks
, ndefns
);
3802 *syms
= defn_symbols
;
3803 *blocks
= defn_blocks
;
3810 /* Return a symbol in NAMESPACE matching NAME, in BLOCK0 and enclosing
3811 * scope and in global scopes, or NULL if none. NAME is folded to
3812 * lower case first, unless it is surrounded in single quotes.
3813 * Otherwise, the result is as for ada_lookup_symbol_list, but is
3814 * disambiguated by user query if needed. */
3817 ada_lookup_symbol (const char *name
, struct block
*block0
,
3818 namespace_enum
namespace)
3820 struct symbol
**candidate_syms
;
3821 struct block
**candidate_blocks
;
3824 n_candidates
= ada_lookup_symbol_list (name
,
3826 &candidate_syms
, &candidate_blocks
);
3828 if (n_candidates
== 0)
3830 else if (n_candidates
!= 1)
3831 user_select_syms (candidate_syms
, candidate_blocks
, n_candidates
, 1);
3833 return candidate_syms
[0];
3837 /* True iff STR is a possible encoded suffix of a normal Ada name
3838 * that is to be ignored for matching purposes. Suffixes of parallel
3839 * names (e.g., XVE) are not included here. Currently, the possible suffixes
3840 * are given by the regular expression:
3841 * (X[nb]*)?(__[0-9]+|\$[0-9]+|___(LJM|X([FDBUP].*|R[^T]?)))?$
3845 is_name_suffix (const char *str
)
3851 while (str
[0] != '_' && str
[0] != '\0')
3853 if (str
[0] != 'n' && str
[0] != 'b')
3858 if (str
[0] == '\000')
3862 if (str
[1] != '_' || str
[2] == '\000')
3866 if (STREQ (str
+ 3, "LJM"))
3870 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B' ||
3871 str
[4] == 'U' || str
[4] == 'P')
3873 if (str
[4] == 'R' && str
[5] != 'T')
3877 for (k
= 2; str
[k
] != '\0'; k
+= 1)
3878 if (!isdigit (str
[k
]))
3882 if (str
[0] == '$' && str
[1] != '\000')
3884 for (k
= 1; str
[k
] != '\0'; k
+= 1)
3885 if (!isdigit (str
[k
]))
3892 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
3893 * PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
3894 * informational suffixes of NAME (i.e., for which is_name_suffix is
3897 wild_match (const char *patn
, int patn_len
, const char *name
)
3902 name_len
= strlen (name
);
3903 if (name_len
>= patn_len
+ 5 && STREQN (name
, "_ada_", 5)
3904 && STREQN (patn
, name
+ 5, patn_len
)
3905 && is_name_suffix (name
+ patn_len
+ 5))
3908 while (name_len
>= patn_len
)
3910 if (STREQN (patn
, name
, patn_len
) && is_name_suffix (name
+ patn_len
))
3918 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
3923 if (!islower (name
[2]))
3930 if (!islower (name
[1]))
3941 /* Add symbols from BLOCK matching identifier NAME in NAMESPACE to
3942 vector *defn_symbols, updating *defn_symbols (if necessary), *SZ (the size of
3943 the vector *defn_symbols), and *ndefns (the number of symbols
3944 currently stored in *defn_symbols). If WILD, treat as NAME with a
3945 wildcard prefix. OBJFILE is the section containing BLOCK. */
3948 ada_add_block_symbols (struct block
*block
, const char *name
,
3949 namespace_enum
namespace, struct objfile
*objfile
,
3953 int name_len
= strlen (name
);
3954 /* A matching argument symbol, if any. */
3955 struct symbol
*arg_sym
;
3956 /* Set true when we find a matching non-argument symbol */
3958 int is_sorted
= BLOCK_SHOULD_SORT (block
);
3966 ALL_BLOCK_SYMBOLS (block
, i
, sym
)
3968 if (SYMBOL_NAMESPACE (sym
) == namespace &&
3969 wild_match (name
, name_len
, SYMBOL_NAME (sym
)))
3971 switch (SYMBOL_CLASS (sym
))
3977 case LOC_REGPARM_ADDR
:
3978 case LOC_BASEREG_ARG
:
3981 case LOC_UNRESOLVED
:
3985 fill_in_ada_prototype (sym
);
3986 add_defn_to_vec (fixup_symbol_section (sym
, objfile
), block
);
3998 U
= BLOCK_NSYMS (block
) - 1;
4001 int M
= (U
+ i
) >> 1;
4002 struct symbol
*sym
= BLOCK_SYM (block
, M
);
4003 if (SYMBOL_NAME (sym
)[0] < name
[0])
4005 else if (SYMBOL_NAME (sym
)[0] > name
[0])
4007 else if (strcmp (SYMBOL_NAME (sym
), name
) < 0)
4016 for (; i
< BLOCK_BUCKETS (block
); i
+= 1)
4017 for (sym
= BLOCK_BUCKET (block
, i
); sym
!= NULL
; sym
= sym
->hash_next
)
4019 if (SYMBOL_NAMESPACE (sym
) == namespace)
4021 int cmp
= strncmp (name
, SYMBOL_NAME (sym
), name_len
);
4027 i
= BLOCK_BUCKETS (block
);
4032 && is_name_suffix (SYMBOL_NAME (sym
) + name_len
))
4034 switch (SYMBOL_CLASS (sym
))
4040 case LOC_REGPARM_ADDR
:
4041 case LOC_BASEREG_ARG
:
4044 case LOC_UNRESOLVED
:
4048 fill_in_ada_prototype (sym
);
4049 add_defn_to_vec (fixup_symbol_section (sym
, objfile
),
4058 if (!found_sym
&& arg_sym
!= NULL
)
4060 fill_in_ada_prototype (arg_sym
);
4061 add_defn_to_vec (fixup_symbol_section (arg_sym
, objfile
), block
);
4072 U
= BLOCK_NSYMS (block
) - 1;
4075 int M
= (U
+ i
) >> 1;
4076 struct symbol
*sym
= BLOCK_SYM (block
, M
);
4077 if (SYMBOL_NAME (sym
)[0] < '_')
4079 else if (SYMBOL_NAME (sym
)[0] > '_')
4081 else if (strcmp (SYMBOL_NAME (sym
), "_ada_") < 0)
4090 for (; i
< BLOCK_BUCKETS (block
); i
+= 1)
4091 for (sym
= BLOCK_BUCKET (block
, i
); sym
!= NULL
; sym
= sym
->hash_next
)
4093 struct symbol
*sym
= BLOCK_SYM (block
, i
);
4095 if (SYMBOL_NAMESPACE (sym
) == namespace)
4099 cmp
= (int) '_' - (int) SYMBOL_NAME (sym
)[0];
4102 cmp
= strncmp ("_ada_", SYMBOL_NAME (sym
), 5);
4104 cmp
= strncmp (name
, SYMBOL_NAME (sym
) + 5, name_len
);
4111 i
= BLOCK_BUCKETS (block
);
4116 && is_name_suffix (SYMBOL_NAME (sym
) + name_len
+ 5))
4118 switch (SYMBOL_CLASS (sym
))
4124 case LOC_REGPARM_ADDR
:
4125 case LOC_BASEREG_ARG
:
4128 case LOC_UNRESOLVED
:
4132 fill_in_ada_prototype (sym
);
4133 add_defn_to_vec (fixup_symbol_section (sym
, objfile
),
4141 /* NOTE: This really shouldn't be needed for _ada_ symbols.
4142 They aren't parameters, right? */
4143 if (!found_sym
&& arg_sym
!= NULL
)
4145 fill_in_ada_prototype (arg_sym
);
4146 add_defn_to_vec (fixup_symbol_section (arg_sym
, objfile
), block
);
4152 /* Function Types */
4154 /* Assuming that SYM is the symbol for a function, fill in its type
4155 with prototype information, if it is not already there. */
4158 fill_in_ada_prototype (struct symbol
*func
)
4169 || TYPE_CODE (SYMBOL_TYPE (func
)) != TYPE_CODE_FUNC
4170 || TYPE_FIELDS (SYMBOL_TYPE (func
)) != NULL
)
4173 /* We make each function type unique, so that each may have its own */
4174 /* parameter types. This particular way of doing so wastes space: */
4175 /* it would be nicer to build the argument types while the original */
4176 /* function type is being built (FIXME). */
4177 rtype
= check_typedef (TYPE_TARGET_TYPE (SYMBOL_TYPE (func
)));
4178 ftype
= alloc_type (TYPE_OBJFILE (SYMBOL_TYPE (func
)));
4179 make_function_type (rtype
, &ftype
);
4180 SYMBOL_TYPE (func
) = ftype
;
4182 b
= SYMBOL_BLOCK_VALUE (func
);
4186 TYPE_FIELDS (ftype
) =
4187 (struct field
*) xmalloc (sizeof (struct field
) * max_fields
);
4188 ALL_BLOCK_SYMBOLS (b
, i
, sym
)
4190 GROW_VECT (TYPE_FIELDS (ftype
), max_fields
, nargs
+ 1);
4192 switch (SYMBOL_CLASS (sym
))
4195 case LOC_REGPARM_ADDR
:
4196 TYPE_FIELD_BITPOS (ftype
, nargs
) = nargs
;
4197 TYPE_FIELD_BITSIZE (ftype
, nargs
) = 0;
4198 TYPE_FIELD_TYPE (ftype
, nargs
) =
4199 lookup_pointer_type (check_typedef (SYMBOL_TYPE (sym
)));
4200 TYPE_FIELD_NAME (ftype
, nargs
) = SYMBOL_NAME (sym
);
4208 case LOC_BASEREG_ARG
:
4209 TYPE_FIELD_BITPOS (ftype
, nargs
) = nargs
;
4210 TYPE_FIELD_BITSIZE (ftype
, nargs
) = 0;
4211 TYPE_FIELD_TYPE (ftype
, nargs
) = check_typedef (SYMBOL_TYPE (sym
));
4212 TYPE_FIELD_NAME (ftype
, nargs
) = SYMBOL_NAME (sym
);
4222 /* Re-allocate fields vector; if there are no fields, make the */
4223 /* fields pointer non-null anyway, to mark that this function type */
4224 /* has been filled in. */
4226 TYPE_NFIELDS (ftype
) = nargs
;
4229 static struct field dummy_field
= { 0, 0, 0, 0 };
4230 xfree (TYPE_FIELDS (ftype
));
4231 TYPE_FIELDS (ftype
) = &dummy_field
;
4235 struct field
*fields
=
4236 (struct field
*) TYPE_ALLOC (ftype
, nargs
* sizeof (struct field
));
4237 memcpy ((char *) fields
,
4238 (char *) TYPE_FIELDS (ftype
), nargs
* sizeof (struct field
));
4239 xfree (TYPE_FIELDS (ftype
));
4240 TYPE_FIELDS (ftype
) = fields
;
4245 /* Breakpoint-related */
4247 char no_symtab_msg
[] =
4248 "No symbol table is loaded. Use the \"file\" command.";
4250 /* Assuming that LINE is pointing at the beginning of an argument to
4251 'break', return a pointer to the delimiter for the initial segment
4252 of that name. This is the first ':', ' ', or end of LINE.
4255 ada_start_decode_line_1 (char *line
)
4257 /* [NOTE: strpbrk would be more elegant, but I am reluctant to be
4258 the first to use such a library function in GDB code.] */
4260 for (p
= line
; *p
!= '\000' && *p
!= ' ' && *p
!= ':'; p
+= 1)
4265 /* *SPEC points to a function and line number spec (as in a break
4266 command), following any initial file name specification.
4268 Return all symbol table/line specfications (sals) consistent with the
4269 information in *SPEC and FILE_TABLE in the
4271 + FILE_TABLE is null, or the sal refers to a line in the file
4272 named by FILE_TABLE.
4273 + If *SPEC points to an argument with a trailing ':LINENUM',
4274 then the sal refers to that line (or one following it as closely as
4276 + If *SPEC does not start with '*', the sal is in a function with
4279 Returns with 0 elements if no matching non-minimal symbols found.
4281 If *SPEC begins with a function name of the form <NAME>, then NAME
4282 is taken as a literal name; otherwise the function name is subject
4283 to the usual mangling.
4285 *SPEC is updated to point after the function/line number specification.
4287 FUNFIRSTLINE is non-zero if we desire the first line of real code
4288 in each function (this is ignored in the presence of a LINENUM spec.).
4290 If CANONICAL is non-NULL, and if any of the sals require a
4291 'canonical line spec', then *CANONICAL is set to point to an array
4292 of strings, corresponding to and equal in length to the returned
4293 list of sals, such that (*CANONICAL)[i] is non-null and contains a
4294 canonical line spec for the ith returned sal, if needed. If no
4295 canonical line specs are required and CANONICAL is non-null,
4296 *CANONICAL is set to NULL.
4298 A 'canonical line spec' is simply a name (in the format of the
4299 breakpoint command) that uniquely identifies a breakpoint position,
4300 with no further contextual information or user selection. It is
4301 needed whenever the file name, function name, and line number
4302 information supplied is insufficient for this unique
4303 identification. Currently overloaded functions, the name '*',
4304 or static functions without a filename yield a canonical line spec.
4305 The array and the line spec strings are allocated on the heap; it
4306 is the caller's responsibility to free them. */
4308 struct symtabs_and_lines
4309 ada_finish_decode_line_1 (char **spec
, struct symtab
*file_table
,
4310 int funfirstline
, char ***canonical
)
4312 struct symbol
**symbols
;
4313 struct block
**blocks
;
4314 struct block
*block
;
4315 int n_matches
, i
, line_num
;
4316 struct symtabs_and_lines selected
;
4317 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
4322 char *unquoted_name
;
4324 if (file_table
== NULL
)
4325 block
= get_selected_block (NULL
);
4327 block
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (file_table
), STATIC_BLOCK
);
4329 if (canonical
!= NULL
)
4330 *canonical
= (char **) NULL
;
4337 while (**spec
!= '\000' &&
4338 !strchr (ada_completer_word_break_characters
, **spec
))
4344 if (file_table
!= NULL
&& (*spec
)[0] == ':' && isdigit ((*spec
)[1]))
4346 line_num
= strtol (*spec
+ 1, spec
, 10);
4347 while (**spec
== ' ' || **spec
== '\t')
4354 error ("Wild-card function with no line number or file name.");
4356 return all_sals_for_line (file_table
->filename
, line_num
, canonical
);
4359 if (name
[0] == '\'')
4367 unquoted_name
= (char *) alloca (len
- 1);
4368 memcpy (unquoted_name
, name
+ 1, len
- 2);
4369 unquoted_name
[len
- 2] = '\000';
4374 unquoted_name
= (char *) alloca (len
+ 1);
4375 memcpy (unquoted_name
, name
, len
);
4376 unquoted_name
[len
] = '\000';
4377 lower_name
= (char *) alloca (len
+ 1);
4378 for (i
= 0; i
< len
; i
+= 1)
4379 lower_name
[i
] = tolower (name
[i
]);
4380 lower_name
[len
] = '\000';
4384 if (lower_name
!= NULL
)
4385 n_matches
= ada_lookup_symbol_list (ada_mangle (lower_name
), block
,
4386 VAR_NAMESPACE
, &symbols
, &blocks
);
4388 n_matches
= ada_lookup_symbol_list (unquoted_name
, block
,
4389 VAR_NAMESPACE
, &symbols
, &blocks
);
4390 if (n_matches
== 0 && line_num
>= 0)
4391 error ("No line number information found for %s.", unquoted_name
);
4392 else if (n_matches
== 0)
4394 #ifdef HPPA_COMPILER_BUG
4395 /* FIXME: See comment in symtab.c::decode_line_1 */
4397 volatile struct symtab_and_line val
;
4398 #define volatile /*nothing */
4400 struct symtab_and_line val
;
4402 struct minimal_symbol
*msymbol
;
4407 if (lower_name
!= NULL
)
4408 msymbol
= ada_lookup_minimal_symbol (ada_mangle (lower_name
));
4409 if (msymbol
== NULL
)
4410 msymbol
= ada_lookup_minimal_symbol (unquoted_name
);
4411 if (msymbol
!= NULL
)
4413 val
.pc
= SYMBOL_VALUE_ADDRESS (msymbol
);
4414 val
.section
= SYMBOL_BFD_SECTION (msymbol
);
4417 val
.pc
+= FUNCTION_START_OFFSET
;
4418 SKIP_PROLOGUE (val
.pc
);
4420 selected
.sals
= (struct symtab_and_line
*)
4421 xmalloc (sizeof (struct symtab_and_line
));
4422 selected
.sals
[0] = val
;
4427 if (!have_full_symbols () &&
4428 !have_partial_symbols () && !have_minimal_symbols ())
4429 error (no_symtab_msg
);
4431 error ("Function \"%s\" not defined.", unquoted_name
);
4432 return selected
; /* for lint */
4438 find_sal_from_funcs_and_line (file_table
->filename
, line_num
,
4439 symbols
, n_matches
);
4444 user_select_syms (symbols
, blocks
, n_matches
, n_matches
);
4447 selected
.sals
= (struct symtab_and_line
*)
4448 xmalloc (sizeof (struct symtab_and_line
) * selected
.nelts
);
4449 memset (selected
.sals
, 0, selected
.nelts
* sizeof (selected
.sals
[i
]));
4450 make_cleanup (xfree
, selected
.sals
);
4453 while (i
< selected
.nelts
)
4455 if (SYMBOL_CLASS (symbols
[i
]) == LOC_BLOCK
)
4456 selected
.sals
[i
] = find_function_start_sal (symbols
[i
], funfirstline
);
4457 else if (SYMBOL_LINE (symbols
[i
]) != 0)
4459 selected
.sals
[i
].symtab
= symtab_for_sym (symbols
[i
]);
4460 selected
.sals
[i
].line
= SYMBOL_LINE (symbols
[i
]);
4462 else if (line_num
>= 0)
4464 /* Ignore this choice */
4465 symbols
[i
] = symbols
[selected
.nelts
- 1];
4466 blocks
[i
] = blocks
[selected
.nelts
- 1];
4467 selected
.nelts
-= 1;
4471 error ("Line number not known for symbol \"%s\"", unquoted_name
);
4475 if (canonical
!= NULL
&& (line_num
>= 0 || n_matches
> 1))
4477 *canonical
= (char **) xmalloc (sizeof (char *) * selected
.nelts
);
4478 for (i
= 0; i
< selected
.nelts
; i
+= 1)
4480 extended_canonical_line_spec (selected
.sals
[i
],
4481 SYMBOL_SOURCE_NAME (symbols
[i
]));
4484 discard_cleanups (old_chain
);
4488 /* The (single) sal corresponding to line LINE_NUM in a symbol table
4489 with file name FILENAME that occurs in one of the functions listed
4490 in SYMBOLS[0 .. NSYMS-1]. */
4491 static struct symtabs_and_lines
4492 find_sal_from_funcs_and_line (const char *filename
, int line_num
,
4493 struct symbol
**symbols
, int nsyms
)
4495 struct symtabs_and_lines sals
;
4496 int best_index
, best
;
4497 struct linetable
*best_linetable
;
4498 struct objfile
*objfile
;
4500 struct symtab
*best_symtab
;
4502 read_all_symtabs (filename
);
4505 best_linetable
= NULL
;
4508 ALL_SYMTABS (objfile
, s
)
4510 struct linetable
*l
;
4515 if (!STREQ (filename
, s
->filename
))
4518 ind
= find_line_in_linetable (l
, line_num
, symbols
, nsyms
, &exact
);
4528 if (best
== 0 || l
->item
[ind
].line
< best
)
4530 best
= l
->item
[ind
].line
;
4539 error ("Line number not found in designated function.");
4544 sals
.sals
= (struct symtab_and_line
*) xmalloc (sizeof (sals
.sals
[0]));
4546 INIT_SAL (&sals
.sals
[0]);
4548 sals
.sals
[0].line
= best_linetable
->item
[best_index
].line
;
4549 sals
.sals
[0].pc
= best_linetable
->item
[best_index
].pc
;
4550 sals
.sals
[0].symtab
= best_symtab
;
4555 /* Return the index in LINETABLE of the best match for LINE_NUM whose
4556 pc falls within one of the functions denoted by SYMBOLS[0..NSYMS-1].
4557 Set *EXACTP to the 1 if the match is exact, and 0 otherwise. */
4559 find_line_in_linetable (struct linetable
*linetable
, int line_num
,
4560 struct symbol
**symbols
, int nsyms
, int *exactp
)
4562 int i
, len
, best_index
, best
;
4564 if (line_num
<= 0 || linetable
== NULL
)
4567 len
= linetable
->nitems
;
4568 for (i
= 0, best_index
= -1, best
= 0; i
< len
; i
+= 1)
4571 struct linetable_entry
*item
= &(linetable
->item
[i
]);
4573 for (k
= 0; k
< nsyms
; k
+= 1)
4575 if (symbols
[k
] != NULL
&& SYMBOL_CLASS (symbols
[k
]) == LOC_BLOCK
4576 && item
->pc
>= BLOCK_START (SYMBOL_BLOCK_VALUE (symbols
[k
]))
4577 && item
->pc
< BLOCK_END (SYMBOL_BLOCK_VALUE (symbols
[k
])))
4584 if (item
->line
== line_num
)
4590 if (item
->line
> line_num
&& (best
== 0 || item
->line
< best
))
4601 /* Find the smallest k >= LINE_NUM such that k is a line number in
4602 LINETABLE, and k falls strictly within a named function that begins at
4603 or before LINE_NUM. Return -1 if there is no such k. */
4605 nearest_line_number_in_linetable (struct linetable
*linetable
, int line_num
)
4609 if (line_num
<= 0 || linetable
== NULL
|| linetable
->nitems
== 0)
4611 len
= linetable
->nitems
;
4618 struct linetable_entry
*item
= &(linetable
->item
[i
]);
4620 if (item
->line
>= line_num
&& item
->line
< best
)
4623 CORE_ADDR start
, end
;
4626 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
4628 if (func_name
!= NULL
&& item
->pc
< end
)
4630 if (item
->line
== line_num
)
4634 struct symbol
*sym
=
4635 standard_lookup (func_name
, VAR_NAMESPACE
);
4636 if (is_plausible_func_for_line (sym
, line_num
))
4642 while (i
< len
&& linetable
->item
[i
].pc
< end
);
4652 return (best
== INT_MAX
) ? -1 : best
;
4656 /* Return the next higher index, k, into LINETABLE such that k > IND,
4657 entry k in LINETABLE has a line number equal to LINE_NUM, k
4658 corresponds to a PC that is in a function different from that
4659 corresponding to IND, and falls strictly within a named function
4660 that begins at a line at or preceding STARTING_LINE.
4661 Return -1 if there is no such k.
4662 IND == -1 corresponds to no function. */
4665 find_next_line_in_linetable (struct linetable
*linetable
, int line_num
,
4666 int starting_line
, int ind
)
4670 if (line_num
<= 0 || linetable
== NULL
|| ind
>= linetable
->nitems
)
4672 len
= linetable
->nitems
;
4676 CORE_ADDR start
, end
;
4678 if (find_pc_partial_function (linetable
->item
[ind
].pc
,
4679 (char **) NULL
, &start
, &end
))
4681 while (ind
< len
&& linetable
->item
[ind
].pc
< end
)
4694 struct linetable_entry
*item
= &(linetable
->item
[i
]);
4696 if (item
->line
>= line_num
)
4699 CORE_ADDR start
, end
;
4702 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
4704 if (func_name
!= NULL
&& item
->pc
< end
)
4706 if (item
->line
== line_num
)
4708 struct symbol
*sym
=
4709 standard_lookup (func_name
, VAR_NAMESPACE
);
4710 if (is_plausible_func_for_line (sym
, starting_line
))
4714 while ((i
+ 1) < len
&& linetable
->item
[i
+ 1].pc
< end
)
4726 /* True iff function symbol SYM starts somewhere at or before line #
4729 is_plausible_func_for_line (struct symbol
*sym
, int line_num
)
4731 struct symtab_and_line start_sal
;
4736 start_sal
= find_function_start_sal (sym
, 0);
4738 return (start_sal
.line
!= 0 && line_num
>= start_sal
.line
);
4742 debug_print_lines (struct linetable
*lt
)
4749 fprintf (stderr
, "\t");
4750 for (i
= 0; i
< lt
->nitems
; i
+= 1)
4751 fprintf (stderr
, "(%d->%p) ", lt
->item
[i
].line
, (void *) lt
->item
[i
].pc
);
4752 fprintf (stderr
, "\n");
4756 debug_print_block (struct block
*b
)
4761 fprintf (stderr
, "Block: %p; [0x%lx, 0x%lx]",
4762 b
, BLOCK_START (b
), BLOCK_END (b
));
4763 if (BLOCK_FUNCTION (b
) != NULL
)
4764 fprintf (stderr
, " Function: %s", SYMBOL_NAME (BLOCK_FUNCTION (b
)));
4765 fprintf (stderr
, "\n");
4766 fprintf (stderr
, "\t Superblock: %p\n", BLOCK_SUPERBLOCK (b
));
4767 fprintf (stderr
, "\t Symbols:");
4768 ALL_BLOCK_SYMBOLS (b
, i
, sym
)
4770 if (i
> 0 && i
% 4 == 0)
4771 fprintf (stderr
, "\n\t\t ");
4772 fprintf (stderr
, " %s", SYMBOL_NAME (sym
));
4774 fprintf (stderr
, "\n");
4778 debug_print_blocks (struct blockvector
*bv
)
4784 for (i
= 0; i
< BLOCKVECTOR_NBLOCKS (bv
); i
+= 1)
4786 fprintf (stderr
, "%6d. ", i
);
4787 debug_print_block (BLOCKVECTOR_BLOCK (bv
, i
));
4792 debug_print_symtab (struct symtab
*s
)
4794 fprintf (stderr
, "Symtab %p\n File: %s; Dir: %s\n", s
,
4795 s
->filename
, s
->dirname
);
4796 fprintf (stderr
, " Blockvector: %p, Primary: %d\n",
4797 BLOCKVECTOR (s
), s
->primary
);
4798 debug_print_blocks (BLOCKVECTOR (s
));
4799 fprintf (stderr
, " Line table: %p\n", LINETABLE (s
));
4800 debug_print_lines (LINETABLE (s
));
4803 /* Read in all symbol tables corresponding to partial symbol tables
4804 with file name FILENAME. */
4806 read_all_symtabs (const char *filename
)
4808 struct partial_symtab
*ps
;
4809 struct objfile
*objfile
;
4811 ALL_PSYMTABS (objfile
, ps
)
4815 if (STREQ (filename
, ps
->filename
))
4816 PSYMTAB_TO_SYMTAB (ps
);
4820 /* All sals corresponding to line LINE_NUM in a symbol table from file
4821 FILENAME, as filtered by the user. If CANONICAL is not null, set
4822 it to a corresponding array of canonical line specs. */
4823 static struct symtabs_and_lines
4824 all_sals_for_line (const char *filename
, int line_num
, char ***canonical
)
4826 struct symtabs_and_lines result
;
4827 struct objfile
*objfile
;
4829 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
4832 read_all_symtabs (filename
);
4835 (struct symtab_and_line
*) xmalloc (4 * sizeof (result
.sals
[0]));
4838 make_cleanup (free_current_contents
, &result
.sals
);
4840 ALL_SYMTABS (objfile
, s
)
4842 int ind
, target_line_num
;
4846 if (!STREQ (s
->filename
, filename
))
4850 nearest_line_number_in_linetable (LINETABLE (s
), line_num
);
4851 if (target_line_num
== -1)
4858 find_next_line_in_linetable (LINETABLE (s
),
4859 target_line_num
, line_num
, ind
);
4864 GROW_VECT (result
.sals
, len
, result
.nelts
+ 1);
4865 INIT_SAL (&result
.sals
[result
.nelts
]);
4866 result
.sals
[result
.nelts
].line
= LINETABLE (s
)->item
[ind
].line
;
4867 result
.sals
[result
.nelts
].pc
= LINETABLE (s
)->item
[ind
].pc
;
4868 result
.sals
[result
.nelts
].symtab
= s
;
4873 if (canonical
!= NULL
|| result
.nelts
> 1)
4876 char **func_names
= (char **) alloca (result
.nelts
* sizeof (char *));
4877 int first_choice
= (result
.nelts
> 1) ? 2 : 1;
4879 int *choices
= (int *) alloca (result
.nelts
* sizeof (int));
4881 for (k
= 0; k
< result
.nelts
; k
+= 1)
4883 find_pc_partial_function (result
.sals
[k
].pc
, &func_names
[k
],
4884 (CORE_ADDR
*) NULL
, (CORE_ADDR
*) NULL
);
4885 if (func_names
[k
] == NULL
)
4886 error ("Could not find function for one or more breakpoints.");
4889 if (result
.nelts
> 1)
4891 printf_unfiltered ("[0] cancel\n");
4892 if (result
.nelts
> 1)
4893 printf_unfiltered ("[1] all\n");
4894 for (k
= 0; k
< result
.nelts
; k
+= 1)
4895 printf_unfiltered ("[%d] %s\n", k
+ first_choice
,
4896 ada_demangle (func_names
[k
]));
4898 n
= get_selections (choices
, result
.nelts
, result
.nelts
,
4899 result
.nelts
> 1, "instance-choice");
4901 for (k
= 0; k
< n
; k
+= 1)
4903 result
.sals
[k
] = result
.sals
[choices
[k
]];
4904 func_names
[k
] = func_names
[choices
[k
]];
4909 if (canonical
!= NULL
)
4911 *canonical
= (char **) xmalloc (result
.nelts
* sizeof (char **));
4912 make_cleanup (xfree
, *canonical
);
4913 for (k
= 0; k
< result
.nelts
; k
+= 1)
4916 extended_canonical_line_spec (result
.sals
[k
], func_names
[k
]);
4917 if ((*canonical
)[k
] == NULL
)
4918 error ("Could not locate one or more breakpoints.");
4919 make_cleanup (xfree
, (*canonical
)[k
]);
4924 discard_cleanups (old_chain
);
4929 /* A canonical line specification of the form FILE:NAME:LINENUM for
4930 symbol table and line data SAL. NULL if insufficient
4931 information. The caller is responsible for releasing any space
4935 extended_canonical_line_spec (struct symtab_and_line sal
, const char *name
)
4939 if (sal
.symtab
== NULL
|| sal
.symtab
->filename
== NULL
|| sal
.line
<= 0)
4942 r
= (char *) xmalloc (strlen (name
) + strlen (sal
.symtab
->filename
)
4943 + sizeof (sal
.line
) * 3 + 3);
4944 sprintf (r
, "%s:'%s':%d", sal
.symtab
->filename
, name
, sal
.line
);
4949 int begin_bnum
= -1;
4951 int begin_annotate_level
= 0;
4954 begin_cleanup (void *dummy
)
4956 begin_annotate_level
= 0;
4960 begin_command (char *args
, int from_tty
)
4962 struct minimal_symbol
*msym
;
4963 CORE_ADDR main_program_name_addr
;
4964 char main_program_name
[1024];
4965 struct cleanup
*old_chain
= make_cleanup (begin_cleanup
, NULL
);
4966 begin_annotate_level
= 2;
4968 /* Check that there is a program to debug */
4969 if (!have_full_symbols () && !have_partial_symbols ())
4970 error ("No symbol table is loaded. Use the \"file\" command.");
4972 /* Check that we are debugging an Ada program */
4973 /* if (ada_update_initial_language (language_unknown, NULL) != language_ada)
4974 error ("Cannot find the Ada initialization procedure. Is this an Ada main program?");
4976 /* FIXME: language_ada should be defined in defs.h */
4978 /* Get the address of the name of the main procedure */
4979 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
4983 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
4984 if (main_program_name_addr
== 0)
4985 error ("Invalid address for Ada main program name.");
4987 /* Read the name of the main procedure */
4988 extract_string (main_program_name_addr
, main_program_name
);
4990 /* Put a temporary breakpoint in the Ada main program and run */
4991 do_command ("tbreak ", main_program_name
, 0);
4992 do_command ("run ", args
, 0);
4996 /* If we could not find the symbol containing the name of the
4997 main program, that means that the compiler that was used to build
4998 was not recent enough. In that case, we fallback to the previous
4999 mechanism, which is a little bit less reliable, but has proved to work
5000 in most cases. The only cases where it will fail is when the user
5001 has set some breakpoints which will be hit before the end of the
5002 begin command processing (eg in the initialization code).
5004 The begining of the main Ada subprogram is located by breaking
5005 on the adainit procedure. Since we know that the binder generates
5006 the call to this procedure exactly 2 calls before the call to the
5007 Ada main subprogram, it is then easy to put a breakpoint on this
5008 Ada main subprogram once we hit adainit.
5010 do_command ("tbreak adainit", 0);
5011 do_command ("run ", args
, 0);
5012 do_command ("up", 0);
5013 do_command ("tbreak +2", 0);
5014 do_command ("continue", 0);
5015 do_command ("step", 0);
5018 do_cleanups (old_chain
);
5022 is_ada_runtime_file (char *filename
)
5024 return (STREQN (filename
, "s-", 2) ||
5025 STREQN (filename
, "a-", 2) ||
5026 STREQN (filename
, "g-", 2) || STREQN (filename
, "i-", 2));
5029 /* find the first frame that contains debugging information and that is not
5030 part of the Ada run-time, starting from fi and moving upward. */
5033 find_printable_frame (struct frame_info
*fi
, int level
)
5035 struct symtab_and_line sal
;
5037 for (; fi
!= NULL
; level
+= 1, fi
= get_prev_frame (fi
))
5039 /* If fi is not the innermost frame, that normally means that fi->pc
5040 points to *after* the call instruction, and we want to get the line
5041 containing the call, never the next line. But if the next frame is
5042 a signal_handler_caller or a dummy frame, then the next frame was
5043 not entered as the result of a call, and we want to get the line
5044 containing fi->pc. */
5046 find_pc_line (fi
->pc
,
5048 && !fi
->next
->signal_handler_caller
5049 && !frame_in_dummy (fi
->next
));
5050 if (sal
.symtab
&& !is_ada_runtime_file (sal
.symtab
->filename
))
5052 #if defined(__alpha__) && defined(__osf__) && !defined(VXWORKS_TARGET)
5053 /* libpthread.so contains some debugging information that prevents us
5054 from finding the right frame */
5056 if (sal
.symtab
->objfile
&&
5057 STREQ (sal
.symtab
->objfile
->name
, "/usr/shlib/libpthread.so"))
5060 selected_frame
= fi
;
5069 ada_report_exception_break (struct breakpoint
*b
)
5072 /* FIXME: break_on_exception should be defined in breakpoint.h */
5073 /* if (b->break_on_exception == 1)
5075 /* Assume that cond has 16 elements, the 15th
5076 being the exception *//*
5077 if (b->cond && b->cond->nelts == 16)
5079 ui_out_text (uiout, "on ");
5080 ui_out_field_string (uiout, "exception",
5081 SYMBOL_NAME (b->cond->elts[14].symbol));
5084 ui_out_text (uiout, "on all exceptions");
5086 else if (b->break_on_exception == 2)
5087 ui_out_text (uiout, "on unhandled exception");
5088 else if (b->break_on_exception == 3)
5089 ui_out_text (uiout, "on assert failure");
5091 if (b->break_on_exception == 1)
5093 /* Assume that cond has 16 elements, the 15th
5094 being the exception *//*
5095 if (b->cond && b->cond->nelts == 16)
5097 fputs_filtered ("on ", gdb_stdout);
5098 fputs_filtered (SYMBOL_NAME
5099 (b->cond->elts[14].symbol), gdb_stdout);
5102 fputs_filtered ("on all exceptions", gdb_stdout);
5104 else if (b->break_on_exception == 2)
5105 fputs_filtered ("on unhandled exception", gdb_stdout);
5106 else if (b->break_on_exception == 3)
5107 fputs_filtered ("on assert failure", gdb_stdout);
5113 ada_is_exception_sym (struct symbol
*sym
)
5115 char *type_name
= type_name_no_tag (SYMBOL_TYPE (sym
));
5117 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5118 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5119 && SYMBOL_CLASS (sym
) != LOC_CONST
5120 && type_name
!= NULL
&& STREQ (type_name
, "exception"));
5124 ada_maybe_exception_partial_symbol (struct partial_symbol
*sym
)
5126 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5127 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5128 && SYMBOL_CLASS (sym
) != LOC_CONST
);
5131 /* If ARG points to an Ada exception or assert breakpoint, rewrite
5132 into equivalent form. Return resulting argument string. Set
5133 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
5134 break on unhandled, 3 for assert, 0 otherwise. */
5136 ada_breakpoint_rewrite (char *arg
, int *break_on_exceptionp
)
5140 *break_on_exceptionp
= 0;
5141 /* FIXME: language_ada should be defined in defs.h */
5142 /* if (current_language->la_language == language_ada
5143 && STREQN (arg, "exception", 9) &&
5144 (arg[9] == ' ' || arg[9] == '\t' || arg[9] == '\0'))
5146 char *tok, *end_tok;
5149 *break_on_exceptionp = 1;
5152 while (*tok == ' ' || *tok == '\t')
5157 while (*end_tok != ' ' && *end_tok != '\t' && *end_tok != '\000')
5160 toklen = end_tok - tok;
5162 arg = (char*) xmalloc (sizeof ("__gnat_raise_nodefer_with_msg if "
5163 "long_integer(e) = long_integer(&)")
5165 make_cleanup (xfree, arg);
5167 strcpy (arg, "__gnat_raise_nodefer_with_msg");
5168 else if (STREQN (tok, "unhandled", toklen))
5170 *break_on_exceptionp = 2;
5171 strcpy (arg, "__gnat_unhandled_exception");
5175 sprintf (arg, "__gnat_raise_nodefer_with_msg if "
5176 "long_integer(e) = long_integer(&%.*s)",
5180 else if (current_language->la_language == language_ada
5181 && STREQN (arg, "assert", 6) &&
5182 (arg[6] == ' ' || arg[6] == '\t' || arg[6] == '\0'))
5184 char *tok = arg + 6;
5186 *break_on_exceptionp = 3;
5189 xmalloc (sizeof ("system__assertions__raise_assert_failure")
5190 + strlen (tok) + 1);
5191 make_cleanup (xfree, arg);
5192 sprintf (arg, "system__assertions__raise_assert_failure%s", tok);
5201 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5202 to be invisible to users. */
5205 ada_is_ignored_field (struct type
*type
, int field_num
)
5207 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5211 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5212 return (name
== NULL
5213 || (name
[0] == '_' && !STREQN (name
, "_parent", 7)));
5217 /* True iff structure type TYPE has a tag field. */
5220 ada_is_tagged_type (struct type
*type
)
5222 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5225 return (ada_lookup_struct_elt_type (type
, "_tag", 1, NULL
) != NULL
);
5228 /* The type of the tag on VAL. */
5231 ada_tag_type (struct value
*val
)
5233 return ada_lookup_struct_elt_type (VALUE_TYPE (val
), "_tag", 0, NULL
);
5236 /* The value of the tag on VAL. */
5239 ada_value_tag (struct value
*val
)
5241 return ada_value_struct_elt (val
, "_tag", "record");
5244 /* The parent type of TYPE, or NULL if none. */
5247 ada_parent_type (struct type
*type
)
5251 CHECK_TYPEDEF (type
);
5253 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5256 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5257 if (ada_is_parent_field (type
, i
))
5258 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5263 /* True iff field number FIELD_NUM of structure type TYPE contains the
5264 parent-type (inherited) fields of a derived type. Assumes TYPE is
5265 a structure type with at least FIELD_NUM+1 fields. */
5268 ada_is_parent_field (struct type
*type
, int field_num
)
5270 const char *name
= TYPE_FIELD_NAME (check_typedef (type
), field_num
);
5271 return (name
!= NULL
&&
5272 (STREQN (name
, "PARENT", 6) || STREQN (name
, "_parent", 7)));
5275 /* True iff field number FIELD_NUM of structure type TYPE is a
5276 transparent wrapper field (which should be silently traversed when doing
5277 field selection and flattened when printing). Assumes TYPE is a
5278 structure type with at least FIELD_NUM+1 fields. Such fields are always
5282 ada_is_wrapper_field (struct type
*type
, int field_num
)
5284 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5285 return (name
!= NULL
5286 && (STREQN (name
, "PARENT", 6) || STREQ (name
, "REP")
5287 || STREQN (name
, "_parent", 7)
5288 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5291 /* True iff field number FIELD_NUM of structure or union type TYPE
5292 is a variant wrapper. Assumes TYPE is a structure type with at least
5293 FIELD_NUM+1 fields. */
5296 ada_is_variant_part (struct type
*type
, int field_num
)
5298 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5299 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5300 || (is_dynamic_field (type
, field_num
)
5301 && TYPE_CODE (TYPE_TARGET_TYPE (field_type
)) ==
5305 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5306 whose discriminants are contained in the record type OUTER_TYPE,
5307 returns the type of the controlling discriminant for the variant. */
5310 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5312 char *name
= ada_variant_discrim_name (var_type
);
5313 struct type
*type
= ada_lookup_struct_elt_type (outer_type
, name
, 1, NULL
);
5315 return builtin_type_int
;
5320 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5321 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5322 represents a 'when others' clause; otherwise 0. */
5325 ada_is_others_clause (struct type
*type
, int field_num
)
5327 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5328 return (name
!= NULL
&& name
[0] == 'O');
5331 /* Assuming that TYPE0 is the type of the variant part of a record,
5332 returns the name of the discriminant controlling the variant. The
5333 value is valid until the next call to ada_variant_discrim_name. */
5336 ada_variant_discrim_name (struct type
*type0
)
5338 static char *result
= NULL
;
5339 static size_t result_len
= 0;
5342 const char *discrim_end
;
5343 const char *discrim_start
;
5345 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5346 type
= TYPE_TARGET_TYPE (type0
);
5350 name
= ada_type_name (type
);
5352 if (name
== NULL
|| name
[0] == '\000')
5355 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5358 if (STREQN (discrim_end
, "___XVN", 6))
5361 if (discrim_end
== name
)
5364 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5367 if (discrim_start
== name
+ 1)
5369 if ((discrim_start
> name
+ 3 && STREQN (discrim_start
- 3, "___", 3))
5370 || discrim_start
[-1] == '.')
5374 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5375 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5376 result
[discrim_end
- discrim_start
] = '\0';
5380 /* Scan STR for a subtype-encoded number, beginning at position K. Put the
5381 position of the character just past the number scanned in *NEW_K,
5382 if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL. Return 1
5383 if there was a valid number at the given position, and 0 otherwise. A
5384 "subtype-encoded" number consists of the absolute value in decimal,
5385 followed by the letter 'm' to indicate a negative number. Assumes 0m
5389 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5393 if (!isdigit (str
[k
]))
5396 /* Do it the hard way so as not to make any assumption about
5397 the relationship of unsigned long (%lu scan format code) and
5400 while (isdigit (str
[k
]))
5402 RU
= RU
* 10 + (str
[k
] - '0');
5409 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5415 /* NOTE on the above: Technically, C does not say what the results of
5416 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5417 number representable as a LONGEST (although either would probably work
5418 in most implementations). When RU>0, the locution in the then branch
5419 above is always equivalent to the negative of RU. */
5426 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5427 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5428 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5431 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5433 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5446 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5455 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5456 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5458 if (val
>= L
&& val
<= U
)
5470 /* Given a value ARG1 (offset by OFFSET bytes)
5471 of a struct or union type ARG_TYPE,
5472 extract and return the value of one of its (non-static) fields.
5473 FIELDNO says which field. Differs from value_primitive_field only
5474 in that it can handle packed values of arbitrary type. */
5477 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5478 struct type
*arg_type
)
5483 CHECK_TYPEDEF (arg_type
);
5484 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5486 /* Handle packed fields */
5488 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5490 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5491 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5493 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
5494 offset
+ bit_pos
/ 8,
5495 bit_pos
% 8, bit_size
, type
);
5498 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5502 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5503 and search in it assuming it has (class) type TYPE.
5504 If found, return value, else return NULL.
5506 Searches recursively through wrapper fields (e.g., '_parent'). */
5509 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5513 CHECK_TYPEDEF (type
);
5515 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5517 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5519 if (t_field_name
== NULL
)
5522 else if (field_name_match (t_field_name
, name
))
5523 return ada_value_primitive_field (arg
, offset
, i
, type
);
5525 else if (ada_is_wrapper_field (type
, i
))
5527 struct value
*v
= ada_search_struct_field (name
, arg
,
5529 TYPE_FIELD_BITPOS (type
,
5532 TYPE_FIELD_TYPE (type
,
5538 else if (ada_is_variant_part (type
, i
))
5541 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5542 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5544 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5546 struct value
*v
= ada_search_struct_field (name
, arg
,
5550 (field_type
, j
) / 8,
5561 /* Given ARG, a value of type (pointer to a)* structure/union,
5562 extract the component named NAME from the ultimate target structure/union
5563 and return it as a value with its appropriate type.
5565 The routine searches for NAME among all members of the structure itself
5566 and (recursively) among all members of any wrapper members
5569 ERR is a name (for use in error messages) that identifies the class
5570 of entity that ARG is supposed to be. */
5573 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5578 arg
= ada_coerce_ref (arg
);
5579 t
= check_typedef (VALUE_TYPE (arg
));
5581 /* Follow pointers until we get to a non-pointer. */
5583 while (TYPE_CODE (t
) == TYPE_CODE_PTR
|| TYPE_CODE (t
) == TYPE_CODE_REF
)
5585 arg
= ada_value_ind (arg
);
5586 t
= check_typedef (VALUE_TYPE (arg
));
5589 if (TYPE_CODE (t
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t
) != TYPE_CODE_UNION
)
5590 error ("Attempt to extract a component of a value that is not a %s.",
5593 v
= ada_search_struct_field (name
, arg
, 0, t
);
5595 error ("There is no member named %s.", name
);
5600 /* Given a type TYPE, look up the type of the component of type named NAME.
5601 If DISPP is non-null, add its byte displacement from the beginning of a
5602 structure (pointed to by a value) of type TYPE to *DISPP (does not
5603 work for packed fields).
5605 Matches any field whose name has NAME as a prefix, possibly
5608 TYPE can be either a struct or union, or a pointer or reference to
5609 a struct or union. If it is a pointer or reference, its target
5610 type is automatically used.
5612 Looks recursively into variant clauses and parent types.
5614 If NOERR is nonzero, return NULL if NAME is not suitably defined. */
5617 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int noerr
,
5627 CHECK_TYPEDEF (type
);
5628 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5629 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5631 type
= TYPE_TARGET_TYPE (type
);
5634 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
&&
5635 TYPE_CODE (type
) != TYPE_CODE_UNION
)
5637 target_terminal_ours ();
5638 gdb_flush (gdb_stdout
);
5639 fprintf_unfiltered (gdb_stderr
, "Type ");
5640 type_print (type
, "", gdb_stderr
, -1);
5641 error (" is not a structure or union type");
5644 type
= to_static_fixed_type (type
);
5646 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5648 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5652 if (t_field_name
== NULL
)
5655 else if (field_name_match (t_field_name
, name
))
5658 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5659 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5662 else if (ada_is_wrapper_field (type
, i
))
5665 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5670 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5675 else if (ada_is_variant_part (type
, i
))
5678 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5680 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5683 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5688 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5699 target_terminal_ours ();
5700 gdb_flush (gdb_stdout
);
5701 fprintf_unfiltered (gdb_stderr
, "Type ");
5702 type_print (type
, "", gdb_stderr
, -1);
5703 fprintf_unfiltered (gdb_stderr
, " has no component named ");
5704 error ("%s", name
== NULL
? "<null>" : name
);
5710 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5711 within a value of type OUTER_TYPE that is stored in GDB at
5712 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5713 numbering from 0) is applicable. Returns -1 if none are. */
5716 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5717 char *outer_valaddr
)
5722 struct type
*discrim_type
;
5723 char *discrim_name
= ada_variant_discrim_name (var_type
);
5724 LONGEST discrim_val
;
5728 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, &disp
);
5729 if (discrim_type
== NULL
)
5731 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5734 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5736 if (ada_is_others_clause (var_type
, i
))
5738 else if (ada_in_variant (discrim_val
, var_type
, i
))
5742 return others_clause
;
5747 /* Dynamic-Sized Records */
5749 /* Strategy: The type ostensibly attached to a value with dynamic size
5750 (i.e., a size that is not statically recorded in the debugging
5751 data) does not accurately reflect the size or layout of the value.
5752 Our strategy is to convert these values to values with accurate,
5753 conventional types that are constructed on the fly. */
5755 /* There is a subtle and tricky problem here. In general, we cannot
5756 determine the size of dynamic records without its data. However,
5757 the 'struct value' data structure, which GDB uses to represent
5758 quantities in the inferior process (the target), requires the size
5759 of the type at the time of its allocation in order to reserve space
5760 for GDB's internal copy of the data. That's why the
5761 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5762 rather than struct value*s.
5764 However, GDB's internal history variables ($1, $2, etc.) are
5765 struct value*s containing internal copies of the data that are not, in
5766 general, the same as the data at their corresponding addresses in
5767 the target. Fortunately, the types we give to these values are all
5768 conventional, fixed-size types (as per the strategy described
5769 above), so that we don't usually have to perform the
5770 'to_fixed_xxx_type' conversions to look at their values.
5771 Unfortunately, there is one exception: if one of the internal
5772 history variables is an array whose elements are unconstrained
5773 records, then we will need to create distinct fixed types for each
5774 element selected. */
5776 /* The upshot of all of this is that many routines take a (type, host
5777 address, target address) triple as arguments to represent a value.
5778 The host address, if non-null, is supposed to contain an internal
5779 copy of the relevant data; otherwise, the program is to consult the
5780 target at the target address. */
5782 /* Assuming that VAL0 represents a pointer value, the result of
5783 dereferencing it. Differs from value_ind in its treatment of
5784 dynamic-sized types. */
5787 ada_value_ind (struct value
*val0
)
5789 struct value
*val
= unwrap_value (value_ind (val0
));
5790 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5791 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
), val
);
5794 /* The value resulting from dereferencing any "reference to"
5795 * qualifiers on VAL0. */
5796 static struct value
*
5797 ada_coerce_ref (struct value
*val0
)
5799 if (TYPE_CODE (VALUE_TYPE (val0
)) == TYPE_CODE_REF
)
5801 struct value
*val
= val0
;
5803 val
= unwrap_value (val
);
5804 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5805 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
5812 /* Return OFF rounded upward if necessary to a multiple of
5813 ALIGNMENT (a power of 2). */
5816 align_value (unsigned int off
, unsigned int alignment
)
5818 return (off
+ alignment
- 1) & ~(alignment
- 1);
5821 /* Return the additional bit offset required by field F of template
5825 field_offset (struct type
*type
, int f
)
5827 int n
= TYPE_FIELD_BITPOS (type
, f
);
5828 /* Kludge (temporary?) to fix problem with dwarf output. */
5830 return (unsigned int) n
& 0xffff;
5836 /* Return the bit alignment required for field #F of template type TYPE. */
5839 field_alignment (struct type
*type
, int f
)
5841 const char *name
= TYPE_FIELD_NAME (type
, f
);
5842 int len
= (name
== NULL
) ? 0 : strlen (name
);
5845 if (len
< 8 || !isdigit (name
[len
- 1]))
5846 return TARGET_CHAR_BIT
;
5848 if (isdigit (name
[len
- 2]))
5849 align_offset
= len
- 2;
5851 align_offset
= len
- 1;
5853 if (align_offset
< 7 || !STREQN ("___XV", name
+ align_offset
- 6, 5))
5854 return TARGET_CHAR_BIT
;
5856 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
5859 /* Find a type named NAME. Ignores ambiguity. */
5861 ada_find_any_type (const char *name
)
5865 sym
= standard_lookup (name
, VAR_NAMESPACE
);
5866 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5867 return SYMBOL_TYPE (sym
);
5869 sym
= standard_lookup (name
, STRUCT_NAMESPACE
);
5871 return SYMBOL_TYPE (sym
);
5876 /* Because of GNAT encoding conventions, several GDB symbols may match a
5877 given type name. If the type denoted by TYPE0 is to be preferred to
5878 that of TYPE1 for purposes of type printing, return non-zero;
5879 otherwise return 0. */
5881 ada_prefer_type (struct type
*type0
, struct type
*type1
)
5885 else if (type0
== NULL
)
5887 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
5889 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
5891 else if (ada_is_packed_array_type (type0
))
5893 else if (ada_is_array_descriptor (type0
)
5894 && !ada_is_array_descriptor (type1
))
5896 else if (ada_renaming_type (type0
) != NULL
5897 && ada_renaming_type (type1
) == NULL
)
5902 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5903 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5905 ada_type_name (struct type
*type
)
5909 else if (TYPE_NAME (type
) != NULL
)
5910 return TYPE_NAME (type
);
5912 return TYPE_TAG_NAME (type
);
5915 /* Find a parallel type to TYPE whose name is formed by appending
5916 SUFFIX to the name of TYPE. */
5919 ada_find_parallel_type (struct type
*type
, const char *suffix
)
5922 static size_t name_len
= 0;
5923 struct symbol
**syms
;
5924 struct block
**blocks
;
5927 char *typename
= ada_type_name (type
);
5929 if (typename
== NULL
)
5932 len
= strlen (typename
);
5934 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
5936 strcpy (name
, typename
);
5937 strcpy (name
+ len
, suffix
);
5939 return ada_find_any_type (name
);
5943 /* If TYPE is a variable-size record type, return the corresponding template
5944 type describing its fields. Otherwise, return NULL. */
5946 static struct type
*
5947 dynamic_template_type (struct type
*type
)
5949 CHECK_TYPEDEF (type
);
5951 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5952 || ada_type_name (type
) == NULL
)
5956 int len
= strlen (ada_type_name (type
));
5957 if (len
> 6 && STREQ (ada_type_name (type
) + len
- 6, "___XVE"))
5960 return ada_find_parallel_type (type
, "___XVE");
5964 /* Assuming that TEMPL_TYPE is a union or struct type, returns
5965 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
5968 is_dynamic_field (struct type
*templ_type
, int field_num
)
5970 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
5972 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
5973 && strstr (name
, "___XVL") != NULL
;
5976 /* Assuming that TYPE is a struct type, returns non-zero iff TYPE
5977 contains a variant part. */
5980 contains_variant_part (struct type
*type
)
5984 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5985 || TYPE_NFIELDS (type
) <= 0)
5987 return ada_is_variant_part (type
, TYPE_NFIELDS (type
) - 1);
5990 /* A record type with no fields, . */
5991 static struct type
*
5992 empty_record (struct objfile
*objfile
)
5994 struct type
*type
= alloc_type (objfile
);
5995 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
5996 TYPE_NFIELDS (type
) = 0;
5997 TYPE_FIELDS (type
) = NULL
;
5998 TYPE_NAME (type
) = "<empty>";
5999 TYPE_TAG_NAME (type
) = NULL
;
6000 TYPE_FLAGS (type
) = 0;
6001 TYPE_LENGTH (type
) = 0;
6005 /* An ordinary record type (with fixed-length fields) that describes
6006 the value of type TYPE at VALADDR or ADDRESS (see comments at
6007 the beginning of this section) VAL according to GNAT conventions.
6008 DVAL0 should describe the (portion of a) record that contains any
6009 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
6010 an outer-level type (i.e., as opposed to a branch of a variant.) A
6011 variant field (unless unchecked) is replaced by a particular branch
6013 /* NOTE: Limitations: For now, we assume that dynamic fields and
6014 * variants occupy whole numbers of bytes. However, they need not be
6017 static struct type
*
6018 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
6019 CORE_ADDR address
, struct value
*dval0
)
6021 struct value
*mark
= value_mark ();
6024 int nfields
, bit_len
;
6028 nfields
= TYPE_NFIELDS (type
);
6029 rtype
= alloc_type (TYPE_OBJFILE (type
));
6030 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6031 INIT_CPLUS_SPECIFIC (rtype
);
6032 TYPE_NFIELDS (rtype
) = nfields
;
6033 TYPE_FIELDS (rtype
) = (struct field
*)
6034 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6035 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6036 TYPE_NAME (rtype
) = ada_type_name (type
);
6037 TYPE_TAG_NAME (rtype
) = NULL
;
6038 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in
6040 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6044 for (f
= 0; f
< nfields
; f
+= 1)
6046 int fld_bit_len
, bit_incr
;
6049 field_alignment (type
, f
)) + TYPE_FIELD_BITPOS (type
, f
);
6050 /* NOTE: used to use field_offset above, but that causes
6051 * problems with really negative bit positions. So, let's
6052 * rediscover why we needed field_offset and fix it properly. */
6053 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6054 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6056 if (ada_is_variant_part (type
, f
))
6058 struct type
*branch_type
;
6061 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6066 to_fixed_variant_branch_type
6067 (TYPE_FIELD_TYPE (type
, f
),
6068 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6069 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6070 if (branch_type
== NULL
)
6071 TYPE_NFIELDS (rtype
) -= 1;
6074 TYPE_FIELD_TYPE (rtype
, f
) = branch_type
;
6075 TYPE_FIELD_NAME (rtype
, f
) = "S";
6079 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6081 else if (is_dynamic_field (type
, f
))
6084 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6088 TYPE_FIELD_TYPE (rtype
, f
) =
6091 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6092 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6093 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6094 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6095 bit_incr
= fld_bit_len
=
6096 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6100 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6101 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6102 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6103 bit_incr
= fld_bit_len
=
6104 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6106 bit_incr
= fld_bit_len
=
6107 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6109 if (off
+ fld_bit_len
> bit_len
)
6110 bit_len
= off
+ fld_bit_len
;
6112 TYPE_LENGTH (rtype
) = bit_len
/ TARGET_CHAR_BIT
;
6114 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
), TYPE_LENGTH (type
));
6116 value_free_to_mark (mark
);
6117 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6118 error ("record type with dynamic size is larger than varsize-limit");
6122 /* As for template_to_fixed_record_type, but uses no run-time values.
6123 As a result, this type can only be approximate, but that's OK,
6124 since it is used only for type determinations. Works on both
6126 Representation note: to save space, we memoize the result of this
6127 function in the TYPE_TARGET_TYPE of the template type. */
6129 static struct type
*
6130 template_to_static_fixed_type (struct type
*templ_type
)
6136 if (TYPE_TARGET_TYPE (templ_type
) != NULL
)
6137 return TYPE_TARGET_TYPE (templ_type
);
6139 nfields
= TYPE_NFIELDS (templ_type
);
6140 TYPE_TARGET_TYPE (templ_type
) = type
=
6141 alloc_type (TYPE_OBJFILE (templ_type
));
6142 TYPE_CODE (type
) = TYPE_CODE (templ_type
);
6143 INIT_CPLUS_SPECIFIC (type
);
6144 TYPE_NFIELDS (type
) = nfields
;
6145 TYPE_FIELDS (type
) = (struct field
*)
6146 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6147 memset (TYPE_FIELDS (type
), 0, sizeof (struct field
) * nfields
);
6148 TYPE_NAME (type
) = ada_type_name (templ_type
);
6149 TYPE_TAG_NAME (type
) = NULL
;
6150 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6151 /* TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE; */
6152 TYPE_LENGTH (type
) = 0;
6154 for (f
= 0; f
< nfields
; f
+= 1)
6156 TYPE_FIELD_BITPOS (type
, f
) = 0;
6157 TYPE_FIELD_BITSIZE (type
, f
) = 0;
6159 if (is_dynamic_field (templ_type
, f
))
6161 TYPE_FIELD_TYPE (type
, f
) =
6162 to_static_fixed_type (TYPE_TARGET_TYPE
6163 (TYPE_FIELD_TYPE (templ_type
, f
)));
6164 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6168 TYPE_FIELD_TYPE (type
, f
) =
6169 check_typedef (TYPE_FIELD_TYPE (templ_type
, f
));
6170 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6177 /* A revision of TYPE0 -- a non-dynamic-sized record with a variant
6178 part -- in which the variant part is replaced with the appropriate
6180 static struct type
*
6181 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
6182 CORE_ADDR address
, struct value
*dval
)
6184 struct value
*mark
= value_mark ();
6186 struct type
*branch_type
;
6187 int nfields
= TYPE_NFIELDS (type
);
6192 rtype
= alloc_type (TYPE_OBJFILE (type
));
6193 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6194 INIT_CPLUS_SPECIFIC (type
);
6195 TYPE_NFIELDS (rtype
) = TYPE_NFIELDS (type
);
6196 TYPE_FIELDS (rtype
) =
6197 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6198 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6199 sizeof (struct field
) * nfields
);
6200 TYPE_NAME (rtype
) = ada_type_name (type
);
6201 TYPE_TAG_NAME (rtype
) = NULL
;
6202 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6203 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6204 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6207 to_fixed_variant_branch_type
6208 (TYPE_FIELD_TYPE (type
, nfields
- 1),
6209 cond_offset_host (valaddr
,
6210 TYPE_FIELD_BITPOS (type
,
6211 nfields
- 1) / TARGET_CHAR_BIT
),
6212 cond_offset_target (address
,
6213 TYPE_FIELD_BITPOS (type
,
6214 nfields
- 1) / TARGET_CHAR_BIT
),
6216 if (branch_type
== NULL
)
6218 TYPE_NFIELDS (rtype
) -= 1;
6219 TYPE_LENGTH (rtype
) -=
6220 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6224 TYPE_FIELD_TYPE (rtype
, nfields
- 1) = branch_type
;
6225 TYPE_FIELD_NAME (rtype
, nfields
- 1) = "S";
6226 TYPE_FIELD_BITSIZE (rtype
, nfields
- 1) = 0;
6227 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6228 -TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6234 /* An ordinary record type (with fixed-length fields) that describes
6235 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6236 beginning of this section]. Any necessary discriminants' values
6237 should be in DVAL, a record value; it should be NULL if the object
6238 at ADDR itself contains any necessary discriminant values. A
6239 variant field (unless unchecked) is replaced by a particular branch
6242 static struct type
*
6243 to_fixed_record_type (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6246 struct type
*templ_type
;
6248 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6249 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6252 templ_type
= dynamic_template_type (type0
);
6254 if (templ_type
!= NULL
)
6255 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6256 else if (contains_variant_part (type0
))
6257 return to_record_with_fixed_variant_part (type0
, valaddr
, address
, dval
);
6260 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6261 /* TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE; */
6267 /* An ordinary record type (with fixed-length fields) that describes
6268 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6269 union type. Any necessary discriminants' values should be in DVAL,
6270 a record value. That is, this routine selects the appropriate
6271 branch of the union at ADDR according to the discriminant value
6272 indicated in the union's type name. */
6274 static struct type
*
6275 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
6276 CORE_ADDR address
, struct value
*dval
)
6279 struct type
*templ_type
;
6280 struct type
*var_type
;
6282 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6283 var_type
= TYPE_TARGET_TYPE (var_type0
);
6285 var_type
= var_type0
;
6287 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6289 if (templ_type
!= NULL
)
6290 var_type
= templ_type
;
6293 ada_which_variant_applies (var_type
,
6294 VALUE_TYPE (dval
), VALUE_CONTENTS (dval
));
6297 return empty_record (TYPE_OBJFILE (var_type
));
6298 else if (is_dynamic_field (var_type
, which
))
6300 to_fixed_record_type
6301 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6302 valaddr
, address
, dval
);
6303 else if (contains_variant_part (TYPE_FIELD_TYPE (var_type
, which
)))
6305 to_fixed_record_type
6306 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6308 return TYPE_FIELD_TYPE (var_type
, which
);
6311 /* Assuming that TYPE0 is an array type describing the type of a value
6312 at ADDR, and that DVAL describes a record containing any
6313 discriminants used in TYPE0, returns a type for the value that
6314 contains no dynamic components (that is, no components whose sizes
6315 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6316 true, gives an error message if the resulting type's size is over
6320 static struct type
*
6321 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6324 struct type
*index_type_desc
;
6325 struct type
*result
;
6327 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6328 /* if (ada_is_packed_array_type (type0) /* revisit? *//*
6329 || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
6332 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6333 if (index_type_desc
== NULL
)
6335 struct type
*elt_type0
= check_typedef (TYPE_TARGET_TYPE (type0
));
6336 /* NOTE: elt_type---the fixed version of elt_type0---should never
6337 * depend on the contents of the array in properly constructed
6338 * debugging data. */
6339 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6341 if (elt_type0
== elt_type
)
6344 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6345 elt_type
, TYPE_INDEX_TYPE (type0
));
6350 struct type
*elt_type0
;
6353 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6354 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6356 /* NOTE: result---the fixed version of elt_type0---should never
6357 * depend on the contents of the array in properly constructed
6358 * debugging data. */
6359 result
= ada_to_fixed_type (check_typedef (elt_type0
), 0, 0, dval
);
6360 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6362 struct type
*range_type
=
6363 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6364 dval
, TYPE_OBJFILE (type0
));
6365 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6366 result
, range_type
);
6368 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6369 error ("array type with dynamic size is larger than varsize-limit");
6372 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6373 /* TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE; */
6378 /* A standard type (containing no dynamically sized components)
6379 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6380 DVAL describes a record containing any discriminants used in TYPE0,
6381 and may be NULL if there are none. */
6384 ada_to_fixed_type (struct type
*type
, char *valaddr
, CORE_ADDR address
,
6387 CHECK_TYPEDEF (type
);
6388 switch (TYPE_CODE (type
))
6392 case TYPE_CODE_STRUCT
:
6393 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6394 case TYPE_CODE_ARRAY
:
6395 return to_fixed_array_type (type
, dval
, 0);
6396 case TYPE_CODE_UNION
:
6400 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6404 /* A standard (static-sized) type corresponding as well as possible to
6405 TYPE0, but based on no runtime data. */
6407 static struct type
*
6408 to_static_fixed_type (struct type
*type0
)
6415 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6416 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6419 CHECK_TYPEDEF (type0
);
6421 switch (TYPE_CODE (type0
))
6425 case TYPE_CODE_STRUCT
:
6426 type
= dynamic_template_type (type0
);
6428 return template_to_static_fixed_type (type
);
6430 case TYPE_CODE_UNION
:
6431 type
= ada_find_parallel_type (type0
, "___XVU");
6433 return template_to_static_fixed_type (type
);
6438 /* A static approximation of TYPE with all type wrappers removed. */
6439 static struct type
*
6440 static_unwrap_type (struct type
*type
)
6442 if (ada_is_aligner_type (type
))
6444 struct type
*type1
= TYPE_FIELD_TYPE (check_typedef (type
), 0);
6445 if (ada_type_name (type1
) == NULL
)
6446 TYPE_NAME (type1
) = ada_type_name (type
);
6448 return static_unwrap_type (type1
);
6452 struct type
*raw_real_type
= ada_get_base_type (type
);
6453 if (raw_real_type
== type
)
6456 return to_static_fixed_type (raw_real_type
);
6460 /* In some cases, incomplete and private types require
6461 cross-references that are not resolved as records (for example,
6463 type FooP is access Foo;
6465 type Foo is array ...;
6466 ). In these cases, since there is no mechanism for producing
6467 cross-references to such types, we instead substitute for FooP a
6468 stub enumeration type that is nowhere resolved, and whose tag is
6469 the name of the actual type. Call these types "non-record stubs". */
6471 /* A type equivalent to TYPE that is not a non-record stub, if one
6472 exists, otherwise TYPE. */
6474 ada_completed_type (struct type
*type
)
6476 CHECK_TYPEDEF (type
);
6477 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6478 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
6479 || TYPE_TAG_NAME (type
) == NULL
)
6483 char *name
= TYPE_TAG_NAME (type
);
6484 struct type
*type1
= ada_find_any_type (name
);
6485 return (type1
== NULL
) ? type
: type1
;
6489 /* A value representing the data at VALADDR/ADDRESS as described by
6490 type TYPE0, but with a standard (static-sized) type that correctly
6491 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6492 type, then return VAL0 [this feature is simply to avoid redundant
6493 creation of struct values]. */
6496 ada_to_fixed_value (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6499 struct type
*type
= ada_to_fixed_type (type0
, valaddr
, address
, NULL
);
6500 if (type
== type0
&& val0
!= NULL
)
6503 return value_from_contents_and_address (type
, valaddr
, address
);
6506 /* A value representing VAL, but with a standard (static-sized) type
6507 chosen to approximate the real type of VAL as well as possible, but
6508 without consulting any runtime values. For Ada dynamic-sized
6509 types, therefore, the type of the result is likely to be inaccurate. */
6512 ada_to_static_fixed_value (struct value
*val
)
6515 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val
)));
6516 if (type
== VALUE_TYPE (val
))
6519 return coerce_unspec_val_to_type (val
, 0, type
);
6528 /* Table mapping attribute numbers to names */
6529 /* NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h */
6531 static const char *attribute_names
[] = {
6548 ada_attribute_name (int n
)
6550 if (n
> 0 && n
< (int) ATR_END
)
6551 return attribute_names
[n
];
6553 return attribute_names
[0];
6556 /* Evaluate the 'POS attribute applied to ARG. */
6558 static struct value
*
6559 value_pos_atr (struct value
*arg
)
6561 struct type
*type
= VALUE_TYPE (arg
);
6563 if (!discrete_type_p (type
))
6564 error ("'POS only defined on discrete types");
6566 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6569 LONGEST v
= value_as_long (arg
);
6571 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6573 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6574 return value_from_longest (builtin_type_ada_int
, i
);
6576 error ("enumeration value is invalid: can't find 'POS");
6579 return value_from_longest (builtin_type_ada_int
, value_as_long (arg
));
6582 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6584 static struct value
*
6585 value_val_atr (struct type
*type
, struct value
*arg
)
6587 if (!discrete_type_p (type
))
6588 error ("'VAL only defined on discrete types");
6589 if (!integer_type_p (VALUE_TYPE (arg
)))
6590 error ("'VAL requires integral argument");
6592 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6594 long pos
= value_as_long (arg
);
6595 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6596 error ("argument to 'VAL out of range");
6597 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6600 return value_from_longest (type
, value_as_long (arg
));
6606 /* True if TYPE appears to be an Ada character type.
6607 * [At the moment, this is true only for Character and Wide_Character;
6608 * It is a heuristic test that could stand improvement]. */
6611 ada_is_character_type (struct type
*type
)
6613 const char *name
= ada_type_name (type
);
6616 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6617 || TYPE_CODE (type
) == TYPE_CODE_INT
6618 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6619 && (STREQ (name
, "character") || STREQ (name
, "wide_character")
6620 || STREQ (name
, "unsigned char"));
6623 /* True if TYPE appears to be an Ada string type. */
6626 ada_is_string_type (struct type
*type
)
6628 CHECK_TYPEDEF (type
);
6630 && TYPE_CODE (type
) != TYPE_CODE_PTR
6631 && (ada_is_simple_array (type
) || ada_is_array_descriptor (type
))
6632 && ada_array_arity (type
) == 1)
6634 struct type
*elttype
= ada_array_element_type (type
, 1);
6636 return ada_is_character_type (elttype
);
6643 /* True if TYPE is a struct type introduced by the compiler to force the
6644 alignment of a value. Such types have a single field with a
6645 distinctive name. */
6648 ada_is_aligner_type (struct type
*type
)
6650 CHECK_TYPEDEF (type
);
6651 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
6652 && TYPE_NFIELDS (type
) == 1
6653 && STREQ (TYPE_FIELD_NAME (type
, 0), "F"));
6656 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6657 the parallel type. */
6660 ada_get_base_type (struct type
*raw_type
)
6662 struct type
*real_type_namer
;
6663 struct type
*raw_real_type
;
6664 struct type
*real_type
;
6666 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
6669 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
6670 if (real_type_namer
== NULL
6671 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
6672 || TYPE_NFIELDS (real_type_namer
) != 1)
6675 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
6676 if (raw_real_type
== NULL
)
6679 return raw_real_type
;
6682 /* The type of value designated by TYPE, with all aligners removed. */
6685 ada_aligned_type (struct type
*type
)
6687 if (ada_is_aligner_type (type
))
6688 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
6690 return ada_get_base_type (type
);
6694 /* The address of the aligned value in an object at address VALADDR
6695 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6698 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
6700 if (ada_is_aligner_type (type
))
6701 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
6703 TYPE_FIELD_BITPOS (type
,
6704 0) / TARGET_CHAR_BIT
);
6709 /* The printed representation of an enumeration literal with encoded
6710 name NAME. The value is good to the next call of ada_enum_name. */
6712 ada_enum_name (const char *name
)
6718 if ((tmp
= strstr (name
, "__")) != NULL
)
6720 else if ((tmp
= strchr (name
, '.')) != NULL
)
6728 static char result
[16];
6730 if (name
[1] == 'U' || name
[1] == 'W')
6732 if (sscanf (name
+ 2, "%x", &v
) != 1)
6738 if (isascii (v
) && isprint (v
))
6739 sprintf (result
, "'%c'", v
);
6740 else if (name
[1] == 'U')
6741 sprintf (result
, "[\"%02x\"]", v
);
6743 sprintf (result
, "[\"%04x\"]", v
);
6751 static struct value
*
6752 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
6755 return (*exp
->language_defn
->evaluate_exp
) (expect_type
, exp
, pos
, noside
);
6758 /* Evaluate the subexpression of EXP starting at *POS as for
6759 evaluate_type, updating *POS to point just past the evaluated
6762 static struct value
*
6763 evaluate_subexp_type (struct expression
*exp
, int *pos
)
6765 return (*exp
->language_defn
->evaluate_exp
)
6766 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
6769 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6772 static struct value
*
6773 unwrap_value (struct value
*val
)
6775 struct type
*type
= check_typedef (VALUE_TYPE (val
));
6776 if (ada_is_aligner_type (type
))
6778 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
6779 NULL
, "internal structure");
6780 struct type
*val_type
= check_typedef (VALUE_TYPE (v
));
6781 if (ada_type_name (val_type
) == NULL
)
6782 TYPE_NAME (val_type
) = ada_type_name (type
);
6784 return unwrap_value (v
);
6788 struct type
*raw_real_type
=
6789 ada_completed_type (ada_get_base_type (type
));
6791 if (type
== raw_real_type
)
6795 coerce_unspec_val_to_type
6796 (val
, 0, ada_to_fixed_type (raw_real_type
, 0,
6797 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
6802 static struct value
*
6803 cast_to_fixed (struct type
*type
, struct value
*arg
)
6807 if (type
== VALUE_TYPE (arg
))
6809 else if (ada_is_fixed_point_type (VALUE_TYPE (arg
)))
6810 val
= ada_float_to_fixed (type
,
6811 ada_fixed_to_float (VALUE_TYPE (arg
),
6812 value_as_long (arg
)));
6816 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
6817 val
= ada_float_to_fixed (type
, argd
);
6820 return value_from_longest (type
, val
);
6823 static struct value
*
6824 cast_from_fixed_to_double (struct value
*arg
)
6826 DOUBLEST val
= ada_fixed_to_float (VALUE_TYPE (arg
),
6827 value_as_long (arg
));
6828 return value_from_double (builtin_type_double
, val
);
6831 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
6832 * return the converted value. */
6833 static struct value
*
6834 coerce_for_assign (struct type
*type
, struct value
*val
)
6836 struct type
*type2
= VALUE_TYPE (val
);
6840 CHECK_TYPEDEF (type2
);
6841 CHECK_TYPEDEF (type
);
6843 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
6844 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6846 val
= ada_value_ind (val
);
6847 type2
= VALUE_TYPE (val
);
6850 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
6851 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6853 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
6854 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
6855 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
6856 error ("Incompatible types in assignment");
6857 VALUE_TYPE (val
) = type
;
6863 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
6864 int *pos
, enum noside noside
)
6867 enum ada_attribute atr
;
6868 int tem
, tem2
, tem3
;
6870 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
6873 struct value
**argvec
;
6877 op
= exp
->elts
[pc
].opcode
;
6884 unwrap_value (evaluate_subexp_standard
6885 (expect_type
, exp
, pos
, noside
));
6889 type
= exp
->elts
[pc
+ 1].type
;
6890 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
6891 if (noside
== EVAL_SKIP
)
6893 if (type
!= check_typedef (VALUE_TYPE (arg1
)))
6895 if (ada_is_fixed_point_type (type
))
6896 arg1
= cast_to_fixed (type
, arg1
);
6897 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6898 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
6899 else if (VALUE_LVAL (arg1
) == lval_memory
)
6901 /* This is in case of the really obscure (and undocumented,
6902 but apparently expected) case of (Foo) Bar.all, where Bar
6903 is an integer constant and Foo is a dynamic-sized type.
6904 If we don't do this, ARG1 will simply be relabeled with
6906 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
6907 return value_zero (to_static_fixed_type (type
), not_lval
);
6910 (type
, 0, VALUE_ADDRESS (arg1
) + VALUE_OFFSET (arg1
), 0);
6913 arg1
= value_cast (type
, arg1
);
6917 /* FIXME: UNOP_QUAL should be defined in expression.h */
6920 type = exp->elts[pc + 1].type;
6921 return ada_evaluate_subexp (type, exp, pos, noside);
6924 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6925 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
6926 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
6928 if (binop_user_defined_p (op
, arg1
, arg2
))
6929 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6932 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6933 arg2
= cast_to_fixed (VALUE_TYPE (arg1
), arg2
);
6934 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6936 ("Fixed-point values must be assigned to fixed-point variables");
6938 arg2
= coerce_for_assign (VALUE_TYPE (arg1
), arg2
);
6939 return ada_value_assign (arg1
, arg2
);
6943 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6944 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6945 if (noside
== EVAL_SKIP
)
6947 if (binop_user_defined_p (op
, arg1
, arg2
))
6948 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6951 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6952 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6953 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6955 ("Operands of fixed-point addition must have the same type");
6956 return value_cast (VALUE_TYPE (arg1
), value_add (arg1
, arg2
));
6960 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6961 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6962 if (noside
== EVAL_SKIP
)
6964 if (binop_user_defined_p (op
, arg1
, arg2
))
6965 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6968 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6969 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6970 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6972 ("Operands of fixed-point subtraction must have the same type");
6973 return value_cast (VALUE_TYPE (arg1
), value_sub (arg1
, arg2
));
6978 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6979 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6980 if (noside
== EVAL_SKIP
)
6982 if (binop_user_defined_p (op
, arg1
, arg2
))
6983 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6985 if (noside
== EVAL_AVOID_SIDE_EFFECTS
6986 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
6987 return value_zero (VALUE_TYPE (arg1
), not_lval
);
6990 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6991 arg1
= cast_from_fixed_to_double (arg1
);
6992 if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6993 arg2
= cast_from_fixed_to_double (arg2
);
6994 return value_binop (arg1
, arg2
, op
);
6998 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6999 if (noside
== EVAL_SKIP
)
7001 if (unop_user_defined_p (op
, arg1
))
7002 return value_x_unop (arg1
, op
, EVAL_NORMAL
);
7003 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
7004 return value_cast (VALUE_TYPE (arg1
), value_neg (arg1
));
7006 return value_neg (arg1
);
7008 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7009 /* case OP_UNRESOLVED_VALUE:
7010 /* Only encountered when an unresolved symbol occurs in a
7011 context other than a function call, in which case, it is
7014 if (noside == EVAL_SKIP)
7017 error ("Unexpected unresolved symbol, %s, during evaluation",
7018 ada_demangle (exp->elts[pc + 2].name));
7022 if (noside
== EVAL_SKIP
)
7027 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7031 (to_static_fixed_type
7032 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
7038 unwrap_value (evaluate_subexp_standard
7039 (expect_type
, exp
, pos
, noside
));
7040 return ada_to_fixed_value (VALUE_TYPE (arg1
), 0,
7041 VALUE_ADDRESS (arg1
) +
7042 VALUE_OFFSET (arg1
), arg1
);
7047 tem2
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7048 tem3
= longest_to_int (exp
->elts
[pc
+ 2].longconst
);
7049 nargs
= tem3
- tem2
+ 1;
7050 type
= expect_type
? check_typedef (expect_type
) : NULL_TYPE
;
7053 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
7054 for (tem
= 0; tem
== 0 || tem
< nargs
; tem
+= 1)
7055 /* At least one element gets inserted for the type */
7057 /* Ensure that array expressions are coerced into pointer objects. */
7058 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
7060 if (noside
== EVAL_SKIP
)
7062 return value_array (tem2
, tem3
, argvec
);
7067 /* Allocate arg vector, including space for the function to be
7068 called in argvec[0] and a terminating NULL */
7069 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7071 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 2));
7073 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7074 /* FIXME: name should be defined in expresion.h */
7075 /* if (exp->elts[*pos].opcode == OP_UNRESOLVED_VALUE)
7076 error ("Unexpected unresolved symbol, %s, during evaluation",
7077 ada_demangle (exp->elts[pc + 5].name));
7081 error ("unexpected code path, FIXME");
7085 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7086 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7089 if (noside
== EVAL_SKIP
)
7093 if (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_REF
)
7094 argvec
[0] = value_addr (argvec
[0]);
7096 if (ada_is_packed_array_type (VALUE_TYPE (argvec
[0])))
7097 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7099 type
= check_typedef (VALUE_TYPE (argvec
[0]));
7100 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7102 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type
))))
7104 case TYPE_CODE_FUNC
:
7105 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7107 case TYPE_CODE_ARRAY
:
7109 case TYPE_CODE_STRUCT
:
7110 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7111 argvec
[0] = ada_value_ind (argvec
[0]);
7112 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7115 error ("cannot subscript or call something of type `%s'",
7116 ada_type_name (VALUE_TYPE (argvec
[0])));
7121 switch (TYPE_CODE (type
))
7123 case TYPE_CODE_FUNC
:
7124 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7125 return allocate_value (TYPE_TARGET_TYPE (type
));
7126 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7127 case TYPE_CODE_STRUCT
:
7129 int arity
= ada_array_arity (type
);
7130 type
= ada_array_element_type (type
, nargs
);
7132 error ("cannot subscript or call a record");
7134 error ("wrong number of subscripts; expecting %d", arity
);
7135 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7136 return allocate_value (ada_aligned_type (type
));
7138 unwrap_value (ada_value_subscript
7139 (argvec
[0], nargs
, argvec
+ 1));
7141 case TYPE_CODE_ARRAY
:
7142 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7144 type
= ada_array_element_type (type
, nargs
);
7146 error ("element type of array unknown");
7148 return allocate_value (ada_aligned_type (type
));
7151 unwrap_value (ada_value_subscript
7152 (ada_coerce_to_simple_array (argvec
[0]),
7153 nargs
, argvec
+ 1));
7154 case TYPE_CODE_PTR
: /* Pointer to array */
7155 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7156 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7158 type
= ada_array_element_type (type
, nargs
);
7160 error ("element type of array unknown");
7162 return allocate_value (ada_aligned_type (type
));
7165 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7166 nargs
, argvec
+ 1));
7169 error ("Internal error in evaluate_subexp");
7174 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7176 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7178 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7179 if (noside
== EVAL_SKIP
)
7182 /* If this is a reference to an array, then dereference it */
7183 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
7184 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7185 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7187 && !ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7189 array
= ada_coerce_ref (array
);
7192 if (noside
== EVAL_AVOID_SIDE_EFFECTS
&&
7193 ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7195 /* Try to dereference the array, in case it is an access to array */
7196 struct type
*arrType
= ada_type_of_array (array
, 0);
7197 if (arrType
!= NULL
)
7198 array
= value_at_lazy (arrType
, 0, NULL
);
7200 if (ada_is_array_descriptor (VALUE_TYPE (array
)))
7201 array
= ada_coerce_to_simple_array (array
);
7203 /* If at this point we have a pointer to an array, it means that
7204 it is a pointer to a simple (non-ada) array. We just then
7206 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
7207 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7208 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7211 array
= ada_value_ind (array
);
7214 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7215 /* The following will get the bounds wrong, but only in contexts
7216 where the value is not being requested (FIXME?). */
7219 return value_slice (array
, lowbound
, upper
- lowbound
+ 1);
7222 /* FIXME: UNOP_MBR should be defined in expression.h */
7225 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7226 type = exp->elts[pc + 1].type;
7228 if (noside == EVAL_SKIP)
7231 switch (TYPE_CODE (type))
7234 warning ("Membership test incompletely implemented; always returns true");
7235 return value_from_longest (builtin_type_int, (LONGEST) 1);
7237 case TYPE_CODE_RANGE:
7238 arg2 = value_from_longest (builtin_type_int,
7239 (LONGEST) TYPE_LOW_BOUND (type));
7240 arg3 = value_from_longest (builtin_type_int,
7241 (LONGEST) TYPE_HIGH_BOUND (type));
7243 value_from_longest (builtin_type_int,
7244 (value_less (arg1,arg3)
7245 || value_equal (arg1,arg3))
7246 && (value_less (arg2,arg1)
7247 || value_equal (arg2,arg1)));
7250 /* FIXME: BINOP_MBR should be defined in expression.h */
7253 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7254 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7256 if (noside == EVAL_SKIP)
7259 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7260 return value_zero (builtin_type_int, not_lval);
7262 tem = longest_to_int (exp->elts[pc + 1].longconst);
7264 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
7265 error ("invalid dimension number to '%s", "range");
7267 arg3 = ada_array_bound (arg2, tem, 1);
7268 arg2 = ada_array_bound (arg2, tem, 0);
7271 value_from_longest (builtin_type_int,
7272 (value_less (arg1,arg3)
7273 || value_equal (arg1,arg3))
7274 && (value_less (arg2,arg1)
7275 || value_equal (arg2,arg1)));
7277 /* FIXME: TERNOP_MBR should be defined in expression.h */
7279 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7280 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7281 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7283 if (noside == EVAL_SKIP)
7287 value_from_longest (builtin_type_int,
7288 (value_less (arg1,arg3)
7289 || value_equal (arg1,arg3))
7290 && (value_less (arg2,arg1)
7291 || value_equal (arg2,arg1)));
7293 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
7294 /* case OP_ATTRIBUTE:
7296 atr = (enum ada_attribute) longest_to_int (exp->elts[pc + 2].longconst);
7300 error ("unexpected attribute encountered");
7306 struct type* type_arg;
7307 if (exp->elts[*pos].opcode == OP_TYPE)
7309 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7311 type_arg = exp->elts[pc + 5].type;
7315 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7319 if (exp->elts[*pos].opcode != OP_LONG)
7320 error ("illegal operand to '%s", ada_attribute_name (atr));
7321 tem = longest_to_int (exp->elts[*pos+2].longconst);
7324 if (noside == EVAL_SKIP)
7327 if (type_arg == NULL)
7329 arg1 = ada_coerce_ref (arg1);
7331 if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
7332 arg1 = ada_coerce_to_simple_array (arg1);
7334 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
7335 error ("invalid dimension number to '%s",
7336 ada_attribute_name (atr));
7338 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7340 type = ada_index_type (VALUE_TYPE (arg1), tem);
7342 error ("attempt to take bound of something that is not an array");
7343 return allocate_value (type);
7349 error ("unexpected attribute encountered");
7351 return ada_array_bound (arg1, tem, 0);
7353 return ada_array_bound (arg1, tem, 1);
7355 return ada_array_length (arg1, tem);
7358 else if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE
7359 || TYPE_CODE (type_arg) == TYPE_CODE_INT)
7361 struct type* range_type;
7362 char* name = ada_type_name (type_arg);
7365 if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE)
7366 range_type = type_arg;
7368 error ("unimplemented type attribute");
7372 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
7376 error ("unexpected attribute encountered");
7378 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7379 TYPE_LOW_BOUND (range_type));
7381 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7382 TYPE_HIGH_BOUND (range_type));
7385 else if (TYPE_CODE (type_arg) == TYPE_CODE_ENUM)
7390 error ("unexpected attribute encountered");
7392 return value_from_longest
7393 (type_arg, TYPE_FIELD_BITPOS (type_arg, 0));
7395 return value_from_longest
7397 TYPE_FIELD_BITPOS (type_arg,
7398 TYPE_NFIELDS (type_arg) - 1));
7401 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
7402 error ("unimplemented type attribute");
7407 if (ada_is_packed_array_type (type_arg))
7408 type_arg = decode_packed_array_type (type_arg);
7410 if (tem < 1 || tem > ada_array_arity (type_arg))
7411 error ("invalid dimension number to '%s",
7412 ada_attribute_name (atr));
7414 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7416 type = ada_index_type (type_arg, tem);
7418 error ("attempt to take bound of something that is not an array");
7419 return allocate_value (type);
7425 error ("unexpected attribute encountered");
7427 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7428 return value_from_longest (type, low);
7430 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
7431 return value_from_longest (type, high);
7433 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7434 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
7435 return value_from_longest (type, high-low+1);
7441 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7442 if (noside == EVAL_SKIP)
7445 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7447 value_zero (ada_tag_type (arg1), not_lval);
7449 return ada_value_tag (arg1);
7453 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7454 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7455 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7456 if (noside == EVAL_SKIP)
7458 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7459 return value_zero (VALUE_TYPE (arg1), not_lval);
7461 return value_binop (arg1, arg2,
7462 atr == ATR_MIN ? BINOP_MIN : BINOP_MAX);
7466 struct type* type_arg = exp->elts[pc + 5].type;
7467 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7470 if (noside == EVAL_SKIP)
7473 if (! ada_is_modular_type (type_arg))
7474 error ("'modulus must be applied to modular type");
7476 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
7477 ada_modulus (type_arg));
7482 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7483 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7484 if (noside == EVAL_SKIP)
7486 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7487 return value_zero (builtin_type_ada_int, not_lval);
7489 return value_pos_atr (arg1);
7492 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7493 if (noside == EVAL_SKIP)
7495 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7496 return value_zero (builtin_type_ada_int, not_lval);
7498 return value_from_longest (builtin_type_ada_int,
7500 * TYPE_LENGTH (VALUE_TYPE (arg1)));
7503 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7504 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7505 type = exp->elts[pc + 5].type;
7506 if (noside == EVAL_SKIP)
7508 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7509 return value_zero (type, not_lval);
7511 return value_val_atr (type, arg1);
7514 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7515 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7516 if (noside
== EVAL_SKIP
)
7518 if (binop_user_defined_p (op
, arg1
, arg2
))
7519 return unwrap_value (value_x_binop (arg1
, arg2
, op
, OP_NULL
,
7521 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7522 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7524 return value_binop (arg1
, arg2
, op
);
7527 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7528 if (noside
== EVAL_SKIP
)
7530 if (unop_user_defined_p (op
, arg1
))
7531 return unwrap_value (value_x_unop (arg1
, op
, EVAL_NORMAL
));
7536 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7537 if (noside
== EVAL_SKIP
)
7539 if (value_less (arg1
, value_zero (VALUE_TYPE (arg1
), not_lval
)))
7540 return value_neg (arg1
);
7545 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
7546 expect_type
= TYPE_TARGET_TYPE (check_typedef (expect_type
));
7547 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
7548 if (noside
== EVAL_SKIP
)
7550 type
= check_typedef (VALUE_TYPE (arg1
));
7551 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7553 if (ada_is_array_descriptor (type
))
7554 /* GDB allows dereferencing GNAT array descriptors. */
7556 struct type
*arrType
= ada_type_of_array (arg1
, 0);
7557 if (arrType
== NULL
)
7558 error ("Attempt to dereference null array pointer.");
7559 return value_at_lazy (arrType
, 0, NULL
);
7561 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
7562 || TYPE_CODE (type
) == TYPE_CODE_REF
7563 /* In C you can dereference an array to get the 1st elt. */
7564 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7567 (to_static_fixed_type
7568 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type
)))),
7570 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
7571 /* GDB allows dereferencing an int. */
7572 return value_zero (builtin_type_int
, lval_memory
);
7574 error ("Attempt to take contents of a non-pointer value.");
7576 arg1
= ada_coerce_ref (arg1
);
7577 type
= check_typedef (VALUE_TYPE (arg1
));
7579 if (ada_is_array_descriptor (type
))
7580 /* GDB allows dereferencing GNAT array descriptors. */
7581 return ada_coerce_to_simple_array (arg1
);
7583 return ada_value_ind (arg1
);
7585 case STRUCTOP_STRUCT
:
7586 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7587 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7588 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7589 if (noside
== EVAL_SKIP
)
7591 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7592 return value_zero (ada_aligned_type
7593 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7599 return unwrap_value (ada_value_struct_elt (arg1
,
7600 &exp
->elts
[pc
+ 2].string
,
7603 /* The value is not supposed to be used. This is here to make it
7604 easier to accommodate expressions that contain types. */
7606 if (noside
== EVAL_SKIP
)
7608 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7609 return allocate_value (builtin_type_void
);
7611 error ("Attempt to use a type name as an expression");
7614 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7615 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7616 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7617 if (noside
== EVAL_SKIP
)
7619 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7620 return value_zero (ada_aligned_type
7621 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7627 return unwrap_value (ada_value_struct_elt (arg1
,
7628 &exp
->elts
[pc
+ 2].string
,
7633 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
7639 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7640 type name that encodes the 'small and 'delta information.
7641 Otherwise, return NULL. */
7644 fixed_type_info (struct type
*type
)
7646 const char *name
= ada_type_name (type
);
7647 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
7649 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
7651 const char *tail
= strstr (name
, "___XF_");
7657 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
7658 return fixed_type_info (TYPE_TARGET_TYPE (type
));
7663 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7666 ada_is_fixed_point_type (struct type
*type
)
7668 return fixed_type_info (type
) != NULL
;
7671 /* Assuming that TYPE is the representation of an Ada fixed-point
7672 type, return its delta, or -1 if the type is malformed and the
7673 delta cannot be determined. */
7676 ada_delta (struct type
*type
)
7678 const char *encoding
= fixed_type_info (type
);
7681 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
7684 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
7687 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7688 factor ('SMALL value) associated with the type. */
7691 scaling_factor (struct type
*type
)
7693 const char *encoding
= fixed_type_info (type
);
7694 unsigned long num0
, den0
, num1
, den1
;
7697 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
7702 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
7704 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
7708 /* Assuming that X is the representation of a value of fixed-point
7709 type TYPE, return its floating-point equivalent. */
7712 ada_fixed_to_float (struct type
*type
, LONGEST x
)
7714 return (DOUBLEST
) x
*scaling_factor (type
);
7717 /* The representation of a fixed-point value of type TYPE
7718 corresponding to the value X. */
7721 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
7723 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
7727 /* VAX floating formats */
7729 /* Non-zero iff TYPE represents one of the special VAX floating-point
7732 ada_is_vax_floating_type (struct type
*type
)
7735 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
7738 && (TYPE_CODE (type
) == TYPE_CODE_INT
7739 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7740 && STREQN (ada_type_name (type
) + name_len
- 6, "___XF", 5);
7743 /* The type of special VAX floating-point type this is, assuming
7744 ada_is_vax_floating_point */
7746 ada_vax_float_type_suffix (struct type
*type
)
7748 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
7751 /* A value representing the special debugging function that outputs
7752 VAX floating-point values of the type represented by TYPE. Assumes
7753 ada_is_vax_floating_type (TYPE). */
7755 ada_vax_float_print_function (struct type
*type
)
7757 switch (ada_vax_float_type_suffix (type
))
7760 return get_var_value ("DEBUG_STRING_F", 0);
7762 return get_var_value ("DEBUG_STRING_D", 0);
7764 return get_var_value ("DEBUG_STRING_G", 0);
7766 error ("invalid VAX floating-point type");
7773 /* Scan STR beginning at position K for a discriminant name, and
7774 return the value of that discriminant field of DVAL in *PX. If
7775 PNEW_K is not null, put the position of the character beyond the
7776 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
7777 not alter *PX and *PNEW_K if unsuccessful. */
7780 scan_discrim_bound (char *, int k
, struct value
*dval
, LONGEST
* px
,
7783 static char *bound_buffer
= NULL
;
7784 static size_t bound_buffer_len
= 0;
7787 struct value
*bound_val
;
7789 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
7792 pend
= strstr (str
+ k
, "__");
7796 k
+= strlen (bound
);
7800 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
7801 bound
= bound_buffer
;
7802 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
7803 bound
[pend
- (str
+ k
)] = '\0';
7807 bound_val
= ada_search_struct_field (bound
, dval
, 0, VALUE_TYPE (dval
));
7808 if (bound_val
== NULL
)
7811 *px
= value_as_long (bound_val
);
7817 /* Value of variable named NAME in the current environment. If
7818 no such variable found, then if ERR_MSG is null, returns 0, and
7819 otherwise causes an error with message ERR_MSG. */
7820 static struct value
*
7821 get_var_value (char *name
, char *err_msg
)
7823 struct symbol
**syms
;
7824 struct block
**blocks
;
7828 ada_lookup_symbol_list (name
, get_selected_block (NULL
), VAR_NAMESPACE
,
7833 if (err_msg
== NULL
)
7836 error ("%s", err_msg
);
7839 return value_of_variable (syms
[0], blocks
[0]);
7842 /* Value of integer variable named NAME in the current environment. If
7843 no such variable found, then if ERR_MSG is null, returns 0, and sets
7844 *FLAG to 0. If successful, sets *FLAG to 1. */
7846 get_int_var_value (char *name
, char *err_msg
, int *flag
)
7848 struct value
*var_val
= get_var_value (name
, err_msg
);
7860 return value_as_long (var_val
);
7865 /* Return a range type whose base type is that of the range type named
7866 NAME in the current environment, and whose bounds are calculated
7867 from NAME according to the GNAT range encoding conventions.
7868 Extract discriminant values, if needed, from DVAL. If a new type
7869 must be created, allocate in OBJFILE's space. The bounds
7870 information, in general, is encoded in NAME, the base type given in
7871 the named range type. */
7873 static struct type
*
7874 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
7876 struct type
*raw_type
= ada_find_any_type (name
);
7877 struct type
*base_type
;
7881 if (raw_type
== NULL
)
7882 base_type
= builtin_type_int
;
7883 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
7884 base_type
= TYPE_TARGET_TYPE (raw_type
);
7886 base_type
= raw_type
;
7888 subtype_info
= strstr (name
, "___XD");
7889 if (subtype_info
== NULL
)
7893 static char *name_buf
= NULL
;
7894 static size_t name_len
= 0;
7895 int prefix_len
= subtype_info
- name
;
7901 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
7902 strncpy (name_buf
, name
, prefix_len
);
7903 name_buf
[prefix_len
] = '\0';
7906 bounds_str
= strchr (subtype_info
, '_');
7909 if (*subtype_info
== 'L')
7911 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
7912 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
7914 if (bounds_str
[n
] == '_')
7916 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
7922 strcpy (name_buf
+ prefix_len
, "___L");
7923 L
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7926 if (*subtype_info
== 'U')
7928 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
7929 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
7934 strcpy (name_buf
+ prefix_len
, "___U");
7935 U
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7938 if (objfile
== NULL
)
7939 objfile
= TYPE_OBJFILE (base_type
);
7940 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
7941 TYPE_NAME (type
) = name
;
7946 /* True iff NAME is the name of a range type. */
7948 ada_is_range_type_name (const char *name
)
7950 return (name
!= NULL
&& strstr (name
, "___XD"));
7956 /* True iff TYPE is an Ada modular type. */
7958 ada_is_modular_type (struct type
*type
)
7960 /* FIXME: base_type should be declared in gdbtypes.h, implemented in
7962 struct type
*subranged_type
; /* = base_type (type); */
7964 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
7965 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
7966 && TYPE_UNSIGNED (subranged_type
));
7969 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
7971 ada_modulus (struct type
* type
)
7973 return TYPE_HIGH_BOUND (type
) + 1;
7980 /* Table mapping opcodes into strings for printing operators
7981 and precedences of the operators. */
7983 static const struct op_print ada_op_print_tab
[] = {
7984 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
7985 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
7986 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
7987 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
7988 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
7989 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
7990 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
7991 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
7992 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
7993 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
7994 {">", BINOP_GTR
, PREC_ORDER
, 0},
7995 {"<", BINOP_LESS
, PREC_ORDER
, 0},
7996 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
7997 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
7998 {"+", BINOP_ADD
, PREC_ADD
, 0},
7999 {"-", BINOP_SUB
, PREC_ADD
, 0},
8000 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
8001 {"*", BINOP_MUL
, PREC_MUL
, 0},
8002 {"/", BINOP_DIV
, PREC_MUL
, 0},
8003 {"rem", BINOP_REM
, PREC_MUL
, 0},
8004 {"mod", BINOP_MOD
, PREC_MUL
, 0},
8005 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
8006 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
8007 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
8008 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
8009 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
8010 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
8011 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
8012 {".all", UNOP_IND
, PREC_SUFFIX
, 1}, /* FIXME: postfix .ALL */
8013 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1}, /* FIXME: postfix 'ACCESS */
8017 /* Assorted Types and Interfaces */
8019 struct type
*builtin_type_ada_int
;
8020 struct type
*builtin_type_ada_short
;
8021 struct type
*builtin_type_ada_long
;
8022 struct type
*builtin_type_ada_long_long
;
8023 struct type
*builtin_type_ada_char
;
8024 struct type
*builtin_type_ada_float
;
8025 struct type
*builtin_type_ada_double
;
8026 struct type
*builtin_type_ada_long_double
;
8027 struct type
*builtin_type_ada_natural
;
8028 struct type
*builtin_type_ada_positive
;
8029 struct type
*builtin_type_ada_system_address
;
8031 struct type
**const (ada_builtin_types
[]) =
8034 &builtin_type_ada_int
,
8035 &builtin_type_ada_long
,
8036 &builtin_type_ada_short
,
8037 &builtin_type_ada_char
,
8038 &builtin_type_ada_float
,
8039 &builtin_type_ada_double
,
8040 &builtin_type_ada_long_long
,
8041 &builtin_type_ada_long_double
,
8042 &builtin_type_ada_natural
, &builtin_type_ada_positive
,
8043 /* The following types are carried over from C for convenience. */
8046 &builtin_type_short
,
8048 &builtin_type_float
,
8049 &builtin_type_double
,
8050 &builtin_type_long_long
,
8052 &builtin_type_signed_char
,
8053 &builtin_type_unsigned_char
,
8054 &builtin_type_unsigned_short
,
8055 &builtin_type_unsigned_int
,
8056 &builtin_type_unsigned_long
,
8057 &builtin_type_unsigned_long_long
,
8058 &builtin_type_long_double
,
8059 &builtin_type_complex
, &builtin_type_double_complex
, 0};
8061 /* Not really used, but needed in the ada_language_defn. */
8063 emit_char (int c
, struct ui_file
*stream
, int quoter
)
8065 ada_emit_char (c
, stream
, quoter
, 1);
8068 const struct language_defn ada_language_defn
= {
8069 "ada", /* Language name */
8072 /* FIXME: language_ada should be defined in defs.h */
8076 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8077 * that's not quite what this means. */
8080 ada_evaluate_subexp
,
8081 ada_printchar
, /* Print a character constant */
8082 ada_printstr
, /* Function to print string constant */
8083 emit_char
, /* Function to print single char (not used) */
8084 ada_create_fundamental_type
, /* Create fundamental type in this language */
8085 ada_print_type
, /* Print a type using appropriate syntax */
8086 ada_val_print
, /* Print a value using appropriate syntax */
8087 ada_value_print
, /* Print a top-level value */
8088 {"", "", "", ""}, /* Binary format info */
8090 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
8091 {"%ld", "", "d", ""}, /* Decimal format info */
8092 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
8094 /* Copied from c-lang.c. */
8095 {"0%lo", "0", "o", ""}, /* Octal format info */
8096 {"%ld", "", "d", ""}, /* Decimal format info */
8097 {"0x%lx", "0x", "x", ""}, /* Hex format info */
8099 ada_op_print_tab
, /* expression operators for printing */
8100 1, /* c-style arrays (FIXME?) */
8101 0, /* String lower bound (FIXME?) */
8102 &builtin_type_ada_char
,
8107 _initialize_ada_language ()
8109 builtin_type_ada_int
=
8110 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8111 0, "integer", (struct objfile
*) NULL
);
8112 builtin_type_ada_long
=
8113 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8114 0, "long_integer", (struct objfile
*) NULL
);
8115 builtin_type_ada_short
=
8116 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8117 0, "short_integer", (struct objfile
*) NULL
);
8118 builtin_type_ada_char
=
8119 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8120 0, "character", (struct objfile
*) NULL
);
8121 builtin_type_ada_float
=
8122 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8123 0, "float", (struct objfile
*) NULL
);
8124 builtin_type_ada_double
=
8125 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8126 0, "long_float", (struct objfile
*) NULL
);
8127 builtin_type_ada_long_long
=
8128 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8129 0, "long_long_integer", (struct objfile
*) NULL
);
8130 builtin_type_ada_long_double
=
8131 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8132 0, "long_long_float", (struct objfile
*) NULL
);
8133 builtin_type_ada_natural
=
8134 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8135 0, "natural", (struct objfile
*) NULL
);
8136 builtin_type_ada_positive
=
8137 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8138 0, "positive", (struct objfile
*) NULL
);
8141 builtin_type_ada_system_address
=
8142 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8143 (struct objfile
*) NULL
));
8144 TYPE_NAME (builtin_type_ada_system_address
) = "system__address";
8146 add_language (&ada_language_defn
);
8149 (add_set_cmd ("varsize-limit", class_support
, var_uinteger
,
8150 (char *) &varsize_limit
,
8151 "Set maximum bytes in dynamic-sized object.",
8152 &setlist
), &showlist
);
8153 varsize_limit
= 65536;
8155 add_com ("begin", class_breakpoint
, begin_command
,
8156 "Start the debugged program, stopping at the beginning of the\n\
8157 main program. You may specify command-line arguments to give it, as for\n\
8158 the \"run\" command (q.v.).");
8162 /* Create a fundamental Ada type using default reasonable for the current
8165 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8166 define fundamental types such as "int" or "double". Others (stabs or
8167 DWARF version 2, etc) do define fundamental types. For the formats which
8168 don't provide fundamental types, gdb can create such types using this
8171 FIXME: Some compilers distinguish explicitly signed integral types
8172 (signed short, signed int, signed long) from "regular" integral types
8173 (short, int, long) in the debugging information. There is some dis-
8174 agreement as to how useful this feature is. In particular, gcc does
8175 not support this. Also, only some debugging formats allow the
8176 distinction to be passed on to a debugger. For now, we always just
8177 use "short", "int", or "long" as the type name, for both the implicit
8178 and explicitly signed types. This also makes life easier for the
8179 gdb test suite since we don't have to account for the differences
8180 in output depending upon what the compiler and debugging format
8181 support. We will probably have to re-examine the issue when gdb
8182 starts taking it's fundamental type information directly from the
8183 debugging information supplied by the compiler. fnf@cygnus.com */
8185 static struct type
*
8186 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8188 struct type
*type
= NULL
;
8193 /* FIXME: For now, if we are asked to produce a type not in this
8194 language, create the equivalent of a C integer type with the
8195 name "<?type?>". When all the dust settles from the type
8196 reconstruction work, this should probably become an error. */
8197 type
= init_type (TYPE_CODE_INT
,
8198 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8199 0, "<?type?>", objfile
);
8200 warning ("internal error: no Ada fundamental type %d", typeid);
8203 type
= init_type (TYPE_CODE_VOID
,
8204 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8205 0, "void", objfile
);
8208 type
= init_type (TYPE_CODE_INT
,
8209 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8210 0, "character", objfile
);
8212 case FT_SIGNED_CHAR
:
8213 type
= init_type (TYPE_CODE_INT
,
8214 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8215 0, "signed char", objfile
);
8217 case FT_UNSIGNED_CHAR
:
8218 type
= init_type (TYPE_CODE_INT
,
8219 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8220 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8223 type
= init_type (TYPE_CODE_INT
,
8224 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8225 0, "short_integer", objfile
);
8227 case FT_SIGNED_SHORT
:
8228 type
= init_type (TYPE_CODE_INT
,
8229 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8230 0, "short_integer", objfile
);
8232 case FT_UNSIGNED_SHORT
:
8233 type
= init_type (TYPE_CODE_INT
,
8234 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8235 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8238 type
= init_type (TYPE_CODE_INT
,
8239 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8240 0, "integer", objfile
);
8242 case FT_SIGNED_INTEGER
:
8243 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
, 0, "integer", objfile
); /* FIXME -fnf */
8245 case FT_UNSIGNED_INTEGER
:
8246 type
= init_type (TYPE_CODE_INT
,
8247 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8248 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8251 type
= init_type (TYPE_CODE_INT
,
8252 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8253 0, "long_integer", objfile
);
8255 case FT_SIGNED_LONG
:
8256 type
= init_type (TYPE_CODE_INT
,
8257 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8258 0, "long_integer", objfile
);
8260 case FT_UNSIGNED_LONG
:
8261 type
= init_type (TYPE_CODE_INT
,
8262 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8263 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8266 type
= init_type (TYPE_CODE_INT
,
8267 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8268 0, "long_long_integer", objfile
);
8270 case FT_SIGNED_LONG_LONG
:
8271 type
= init_type (TYPE_CODE_INT
,
8272 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8273 0, "long_long_integer", objfile
);
8275 case FT_UNSIGNED_LONG_LONG
:
8276 type
= init_type (TYPE_CODE_INT
,
8277 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8278 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8281 type
= init_type (TYPE_CODE_FLT
,
8282 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8283 0, "float", objfile
);
8285 case FT_DBL_PREC_FLOAT
:
8286 type
= init_type (TYPE_CODE_FLT
,
8287 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8288 0, "long_float", objfile
);
8290 case FT_EXT_PREC_FLOAT
:
8291 type
= init_type (TYPE_CODE_FLT
,
8292 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8293 0, "long_long_float", objfile
);
8300 ada_dump_symtab (struct symtab
*s
)
8303 fprintf (stderr
, "New symtab: [\n");
8304 fprintf (stderr
, " Name: %s/%s;\n",
8305 s
->dirname
? s
->dirname
: "?", s
->filename
? s
->filename
: "?");
8306 fprintf (stderr
, " Format: %s;\n", s
->debugformat
);
8307 if (s
->linetable
!= NULL
)
8309 fprintf (stderr
, " Line table (section %d):\n", s
->block_line_section
);
8310 for (i
= 0; i
< s
->linetable
->nitems
; i
+= 1)
8312 struct linetable_entry
*e
= s
->linetable
->item
+ i
;
8313 fprintf (stderr
, " %4ld: %8lx\n", (long) e
->line
, (long) e
->pc
);
8316 fprintf (stderr
, "]\n");