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 (struct value
*arr
, int n
, int which
)
1857 struct type
*arr_type
= VALUE_TYPE (arr
);
1859 if (ada_is_packed_array_type (arr_type
))
1860 return ada_array_bound (decode_packed_array (arr
), n
, which
);
1861 else if (ada_is_simple_array (arr_type
))
1864 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
1865 return value_from_longest (type
, v
);
1868 return desc_one_bound (desc_bounds (arr
), n
, which
);
1871 /* Given that arr is an array value, returns the length of the
1872 nth index. This routine will also work for arrays with bounds
1873 supplied by run-time quantities other than discriminants. Does not
1874 work for arrays indexed by enumeration types with representation
1875 clauses at the moment. */
1878 ada_array_length (struct value
*arr
, int n
)
1880 struct type
*arr_type
= check_typedef (VALUE_TYPE (arr
));
1881 struct type
*index_type_desc
;
1883 if (ada_is_packed_array_type (arr_type
))
1884 return ada_array_length (decode_packed_array (arr
), n
);
1886 if (ada_is_simple_array (arr_type
))
1890 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
1891 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
1892 return value_from_longest (type
, v
);
1896 value_from_longest (builtin_type_ada_int
,
1897 value_as_long (desc_one_bound (desc_bounds (arr
),
1899 - value_as_long (desc_one_bound (desc_bounds (arr
),
1904 /* Name resolution */
1906 /* The "demangled" name for the user-definable Ada operator corresponding
1910 ada_op_name (enum exp_opcode op
)
1914 for (i
= 0; ada_opname_table
[i
].mangled
!= NULL
; i
+= 1)
1916 if (ada_opname_table
[i
].op
== op
)
1917 return ada_opname_table
[i
].demangled
;
1919 error ("Could not find operator name for opcode");
1923 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
1924 references (OP_UNRESOLVED_VALUES) and converts operators that are
1925 user-defined into appropriate function calls. If CONTEXT_TYPE is
1926 non-null, it provides a preferred result type [at the moment, only
1927 type void has any effect---causing procedures to be preferred over
1928 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
1929 return type is preferred. The variable unresolved_names contains a list
1930 of character strings referenced by expout that should be freed.
1931 May change (expand) *EXP. */
1934 ada_resolve (struct expression
**expp
, struct type
*context_type
)
1938 ada_resolve_subexp (expp
, &pc
, 1, context_type
);
1941 /* Resolve the operator of the subexpression beginning at
1942 position *POS of *EXPP. "Resolving" consists of replacing
1943 OP_UNRESOLVED_VALUE with an appropriate OP_VAR_VALUE, replacing
1944 built-in operators with function calls to user-defined operators,
1945 where appropriate, and (when DEPROCEDURE_P is non-zero), converting
1946 function-valued variables into parameterless calls. May expand
1947 EXP. The CONTEXT_TYPE functions as in ada_resolve, above. */
1949 static struct value
*
1950 ada_resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
1951 struct type
*context_type
)
1955 struct expression
*exp
; /* Convenience: == *expp */
1956 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
1957 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
1958 int nargs
; /* Number of operands */
1964 /* Pass one: resolve operands, saving their types and updating *pos. */
1968 /* case OP_UNRESOLVED_VALUE: */
1969 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
1974 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
1975 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
1976 /* if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
1980 argvec = (struct value* *) alloca (sizeof (struct value*) * (nargs + 1));
1981 for (i = 0; i < nargs-1; i += 1)
1982 argvec[i] = ada_resolve_subexp (expp, pos, 1, NULL);
1988 ada_resolve_subexp (expp, pos, 0, NULL);
1989 for (i = 1; i < nargs; i += 1)
1990 ada_resolve_subexp (expp, pos, 1, NULL);
1996 /* FIXME: UNOP_QUAL should be defined in expression.h */
2000 ada_resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
2004 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
2005 /* case OP_ATTRIBUTE:
2006 nargs = longest_to_int (exp->elts[pc + 1].longconst) + 1;
2008 for (i = 0; i < nargs; i += 1)
2009 ada_resolve_subexp (expp, pos, 1, NULL);
2016 ada_resolve_subexp (expp
, pos
, 0, NULL
);
2025 arg1
= ada_resolve_subexp (expp
, pos
, 0, NULL
);
2027 ada_resolve_subexp (expp
, pos
, 1, NULL
);
2029 ada_resolve_subexp (expp
, pos
, 1, VALUE_TYPE (arg1
));
2037 error ("Unexpected operator during name resolution");
2052 case BINOP_LOGICAL_AND
:
2053 case BINOP_LOGICAL_OR
:
2054 case BINOP_BITWISE_AND
:
2055 case BINOP_BITWISE_IOR
:
2056 case BINOP_BITWISE_XOR
:
2059 case BINOP_NOTEQUAL
:
2066 case BINOP_SUBSCRIPT
:
2074 case UNOP_LOGICAL_NOT
:
2091 case OP_INTERNALVAR
:
2100 case STRUCTOP_STRUCT
:
2103 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2108 nargs
= longest_to_int (exp
->elts
[pc
+ 2].longconst
) + 1;
2109 nargs
-= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2110 /* A null array contains one dummy element to give the type. */
2116 /* FIXME: TERNOP_MBR should be defined in expression.h */
2122 /* FIXME: BINOP_MBR should be defined in expression.h */
2130 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2131 for (i
= 0; i
< nargs
; i
+= 1)
2132 argvec
[i
] = ada_resolve_subexp (expp
, pos
, 1, NULL
);
2138 /* Pass two: perform any resolution on principal operator. */
2144 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2145 /* case OP_UNRESOLVED_VALUE:
2147 struct symbol** candidate_syms;
2148 struct block** candidate_blocks;
2151 n_candidates = ada_lookup_symbol_list (exp->elts[pc + 2].name,
2152 exp->elts[pc + 1].block,
2157 if (n_candidates > 1)
2159 /* Types tend to get re-introduced locally, so if there
2160 are any local symbols that are not types, first filter
2163 for (j = 0; j < n_candidates; j += 1)
2164 switch (SYMBOL_CLASS (candidate_syms[j]))
2170 case LOC_REGPARM_ADDR:
2174 case LOC_BASEREG_ARG:
2180 if (j < n_candidates)
2183 while (j < n_candidates)
2185 if (SYMBOL_CLASS (candidate_syms[j]) == LOC_TYPEDEF)
2187 candidate_syms[j] = candidate_syms[n_candidates-1];
2188 candidate_blocks[j] = candidate_blocks[n_candidates-1];
2197 if (n_candidates == 0)
2198 error ("No definition found for %s",
2199 ada_demangle (exp->elts[pc + 2].name));
2200 else if (n_candidates == 1)
2202 else if (deprocedure_p
2203 && ! is_nonfunction (candidate_syms, n_candidates))
2205 i = ada_resolve_function (candidate_syms, candidate_blocks,
2206 n_candidates, NULL, 0,
2207 exp->elts[pc + 2].name, context_type);
2209 error ("Could not find a match for %s",
2210 ada_demangle (exp->elts[pc + 2].name));
2214 printf_filtered ("Multiple matches for %s\n",
2215 ada_demangle (exp->elts[pc+2].name));
2216 user_select_syms (candidate_syms, candidate_blocks,
2221 exp->elts[pc].opcode = exp->elts[pc + 3].opcode = OP_VAR_VALUE;
2222 exp->elts[pc + 1].block = candidate_blocks[i];
2223 exp->elts[pc + 2].symbol = candidate_syms[i];
2224 if (innermost_block == NULL ||
2225 contained_in (candidate_blocks[i], innermost_block))
2226 innermost_block = candidate_blocks[i];
2231 if (deprocedure_p
&&
2232 TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
)) ==
2235 replace_operator_with_call (expp
, pc
, 0, 0,
2236 exp
->elts
[pc
+ 2].symbol
,
2237 exp
->elts
[pc
+ 1].block
);
2244 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2245 /* if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
2247 struct symbol** candidate_syms;
2248 struct block** candidate_blocks;
2251 n_candidates = ada_lookup_symbol_list (exp->elts[pc + 5].name,
2252 exp->elts[pc + 4].block,
2256 if (n_candidates == 1)
2260 i = ada_resolve_function (candidate_syms, candidate_blocks,
2261 n_candidates, argvec, nargs-1,
2262 exp->elts[pc + 5].name, context_type);
2264 error ("Could not find a match for %s",
2265 ada_demangle (exp->elts[pc + 5].name));
2268 exp->elts[pc + 3].opcode = exp->elts[pc + 6].opcode = OP_VAR_VALUE;
2269 exp->elts[pc + 4].block = candidate_blocks[i];
2270 exp->elts[pc + 5].symbol = candidate_syms[i];
2271 if (innermost_block == NULL ||
2272 contained_in (candidate_blocks[i], innermost_block))
2273 innermost_block = candidate_blocks[i];
2285 case BINOP_BITWISE_AND
:
2286 case BINOP_BITWISE_IOR
:
2287 case BINOP_BITWISE_XOR
:
2289 case BINOP_NOTEQUAL
:
2297 case UNOP_LOGICAL_NOT
:
2299 if (possible_user_operator_p (op
, argvec
))
2301 struct symbol
**candidate_syms
;
2302 struct block
**candidate_blocks
;
2306 ada_lookup_symbol_list (ada_mangle (ada_op_name (op
)),
2307 (struct block
*) NULL
, VAR_NAMESPACE
,
2308 &candidate_syms
, &candidate_blocks
);
2310 ada_resolve_function (candidate_syms
, candidate_blocks
,
2311 n_candidates
, argvec
, nargs
,
2312 ada_op_name (op
), NULL
);
2316 replace_operator_with_call (expp
, pc
, nargs
, 1,
2317 candidate_syms
[i
], candidate_blocks
[i
]);
2324 return evaluate_subexp_type (exp
, pos
);
2327 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2328 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2330 /* The term "match" here is rather loose. The match is heuristic and
2331 liberal. FIXME: TOO liberal, in fact. */
2334 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
2336 CHECK_TYPEDEF (ftype
);
2337 CHECK_TYPEDEF (atype
);
2339 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2340 ftype
= TYPE_TARGET_TYPE (ftype
);
2341 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2342 atype
= TYPE_TARGET_TYPE (atype
);
2344 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2345 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2348 switch (TYPE_CODE (ftype
))
2353 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2354 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2355 TYPE_TARGET_TYPE (atype
), 0);
2357 return (may_deref
&&
2358 ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2360 case TYPE_CODE_ENUM
:
2361 case TYPE_CODE_RANGE
:
2362 switch (TYPE_CODE (atype
))
2365 case TYPE_CODE_ENUM
:
2366 case TYPE_CODE_RANGE
:
2372 case TYPE_CODE_ARRAY
:
2373 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2374 || ada_is_array_descriptor (atype
));
2376 case TYPE_CODE_STRUCT
:
2377 if (ada_is_array_descriptor (ftype
))
2378 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2379 || ada_is_array_descriptor (atype
));
2381 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2382 && !ada_is_array_descriptor (atype
));
2384 case TYPE_CODE_UNION
:
2386 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2390 /* Return non-zero if the formals of FUNC "sufficiently match" the
2391 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2392 may also be an enumeral, in which case it is treated as a 0-
2393 argument function. */
2396 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
2399 struct type
*func_type
= SYMBOL_TYPE (func
);
2401 if (SYMBOL_CLASS (func
) == LOC_CONST
&&
2402 TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2403 return (n_actuals
== 0);
2404 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2407 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2410 for (i
= 0; i
< n_actuals
; i
+= 1)
2412 struct type
*ftype
= check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2413 struct type
*atype
= check_typedef (VALUE_TYPE (actuals
[i
]));
2415 if (!ada_type_match (TYPE_FIELD_TYPE (func_type
, i
),
2416 VALUE_TYPE (actuals
[i
]), 1))
2422 /* False iff function type FUNC_TYPE definitely does not produce a value
2423 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2424 FUNC_TYPE is not a valid function type with a non-null return type
2425 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2428 return_match (struct type
*func_type
, struct type
*context_type
)
2430 struct type
*return_type
;
2432 if (func_type
== NULL
)
2435 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2436 /* if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
2437 return_type = base_type (TYPE_TARGET_TYPE (func_type));
2439 return_type = base_type (func_type); */
2440 if (return_type
== NULL
)
2443 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2444 /* context_type = base_type (context_type); */
2446 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2447 return context_type
== NULL
|| return_type
== context_type
;
2448 else if (context_type
== NULL
)
2449 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2451 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
2455 /* Return the index in SYMS[0..NSYMS-1] of symbol for the
2456 function (if any) that matches the types of the NARGS arguments in
2457 ARGS. If CONTEXT_TYPE is non-null, and there is at least one match
2458 that returns type CONTEXT_TYPE, then eliminate other matches. If
2459 CONTEXT_TYPE is null, prefer a non-void-returning function.
2460 Asks the user if there is more than one match remaining. Returns -1
2461 if there is no such symbol or none is selected. NAME is used
2462 solely for messages. May re-arrange and modify SYMS in
2463 the process; the index returned is for the modified vector. BLOCKS
2464 is modified in parallel to SYMS. */
2467 ada_resolve_function (struct symbol
*syms
[], struct block
*blocks
[],
2468 int nsyms
, struct value
**args
, int nargs
,
2469 const char *name
, struct type
*context_type
)
2472 int m
; /* Number of hits */
2473 struct type
*fallback
;
2474 struct type
*return_type
;
2476 return_type
= context_type
;
2477 if (context_type
== NULL
)
2478 fallback
= builtin_type_void
;
2485 for (k
= 0; k
< nsyms
; k
+= 1)
2487 struct type
*type
= check_typedef (SYMBOL_TYPE (syms
[k
]));
2489 if (ada_args_match (syms
[k
], args
, nargs
)
2490 && return_match (SYMBOL_TYPE (syms
[k
]), return_type
))
2494 blocks
[m
] = blocks
[k
];
2498 if (m
> 0 || return_type
== fallback
)
2501 return_type
= fallback
;
2508 printf_filtered ("Multiple matches for %s\n", name
);
2509 user_select_syms (syms
, blocks
, m
, 1);
2515 /* Returns true (non-zero) iff demangled name N0 should appear before N1 */
2516 /* in a listing of choices during disambiguation (see sort_choices, below). */
2517 /* The idea is that overloadings of a subprogram name from the */
2518 /* same package should sort in their source order. We settle for ordering */
2519 /* such symbols by their trailing number (__N or $N). */
2521 mangled_ordered_before (char *N0
, char *N1
)
2525 else if (N0
== NULL
)
2530 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
2532 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
2534 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
2535 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
2539 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
2542 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
2544 if (n0
== n1
&& STREQN (N0
, N1
, n0
))
2545 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
2547 return (strcmp (N0
, N1
) < 0);
2551 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by their */
2552 /* mangled names, rearranging BLOCKS[0..NSYMS-1] according to the same */
2555 sort_choices (struct symbol
*syms
[], struct block
*blocks
[], int nsyms
)
2558 for (i
= 1; i
< nsyms
; i
+= 1)
2560 struct symbol
*sym
= syms
[i
];
2561 struct block
*block
= blocks
[i
];
2564 for (j
= i
- 1; j
>= 0; j
-= 1)
2566 if (mangled_ordered_before (SYMBOL_NAME (syms
[j
]),
2569 syms
[j
+ 1] = syms
[j
];
2570 blocks
[j
+ 1] = blocks
[j
];
2573 blocks
[j
+ 1] = block
;
2577 /* Given a list of NSYMS symbols in SYMS and corresponding blocks in */
2578 /* BLOCKS, select up to MAX_RESULTS>0 by asking the user (if */
2579 /* necessary), returning the number selected, and setting the first */
2580 /* elements of SYMS and BLOCKS to the selected symbols and */
2581 /* corresponding blocks. Error if no symbols selected. BLOCKS may */
2582 /* be NULL, in which case it is ignored. */
2584 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
2585 to be re-integrated one of these days. */
2588 user_select_syms (struct symbol
*syms
[], struct block
*blocks
[], int nsyms
,
2592 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
2594 int first_choice
= (max_results
== 1) ? 1 : 2;
2596 if (max_results
< 1)
2597 error ("Request to select 0 symbols!");
2601 printf_unfiltered ("[0] cancel\n");
2602 if (max_results
> 1)
2603 printf_unfiltered ("[1] all\n");
2605 sort_choices (syms
, blocks
, nsyms
);
2607 for (i
= 0; i
< nsyms
; i
+= 1)
2609 if (syms
[i
] == NULL
)
2612 if (SYMBOL_CLASS (syms
[i
]) == LOC_BLOCK
)
2614 struct symtab_and_line sal
= find_function_start_sal (syms
[i
], 1);
2615 printf_unfiltered ("[%d] %s at %s:%d\n",
2617 SYMBOL_SOURCE_NAME (syms
[i
]),
2619 ? "<no source file available>"
2620 : sal
.symtab
->filename
, sal
.line
);
2626 (SYMBOL_CLASS (syms
[i
]) == LOC_CONST
2627 && SYMBOL_TYPE (syms
[i
]) != NULL
2628 && TYPE_CODE (SYMBOL_TYPE (syms
[i
])) == TYPE_CODE_ENUM
);
2629 struct symtab
*symtab
= symtab_for_sym (syms
[i
]);
2631 if (SYMBOL_LINE (syms
[i
]) != 0 && symtab
!= NULL
)
2632 printf_unfiltered ("[%d] %s at %s:%d\n",
2634 SYMBOL_SOURCE_NAME (syms
[i
]),
2635 symtab
->filename
, SYMBOL_LINE (syms
[i
]));
2636 else if (is_enumeral
&& TYPE_NAME (SYMBOL_TYPE (syms
[i
])) != NULL
)
2638 printf_unfiltered ("[%d] ", i
+ first_choice
);
2639 ada_print_type (SYMBOL_TYPE (syms
[i
]), NULL
, gdb_stdout
, -1, 0);
2640 printf_unfiltered ("'(%s) (enumeral)\n",
2641 SYMBOL_SOURCE_NAME (syms
[i
]));
2643 else if (symtab
!= NULL
)
2644 printf_unfiltered (is_enumeral
2645 ? "[%d] %s in %s (enumeral)\n"
2646 : "[%d] %s at %s:?\n",
2648 SYMBOL_SOURCE_NAME (syms
[i
]),
2651 printf_unfiltered (is_enumeral
2652 ? "[%d] %s (enumeral)\n"
2655 SYMBOL_SOURCE_NAME (syms
[i
]));
2659 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
2662 for (i
= 0; i
< n_chosen
; i
+= 1)
2664 syms
[i
] = syms
[chosen
[i
]];
2666 blocks
[i
] = blocks
[chosen
[i
]];
2672 /* Read and validate a set of numeric choices from the user in the
2673 range 0 .. N_CHOICES-1. Place the results in increasing
2674 order in CHOICES[0 .. N-1], and return N.
2676 The user types choices as a sequence of numbers on one line
2677 separated by blanks, encoding them as follows:
2679 + A choice of 0 means to cancel the selection, throwing an error.
2680 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
2681 + The user chooses k by typing k+IS_ALL_CHOICE+1.
2683 The user is not allowed to choose more than MAX_RESULTS values.
2685 ANNOTATION_SUFFIX, if present, is used to annotate the input
2686 prompts (for use with the -f switch). */
2689 get_selections (int *choices
, int n_choices
, int max_results
,
2690 int is_all_choice
, char *annotation_suffix
)
2696 int first_choice
= is_all_choice
? 2 : 1;
2698 prompt
= getenv ("PS2");
2702 printf_unfiltered ("%s ", prompt
);
2703 gdb_flush (gdb_stdout
);
2705 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
2708 error_no_arg ("one or more choice numbers");
2712 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
2713 order, as given in args. Choices are validated. */
2719 while (isspace (*args
))
2721 if (*args
== '\0' && n_chosen
== 0)
2722 error_no_arg ("one or more choice numbers");
2723 else if (*args
== '\0')
2726 choice
= strtol (args
, &args2
, 10);
2727 if (args
== args2
|| choice
< 0
2728 || choice
> n_choices
+ first_choice
- 1)
2729 error ("Argument must be choice number");
2733 error ("cancelled");
2735 if (choice
< first_choice
)
2737 n_chosen
= n_choices
;
2738 for (j
= 0; j
< n_choices
; j
+= 1)
2742 choice
-= first_choice
;
2744 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
2748 if (j
< 0 || choice
!= choices
[j
])
2751 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
2752 choices
[k
+ 1] = choices
[k
];
2753 choices
[j
+ 1] = choice
;
2758 if (n_chosen
> max_results
)
2759 error ("Select no more than %d of the above", max_results
);
2764 /* Replace the operator of length OPLEN at position PC in *EXPP with a call */
2765 /* on the function identified by SYM and BLOCK, and taking NARGS */
2766 /* arguments. Update *EXPP as needed to hold more space. */
2769 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
2770 int oplen
, struct symbol
*sym
,
2771 struct block
*block
)
2773 /* A new expression, with 6 more elements (3 for funcall, 4 for function
2774 symbol, -oplen for operator being replaced). */
2775 struct expression
*newexp
= (struct expression
*)
2776 xmalloc (sizeof (struct expression
)
2777 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
2778 struct expression
*exp
= *expp
;
2780 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
2781 newexp
->language_defn
= exp
->language_defn
;
2782 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
2783 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
2784 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
2786 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
2787 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
2789 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
2790 newexp
->elts
[pc
+ 4].block
= block
;
2791 newexp
->elts
[pc
+ 5].symbol
= sym
;
2797 /* Type-class predicates */
2799 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type), or */
2803 numeric_type_p (struct type
*type
)
2809 switch (TYPE_CODE (type
))
2814 case TYPE_CODE_RANGE
:
2815 return (type
== TYPE_TARGET_TYPE (type
)
2816 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
2823 /* True iff TYPE is integral (an INT or RANGE of INTs). */
2826 integer_type_p (struct type
*type
)
2832 switch (TYPE_CODE (type
))
2836 case TYPE_CODE_RANGE
:
2837 return (type
== TYPE_TARGET_TYPE (type
)
2838 || integer_type_p (TYPE_TARGET_TYPE (type
)));
2845 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
2848 scalar_type_p (struct type
*type
)
2854 switch (TYPE_CODE (type
))
2857 case TYPE_CODE_RANGE
:
2858 case TYPE_CODE_ENUM
:
2867 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
2870 discrete_type_p (struct type
*type
)
2876 switch (TYPE_CODE (type
))
2879 case TYPE_CODE_RANGE
:
2880 case TYPE_CODE_ENUM
:
2888 /* Returns non-zero if OP with operatands in the vector ARGS could be
2889 a user-defined function. Errs on the side of pre-defined operators
2890 (i.e., result 0). */
2893 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
2895 struct type
*type0
= check_typedef (VALUE_TYPE (args
[0]));
2896 struct type
*type1
=
2897 (args
[1] == NULL
) ? NULL
: check_typedef (VALUE_TYPE (args
[1]));
2908 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
2912 case BINOP_BITWISE_AND
:
2913 case BINOP_BITWISE_IOR
:
2914 case BINOP_BITWISE_XOR
:
2915 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
2918 case BINOP_NOTEQUAL
:
2923 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
2926 return ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
&&
2927 (TYPE_CODE (type0
) != TYPE_CODE_PTR
||
2928 TYPE_CODE (TYPE_TARGET_TYPE (type0
))
2929 != TYPE_CODE_ARRAY
))
2930 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
&&
2931 (TYPE_CODE (type1
) != TYPE_CODE_PTR
||
2932 TYPE_CODE (TYPE_TARGET_TYPE (type1
)) != TYPE_CODE_ARRAY
)));
2935 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
2939 case UNOP_LOGICAL_NOT
:
2941 return (!numeric_type_p (type0
));
2948 /** NOTE: In the following, we assume that a renaming type's name may
2949 * have an ___XD suffix. It would be nice if this went away at some
2952 /* If TYPE encodes a renaming, returns the renaming suffix, which
2953 * is XR for an object renaming, XRP for a procedure renaming, XRE for
2954 * an exception renaming, and XRS for a subprogram renaming. Returns
2955 * NULL if NAME encodes none of these. */
2957 ada_renaming_type (struct type
*type
)
2959 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
2961 const char *name
= type_name_no_tag (type
);
2962 const char *suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
2964 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
2973 /* Return non-zero iff SYM encodes an object renaming. */
2975 ada_is_object_renaming (struct symbol
*sym
)
2977 const char *renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
2978 return renaming_type
!= NULL
2979 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
2982 /* Assuming that SYM encodes a non-object renaming, returns the original
2983 * name of the renamed entity. The name is good until the end of
2986 ada_simple_renamed_entity (struct symbol
*sym
)
2989 const char *raw_name
;
2993 type
= SYMBOL_TYPE (sym
);
2994 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
2995 error ("Improperly encoded renaming.");
2997 raw_name
= TYPE_FIELD_NAME (type
, 0);
2998 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
3000 error ("Improperly encoded renaming.");
3002 result
= xmalloc (len
+ 1);
3003 /* FIXME: add_name_string_cleanup should be defined in parse.c */
3004 /* add_name_string_cleanup (result); */
3005 strncpy (result
, raw_name
, len
);
3006 result
[len
] = '\000';
3011 /* Evaluation: Function Calls */
3013 /* Copy VAL onto the stack, using and updating *SP as the stack
3014 pointer. Return VAL as an lvalue. */
3016 static struct value
*
3017 place_on_stack (struct value
*val
, CORE_ADDR
*sp
)
3019 CORE_ADDR old_sp
= *sp
;
3022 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3023 STACK_ALIGN (TYPE_LENGTH
3024 (check_typedef (VALUE_TYPE (val
)))));
3026 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3027 TYPE_LENGTH (check_typedef (VALUE_TYPE (val
))));
3030 VALUE_LVAL (val
) = lval_memory
;
3031 if (INNER_THAN (1, 2))
3032 VALUE_ADDRESS (val
) = *sp
;
3034 VALUE_ADDRESS (val
) = old_sp
;
3039 /* Return the value ACTUAL, converted to be an appropriate value for a
3040 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3041 allocating any necessary descriptors (fat pointers), or copies of
3042 values not residing in memory, updating it as needed. */
3044 static struct value
*
3045 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3048 struct type
*actual_type
= check_typedef (VALUE_TYPE (actual
));
3049 struct type
*formal_type
= check_typedef (formal_type0
);
3050 struct type
*formal_target
=
3051 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3052 ? check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3053 struct type
*actual_target
=
3054 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3055 ? check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3057 if (ada_is_array_descriptor (formal_target
)
3058 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3059 return make_array_descriptor (formal_type
, actual
, sp
);
3060 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3062 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3063 && ada_is_array_descriptor (actual_target
))
3064 return desc_data (actual
);
3065 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3067 if (VALUE_LVAL (actual
) != lval_memory
)
3070 actual_type
= check_typedef (VALUE_TYPE (actual
));
3071 val
= allocate_value (actual_type
);
3072 memcpy ((char *) VALUE_CONTENTS_RAW (val
),
3073 (char *) VALUE_CONTENTS (actual
),
3074 TYPE_LENGTH (actual_type
));
3075 actual
= place_on_stack (val
, sp
);
3077 return value_addr (actual
);
3080 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3081 return ada_value_ind (actual
);
3087 /* Push a descriptor of type TYPE for array value ARR on the stack at
3088 *SP, updating *SP to reflect the new descriptor. Return either
3089 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3090 to-descriptor type rather than a descriptor type), a struct value*
3091 representing a pointer to this descriptor. */
3093 static struct value
*
3094 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3096 struct type
*bounds_type
= desc_bounds_type (type
);
3097 struct type
*desc_type
= desc_base_type (type
);
3098 struct value
*descriptor
= allocate_value (desc_type
);
3099 struct value
*bounds
= allocate_value (bounds_type
);
3100 CORE_ADDR bounds_addr
;
3103 for (i
= ada_array_arity (check_typedef (VALUE_TYPE (arr
))); i
> 0; i
-= 1)
3105 modify_general_field (VALUE_CONTENTS (bounds
),
3106 value_as_long (ada_array_bound (arr
, i
, 0)),
3107 desc_bound_bitpos (bounds_type
, i
, 0),
3108 desc_bound_bitsize (bounds_type
, i
, 0));
3109 modify_general_field (VALUE_CONTENTS (bounds
),
3110 value_as_long (ada_array_bound (arr
, i
, 1)),
3111 desc_bound_bitpos (bounds_type
, i
, 1),
3112 desc_bound_bitsize (bounds_type
, i
, 1));
3115 bounds
= place_on_stack (bounds
, sp
);
3117 modify_general_field (VALUE_CONTENTS (descriptor
),
3119 fat_pntr_data_bitpos (desc_type
),
3120 fat_pntr_data_bitsize (desc_type
));
3121 modify_general_field (VALUE_CONTENTS (descriptor
),
3122 VALUE_ADDRESS (bounds
),
3123 fat_pntr_bounds_bitpos (desc_type
),
3124 fat_pntr_bounds_bitsize (desc_type
));
3126 descriptor
= place_on_stack (descriptor
, sp
);
3128 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3129 return value_addr (descriptor
);
3135 /* Assuming a dummy frame has been established on the target, perform any
3136 conversions needed for calling function FUNC on the NARGS actual
3137 parameters in ARGS, other than standard C conversions. Does
3138 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3139 does not match the number of arguments expected. Use *SP as a
3140 stack pointer for additional data that must be pushed, updating its
3144 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3149 if (TYPE_NFIELDS (VALUE_TYPE (func
)) == 0
3150 || nargs
!= TYPE_NFIELDS (VALUE_TYPE (func
)))
3153 for (i
= 0; i
< nargs
; i
+= 1)
3155 convert_actual (args
[i
], TYPE_FIELD_TYPE (VALUE_TYPE (func
), i
), sp
);
3162 /* The vectors of symbols and blocks ultimately returned from */
3163 /* ada_lookup_symbol_list. */
3165 /* Current size of defn_symbols and defn_blocks */
3166 static size_t defn_vector_size
= 0;
3168 /* Current number of symbols found. */
3169 static int ndefns
= 0;
3171 static struct symbol
**defn_symbols
= NULL
;
3172 static struct block
**defn_blocks
= NULL
;
3174 /* Return the result of a standard (literal, C-like) lookup of NAME in
3175 * given NAMESPACE. */
3177 static struct symbol
*
3178 standard_lookup (const char *name
, namespace_enum
namespace)
3181 struct symtab
*symtab
;
3182 sym
= lookup_symbol (name
, (struct block
*) NULL
, namespace, 0, &symtab
);
3187 /* Non-zero iff there is at least one non-function/non-enumeral symbol */
3188 /* in SYMS[0..N-1]. We treat enumerals as functions, since they */
3189 /* contend in overloading in the same way. */
3191 is_nonfunction (struct symbol
*syms
[], int n
)
3195 for (i
= 0; i
< n
; i
+= 1)
3196 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
])) != TYPE_CODE_FUNC
3197 && TYPE_CODE (SYMBOL_TYPE (syms
[i
])) != TYPE_CODE_ENUM
)
3203 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3204 struct types. Otherwise, they may not. */
3207 equiv_types (struct type
*type0
, struct type
*type1
)
3211 if (type0
== NULL
|| type1
== NULL
3212 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3214 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3215 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3216 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3217 && STREQ (ada_type_name (type0
), ada_type_name (type1
)))
3223 /* True iff SYM0 represents the same entity as SYM1, or one that is
3224 no more defined than that of SYM1. */
3227 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3231 if (SYMBOL_NAMESPACE (sym0
) != SYMBOL_NAMESPACE (sym1
)
3232 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3235 switch (SYMBOL_CLASS (sym0
))
3241 struct type
*type0
= SYMBOL_TYPE (sym0
);
3242 struct type
*type1
= SYMBOL_TYPE (sym1
);
3243 char *name0
= SYMBOL_NAME (sym0
);
3244 char *name1
= SYMBOL_NAME (sym1
);
3245 int len0
= strlen (name0
);
3247 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3248 && (equiv_types (type0
, type1
)
3249 || (len0
< strlen (name1
) && STREQN (name0
, name1
, len0
)
3250 && STREQN (name1
+ len0
, "___XV", 5)));
3253 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3254 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3260 /* Append SYM to the end of defn_symbols, and BLOCK to the end of
3261 defn_blocks, updating ndefns, and expanding defn_symbols and
3262 defn_blocks as needed. Do not include SYM if it is a duplicate. */
3265 add_defn_to_vec (struct symbol
*sym
, struct block
*block
)
3270 if (SYMBOL_TYPE (sym
) != NULL
)
3271 CHECK_TYPEDEF (SYMBOL_TYPE (sym
));
3272 for (i
= 0; i
< ndefns
; i
+= 1)
3274 if (lesseq_defined_than (sym
, defn_symbols
[i
]))
3276 else if (lesseq_defined_than (defn_symbols
[i
], sym
))
3278 defn_symbols
[i
] = sym
;
3279 defn_blocks
[i
] = block
;
3284 tmp
= defn_vector_size
;
3285 GROW_VECT (defn_symbols
, tmp
, ndefns
+ 2);
3286 GROW_VECT (defn_blocks
, defn_vector_size
, ndefns
+ 2);
3288 defn_symbols
[ndefns
] = sym
;
3289 defn_blocks
[ndefns
] = block
;
3293 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3294 Check the global symbols if GLOBAL, the static symbols if not. Do
3295 wild-card match if WILD. */
3297 static struct partial_symbol
*
3298 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
3299 int global
, namespace_enum
namespace, int wild
)
3301 struct partial_symbol
**start
;
3302 int name_len
= strlen (name
);
3303 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
3312 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
3313 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
3317 for (i
= 0; i
< length
; i
+= 1)
3319 struct partial_symbol
*psym
= start
[i
];
3321 if (SYMBOL_NAMESPACE (psym
) == namespace &&
3322 wild_match (name
, name_len
, SYMBOL_NAME (psym
)))
3336 int M
= (U
+ i
) >> 1;
3337 struct partial_symbol
*psym
= start
[M
];
3338 if (SYMBOL_NAME (psym
)[0] < name
[0])
3340 else if (SYMBOL_NAME (psym
)[0] > name
[0])
3342 else if (strcmp (SYMBOL_NAME (psym
), name
) < 0)
3353 struct partial_symbol
*psym
= start
[i
];
3355 if (SYMBOL_NAMESPACE (psym
) == namespace)
3357 int cmp
= strncmp (name
, SYMBOL_NAME (psym
), name_len
);
3365 && is_name_suffix (SYMBOL_NAME (psym
) + name_len
))
3378 int M
= (U
+ i
) >> 1;
3379 struct partial_symbol
*psym
= start
[M
];
3380 if (SYMBOL_NAME (psym
)[0] < '_')
3382 else if (SYMBOL_NAME (psym
)[0] > '_')
3384 else if (strcmp (SYMBOL_NAME (psym
), "_ada_") < 0)
3395 struct partial_symbol
*psym
= start
[i
];
3397 if (SYMBOL_NAMESPACE (psym
) == namespace)
3401 cmp
= (int) '_' - (int) SYMBOL_NAME (psym
)[0];
3404 cmp
= strncmp ("_ada_", SYMBOL_NAME (psym
), 5);
3406 cmp
= strncmp (name
, SYMBOL_NAME (psym
) + 5, name_len
);
3415 && is_name_suffix (SYMBOL_NAME (psym
) + name_len
+ 5))
3426 /* Find a symbol table containing symbol SYM or NULL if none. */
3427 static struct symtab
*
3428 symtab_for_sym (struct symbol
*sym
)
3431 struct objfile
*objfile
;
3433 struct symbol
*tmp_sym
;
3436 ALL_SYMTABS (objfile
, s
)
3438 switch (SYMBOL_CLASS (sym
))
3446 case LOC_CONST_BYTES
:
3447 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
3448 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
) if (sym
== tmp_sym
)
3450 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
3451 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
) if (sym
== tmp_sym
)
3457 switch (SYMBOL_CLASS (sym
))
3463 case LOC_REGPARM_ADDR
:
3468 case LOC_BASEREG_ARG
:
3469 for (j
= FIRST_LOCAL_BLOCK
;
3470 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
3472 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
3473 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
) if (sym
== tmp_sym
)
3484 /* Return a minimal symbol matching NAME according to Ada demangling
3485 rules. Returns NULL if there is no such minimal symbol. */
3487 struct minimal_symbol
*
3488 ada_lookup_minimal_symbol (const char *name
)
3490 struct objfile
*objfile
;
3491 struct minimal_symbol
*msymbol
;
3492 int wild_match
= (strstr (name
, "__") == NULL
);
3494 ALL_MSYMBOLS (objfile
, msymbol
)
3496 if (ada_match_name (SYMBOL_NAME (msymbol
), name
, wild_match
)
3497 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
3504 /* For all subprograms that statically enclose the subprogram of the
3505 * selected frame, add symbols matching identifier NAME in NAMESPACE
3506 * and their blocks to vectors *defn_symbols and *defn_blocks, as for
3507 * ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
3508 * wildcard prefix. At the moment, this function uses a heuristic to
3509 * find the frames of enclosing subprograms: it treats the
3510 * pointer-sized value at location 0 from the local-variable base of a
3511 * frame as a static link, and then searches up the call stack for a
3512 * frame with that same local-variable base. */
3514 add_symbols_from_enclosing_procs (const char *name
, namespace_enum
namespace,
3518 static struct symbol static_link_sym
;
3519 static struct symbol
*static_link
;
3521 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
3522 struct frame_info
*frame
;
3523 struct frame_info
*target_frame
;
3525 if (static_link
== NULL
)
3527 /* Initialize the local variable symbol that stands for the
3528 * static link (when it exists). */
3529 static_link
= &static_link_sym
;
3530 SYMBOL_NAME (static_link
) = "";
3531 SYMBOL_LANGUAGE (static_link
) = language_unknown
;
3532 SYMBOL_CLASS (static_link
) = LOC_LOCAL
;
3533 SYMBOL_NAMESPACE (static_link
) = VAR_NAMESPACE
;
3534 SYMBOL_TYPE (static_link
) = lookup_pointer_type (builtin_type_void
);
3535 SYMBOL_VALUE (static_link
) =
3536 -(long) TYPE_LENGTH (SYMBOL_TYPE (static_link
));
3539 frame
= deprecated_selected_frame
;
3540 while (frame
!= NULL
&& ndefns
== 0)
3542 struct block
*block
;
3543 struct value
*target_link_val
= read_var_value (static_link
, frame
);
3544 CORE_ADDR target_link
;
3546 if (target_link_val
== NULL
)
3550 target_link
= target_link_val
;
3554 frame
= get_prev_frame (frame
);
3556 while (frame
!= NULL
&& FRAME_LOCALS_ADDRESS (frame
) != target_link
);
3561 block
= get_frame_block (frame
, 0);
3562 while (block
!= NULL
&& block_function (block
) != NULL
&& ndefns
== 0)
3564 ada_add_block_symbols (block
, name
, namespace, NULL
, wild_match
);
3566 block
= BLOCK_SUPERBLOCK (block
);
3570 do_cleanups (old_chain
);
3574 /* True if TYPE is definitely an artificial type supplied to a symbol
3575 * for which no debugging information was given in the symbol file. */
3577 is_nondebugging_type (struct type
*type
)
3579 char *name
= ada_type_name (type
);
3580 return (name
!= NULL
&& STREQ (name
, "<variable, no debug info>"));
3583 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
3584 * duplicate other symbols in the list. (The only case I know of where
3585 * this happens is when object files containing stabs-in-ecoff are
3586 * linked with files containing ordinary ecoff debugging symbols (or no
3587 * debugging symbols)). Modifies SYMS to squeeze out deleted symbols,
3588 * and applies the same modification to BLOCKS to maintain the
3589 * correspondence between SYMS[i] and BLOCKS[i]. Returns the number
3590 * of symbols in the modified list. */
3592 remove_extra_symbols (struct symbol
**syms
, struct block
**blocks
, int nsyms
)
3599 if (SYMBOL_NAME (syms
[i
]) != NULL
3600 && SYMBOL_CLASS (syms
[i
]) == LOC_STATIC
3601 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
])))
3603 for (j
= 0; j
< nsyms
; j
+= 1)
3606 && SYMBOL_NAME (syms
[j
]) != NULL
3607 && STREQ (SYMBOL_NAME (syms
[i
]), SYMBOL_NAME (syms
[j
]))
3608 && SYMBOL_CLASS (syms
[i
]) == SYMBOL_CLASS (syms
[j
])
3609 && SYMBOL_VALUE_ADDRESS (syms
[i
])
3610 == SYMBOL_VALUE_ADDRESS (syms
[j
]))
3613 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
3615 syms
[k
- 1] = syms
[k
];
3616 blocks
[k
- 1] = blocks
[k
];
3630 /* Find symbols in NAMESPACE matching NAME, in BLOCK0 and enclosing
3631 scope and in global scopes, returning the number of matches. Sets
3632 *SYMS to point to a vector of matching symbols, with *BLOCKS
3633 pointing to the vector of corresponding blocks in which those
3634 symbols reside. These two vectors are transient---good only to the
3635 next call of ada_lookup_symbol_list. Any non-function/non-enumeral symbol
3636 match within the nest of blocks whose innermost member is BLOCK0,
3637 is the outermost match returned (no other matches in that or
3638 enclosing blocks is returned). If there are any matches in or
3639 surrounding BLOCK0, then these alone are returned. */
3642 ada_lookup_symbol_list (const char *name
, struct block
*block0
,
3643 namespace_enum
namespace, struct symbol
***syms
,
3644 struct block
***blocks
)
3648 struct partial_symtab
*ps
;
3649 struct blockvector
*bv
;
3650 struct objfile
*objfile
;
3652 struct block
*block
;
3653 struct minimal_symbol
*msymbol
;
3654 int wild_match
= (strstr (name
, "__") == NULL
);
3664 /* Search specified block and its superiors. */
3667 while (block
!= NULL
)
3669 ada_add_block_symbols (block
, name
, namespace, NULL
, wild_match
);
3671 /* If we found a non-function match, assume that's the one. */
3672 if (is_nonfunction (defn_symbols
, ndefns
))
3675 block
= BLOCK_SUPERBLOCK (block
);
3678 /* If we found ANY matches in the specified BLOCK, we're done. */
3685 /* Now add symbols from all global blocks: symbol tables, minimal symbol
3686 tables, and psymtab's */
3688 ALL_SYMTABS (objfile
, s
)
3693 bv
= BLOCKVECTOR (s
);
3694 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3695 ada_add_block_symbols (block
, name
, namespace, objfile
, wild_match
);
3698 if (namespace == VAR_NAMESPACE
)
3700 ALL_MSYMBOLS (objfile
, msymbol
)
3702 if (ada_match_name (SYMBOL_NAME (msymbol
), name
, wild_match
))
3704 switch (MSYMBOL_TYPE (msymbol
))
3706 case mst_solib_trampoline
:
3709 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
3712 int old_ndefns
= ndefns
;
3714 bv
= BLOCKVECTOR (s
);
3715 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3716 ada_add_block_symbols (block
,
3717 SYMBOL_NAME (msymbol
),
3718 namespace, objfile
, wild_match
);
3719 if (ndefns
== old_ndefns
)
3721 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3722 ada_add_block_symbols (block
,
3723 SYMBOL_NAME (msymbol
),
3733 ALL_PSYMTABS (objfile
, ps
)
3737 && ada_lookup_partial_symbol (ps
, name
, 1, namespace, wild_match
))
3739 s
= PSYMTAB_TO_SYMTAB (ps
);
3742 bv
= BLOCKVECTOR (s
);
3743 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3744 ada_add_block_symbols (block
, name
, namespace, objfile
, wild_match
);
3748 /* Now add symbols from all per-file blocks if we've gotten no hits.
3749 (Not strictly correct, but perhaps better than an error).
3750 Do the symtabs first, then check the psymtabs */
3755 ALL_SYMTABS (objfile
, s
)
3760 bv
= BLOCKVECTOR (s
);
3761 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3762 ada_add_block_symbols (block
, name
, namespace, objfile
, wild_match
);
3765 ALL_PSYMTABS (objfile
, ps
)
3769 && ada_lookup_partial_symbol (ps
, name
, 0, namespace, wild_match
))
3771 s
= PSYMTAB_TO_SYMTAB (ps
);
3772 bv
= BLOCKVECTOR (s
);
3775 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3776 ada_add_block_symbols (block
, name
, namespace,
3777 objfile
, wild_match
);
3782 /* Finally, we try to find NAME as a local symbol in some lexically
3783 enclosing block. We do this last, expecting this case to be
3787 add_symbols_from_enclosing_procs (name
, namespace, wild_match
);
3793 ndefns
= remove_extra_symbols (defn_symbols
, defn_blocks
, ndefns
);
3796 *syms
= defn_symbols
;
3797 *blocks
= defn_blocks
;
3804 /* Return a symbol in NAMESPACE matching NAME, in BLOCK0 and enclosing
3805 * scope and in global scopes, or NULL if none. NAME is folded to
3806 * lower case first, unless it is surrounded in single quotes.
3807 * Otherwise, the result is as for ada_lookup_symbol_list, but is
3808 * disambiguated by user query if needed. */
3811 ada_lookup_symbol (const char *name
, struct block
*block0
,
3812 namespace_enum
namespace)
3814 struct symbol
**candidate_syms
;
3815 struct block
**candidate_blocks
;
3818 n_candidates
= ada_lookup_symbol_list (name
,
3820 &candidate_syms
, &candidate_blocks
);
3822 if (n_candidates
== 0)
3824 else if (n_candidates
!= 1)
3825 user_select_syms (candidate_syms
, candidate_blocks
, n_candidates
, 1);
3827 return candidate_syms
[0];
3831 /* True iff STR is a possible encoded suffix of a normal Ada name
3832 * that is to be ignored for matching purposes. Suffixes of parallel
3833 * names (e.g., XVE) are not included here. Currently, the possible suffixes
3834 * are given by the regular expression:
3835 * (X[nb]*)?(__[0-9]+|\$[0-9]+|___(LJM|X([FDBUP].*|R[^T]?)))?$
3839 is_name_suffix (const char *str
)
3845 while (str
[0] != '_' && str
[0] != '\0')
3847 if (str
[0] != 'n' && str
[0] != 'b')
3852 if (str
[0] == '\000')
3856 if (str
[1] != '_' || str
[2] == '\000')
3860 if (STREQ (str
+ 3, "LJM"))
3864 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B' ||
3865 str
[4] == 'U' || str
[4] == 'P')
3867 if (str
[4] == 'R' && str
[5] != 'T')
3871 for (k
= 2; str
[k
] != '\0'; k
+= 1)
3872 if (!isdigit (str
[k
]))
3876 if (str
[0] == '$' && str
[1] != '\000')
3878 for (k
= 1; str
[k
] != '\0'; k
+= 1)
3879 if (!isdigit (str
[k
]))
3886 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
3887 * PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
3888 * informational suffixes of NAME (i.e., for which is_name_suffix is
3891 wild_match (const char *patn
, int patn_len
, const char *name
)
3896 name_len
= strlen (name
);
3897 if (name_len
>= patn_len
+ 5 && STREQN (name
, "_ada_", 5)
3898 && STREQN (patn
, name
+ 5, patn_len
)
3899 && is_name_suffix (name
+ patn_len
+ 5))
3902 while (name_len
>= patn_len
)
3904 if (STREQN (patn
, name
, patn_len
) && is_name_suffix (name
+ patn_len
))
3912 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
3917 if (!islower (name
[2]))
3924 if (!islower (name
[1]))
3935 /* Add symbols from BLOCK matching identifier NAME in NAMESPACE to
3936 vector *defn_symbols, updating *defn_symbols (if necessary), *SZ (the size of
3937 the vector *defn_symbols), and *ndefns (the number of symbols
3938 currently stored in *defn_symbols). If WILD, treat as NAME with a
3939 wildcard prefix. OBJFILE is the section containing BLOCK. */
3942 ada_add_block_symbols (struct block
*block
, const char *name
,
3943 namespace_enum
namespace, struct objfile
*objfile
,
3947 int name_len
= strlen (name
);
3948 /* A matching argument symbol, if any. */
3949 struct symbol
*arg_sym
;
3950 /* Set true when we find a matching non-argument symbol */
3952 int is_sorted
= BLOCK_SHOULD_SORT (block
);
3960 ALL_BLOCK_SYMBOLS (block
, i
, sym
)
3962 if (SYMBOL_NAMESPACE (sym
) == namespace &&
3963 wild_match (name
, name_len
, SYMBOL_NAME (sym
)))
3965 switch (SYMBOL_CLASS (sym
))
3971 case LOC_REGPARM_ADDR
:
3972 case LOC_BASEREG_ARG
:
3975 case LOC_UNRESOLVED
:
3979 fill_in_ada_prototype (sym
);
3980 add_defn_to_vec (fixup_symbol_section (sym
, objfile
), block
);
3992 U
= BLOCK_NSYMS (block
) - 1;
3995 int M
= (U
+ i
) >> 1;
3996 struct symbol
*sym
= BLOCK_SYM (block
, M
);
3997 if (SYMBOL_NAME (sym
)[0] < name
[0])
3999 else if (SYMBOL_NAME (sym
)[0] > name
[0])
4001 else if (strcmp (SYMBOL_NAME (sym
), name
) < 0)
4010 for (; i
< BLOCK_BUCKETS (block
); i
+= 1)
4011 for (sym
= BLOCK_BUCKET (block
, i
); sym
!= NULL
; sym
= sym
->hash_next
)
4013 if (SYMBOL_NAMESPACE (sym
) == namespace)
4015 int cmp
= strncmp (name
, SYMBOL_NAME (sym
), name_len
);
4021 i
= BLOCK_BUCKETS (block
);
4026 && is_name_suffix (SYMBOL_NAME (sym
) + name_len
))
4028 switch (SYMBOL_CLASS (sym
))
4034 case LOC_REGPARM_ADDR
:
4035 case LOC_BASEREG_ARG
:
4038 case LOC_UNRESOLVED
:
4042 fill_in_ada_prototype (sym
);
4043 add_defn_to_vec (fixup_symbol_section (sym
, objfile
),
4052 if (!found_sym
&& arg_sym
!= NULL
)
4054 fill_in_ada_prototype (arg_sym
);
4055 add_defn_to_vec (fixup_symbol_section (arg_sym
, objfile
), block
);
4066 U
= BLOCK_NSYMS (block
) - 1;
4069 int M
= (U
+ i
) >> 1;
4070 struct symbol
*sym
= BLOCK_SYM (block
, M
);
4071 if (SYMBOL_NAME (sym
)[0] < '_')
4073 else if (SYMBOL_NAME (sym
)[0] > '_')
4075 else if (strcmp (SYMBOL_NAME (sym
), "_ada_") < 0)
4084 for (; i
< BLOCK_BUCKETS (block
); i
+= 1)
4085 for (sym
= BLOCK_BUCKET (block
, i
); sym
!= NULL
; sym
= sym
->hash_next
)
4087 struct symbol
*sym
= BLOCK_SYM (block
, i
);
4089 if (SYMBOL_NAMESPACE (sym
) == namespace)
4093 cmp
= (int) '_' - (int) SYMBOL_NAME (sym
)[0];
4096 cmp
= strncmp ("_ada_", SYMBOL_NAME (sym
), 5);
4098 cmp
= strncmp (name
, SYMBOL_NAME (sym
) + 5, name_len
);
4105 i
= BLOCK_BUCKETS (block
);
4110 && is_name_suffix (SYMBOL_NAME (sym
) + name_len
+ 5))
4112 switch (SYMBOL_CLASS (sym
))
4118 case LOC_REGPARM_ADDR
:
4119 case LOC_BASEREG_ARG
:
4122 case LOC_UNRESOLVED
:
4126 fill_in_ada_prototype (sym
);
4127 add_defn_to_vec (fixup_symbol_section (sym
, objfile
),
4135 /* NOTE: This really shouldn't be needed for _ada_ symbols.
4136 They aren't parameters, right? */
4137 if (!found_sym
&& arg_sym
!= NULL
)
4139 fill_in_ada_prototype (arg_sym
);
4140 add_defn_to_vec (fixup_symbol_section (arg_sym
, objfile
), block
);
4146 /* Function Types */
4148 /* Assuming that SYM is the symbol for a function, fill in its type
4149 with prototype information, if it is not already there. */
4152 fill_in_ada_prototype (struct symbol
*func
)
4163 || TYPE_CODE (SYMBOL_TYPE (func
)) != TYPE_CODE_FUNC
4164 || TYPE_FIELDS (SYMBOL_TYPE (func
)) != NULL
)
4167 /* We make each function type unique, so that each may have its own */
4168 /* parameter types. This particular way of doing so wastes space: */
4169 /* it would be nicer to build the argument types while the original */
4170 /* function type is being built (FIXME). */
4171 rtype
= check_typedef (TYPE_TARGET_TYPE (SYMBOL_TYPE (func
)));
4172 ftype
= alloc_type (TYPE_OBJFILE (SYMBOL_TYPE (func
)));
4173 make_function_type (rtype
, &ftype
);
4174 SYMBOL_TYPE (func
) = ftype
;
4176 b
= SYMBOL_BLOCK_VALUE (func
);
4180 TYPE_FIELDS (ftype
) =
4181 (struct field
*) xmalloc (sizeof (struct field
) * max_fields
);
4182 ALL_BLOCK_SYMBOLS (b
, i
, sym
)
4184 GROW_VECT (TYPE_FIELDS (ftype
), max_fields
, nargs
+ 1);
4186 switch (SYMBOL_CLASS (sym
))
4189 case LOC_REGPARM_ADDR
:
4190 TYPE_FIELD_BITPOS (ftype
, nargs
) = nargs
;
4191 TYPE_FIELD_BITSIZE (ftype
, nargs
) = 0;
4192 TYPE_FIELD_STATIC_KIND (ftype
, nargs
) = 0;
4193 TYPE_FIELD_TYPE (ftype
, nargs
) =
4194 lookup_pointer_type (check_typedef (SYMBOL_TYPE (sym
)));
4195 TYPE_FIELD_NAME (ftype
, nargs
) = SYMBOL_NAME (sym
);
4203 case LOC_BASEREG_ARG
:
4204 TYPE_FIELD_BITPOS (ftype
, nargs
) = nargs
;
4205 TYPE_FIELD_BITSIZE (ftype
, nargs
) = 0;
4206 TYPE_FIELD_STATIC_KIND (ftype
, nargs
) = 0;
4207 TYPE_FIELD_TYPE (ftype
, nargs
) = check_typedef (SYMBOL_TYPE (sym
));
4208 TYPE_FIELD_NAME (ftype
, nargs
) = SYMBOL_NAME (sym
);
4218 /* Re-allocate fields vector; if there are no fields, make the */
4219 /* fields pointer non-null anyway, to mark that this function type */
4220 /* has been filled in. */
4222 TYPE_NFIELDS (ftype
) = nargs
;
4225 static struct field dummy_field
= { 0, 0, 0, 0 };
4226 xfree (TYPE_FIELDS (ftype
));
4227 TYPE_FIELDS (ftype
) = &dummy_field
;
4231 struct field
*fields
=
4232 (struct field
*) TYPE_ALLOC (ftype
, nargs
* sizeof (struct field
));
4233 memcpy ((char *) fields
,
4234 (char *) TYPE_FIELDS (ftype
), nargs
* sizeof (struct field
));
4235 xfree (TYPE_FIELDS (ftype
));
4236 TYPE_FIELDS (ftype
) = fields
;
4241 /* Breakpoint-related */
4243 char no_symtab_msg
[] =
4244 "No symbol table is loaded. Use the \"file\" command.";
4246 /* Assuming that LINE is pointing at the beginning of an argument to
4247 'break', return a pointer to the delimiter for the initial segment
4248 of that name. This is the first ':', ' ', or end of LINE.
4251 ada_start_decode_line_1 (char *line
)
4253 /* [NOTE: strpbrk would be more elegant, but I am reluctant to be
4254 the first to use such a library function in GDB code.] */
4256 for (p
= line
; *p
!= '\000' && *p
!= ' ' && *p
!= ':'; p
+= 1)
4261 /* *SPEC points to a function and line number spec (as in a break
4262 command), following any initial file name specification.
4264 Return all symbol table/line specfications (sals) consistent with the
4265 information in *SPEC and FILE_TABLE in the
4267 + FILE_TABLE is null, or the sal refers to a line in the file
4268 named by FILE_TABLE.
4269 + If *SPEC points to an argument with a trailing ':LINENUM',
4270 then the sal refers to that line (or one following it as closely as
4272 + If *SPEC does not start with '*', the sal is in a function with
4275 Returns with 0 elements if no matching non-minimal symbols found.
4277 If *SPEC begins with a function name of the form <NAME>, then NAME
4278 is taken as a literal name; otherwise the function name is subject
4279 to the usual mangling.
4281 *SPEC is updated to point after the function/line number specification.
4283 FUNFIRSTLINE is non-zero if we desire the first line of real code
4284 in each function (this is ignored in the presence of a LINENUM spec.).
4286 If CANONICAL is non-NULL, and if any of the sals require a
4287 'canonical line spec', then *CANONICAL is set to point to an array
4288 of strings, corresponding to and equal in length to the returned
4289 list of sals, such that (*CANONICAL)[i] is non-null and contains a
4290 canonical line spec for the ith returned sal, if needed. If no
4291 canonical line specs are required and CANONICAL is non-null,
4292 *CANONICAL is set to NULL.
4294 A 'canonical line spec' is simply a name (in the format of the
4295 breakpoint command) that uniquely identifies a breakpoint position,
4296 with no further contextual information or user selection. It is
4297 needed whenever the file name, function name, and line number
4298 information supplied is insufficient for this unique
4299 identification. Currently overloaded functions, the name '*',
4300 or static functions without a filename yield a canonical line spec.
4301 The array and the line spec strings are allocated on the heap; it
4302 is the caller's responsibility to free them. */
4304 struct symtabs_and_lines
4305 ada_finish_decode_line_1 (char **spec
, struct symtab
*file_table
,
4306 int funfirstline
, char ***canonical
)
4308 struct symbol
**symbols
;
4309 struct block
**blocks
;
4310 struct block
*block
;
4311 int n_matches
, i
, line_num
;
4312 struct symtabs_and_lines selected
;
4313 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
4318 char *unquoted_name
;
4320 if (file_table
== NULL
)
4321 block
= get_selected_block (NULL
);
4323 block
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (file_table
), STATIC_BLOCK
);
4325 if (canonical
!= NULL
)
4326 *canonical
= (char **) NULL
;
4333 while (**spec
!= '\000' &&
4334 !strchr (ada_completer_word_break_characters
, **spec
))
4340 if (file_table
!= NULL
&& (*spec
)[0] == ':' && isdigit ((*spec
)[1]))
4342 line_num
= strtol (*spec
+ 1, spec
, 10);
4343 while (**spec
== ' ' || **spec
== '\t')
4350 error ("Wild-card function with no line number or file name.");
4352 return all_sals_for_line (file_table
->filename
, line_num
, canonical
);
4355 if (name
[0] == '\'')
4363 unquoted_name
= (char *) alloca (len
- 1);
4364 memcpy (unquoted_name
, name
+ 1, len
- 2);
4365 unquoted_name
[len
- 2] = '\000';
4370 unquoted_name
= (char *) alloca (len
+ 1);
4371 memcpy (unquoted_name
, name
, len
);
4372 unquoted_name
[len
] = '\000';
4373 lower_name
= (char *) alloca (len
+ 1);
4374 for (i
= 0; i
< len
; i
+= 1)
4375 lower_name
[i
] = tolower (name
[i
]);
4376 lower_name
[len
] = '\000';
4380 if (lower_name
!= NULL
)
4381 n_matches
= ada_lookup_symbol_list (ada_mangle (lower_name
), block
,
4382 VAR_NAMESPACE
, &symbols
, &blocks
);
4384 n_matches
= ada_lookup_symbol_list (unquoted_name
, block
,
4385 VAR_NAMESPACE
, &symbols
, &blocks
);
4386 if (n_matches
== 0 && line_num
>= 0)
4387 error ("No line number information found for %s.", unquoted_name
);
4388 else if (n_matches
== 0)
4390 #ifdef HPPA_COMPILER_BUG
4391 /* FIXME: See comment in symtab.c::decode_line_1 */
4393 volatile struct symtab_and_line val
;
4394 #define volatile /*nothing */
4396 struct symtab_and_line val
;
4398 struct minimal_symbol
*msymbol
;
4403 if (lower_name
!= NULL
)
4404 msymbol
= ada_lookup_minimal_symbol (ada_mangle (lower_name
));
4405 if (msymbol
== NULL
)
4406 msymbol
= ada_lookup_minimal_symbol (unquoted_name
);
4407 if (msymbol
!= NULL
)
4409 val
.pc
= SYMBOL_VALUE_ADDRESS (msymbol
);
4410 val
.section
= SYMBOL_BFD_SECTION (msymbol
);
4413 val
.pc
+= FUNCTION_START_OFFSET
;
4414 SKIP_PROLOGUE (val
.pc
);
4416 selected
.sals
= (struct symtab_and_line
*)
4417 xmalloc (sizeof (struct symtab_and_line
));
4418 selected
.sals
[0] = val
;
4423 if (!have_full_symbols () &&
4424 !have_partial_symbols () && !have_minimal_symbols ())
4425 error (no_symtab_msg
);
4427 error ("Function \"%s\" not defined.", unquoted_name
);
4428 return selected
; /* for lint */
4434 find_sal_from_funcs_and_line (file_table
->filename
, line_num
,
4435 symbols
, n_matches
);
4440 user_select_syms (symbols
, blocks
, n_matches
, n_matches
);
4443 selected
.sals
= (struct symtab_and_line
*)
4444 xmalloc (sizeof (struct symtab_and_line
) * selected
.nelts
);
4445 memset (selected
.sals
, 0, selected
.nelts
* sizeof (selected
.sals
[i
]));
4446 make_cleanup (xfree
, selected
.sals
);
4449 while (i
< selected
.nelts
)
4451 if (SYMBOL_CLASS (symbols
[i
]) == LOC_BLOCK
)
4452 selected
.sals
[i
] = find_function_start_sal (symbols
[i
], funfirstline
);
4453 else if (SYMBOL_LINE (symbols
[i
]) != 0)
4455 selected
.sals
[i
].symtab
= symtab_for_sym (symbols
[i
]);
4456 selected
.sals
[i
].line
= SYMBOL_LINE (symbols
[i
]);
4458 else if (line_num
>= 0)
4460 /* Ignore this choice */
4461 symbols
[i
] = symbols
[selected
.nelts
- 1];
4462 blocks
[i
] = blocks
[selected
.nelts
- 1];
4463 selected
.nelts
-= 1;
4467 error ("Line number not known for symbol \"%s\"", unquoted_name
);
4471 if (canonical
!= NULL
&& (line_num
>= 0 || n_matches
> 1))
4473 *canonical
= (char **) xmalloc (sizeof (char *) * selected
.nelts
);
4474 for (i
= 0; i
< selected
.nelts
; i
+= 1)
4476 extended_canonical_line_spec (selected
.sals
[i
],
4477 SYMBOL_SOURCE_NAME (symbols
[i
]));
4480 discard_cleanups (old_chain
);
4484 /* The (single) sal corresponding to line LINE_NUM in a symbol table
4485 with file name FILENAME that occurs in one of the functions listed
4486 in SYMBOLS[0 .. NSYMS-1]. */
4487 static struct symtabs_and_lines
4488 find_sal_from_funcs_and_line (const char *filename
, int line_num
,
4489 struct symbol
**symbols
, int nsyms
)
4491 struct symtabs_and_lines sals
;
4492 int best_index
, best
;
4493 struct linetable
*best_linetable
;
4494 struct objfile
*objfile
;
4496 struct symtab
*best_symtab
;
4498 read_all_symtabs (filename
);
4501 best_linetable
= NULL
;
4504 ALL_SYMTABS (objfile
, s
)
4506 struct linetable
*l
;
4511 if (!STREQ (filename
, s
->filename
))
4514 ind
= find_line_in_linetable (l
, line_num
, symbols
, nsyms
, &exact
);
4524 if (best
== 0 || l
->item
[ind
].line
< best
)
4526 best
= l
->item
[ind
].line
;
4535 error ("Line number not found in designated function.");
4540 sals
.sals
= (struct symtab_and_line
*) xmalloc (sizeof (sals
.sals
[0]));
4542 init_sal (&sals
.sals
[0]);
4544 sals
.sals
[0].line
= best_linetable
->item
[best_index
].line
;
4545 sals
.sals
[0].pc
= best_linetable
->item
[best_index
].pc
;
4546 sals
.sals
[0].symtab
= best_symtab
;
4551 /* Return the index in LINETABLE of the best match for LINE_NUM whose
4552 pc falls within one of the functions denoted by SYMBOLS[0..NSYMS-1].
4553 Set *EXACTP to the 1 if the match is exact, and 0 otherwise. */
4555 find_line_in_linetable (struct linetable
*linetable
, int line_num
,
4556 struct symbol
**symbols
, int nsyms
, int *exactp
)
4558 int i
, len
, best_index
, best
;
4560 if (line_num
<= 0 || linetable
== NULL
)
4563 len
= linetable
->nitems
;
4564 for (i
= 0, best_index
= -1, best
= 0; i
< len
; i
+= 1)
4567 struct linetable_entry
*item
= &(linetable
->item
[i
]);
4569 for (k
= 0; k
< nsyms
; k
+= 1)
4571 if (symbols
[k
] != NULL
&& SYMBOL_CLASS (symbols
[k
]) == LOC_BLOCK
4572 && item
->pc
>= BLOCK_START (SYMBOL_BLOCK_VALUE (symbols
[k
]))
4573 && item
->pc
< BLOCK_END (SYMBOL_BLOCK_VALUE (symbols
[k
])))
4580 if (item
->line
== line_num
)
4586 if (item
->line
> line_num
&& (best
== 0 || item
->line
< best
))
4597 /* Find the smallest k >= LINE_NUM such that k is a line number in
4598 LINETABLE, and k falls strictly within a named function that begins at
4599 or before LINE_NUM. Return -1 if there is no such k. */
4601 nearest_line_number_in_linetable (struct linetable
*linetable
, int line_num
)
4605 if (line_num
<= 0 || linetable
== NULL
|| linetable
->nitems
== 0)
4607 len
= linetable
->nitems
;
4614 struct linetable_entry
*item
= &(linetable
->item
[i
]);
4616 if (item
->line
>= line_num
&& item
->line
< best
)
4619 CORE_ADDR start
, end
;
4622 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
4624 if (func_name
!= NULL
&& item
->pc
< end
)
4626 if (item
->line
== line_num
)
4630 struct symbol
*sym
=
4631 standard_lookup (func_name
, VAR_NAMESPACE
);
4632 if (is_plausible_func_for_line (sym
, line_num
))
4638 while (i
< len
&& linetable
->item
[i
].pc
< end
);
4648 return (best
== INT_MAX
) ? -1 : best
;
4652 /* Return the next higher index, k, into LINETABLE such that k > IND,
4653 entry k in LINETABLE has a line number equal to LINE_NUM, k
4654 corresponds to a PC that is in a function different from that
4655 corresponding to IND, and falls strictly within a named function
4656 that begins at a line at or preceding STARTING_LINE.
4657 Return -1 if there is no such k.
4658 IND == -1 corresponds to no function. */
4661 find_next_line_in_linetable (struct linetable
*linetable
, int line_num
,
4662 int starting_line
, int ind
)
4666 if (line_num
<= 0 || linetable
== NULL
|| ind
>= linetable
->nitems
)
4668 len
= linetable
->nitems
;
4672 CORE_ADDR start
, end
;
4674 if (find_pc_partial_function (linetable
->item
[ind
].pc
,
4675 (char **) NULL
, &start
, &end
))
4677 while (ind
< len
&& linetable
->item
[ind
].pc
< end
)
4690 struct linetable_entry
*item
= &(linetable
->item
[i
]);
4692 if (item
->line
>= line_num
)
4695 CORE_ADDR start
, end
;
4698 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
4700 if (func_name
!= NULL
&& item
->pc
< end
)
4702 if (item
->line
== line_num
)
4704 struct symbol
*sym
=
4705 standard_lookup (func_name
, VAR_NAMESPACE
);
4706 if (is_plausible_func_for_line (sym
, starting_line
))
4710 while ((i
+ 1) < len
&& linetable
->item
[i
+ 1].pc
< end
)
4722 /* True iff function symbol SYM starts somewhere at or before line #
4725 is_plausible_func_for_line (struct symbol
*sym
, int line_num
)
4727 struct symtab_and_line start_sal
;
4732 start_sal
= find_function_start_sal (sym
, 0);
4734 return (start_sal
.line
!= 0 && line_num
>= start_sal
.line
);
4738 debug_print_lines (struct linetable
*lt
)
4745 fprintf (stderr
, "\t");
4746 for (i
= 0; i
< lt
->nitems
; i
+= 1)
4747 fprintf (stderr
, "(%d->%p) ", lt
->item
[i
].line
, (void *) lt
->item
[i
].pc
);
4748 fprintf (stderr
, "\n");
4752 debug_print_block (struct block
*b
)
4757 fprintf (stderr
, "Block: %p; [0x%lx, 0x%lx]",
4758 b
, BLOCK_START (b
), BLOCK_END (b
));
4759 if (BLOCK_FUNCTION (b
) != NULL
)
4760 fprintf (stderr
, " Function: %s", SYMBOL_NAME (BLOCK_FUNCTION (b
)));
4761 fprintf (stderr
, "\n");
4762 fprintf (stderr
, "\t Superblock: %p\n", BLOCK_SUPERBLOCK (b
));
4763 fprintf (stderr
, "\t Symbols:");
4764 ALL_BLOCK_SYMBOLS (b
, i
, sym
)
4766 if (i
> 0 && i
% 4 == 0)
4767 fprintf (stderr
, "\n\t\t ");
4768 fprintf (stderr
, " %s", SYMBOL_NAME (sym
));
4770 fprintf (stderr
, "\n");
4774 debug_print_blocks (struct blockvector
*bv
)
4780 for (i
= 0; i
< BLOCKVECTOR_NBLOCKS (bv
); i
+= 1)
4782 fprintf (stderr
, "%6d. ", i
);
4783 debug_print_block (BLOCKVECTOR_BLOCK (bv
, i
));
4788 debug_print_symtab (struct symtab
*s
)
4790 fprintf (stderr
, "Symtab %p\n File: %s; Dir: %s\n", s
,
4791 s
->filename
, s
->dirname
);
4792 fprintf (stderr
, " Blockvector: %p, Primary: %d\n",
4793 BLOCKVECTOR (s
), s
->primary
);
4794 debug_print_blocks (BLOCKVECTOR (s
));
4795 fprintf (stderr
, " Line table: %p\n", LINETABLE (s
));
4796 debug_print_lines (LINETABLE (s
));
4799 /* Read in all symbol tables corresponding to partial symbol tables
4800 with file name FILENAME. */
4802 read_all_symtabs (const char *filename
)
4804 struct partial_symtab
*ps
;
4805 struct objfile
*objfile
;
4807 ALL_PSYMTABS (objfile
, ps
)
4811 if (STREQ (filename
, ps
->filename
))
4812 PSYMTAB_TO_SYMTAB (ps
);
4816 /* All sals corresponding to line LINE_NUM in a symbol table from file
4817 FILENAME, as filtered by the user. If CANONICAL is not null, set
4818 it to a corresponding array of canonical line specs. */
4819 static struct symtabs_and_lines
4820 all_sals_for_line (const char *filename
, int line_num
, char ***canonical
)
4822 struct symtabs_and_lines result
;
4823 struct objfile
*objfile
;
4825 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
4828 read_all_symtabs (filename
);
4831 (struct symtab_and_line
*) xmalloc (4 * sizeof (result
.sals
[0]));
4834 make_cleanup (free_current_contents
, &result
.sals
);
4836 ALL_SYMTABS (objfile
, s
)
4838 int ind
, target_line_num
;
4842 if (!STREQ (s
->filename
, filename
))
4846 nearest_line_number_in_linetable (LINETABLE (s
), line_num
);
4847 if (target_line_num
== -1)
4854 find_next_line_in_linetable (LINETABLE (s
),
4855 target_line_num
, line_num
, ind
);
4860 GROW_VECT (result
.sals
, len
, result
.nelts
+ 1);
4861 init_sal (&result
.sals
[result
.nelts
]);
4862 result
.sals
[result
.nelts
].line
= LINETABLE (s
)->item
[ind
].line
;
4863 result
.sals
[result
.nelts
].pc
= LINETABLE (s
)->item
[ind
].pc
;
4864 result
.sals
[result
.nelts
].symtab
= s
;
4869 if (canonical
!= NULL
|| result
.nelts
> 1)
4872 char **func_names
= (char **) alloca (result
.nelts
* sizeof (char *));
4873 int first_choice
= (result
.nelts
> 1) ? 2 : 1;
4875 int *choices
= (int *) alloca (result
.nelts
* sizeof (int));
4877 for (k
= 0; k
< result
.nelts
; k
+= 1)
4879 find_pc_partial_function (result
.sals
[k
].pc
, &func_names
[k
],
4880 (CORE_ADDR
*) NULL
, (CORE_ADDR
*) NULL
);
4881 if (func_names
[k
] == NULL
)
4882 error ("Could not find function for one or more breakpoints.");
4885 if (result
.nelts
> 1)
4887 printf_unfiltered ("[0] cancel\n");
4888 if (result
.nelts
> 1)
4889 printf_unfiltered ("[1] all\n");
4890 for (k
= 0; k
< result
.nelts
; k
+= 1)
4891 printf_unfiltered ("[%d] %s\n", k
+ first_choice
,
4892 ada_demangle (func_names
[k
]));
4894 n
= get_selections (choices
, result
.nelts
, result
.nelts
,
4895 result
.nelts
> 1, "instance-choice");
4897 for (k
= 0; k
< n
; k
+= 1)
4899 result
.sals
[k
] = result
.sals
[choices
[k
]];
4900 func_names
[k
] = func_names
[choices
[k
]];
4905 if (canonical
!= NULL
)
4907 *canonical
= (char **) xmalloc (result
.nelts
* sizeof (char **));
4908 make_cleanup (xfree
, *canonical
);
4909 for (k
= 0; k
< result
.nelts
; k
+= 1)
4912 extended_canonical_line_spec (result
.sals
[k
], func_names
[k
]);
4913 if ((*canonical
)[k
] == NULL
)
4914 error ("Could not locate one or more breakpoints.");
4915 make_cleanup (xfree
, (*canonical
)[k
]);
4920 discard_cleanups (old_chain
);
4925 /* A canonical line specification of the form FILE:NAME:LINENUM for
4926 symbol table and line data SAL. NULL if insufficient
4927 information. The caller is responsible for releasing any space
4931 extended_canonical_line_spec (struct symtab_and_line sal
, const char *name
)
4935 if (sal
.symtab
== NULL
|| sal
.symtab
->filename
== NULL
|| sal
.line
<= 0)
4938 r
= (char *) xmalloc (strlen (name
) + strlen (sal
.symtab
->filename
)
4939 + sizeof (sal
.line
) * 3 + 3);
4940 sprintf (r
, "%s:'%s':%d", sal
.symtab
->filename
, name
, sal
.line
);
4945 int begin_bnum
= -1;
4947 int begin_annotate_level
= 0;
4950 begin_cleanup (void *dummy
)
4952 begin_annotate_level
= 0;
4956 begin_command (char *args
, int from_tty
)
4958 struct minimal_symbol
*msym
;
4959 CORE_ADDR main_program_name_addr
;
4960 char main_program_name
[1024];
4961 struct cleanup
*old_chain
= make_cleanup (begin_cleanup
, NULL
);
4962 begin_annotate_level
= 2;
4964 /* Check that there is a program to debug */
4965 if (!have_full_symbols () && !have_partial_symbols ())
4966 error ("No symbol table is loaded. Use the \"file\" command.");
4968 /* Check that we are debugging an Ada program */
4969 /* if (ada_update_initial_language (language_unknown, NULL) != language_ada)
4970 error ("Cannot find the Ada initialization procedure. Is this an Ada main program?");
4972 /* FIXME: language_ada should be defined in defs.h */
4974 /* Get the address of the name of the main procedure */
4975 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
4979 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
4980 if (main_program_name_addr
== 0)
4981 error ("Invalid address for Ada main program name.");
4983 /* Read the name of the main procedure */
4984 extract_string (main_program_name_addr
, main_program_name
);
4986 /* Put a temporary breakpoint in the Ada main program and run */
4987 do_command ("tbreak ", main_program_name
, 0);
4988 do_command ("run ", args
, 0);
4992 /* If we could not find the symbol containing the name of the
4993 main program, that means that the compiler that was used to build
4994 was not recent enough. In that case, we fallback to the previous
4995 mechanism, which is a little bit less reliable, but has proved to work
4996 in most cases. The only cases where it will fail is when the user
4997 has set some breakpoints which will be hit before the end of the
4998 begin command processing (eg in the initialization code).
5000 The begining of the main Ada subprogram is located by breaking
5001 on the adainit procedure. Since we know that the binder generates
5002 the call to this procedure exactly 2 calls before the call to the
5003 Ada main subprogram, it is then easy to put a breakpoint on this
5004 Ada main subprogram once we hit adainit.
5006 do_command ("tbreak adainit", 0);
5007 do_command ("run ", args
, 0);
5008 do_command ("up", 0);
5009 do_command ("tbreak +2", 0);
5010 do_command ("continue", 0);
5011 do_command ("step", 0);
5014 do_cleanups (old_chain
);
5018 is_ada_runtime_file (char *filename
)
5020 return (STREQN (filename
, "s-", 2) ||
5021 STREQN (filename
, "a-", 2) ||
5022 STREQN (filename
, "g-", 2) || STREQN (filename
, "i-", 2));
5025 /* find the first frame that contains debugging information and that is not
5026 part of the Ada run-time, starting from fi and moving upward. */
5029 find_printable_frame (struct frame_info
*fi
, int level
)
5031 struct symtab_and_line sal
;
5033 for (; fi
!= NULL
; level
+= 1, fi
= get_prev_frame (fi
))
5035 find_frame_sal (fi
, &sal
);
5036 if (sal
.symtab
&& !is_ada_runtime_file (sal
.symtab
->filename
))
5038 #if defined(__alpha__) && defined(__osf__) && !defined(VXWORKS_TARGET)
5039 /* libpthread.so contains some debugging information that prevents us
5040 from finding the right frame */
5042 if (sal
.symtab
->objfile
&&
5043 STREQ (sal
.symtab
->objfile
->name
, "/usr/shlib/libpthread.so"))
5046 deprecated_selected_frame
= fi
;
5055 ada_report_exception_break (struct breakpoint
*b
)
5058 /* FIXME: break_on_exception should be defined in breakpoint.h */
5059 /* if (b->break_on_exception == 1)
5061 /* Assume that cond has 16 elements, the 15th
5062 being the exception *//*
5063 if (b->cond && b->cond->nelts == 16)
5065 ui_out_text (uiout, "on ");
5066 ui_out_field_string (uiout, "exception",
5067 SYMBOL_NAME (b->cond->elts[14].symbol));
5070 ui_out_text (uiout, "on all exceptions");
5072 else if (b->break_on_exception == 2)
5073 ui_out_text (uiout, "on unhandled exception");
5074 else if (b->break_on_exception == 3)
5075 ui_out_text (uiout, "on assert failure");
5077 if (b->break_on_exception == 1)
5079 /* Assume that cond has 16 elements, the 15th
5080 being the exception *//*
5081 if (b->cond && b->cond->nelts == 16)
5083 fputs_filtered ("on ", gdb_stdout);
5084 fputs_filtered (SYMBOL_NAME
5085 (b->cond->elts[14].symbol), gdb_stdout);
5088 fputs_filtered ("on all exceptions", gdb_stdout);
5090 else if (b->break_on_exception == 2)
5091 fputs_filtered ("on unhandled exception", gdb_stdout);
5092 else if (b->break_on_exception == 3)
5093 fputs_filtered ("on assert failure", gdb_stdout);
5099 ada_is_exception_sym (struct symbol
*sym
)
5101 char *type_name
= type_name_no_tag (SYMBOL_TYPE (sym
));
5103 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5104 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5105 && SYMBOL_CLASS (sym
) != LOC_CONST
5106 && type_name
!= NULL
&& STREQ (type_name
, "exception"));
5110 ada_maybe_exception_partial_symbol (struct partial_symbol
*sym
)
5112 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5113 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5114 && SYMBOL_CLASS (sym
) != LOC_CONST
);
5117 /* If ARG points to an Ada exception or assert breakpoint, rewrite
5118 into equivalent form. Return resulting argument string. Set
5119 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
5120 break on unhandled, 3 for assert, 0 otherwise. */
5122 ada_breakpoint_rewrite (char *arg
, int *break_on_exceptionp
)
5126 *break_on_exceptionp
= 0;
5127 /* FIXME: language_ada should be defined in defs.h */
5128 /* if (current_language->la_language == language_ada
5129 && STREQN (arg, "exception", 9) &&
5130 (arg[9] == ' ' || arg[9] == '\t' || arg[9] == '\0'))
5132 char *tok, *end_tok;
5135 *break_on_exceptionp = 1;
5138 while (*tok == ' ' || *tok == '\t')
5143 while (*end_tok != ' ' && *end_tok != '\t' && *end_tok != '\000')
5146 toklen = end_tok - tok;
5148 arg = (char*) xmalloc (sizeof ("__gnat_raise_nodefer_with_msg if "
5149 "long_integer(e) = long_integer(&)")
5151 make_cleanup (xfree, arg);
5153 strcpy (arg, "__gnat_raise_nodefer_with_msg");
5154 else if (STREQN (tok, "unhandled", toklen))
5156 *break_on_exceptionp = 2;
5157 strcpy (arg, "__gnat_unhandled_exception");
5161 sprintf (arg, "__gnat_raise_nodefer_with_msg if "
5162 "long_integer(e) = long_integer(&%.*s)",
5166 else if (current_language->la_language == language_ada
5167 && STREQN (arg, "assert", 6) &&
5168 (arg[6] == ' ' || arg[6] == '\t' || arg[6] == '\0'))
5170 char *tok = arg + 6;
5172 *break_on_exceptionp = 3;
5175 xmalloc (sizeof ("system__assertions__raise_assert_failure")
5176 + strlen (tok) + 1);
5177 make_cleanup (xfree, arg);
5178 sprintf (arg, "system__assertions__raise_assert_failure%s", tok);
5187 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5188 to be invisible to users. */
5191 ada_is_ignored_field (struct type
*type
, int field_num
)
5193 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5197 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5198 return (name
== NULL
5199 || (name
[0] == '_' && !STREQN (name
, "_parent", 7)));
5203 /* True iff structure type TYPE has a tag field. */
5206 ada_is_tagged_type (struct type
*type
)
5208 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5211 return (ada_lookup_struct_elt_type (type
, "_tag", 1, NULL
) != NULL
);
5214 /* The type of the tag on VAL. */
5217 ada_tag_type (struct value
*val
)
5219 return ada_lookup_struct_elt_type (VALUE_TYPE (val
), "_tag", 0, NULL
);
5222 /* The value of the tag on VAL. */
5225 ada_value_tag (struct value
*val
)
5227 return ada_value_struct_elt (val
, "_tag", "record");
5230 /* The parent type of TYPE, or NULL if none. */
5233 ada_parent_type (struct type
*type
)
5237 CHECK_TYPEDEF (type
);
5239 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5242 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5243 if (ada_is_parent_field (type
, i
))
5244 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5249 /* True iff field number FIELD_NUM of structure type TYPE contains the
5250 parent-type (inherited) fields of a derived type. Assumes TYPE is
5251 a structure type with at least FIELD_NUM+1 fields. */
5254 ada_is_parent_field (struct type
*type
, int field_num
)
5256 const char *name
= TYPE_FIELD_NAME (check_typedef (type
), field_num
);
5257 return (name
!= NULL
&&
5258 (STREQN (name
, "PARENT", 6) || STREQN (name
, "_parent", 7)));
5261 /* True iff field number FIELD_NUM of structure type TYPE is a
5262 transparent wrapper field (which should be silently traversed when doing
5263 field selection and flattened when printing). Assumes TYPE is a
5264 structure type with at least FIELD_NUM+1 fields. Such fields are always
5268 ada_is_wrapper_field (struct type
*type
, int field_num
)
5270 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5271 return (name
!= NULL
5272 && (STREQN (name
, "PARENT", 6) || STREQ (name
, "REP")
5273 || STREQN (name
, "_parent", 7)
5274 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5277 /* True iff field number FIELD_NUM of structure or union type TYPE
5278 is a variant wrapper. Assumes TYPE is a structure type with at least
5279 FIELD_NUM+1 fields. */
5282 ada_is_variant_part (struct type
*type
, int field_num
)
5284 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5285 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5286 || (is_dynamic_field (type
, field_num
)
5287 && TYPE_CODE (TYPE_TARGET_TYPE (field_type
)) ==
5291 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5292 whose discriminants are contained in the record type OUTER_TYPE,
5293 returns the type of the controlling discriminant for the variant. */
5296 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5298 char *name
= ada_variant_discrim_name (var_type
);
5299 struct type
*type
= ada_lookup_struct_elt_type (outer_type
, name
, 1, NULL
);
5301 return builtin_type_int
;
5306 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5307 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5308 represents a 'when others' clause; otherwise 0. */
5311 ada_is_others_clause (struct type
*type
, int field_num
)
5313 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5314 return (name
!= NULL
&& name
[0] == 'O');
5317 /* Assuming that TYPE0 is the type of the variant part of a record,
5318 returns the name of the discriminant controlling the variant. The
5319 value is valid until the next call to ada_variant_discrim_name. */
5322 ada_variant_discrim_name (struct type
*type0
)
5324 static char *result
= NULL
;
5325 static size_t result_len
= 0;
5328 const char *discrim_end
;
5329 const char *discrim_start
;
5331 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5332 type
= TYPE_TARGET_TYPE (type0
);
5336 name
= ada_type_name (type
);
5338 if (name
== NULL
|| name
[0] == '\000')
5341 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5344 if (STREQN (discrim_end
, "___XVN", 6))
5347 if (discrim_end
== name
)
5350 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5353 if (discrim_start
== name
+ 1)
5355 if ((discrim_start
> name
+ 3 && STREQN (discrim_start
- 3, "___", 3))
5356 || discrim_start
[-1] == '.')
5360 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5361 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5362 result
[discrim_end
- discrim_start
] = '\0';
5366 /* Scan STR for a subtype-encoded number, beginning at position K. Put the
5367 position of the character just past the number scanned in *NEW_K,
5368 if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL. Return 1
5369 if there was a valid number at the given position, and 0 otherwise. A
5370 "subtype-encoded" number consists of the absolute value in decimal,
5371 followed by the letter 'm' to indicate a negative number. Assumes 0m
5375 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5379 if (!isdigit (str
[k
]))
5382 /* Do it the hard way so as not to make any assumption about
5383 the relationship of unsigned long (%lu scan format code) and
5386 while (isdigit (str
[k
]))
5388 RU
= RU
* 10 + (str
[k
] - '0');
5395 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5401 /* NOTE on the above: Technically, C does not say what the results of
5402 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5403 number representable as a LONGEST (although either would probably work
5404 in most implementations). When RU>0, the locution in the then branch
5405 above is always equivalent to the negative of RU. */
5412 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5413 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5414 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5417 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5419 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5432 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5441 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5442 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5444 if (val
>= L
&& val
<= U
)
5456 /* Given a value ARG1 (offset by OFFSET bytes)
5457 of a struct or union type ARG_TYPE,
5458 extract and return the value of one of its (non-static) fields.
5459 FIELDNO says which field. Differs from value_primitive_field only
5460 in that it can handle packed values of arbitrary type. */
5463 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5464 struct type
*arg_type
)
5469 CHECK_TYPEDEF (arg_type
);
5470 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5472 /* Handle packed fields */
5474 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5476 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5477 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5479 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
5480 offset
+ bit_pos
/ 8,
5481 bit_pos
% 8, bit_size
, type
);
5484 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5488 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5489 and search in it assuming it has (class) type TYPE.
5490 If found, return value, else return NULL.
5492 Searches recursively through wrapper fields (e.g., '_parent'). */
5495 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5499 CHECK_TYPEDEF (type
);
5501 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5503 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5505 if (t_field_name
== NULL
)
5508 else if (field_name_match (t_field_name
, name
))
5509 return ada_value_primitive_field (arg
, offset
, i
, type
);
5511 else if (ada_is_wrapper_field (type
, i
))
5513 struct value
*v
= ada_search_struct_field (name
, arg
,
5515 TYPE_FIELD_BITPOS (type
,
5518 TYPE_FIELD_TYPE (type
,
5524 else if (ada_is_variant_part (type
, i
))
5527 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5528 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5530 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5532 struct value
*v
= ada_search_struct_field (name
, arg
,
5536 (field_type
, j
) / 8,
5547 /* Given ARG, a value of type (pointer to a)* structure/union,
5548 extract the component named NAME from the ultimate target structure/union
5549 and return it as a value with its appropriate type.
5551 The routine searches for NAME among all members of the structure itself
5552 and (recursively) among all members of any wrapper members
5555 ERR is a name (for use in error messages) that identifies the class
5556 of entity that ARG is supposed to be. */
5559 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5564 arg
= ada_coerce_ref (arg
);
5565 t
= check_typedef (VALUE_TYPE (arg
));
5567 /* Follow pointers until we get to a non-pointer. */
5569 while (TYPE_CODE (t
) == TYPE_CODE_PTR
|| TYPE_CODE (t
) == TYPE_CODE_REF
)
5571 arg
= ada_value_ind (arg
);
5572 t
= check_typedef (VALUE_TYPE (arg
));
5575 if (TYPE_CODE (t
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t
) != TYPE_CODE_UNION
)
5576 error ("Attempt to extract a component of a value that is not a %s.",
5579 v
= ada_search_struct_field (name
, arg
, 0, t
);
5581 error ("There is no member named %s.", name
);
5586 /* Given a type TYPE, look up the type of the component of type named NAME.
5587 If DISPP is non-null, add its byte displacement from the beginning of a
5588 structure (pointed to by a value) of type TYPE to *DISPP (does not
5589 work for packed fields).
5591 Matches any field whose name has NAME as a prefix, possibly
5594 TYPE can be either a struct or union, or a pointer or reference to
5595 a struct or union. If it is a pointer or reference, its target
5596 type is automatically used.
5598 Looks recursively into variant clauses and parent types.
5600 If NOERR is nonzero, return NULL if NAME is not suitably defined. */
5603 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int noerr
,
5613 CHECK_TYPEDEF (type
);
5614 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5615 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5617 type
= TYPE_TARGET_TYPE (type
);
5620 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
&&
5621 TYPE_CODE (type
) != TYPE_CODE_UNION
)
5623 target_terminal_ours ();
5624 gdb_flush (gdb_stdout
);
5625 fprintf_unfiltered (gdb_stderr
, "Type ");
5626 type_print (type
, "", gdb_stderr
, -1);
5627 error (" is not a structure or union type");
5630 type
= to_static_fixed_type (type
);
5632 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5634 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5638 if (t_field_name
== NULL
)
5641 else if (field_name_match (t_field_name
, name
))
5644 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5645 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5648 else if (ada_is_wrapper_field (type
, i
))
5651 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5656 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5661 else if (ada_is_variant_part (type
, i
))
5664 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5666 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5669 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5674 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5685 target_terminal_ours ();
5686 gdb_flush (gdb_stdout
);
5687 fprintf_unfiltered (gdb_stderr
, "Type ");
5688 type_print (type
, "", gdb_stderr
, -1);
5689 fprintf_unfiltered (gdb_stderr
, " has no component named ");
5690 error ("%s", name
== NULL
? "<null>" : name
);
5696 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5697 within a value of type OUTER_TYPE that is stored in GDB at
5698 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5699 numbering from 0) is applicable. Returns -1 if none are. */
5702 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5703 char *outer_valaddr
)
5708 struct type
*discrim_type
;
5709 char *discrim_name
= ada_variant_discrim_name (var_type
);
5710 LONGEST discrim_val
;
5714 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, &disp
);
5715 if (discrim_type
== NULL
)
5717 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5720 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5722 if (ada_is_others_clause (var_type
, i
))
5724 else if (ada_in_variant (discrim_val
, var_type
, i
))
5728 return others_clause
;
5733 /* Dynamic-Sized Records */
5735 /* Strategy: The type ostensibly attached to a value with dynamic size
5736 (i.e., a size that is not statically recorded in the debugging
5737 data) does not accurately reflect the size or layout of the value.
5738 Our strategy is to convert these values to values with accurate,
5739 conventional types that are constructed on the fly. */
5741 /* There is a subtle and tricky problem here. In general, we cannot
5742 determine the size of dynamic records without its data. However,
5743 the 'struct value' data structure, which GDB uses to represent
5744 quantities in the inferior process (the target), requires the size
5745 of the type at the time of its allocation in order to reserve space
5746 for GDB's internal copy of the data. That's why the
5747 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5748 rather than struct value*s.
5750 However, GDB's internal history variables ($1, $2, etc.) are
5751 struct value*s containing internal copies of the data that are not, in
5752 general, the same as the data at their corresponding addresses in
5753 the target. Fortunately, the types we give to these values are all
5754 conventional, fixed-size types (as per the strategy described
5755 above), so that we don't usually have to perform the
5756 'to_fixed_xxx_type' conversions to look at their values.
5757 Unfortunately, there is one exception: if one of the internal
5758 history variables is an array whose elements are unconstrained
5759 records, then we will need to create distinct fixed types for each
5760 element selected. */
5762 /* The upshot of all of this is that many routines take a (type, host
5763 address, target address) triple as arguments to represent a value.
5764 The host address, if non-null, is supposed to contain an internal
5765 copy of the relevant data; otherwise, the program is to consult the
5766 target at the target address. */
5768 /* Assuming that VAL0 represents a pointer value, the result of
5769 dereferencing it. Differs from value_ind in its treatment of
5770 dynamic-sized types. */
5773 ada_value_ind (struct value
*val0
)
5775 struct value
*val
= unwrap_value (value_ind (val0
));
5776 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5777 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
), val
);
5780 /* The value resulting from dereferencing any "reference to"
5781 * qualifiers on VAL0. */
5782 static struct value
*
5783 ada_coerce_ref (struct value
*val0
)
5785 if (TYPE_CODE (VALUE_TYPE (val0
)) == TYPE_CODE_REF
)
5787 struct value
*val
= val0
;
5789 val
= unwrap_value (val
);
5790 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5791 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
5798 /* Return OFF rounded upward if necessary to a multiple of
5799 ALIGNMENT (a power of 2). */
5802 align_value (unsigned int off
, unsigned int alignment
)
5804 return (off
+ alignment
- 1) & ~(alignment
- 1);
5807 /* Return the additional bit offset required by field F of template
5811 field_offset (struct type
*type
, int f
)
5813 int n
= TYPE_FIELD_BITPOS (type
, f
);
5814 /* Kludge (temporary?) to fix problem with dwarf output. */
5816 return (unsigned int) n
& 0xffff;
5822 /* Return the bit alignment required for field #F of template type TYPE. */
5825 field_alignment (struct type
*type
, int f
)
5827 const char *name
= TYPE_FIELD_NAME (type
, f
);
5828 int len
= (name
== NULL
) ? 0 : strlen (name
);
5831 if (len
< 8 || !isdigit (name
[len
- 1]))
5832 return TARGET_CHAR_BIT
;
5834 if (isdigit (name
[len
- 2]))
5835 align_offset
= len
- 2;
5837 align_offset
= len
- 1;
5839 if (align_offset
< 7 || !STREQN ("___XV", name
+ align_offset
- 6, 5))
5840 return TARGET_CHAR_BIT
;
5842 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
5845 /* Find a type named NAME. Ignores ambiguity. */
5847 ada_find_any_type (const char *name
)
5851 sym
= standard_lookup (name
, VAR_NAMESPACE
);
5852 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5853 return SYMBOL_TYPE (sym
);
5855 sym
= standard_lookup (name
, STRUCT_NAMESPACE
);
5857 return SYMBOL_TYPE (sym
);
5862 /* Because of GNAT encoding conventions, several GDB symbols may match a
5863 given type name. If the type denoted by TYPE0 is to be preferred to
5864 that of TYPE1 for purposes of type printing, return non-zero;
5865 otherwise return 0. */
5867 ada_prefer_type (struct type
*type0
, struct type
*type1
)
5871 else if (type0
== NULL
)
5873 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
5875 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
5877 else if (ada_is_packed_array_type (type0
))
5879 else if (ada_is_array_descriptor (type0
)
5880 && !ada_is_array_descriptor (type1
))
5882 else if (ada_renaming_type (type0
) != NULL
5883 && ada_renaming_type (type1
) == NULL
)
5888 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5889 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5891 ada_type_name (struct type
*type
)
5895 else if (TYPE_NAME (type
) != NULL
)
5896 return TYPE_NAME (type
);
5898 return TYPE_TAG_NAME (type
);
5901 /* Find a parallel type to TYPE whose name is formed by appending
5902 SUFFIX to the name of TYPE. */
5905 ada_find_parallel_type (struct type
*type
, const char *suffix
)
5908 static size_t name_len
= 0;
5909 struct symbol
**syms
;
5910 struct block
**blocks
;
5913 char *typename
= ada_type_name (type
);
5915 if (typename
== NULL
)
5918 len
= strlen (typename
);
5920 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
5922 strcpy (name
, typename
);
5923 strcpy (name
+ len
, suffix
);
5925 return ada_find_any_type (name
);
5929 /* If TYPE is a variable-size record type, return the corresponding template
5930 type describing its fields. Otherwise, return NULL. */
5932 static struct type
*
5933 dynamic_template_type (struct type
*type
)
5935 CHECK_TYPEDEF (type
);
5937 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5938 || ada_type_name (type
) == NULL
)
5942 int len
= strlen (ada_type_name (type
));
5943 if (len
> 6 && STREQ (ada_type_name (type
) + len
- 6, "___XVE"))
5946 return ada_find_parallel_type (type
, "___XVE");
5950 /* Assuming that TEMPL_TYPE is a union or struct type, returns
5951 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
5954 is_dynamic_field (struct type
*templ_type
, int field_num
)
5956 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
5958 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
5959 && strstr (name
, "___XVL") != NULL
;
5962 /* Assuming that TYPE is a struct type, returns non-zero iff TYPE
5963 contains a variant part. */
5966 contains_variant_part (struct type
*type
)
5970 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5971 || TYPE_NFIELDS (type
) <= 0)
5973 return ada_is_variant_part (type
, TYPE_NFIELDS (type
) - 1);
5976 /* A record type with no fields, . */
5977 static struct type
*
5978 empty_record (struct objfile
*objfile
)
5980 struct type
*type
= alloc_type (objfile
);
5981 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
5982 TYPE_NFIELDS (type
) = 0;
5983 TYPE_FIELDS (type
) = NULL
;
5984 TYPE_NAME (type
) = "<empty>";
5985 TYPE_TAG_NAME (type
) = NULL
;
5986 TYPE_FLAGS (type
) = 0;
5987 TYPE_LENGTH (type
) = 0;
5991 /* An ordinary record type (with fixed-length fields) that describes
5992 the value of type TYPE at VALADDR or ADDRESS (see comments at
5993 the beginning of this section) VAL according to GNAT conventions.
5994 DVAL0 should describe the (portion of a) record that contains any
5995 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
5996 an outer-level type (i.e., as opposed to a branch of a variant.) A
5997 variant field (unless unchecked) is replaced by a particular branch
5999 /* NOTE: Limitations: For now, we assume that dynamic fields and
6000 * variants occupy whole numbers of bytes. However, they need not be
6003 static struct type
*
6004 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
6005 CORE_ADDR address
, struct value
*dval0
)
6007 struct value
*mark
= value_mark ();
6010 int nfields
, bit_len
;
6014 nfields
= TYPE_NFIELDS (type
);
6015 rtype
= alloc_type (TYPE_OBJFILE (type
));
6016 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6017 INIT_CPLUS_SPECIFIC (rtype
);
6018 TYPE_NFIELDS (rtype
) = nfields
;
6019 TYPE_FIELDS (rtype
) = (struct field
*)
6020 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6021 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6022 TYPE_NAME (rtype
) = ada_type_name (type
);
6023 TYPE_TAG_NAME (rtype
) = NULL
;
6024 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in
6026 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6030 for (f
= 0; f
< nfields
; f
+= 1)
6032 int fld_bit_len
, bit_incr
;
6035 field_alignment (type
, f
)) + TYPE_FIELD_BITPOS (type
, f
);
6036 /* NOTE: used to use field_offset above, but that causes
6037 * problems with really negative bit positions. So, let's
6038 * rediscover why we needed field_offset and fix it properly. */
6039 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6040 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6041 TYPE_FIELD_STATIC_KIND (rtype
, f
) = 0;
6043 if (ada_is_variant_part (type
, f
))
6045 struct type
*branch_type
;
6048 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6053 to_fixed_variant_branch_type
6054 (TYPE_FIELD_TYPE (type
, f
),
6055 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6056 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6057 if (branch_type
== NULL
)
6058 TYPE_NFIELDS (rtype
) -= 1;
6061 TYPE_FIELD_TYPE (rtype
, f
) = branch_type
;
6062 TYPE_FIELD_NAME (rtype
, f
) = "S";
6066 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6068 else if (is_dynamic_field (type
, f
))
6071 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6075 TYPE_FIELD_TYPE (rtype
, f
) =
6078 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6079 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6080 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6081 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6082 bit_incr
= fld_bit_len
=
6083 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6087 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6088 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6089 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6090 bit_incr
= fld_bit_len
=
6091 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6093 bit_incr
= fld_bit_len
=
6094 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6096 if (off
+ fld_bit_len
> bit_len
)
6097 bit_len
= off
+ fld_bit_len
;
6099 TYPE_LENGTH (rtype
) = bit_len
/ TARGET_CHAR_BIT
;
6101 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
), TYPE_LENGTH (type
));
6103 value_free_to_mark (mark
);
6104 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6105 error ("record type with dynamic size is larger than varsize-limit");
6109 /* As for template_to_fixed_record_type, but uses no run-time values.
6110 As a result, this type can only be approximate, but that's OK,
6111 since it is used only for type determinations. Works on both
6113 Representation note: to save space, we memoize the result of this
6114 function in the TYPE_TARGET_TYPE of the template type. */
6116 static struct type
*
6117 template_to_static_fixed_type (struct type
*templ_type
)
6123 if (TYPE_TARGET_TYPE (templ_type
) != NULL
)
6124 return TYPE_TARGET_TYPE (templ_type
);
6126 nfields
= TYPE_NFIELDS (templ_type
);
6127 TYPE_TARGET_TYPE (templ_type
) = type
=
6128 alloc_type (TYPE_OBJFILE (templ_type
));
6129 TYPE_CODE (type
) = TYPE_CODE (templ_type
);
6130 INIT_CPLUS_SPECIFIC (type
);
6131 TYPE_NFIELDS (type
) = nfields
;
6132 TYPE_FIELDS (type
) = (struct field
*)
6133 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6134 memset (TYPE_FIELDS (type
), 0, sizeof (struct field
) * nfields
);
6135 TYPE_NAME (type
) = ada_type_name (templ_type
);
6136 TYPE_TAG_NAME (type
) = NULL
;
6137 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6138 /* TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE; */
6139 TYPE_LENGTH (type
) = 0;
6141 for (f
= 0; f
< nfields
; f
+= 1)
6143 TYPE_FIELD_BITPOS (type
, f
) = 0;
6144 TYPE_FIELD_BITSIZE (type
, f
) = 0;
6145 TYPE_FIELD_STATIC_KIND (type
, f
) = 0;
6147 if (is_dynamic_field (templ_type
, f
))
6149 TYPE_FIELD_TYPE (type
, f
) =
6150 to_static_fixed_type (TYPE_TARGET_TYPE
6151 (TYPE_FIELD_TYPE (templ_type
, f
)));
6152 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6156 TYPE_FIELD_TYPE (type
, f
) =
6157 check_typedef (TYPE_FIELD_TYPE (templ_type
, f
));
6158 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6165 /* A revision of TYPE0 -- a non-dynamic-sized record with a variant
6166 part -- in which the variant part is replaced with the appropriate
6168 static struct type
*
6169 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
6170 CORE_ADDR address
, struct value
*dval
)
6172 struct value
*mark
= value_mark ();
6174 struct type
*branch_type
;
6175 int nfields
= TYPE_NFIELDS (type
);
6180 rtype
= alloc_type (TYPE_OBJFILE (type
));
6181 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6182 INIT_CPLUS_SPECIFIC (type
);
6183 TYPE_NFIELDS (rtype
) = TYPE_NFIELDS (type
);
6184 TYPE_FIELDS (rtype
) =
6185 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6186 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6187 sizeof (struct field
) * nfields
);
6188 TYPE_NAME (rtype
) = ada_type_name (type
);
6189 TYPE_TAG_NAME (rtype
) = NULL
;
6190 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6191 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6192 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6195 to_fixed_variant_branch_type
6196 (TYPE_FIELD_TYPE (type
, nfields
- 1),
6197 cond_offset_host (valaddr
,
6198 TYPE_FIELD_BITPOS (type
,
6199 nfields
- 1) / TARGET_CHAR_BIT
),
6200 cond_offset_target (address
,
6201 TYPE_FIELD_BITPOS (type
,
6202 nfields
- 1) / TARGET_CHAR_BIT
),
6204 if (branch_type
== NULL
)
6206 TYPE_NFIELDS (rtype
) -= 1;
6207 TYPE_LENGTH (rtype
) -=
6208 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6212 TYPE_FIELD_TYPE (rtype
, nfields
- 1) = branch_type
;
6213 TYPE_FIELD_NAME (rtype
, nfields
- 1) = "S";
6214 TYPE_FIELD_BITSIZE (rtype
, nfields
- 1) = 0;
6215 TYPE_FIELD_STATIC_KIND (rtype
, nfields
- 1) = 0;
6216 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6217 -TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6223 /* An ordinary record type (with fixed-length fields) that describes
6224 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6225 beginning of this section]. Any necessary discriminants' values
6226 should be in DVAL, a record value; it should be NULL if the object
6227 at ADDR itself contains any necessary discriminant values. A
6228 variant field (unless unchecked) is replaced by a particular branch
6231 static struct type
*
6232 to_fixed_record_type (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6235 struct type
*templ_type
;
6237 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6238 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6241 templ_type
= dynamic_template_type (type0
);
6243 if (templ_type
!= NULL
)
6244 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6245 else if (contains_variant_part (type0
))
6246 return to_record_with_fixed_variant_part (type0
, valaddr
, address
, dval
);
6249 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6250 /* TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE; */
6256 /* An ordinary record type (with fixed-length fields) that describes
6257 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6258 union type. Any necessary discriminants' values should be in DVAL,
6259 a record value. That is, this routine selects the appropriate
6260 branch of the union at ADDR according to the discriminant value
6261 indicated in the union's type name. */
6263 static struct type
*
6264 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
6265 CORE_ADDR address
, struct value
*dval
)
6268 struct type
*templ_type
;
6269 struct type
*var_type
;
6271 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6272 var_type
= TYPE_TARGET_TYPE (var_type0
);
6274 var_type
= var_type0
;
6276 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6278 if (templ_type
!= NULL
)
6279 var_type
= templ_type
;
6282 ada_which_variant_applies (var_type
,
6283 VALUE_TYPE (dval
), VALUE_CONTENTS (dval
));
6286 return empty_record (TYPE_OBJFILE (var_type
));
6287 else if (is_dynamic_field (var_type
, which
))
6289 to_fixed_record_type
6290 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6291 valaddr
, address
, dval
);
6292 else if (contains_variant_part (TYPE_FIELD_TYPE (var_type
, which
)))
6294 to_fixed_record_type
6295 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6297 return TYPE_FIELD_TYPE (var_type
, which
);
6300 /* Assuming that TYPE0 is an array type describing the type of a value
6301 at ADDR, and that DVAL describes a record containing any
6302 discriminants used in TYPE0, returns a type for the value that
6303 contains no dynamic components (that is, no components whose sizes
6304 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6305 true, gives an error message if the resulting type's size is over
6309 static struct type
*
6310 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6313 struct type
*index_type_desc
;
6314 struct type
*result
;
6316 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6317 /* if (ada_is_packed_array_type (type0) /* revisit? *//*
6318 || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
6321 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6322 if (index_type_desc
== NULL
)
6324 struct type
*elt_type0
= check_typedef (TYPE_TARGET_TYPE (type0
));
6325 /* NOTE: elt_type---the fixed version of elt_type0---should never
6326 * depend on the contents of the array in properly constructed
6327 * debugging data. */
6328 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6330 if (elt_type0
== elt_type
)
6333 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6334 elt_type
, TYPE_INDEX_TYPE (type0
));
6339 struct type
*elt_type0
;
6342 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6343 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6345 /* NOTE: result---the fixed version of elt_type0---should never
6346 * depend on the contents of the array in properly constructed
6347 * debugging data. */
6348 result
= ada_to_fixed_type (check_typedef (elt_type0
), 0, 0, dval
);
6349 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6351 struct type
*range_type
=
6352 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6353 dval
, TYPE_OBJFILE (type0
));
6354 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6355 result
, range_type
);
6357 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6358 error ("array type with dynamic size is larger than varsize-limit");
6361 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6362 /* TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE; */
6367 /* A standard type (containing no dynamically sized components)
6368 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6369 DVAL describes a record containing any discriminants used in TYPE0,
6370 and may be NULL if there are none. */
6373 ada_to_fixed_type (struct type
*type
, char *valaddr
, CORE_ADDR address
,
6376 CHECK_TYPEDEF (type
);
6377 switch (TYPE_CODE (type
))
6381 case TYPE_CODE_STRUCT
:
6382 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6383 case TYPE_CODE_ARRAY
:
6384 return to_fixed_array_type (type
, dval
, 0);
6385 case TYPE_CODE_UNION
:
6389 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6393 /* A standard (static-sized) type corresponding as well as possible to
6394 TYPE0, but based on no runtime data. */
6396 static struct type
*
6397 to_static_fixed_type (struct type
*type0
)
6404 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6405 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6408 CHECK_TYPEDEF (type0
);
6410 switch (TYPE_CODE (type0
))
6414 case TYPE_CODE_STRUCT
:
6415 type
= dynamic_template_type (type0
);
6417 return template_to_static_fixed_type (type
);
6419 case TYPE_CODE_UNION
:
6420 type
= ada_find_parallel_type (type0
, "___XVU");
6422 return template_to_static_fixed_type (type
);
6427 /* A static approximation of TYPE with all type wrappers removed. */
6428 static struct type
*
6429 static_unwrap_type (struct type
*type
)
6431 if (ada_is_aligner_type (type
))
6433 struct type
*type1
= TYPE_FIELD_TYPE (check_typedef (type
), 0);
6434 if (ada_type_name (type1
) == NULL
)
6435 TYPE_NAME (type1
) = ada_type_name (type
);
6437 return static_unwrap_type (type1
);
6441 struct type
*raw_real_type
= ada_get_base_type (type
);
6442 if (raw_real_type
== type
)
6445 return to_static_fixed_type (raw_real_type
);
6449 /* In some cases, incomplete and private types require
6450 cross-references that are not resolved as records (for example,
6452 type FooP is access Foo;
6454 type Foo is array ...;
6455 ). In these cases, since there is no mechanism for producing
6456 cross-references to such types, we instead substitute for FooP a
6457 stub enumeration type that is nowhere resolved, and whose tag is
6458 the name of the actual type. Call these types "non-record stubs". */
6460 /* A type equivalent to TYPE that is not a non-record stub, if one
6461 exists, otherwise TYPE. */
6463 ada_completed_type (struct type
*type
)
6465 CHECK_TYPEDEF (type
);
6466 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6467 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
6468 || TYPE_TAG_NAME (type
) == NULL
)
6472 char *name
= TYPE_TAG_NAME (type
);
6473 struct type
*type1
= ada_find_any_type (name
);
6474 return (type1
== NULL
) ? type
: type1
;
6478 /* A value representing the data at VALADDR/ADDRESS as described by
6479 type TYPE0, but with a standard (static-sized) type that correctly
6480 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6481 type, then return VAL0 [this feature is simply to avoid redundant
6482 creation of struct values]. */
6485 ada_to_fixed_value (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6488 struct type
*type
= ada_to_fixed_type (type0
, valaddr
, address
, NULL
);
6489 if (type
== type0
&& val0
!= NULL
)
6492 return value_from_contents_and_address (type
, valaddr
, address
);
6495 /* A value representing VAL, but with a standard (static-sized) type
6496 chosen to approximate the real type of VAL as well as possible, but
6497 without consulting any runtime values. For Ada dynamic-sized
6498 types, therefore, the type of the result is likely to be inaccurate. */
6501 ada_to_static_fixed_value (struct value
*val
)
6504 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val
)));
6505 if (type
== VALUE_TYPE (val
))
6508 return coerce_unspec_val_to_type (val
, 0, type
);
6517 /* Table mapping attribute numbers to names */
6518 /* NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h */
6520 static const char *attribute_names
[] = {
6537 ada_attribute_name (int n
)
6539 if (n
> 0 && n
< (int) ATR_END
)
6540 return attribute_names
[n
];
6542 return attribute_names
[0];
6545 /* Evaluate the 'POS attribute applied to ARG. */
6547 static struct value
*
6548 value_pos_atr (struct value
*arg
)
6550 struct type
*type
= VALUE_TYPE (arg
);
6552 if (!discrete_type_p (type
))
6553 error ("'POS only defined on discrete types");
6555 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6558 LONGEST v
= value_as_long (arg
);
6560 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6562 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6563 return value_from_longest (builtin_type_ada_int
, i
);
6565 error ("enumeration value is invalid: can't find 'POS");
6568 return value_from_longest (builtin_type_ada_int
, value_as_long (arg
));
6571 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6573 static struct value
*
6574 value_val_atr (struct type
*type
, struct value
*arg
)
6576 if (!discrete_type_p (type
))
6577 error ("'VAL only defined on discrete types");
6578 if (!integer_type_p (VALUE_TYPE (arg
)))
6579 error ("'VAL requires integral argument");
6581 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6583 long pos
= value_as_long (arg
);
6584 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6585 error ("argument to 'VAL out of range");
6586 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6589 return value_from_longest (type
, value_as_long (arg
));
6595 /* True if TYPE appears to be an Ada character type.
6596 * [At the moment, this is true only for Character and Wide_Character;
6597 * It is a heuristic test that could stand improvement]. */
6600 ada_is_character_type (struct type
*type
)
6602 const char *name
= ada_type_name (type
);
6605 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6606 || TYPE_CODE (type
) == TYPE_CODE_INT
6607 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6608 && (STREQ (name
, "character") || STREQ (name
, "wide_character")
6609 || STREQ (name
, "unsigned char"));
6612 /* True if TYPE appears to be an Ada string type. */
6615 ada_is_string_type (struct type
*type
)
6617 CHECK_TYPEDEF (type
);
6619 && TYPE_CODE (type
) != TYPE_CODE_PTR
6620 && (ada_is_simple_array (type
) || ada_is_array_descriptor (type
))
6621 && ada_array_arity (type
) == 1)
6623 struct type
*elttype
= ada_array_element_type (type
, 1);
6625 return ada_is_character_type (elttype
);
6632 /* True if TYPE is a struct type introduced by the compiler to force the
6633 alignment of a value. Such types have a single field with a
6634 distinctive name. */
6637 ada_is_aligner_type (struct type
*type
)
6639 CHECK_TYPEDEF (type
);
6640 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
6641 && TYPE_NFIELDS (type
) == 1
6642 && STREQ (TYPE_FIELD_NAME (type
, 0), "F"));
6645 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6646 the parallel type. */
6649 ada_get_base_type (struct type
*raw_type
)
6651 struct type
*real_type_namer
;
6652 struct type
*raw_real_type
;
6653 struct type
*real_type
;
6655 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
6658 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
6659 if (real_type_namer
== NULL
6660 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
6661 || TYPE_NFIELDS (real_type_namer
) != 1)
6664 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
6665 if (raw_real_type
== NULL
)
6668 return raw_real_type
;
6671 /* The type of value designated by TYPE, with all aligners removed. */
6674 ada_aligned_type (struct type
*type
)
6676 if (ada_is_aligner_type (type
))
6677 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
6679 return ada_get_base_type (type
);
6683 /* The address of the aligned value in an object at address VALADDR
6684 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6687 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
6689 if (ada_is_aligner_type (type
))
6690 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
6692 TYPE_FIELD_BITPOS (type
,
6693 0) / TARGET_CHAR_BIT
);
6698 /* The printed representation of an enumeration literal with encoded
6699 name NAME. The value is good to the next call of ada_enum_name. */
6701 ada_enum_name (const char *name
)
6707 if ((tmp
= strstr (name
, "__")) != NULL
)
6709 else if ((tmp
= strchr (name
, '.')) != NULL
)
6717 static char result
[16];
6719 if (name
[1] == 'U' || name
[1] == 'W')
6721 if (sscanf (name
+ 2, "%x", &v
) != 1)
6727 if (isascii (v
) && isprint (v
))
6728 sprintf (result
, "'%c'", v
);
6729 else if (name
[1] == 'U')
6730 sprintf (result
, "[\"%02x\"]", v
);
6732 sprintf (result
, "[\"%04x\"]", v
);
6740 static struct value
*
6741 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
6744 return (*exp
->language_defn
->evaluate_exp
) (expect_type
, exp
, pos
, noside
);
6747 /* Evaluate the subexpression of EXP starting at *POS as for
6748 evaluate_type, updating *POS to point just past the evaluated
6751 static struct value
*
6752 evaluate_subexp_type (struct expression
*exp
, int *pos
)
6754 return (*exp
->language_defn
->evaluate_exp
)
6755 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
6758 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6761 static struct value
*
6762 unwrap_value (struct value
*val
)
6764 struct type
*type
= check_typedef (VALUE_TYPE (val
));
6765 if (ada_is_aligner_type (type
))
6767 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
6768 NULL
, "internal structure");
6769 struct type
*val_type
= check_typedef (VALUE_TYPE (v
));
6770 if (ada_type_name (val_type
) == NULL
)
6771 TYPE_NAME (val_type
) = ada_type_name (type
);
6773 return unwrap_value (v
);
6777 struct type
*raw_real_type
=
6778 ada_completed_type (ada_get_base_type (type
));
6780 if (type
== raw_real_type
)
6784 coerce_unspec_val_to_type
6785 (val
, 0, ada_to_fixed_type (raw_real_type
, 0,
6786 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
6791 static struct value
*
6792 cast_to_fixed (struct type
*type
, struct value
*arg
)
6796 if (type
== VALUE_TYPE (arg
))
6798 else if (ada_is_fixed_point_type (VALUE_TYPE (arg
)))
6799 val
= ada_float_to_fixed (type
,
6800 ada_fixed_to_float (VALUE_TYPE (arg
),
6801 value_as_long (arg
)));
6805 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
6806 val
= ada_float_to_fixed (type
, argd
);
6809 return value_from_longest (type
, val
);
6812 static struct value
*
6813 cast_from_fixed_to_double (struct value
*arg
)
6815 DOUBLEST val
= ada_fixed_to_float (VALUE_TYPE (arg
),
6816 value_as_long (arg
));
6817 return value_from_double (builtin_type_double
, val
);
6820 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
6821 * return the converted value. */
6822 static struct value
*
6823 coerce_for_assign (struct type
*type
, struct value
*val
)
6825 struct type
*type2
= VALUE_TYPE (val
);
6829 CHECK_TYPEDEF (type2
);
6830 CHECK_TYPEDEF (type
);
6832 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
6833 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6835 val
= ada_value_ind (val
);
6836 type2
= VALUE_TYPE (val
);
6839 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
6840 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6842 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
6843 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
6844 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
6845 error ("Incompatible types in assignment");
6846 VALUE_TYPE (val
) = type
;
6852 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
6853 int *pos
, enum noside noside
)
6856 enum ada_attribute atr
;
6857 int tem
, tem2
, tem3
;
6859 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
6862 struct value
**argvec
;
6866 op
= exp
->elts
[pc
].opcode
;
6873 unwrap_value (evaluate_subexp_standard
6874 (expect_type
, exp
, pos
, noside
));
6878 type
= exp
->elts
[pc
+ 1].type
;
6879 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
6880 if (noside
== EVAL_SKIP
)
6882 if (type
!= check_typedef (VALUE_TYPE (arg1
)))
6884 if (ada_is_fixed_point_type (type
))
6885 arg1
= cast_to_fixed (type
, arg1
);
6886 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6887 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
6888 else if (VALUE_LVAL (arg1
) == lval_memory
)
6890 /* This is in case of the really obscure (and undocumented,
6891 but apparently expected) case of (Foo) Bar.all, where Bar
6892 is an integer constant and Foo is a dynamic-sized type.
6893 If we don't do this, ARG1 will simply be relabeled with
6895 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
6896 return value_zero (to_static_fixed_type (type
), not_lval
);
6899 (type
, 0, VALUE_ADDRESS (arg1
) + VALUE_OFFSET (arg1
), 0);
6902 arg1
= value_cast (type
, arg1
);
6906 /* FIXME: UNOP_QUAL should be defined in expression.h */
6909 type = exp->elts[pc + 1].type;
6910 return ada_evaluate_subexp (type, exp, pos, noside);
6913 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6914 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
6915 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
6917 if (binop_user_defined_p (op
, arg1
, arg2
))
6918 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6921 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6922 arg2
= cast_to_fixed (VALUE_TYPE (arg1
), arg2
);
6923 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6925 ("Fixed-point values must be assigned to fixed-point variables");
6927 arg2
= coerce_for_assign (VALUE_TYPE (arg1
), arg2
);
6928 return ada_value_assign (arg1
, arg2
);
6932 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6933 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6934 if (noside
== EVAL_SKIP
)
6936 if (binop_user_defined_p (op
, arg1
, arg2
))
6937 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6940 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6941 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6942 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6944 ("Operands of fixed-point addition must have the same type");
6945 return value_cast (VALUE_TYPE (arg1
), value_add (arg1
, arg2
));
6949 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6950 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6951 if (noside
== EVAL_SKIP
)
6953 if (binop_user_defined_p (op
, arg1
, arg2
))
6954 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6957 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6958 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6959 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6961 ("Operands of fixed-point subtraction must have the same type");
6962 return value_cast (VALUE_TYPE (arg1
), value_sub (arg1
, arg2
));
6967 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6968 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6969 if (noside
== EVAL_SKIP
)
6971 if (binop_user_defined_p (op
, arg1
, arg2
))
6972 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6974 if (noside
== EVAL_AVOID_SIDE_EFFECTS
6975 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
6976 return value_zero (VALUE_TYPE (arg1
), not_lval
);
6979 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6980 arg1
= cast_from_fixed_to_double (arg1
);
6981 if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6982 arg2
= cast_from_fixed_to_double (arg2
);
6983 return value_binop (arg1
, arg2
, op
);
6987 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6988 if (noside
== EVAL_SKIP
)
6990 if (unop_user_defined_p (op
, arg1
))
6991 return value_x_unop (arg1
, op
, EVAL_NORMAL
);
6992 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6993 return value_cast (VALUE_TYPE (arg1
), value_neg (arg1
));
6995 return value_neg (arg1
);
6997 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
6998 /* case OP_UNRESOLVED_VALUE:
6999 /* Only encountered when an unresolved symbol occurs in a
7000 context other than a function call, in which case, it is
7003 if (noside == EVAL_SKIP)
7006 error ("Unexpected unresolved symbol, %s, during evaluation",
7007 ada_demangle (exp->elts[pc + 2].name));
7011 if (noside
== EVAL_SKIP
)
7016 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7020 (to_static_fixed_type
7021 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
7027 unwrap_value (evaluate_subexp_standard
7028 (expect_type
, exp
, pos
, noside
));
7029 return ada_to_fixed_value (VALUE_TYPE (arg1
), 0,
7030 VALUE_ADDRESS (arg1
) +
7031 VALUE_OFFSET (arg1
), arg1
);
7036 tem2
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7037 tem3
= longest_to_int (exp
->elts
[pc
+ 2].longconst
);
7038 nargs
= tem3
- tem2
+ 1;
7039 type
= expect_type
? check_typedef (expect_type
) : NULL_TYPE
;
7042 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
7043 for (tem
= 0; tem
== 0 || tem
< nargs
; tem
+= 1)
7044 /* At least one element gets inserted for the type */
7046 /* Ensure that array expressions are coerced into pointer objects. */
7047 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
7049 if (noside
== EVAL_SKIP
)
7051 return value_array (tem2
, tem3
, argvec
);
7056 /* Allocate arg vector, including space for the function to be
7057 called in argvec[0] and a terminating NULL */
7058 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7060 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 2));
7062 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7063 /* FIXME: name should be defined in expresion.h */
7064 /* if (exp->elts[*pos].opcode == OP_UNRESOLVED_VALUE)
7065 error ("Unexpected unresolved symbol, %s, during evaluation",
7066 ada_demangle (exp->elts[pc + 5].name));
7070 error ("unexpected code path, FIXME");
7074 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7075 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7078 if (noside
== EVAL_SKIP
)
7082 if (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_REF
)
7083 argvec
[0] = value_addr (argvec
[0]);
7085 if (ada_is_packed_array_type (VALUE_TYPE (argvec
[0])))
7086 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7088 type
= check_typedef (VALUE_TYPE (argvec
[0]));
7089 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7091 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type
))))
7093 case TYPE_CODE_FUNC
:
7094 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7096 case TYPE_CODE_ARRAY
:
7098 case TYPE_CODE_STRUCT
:
7099 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7100 argvec
[0] = ada_value_ind (argvec
[0]);
7101 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7104 error ("cannot subscript or call something of type `%s'",
7105 ada_type_name (VALUE_TYPE (argvec
[0])));
7110 switch (TYPE_CODE (type
))
7112 case TYPE_CODE_FUNC
:
7113 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7114 return allocate_value (TYPE_TARGET_TYPE (type
));
7115 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7116 case TYPE_CODE_STRUCT
:
7118 int arity
= ada_array_arity (type
);
7119 type
= ada_array_element_type (type
, nargs
);
7121 error ("cannot subscript or call a record");
7123 error ("wrong number of subscripts; expecting %d", arity
);
7124 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7125 return allocate_value (ada_aligned_type (type
));
7127 unwrap_value (ada_value_subscript
7128 (argvec
[0], nargs
, argvec
+ 1));
7130 case TYPE_CODE_ARRAY
:
7131 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7133 type
= ada_array_element_type (type
, nargs
);
7135 error ("element type of array unknown");
7137 return allocate_value (ada_aligned_type (type
));
7140 unwrap_value (ada_value_subscript
7141 (ada_coerce_to_simple_array (argvec
[0]),
7142 nargs
, argvec
+ 1));
7143 case TYPE_CODE_PTR
: /* Pointer to array */
7144 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7145 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7147 type
= ada_array_element_type (type
, nargs
);
7149 error ("element type of array unknown");
7151 return allocate_value (ada_aligned_type (type
));
7154 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7155 nargs
, argvec
+ 1));
7158 error ("Internal error in evaluate_subexp");
7163 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7165 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7167 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7168 if (noside
== EVAL_SKIP
)
7171 /* If this is a reference to an array, then dereference it */
7172 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
7173 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7174 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7176 && !ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7178 array
= ada_coerce_ref (array
);
7181 if (noside
== EVAL_AVOID_SIDE_EFFECTS
&&
7182 ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7184 /* Try to dereference the array, in case it is an access to array */
7185 struct type
*arrType
= ada_type_of_array (array
, 0);
7186 if (arrType
!= NULL
)
7187 array
= value_at_lazy (arrType
, 0, NULL
);
7189 if (ada_is_array_descriptor (VALUE_TYPE (array
)))
7190 array
= ada_coerce_to_simple_array (array
);
7192 /* If at this point we have a pointer to an array, it means that
7193 it is a pointer to a simple (non-ada) array. We just then
7195 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
7196 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7197 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7200 array
= ada_value_ind (array
);
7203 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7204 /* The following will get the bounds wrong, but only in contexts
7205 where the value is not being requested (FIXME?). */
7208 return value_slice (array
, lowbound
, upper
- lowbound
+ 1);
7211 /* FIXME: UNOP_MBR should be defined in expression.h */
7214 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7215 type = exp->elts[pc + 1].type;
7217 if (noside == EVAL_SKIP)
7220 switch (TYPE_CODE (type))
7223 warning ("Membership test incompletely implemented; always returns true");
7224 return value_from_longest (builtin_type_int, (LONGEST) 1);
7226 case TYPE_CODE_RANGE:
7227 arg2 = value_from_longest (builtin_type_int,
7228 (LONGEST) TYPE_LOW_BOUND (type));
7229 arg3 = value_from_longest (builtin_type_int,
7230 (LONGEST) TYPE_HIGH_BOUND (type));
7232 value_from_longest (builtin_type_int,
7233 (value_less (arg1,arg3)
7234 || value_equal (arg1,arg3))
7235 && (value_less (arg2,arg1)
7236 || value_equal (arg2,arg1)));
7239 /* FIXME: BINOP_MBR should be defined in expression.h */
7242 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7243 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7245 if (noside == EVAL_SKIP)
7248 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7249 return value_zero (builtin_type_int, not_lval);
7251 tem = longest_to_int (exp->elts[pc + 1].longconst);
7253 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
7254 error ("invalid dimension number to '%s", "range");
7256 arg3 = ada_array_bound (arg2, tem, 1);
7257 arg2 = ada_array_bound (arg2, tem, 0);
7260 value_from_longest (builtin_type_int,
7261 (value_less (arg1,arg3)
7262 || value_equal (arg1,arg3))
7263 && (value_less (arg2,arg1)
7264 || value_equal (arg2,arg1)));
7266 /* FIXME: TERNOP_MBR should be defined in expression.h */
7268 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7269 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7270 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7272 if (noside == EVAL_SKIP)
7276 value_from_longest (builtin_type_int,
7277 (value_less (arg1,arg3)
7278 || value_equal (arg1,arg3))
7279 && (value_less (arg2,arg1)
7280 || value_equal (arg2,arg1)));
7282 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
7283 /* case OP_ATTRIBUTE:
7285 atr = (enum ada_attribute) longest_to_int (exp->elts[pc + 2].longconst);
7289 error ("unexpected attribute encountered");
7295 struct type* type_arg;
7296 if (exp->elts[*pos].opcode == OP_TYPE)
7298 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7300 type_arg = exp->elts[pc + 5].type;
7304 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7308 if (exp->elts[*pos].opcode != OP_LONG)
7309 error ("illegal operand to '%s", ada_attribute_name (atr));
7310 tem = longest_to_int (exp->elts[*pos+2].longconst);
7313 if (noside == EVAL_SKIP)
7316 if (type_arg == NULL)
7318 arg1 = ada_coerce_ref (arg1);
7320 if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
7321 arg1 = ada_coerce_to_simple_array (arg1);
7323 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
7324 error ("invalid dimension number to '%s",
7325 ada_attribute_name (atr));
7327 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7329 type = ada_index_type (VALUE_TYPE (arg1), tem);
7331 error ("attempt to take bound of something that is not an array");
7332 return allocate_value (type);
7338 error ("unexpected attribute encountered");
7340 return ada_array_bound (arg1, tem, 0);
7342 return ada_array_bound (arg1, tem, 1);
7344 return ada_array_length (arg1, tem);
7347 else if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE
7348 || TYPE_CODE (type_arg) == TYPE_CODE_INT)
7350 struct type* range_type;
7351 char* name = ada_type_name (type_arg);
7354 if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE)
7355 range_type = type_arg;
7357 error ("unimplemented type attribute");
7361 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
7365 error ("unexpected attribute encountered");
7367 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7368 TYPE_LOW_BOUND (range_type));
7370 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7371 TYPE_HIGH_BOUND (range_type));
7374 else if (TYPE_CODE (type_arg) == TYPE_CODE_ENUM)
7379 error ("unexpected attribute encountered");
7381 return value_from_longest
7382 (type_arg, TYPE_FIELD_BITPOS (type_arg, 0));
7384 return value_from_longest
7386 TYPE_FIELD_BITPOS (type_arg,
7387 TYPE_NFIELDS (type_arg) - 1));
7390 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
7391 error ("unimplemented type attribute");
7396 if (ada_is_packed_array_type (type_arg))
7397 type_arg = decode_packed_array_type (type_arg);
7399 if (tem < 1 || tem > ada_array_arity (type_arg))
7400 error ("invalid dimension number to '%s",
7401 ada_attribute_name (atr));
7403 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7405 type = ada_index_type (type_arg, tem);
7407 error ("attempt to take bound of something that is not an array");
7408 return allocate_value (type);
7414 error ("unexpected attribute encountered");
7416 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7417 return value_from_longest (type, low);
7419 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
7420 return value_from_longest (type, high);
7422 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7423 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
7424 return value_from_longest (type, high-low+1);
7430 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7431 if (noside == EVAL_SKIP)
7434 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7436 value_zero (ada_tag_type (arg1), not_lval);
7438 return ada_value_tag (arg1);
7442 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7443 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7444 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7445 if (noside == EVAL_SKIP)
7447 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7448 return value_zero (VALUE_TYPE (arg1), not_lval);
7450 return value_binop (arg1, arg2,
7451 atr == ATR_MIN ? BINOP_MIN : BINOP_MAX);
7455 struct type* type_arg = exp->elts[pc + 5].type;
7456 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7459 if (noside == EVAL_SKIP)
7462 if (! ada_is_modular_type (type_arg))
7463 error ("'modulus must be applied to modular type");
7465 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
7466 ada_modulus (type_arg));
7471 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7472 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7473 if (noside == EVAL_SKIP)
7475 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7476 return value_zero (builtin_type_ada_int, not_lval);
7478 return value_pos_atr (arg1);
7481 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7482 if (noside == EVAL_SKIP)
7484 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7485 return value_zero (builtin_type_ada_int, not_lval);
7487 return value_from_longest (builtin_type_ada_int,
7489 * TYPE_LENGTH (VALUE_TYPE (arg1)));
7492 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7493 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7494 type = exp->elts[pc + 5].type;
7495 if (noside == EVAL_SKIP)
7497 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7498 return value_zero (type, not_lval);
7500 return value_val_atr (type, arg1);
7503 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7504 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7505 if (noside
== EVAL_SKIP
)
7507 if (binop_user_defined_p (op
, arg1
, arg2
))
7508 return unwrap_value (value_x_binop (arg1
, arg2
, op
, OP_NULL
,
7510 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7511 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7513 return value_binop (arg1
, arg2
, op
);
7516 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7517 if (noside
== EVAL_SKIP
)
7519 if (unop_user_defined_p (op
, arg1
))
7520 return unwrap_value (value_x_unop (arg1
, op
, EVAL_NORMAL
));
7525 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7526 if (noside
== EVAL_SKIP
)
7528 if (value_less (arg1
, value_zero (VALUE_TYPE (arg1
), not_lval
)))
7529 return value_neg (arg1
);
7534 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
7535 expect_type
= TYPE_TARGET_TYPE (check_typedef (expect_type
));
7536 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
7537 if (noside
== EVAL_SKIP
)
7539 type
= check_typedef (VALUE_TYPE (arg1
));
7540 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7542 if (ada_is_array_descriptor (type
))
7543 /* GDB allows dereferencing GNAT array descriptors. */
7545 struct type
*arrType
= ada_type_of_array (arg1
, 0);
7546 if (arrType
== NULL
)
7547 error ("Attempt to dereference null array pointer.");
7548 return value_at_lazy (arrType
, 0, NULL
);
7550 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
7551 || TYPE_CODE (type
) == TYPE_CODE_REF
7552 /* In C you can dereference an array to get the 1st elt. */
7553 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7556 (to_static_fixed_type
7557 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type
)))),
7559 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
7560 /* GDB allows dereferencing an int. */
7561 return value_zero (builtin_type_int
, lval_memory
);
7563 error ("Attempt to take contents of a non-pointer value.");
7565 arg1
= ada_coerce_ref (arg1
);
7566 type
= check_typedef (VALUE_TYPE (arg1
));
7568 if (ada_is_array_descriptor (type
))
7569 /* GDB allows dereferencing GNAT array descriptors. */
7570 return ada_coerce_to_simple_array (arg1
);
7572 return ada_value_ind (arg1
);
7574 case STRUCTOP_STRUCT
:
7575 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7576 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7577 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7578 if (noside
== EVAL_SKIP
)
7580 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7581 return value_zero (ada_aligned_type
7582 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7588 return unwrap_value (ada_value_struct_elt (arg1
,
7589 &exp
->elts
[pc
+ 2].string
,
7592 /* The value is not supposed to be used. This is here to make it
7593 easier to accommodate expressions that contain types. */
7595 if (noside
== EVAL_SKIP
)
7597 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7598 return allocate_value (builtin_type_void
);
7600 error ("Attempt to use a type name as an expression");
7603 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7604 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7605 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7606 if (noside
== EVAL_SKIP
)
7608 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7609 return value_zero (ada_aligned_type
7610 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7616 return unwrap_value (ada_value_struct_elt (arg1
,
7617 &exp
->elts
[pc
+ 2].string
,
7622 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
7628 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7629 type name that encodes the 'small and 'delta information.
7630 Otherwise, return NULL. */
7633 fixed_type_info (struct type
*type
)
7635 const char *name
= ada_type_name (type
);
7636 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
7638 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
7640 const char *tail
= strstr (name
, "___XF_");
7646 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
7647 return fixed_type_info (TYPE_TARGET_TYPE (type
));
7652 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7655 ada_is_fixed_point_type (struct type
*type
)
7657 return fixed_type_info (type
) != NULL
;
7660 /* Assuming that TYPE is the representation of an Ada fixed-point
7661 type, return its delta, or -1 if the type is malformed and the
7662 delta cannot be determined. */
7665 ada_delta (struct type
*type
)
7667 const char *encoding
= fixed_type_info (type
);
7670 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
7673 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
7676 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7677 factor ('SMALL value) associated with the type. */
7680 scaling_factor (struct type
*type
)
7682 const char *encoding
= fixed_type_info (type
);
7683 unsigned long num0
, den0
, num1
, den1
;
7686 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
7691 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
7693 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
7697 /* Assuming that X is the representation of a value of fixed-point
7698 type TYPE, return its floating-point equivalent. */
7701 ada_fixed_to_float (struct type
*type
, LONGEST x
)
7703 return (DOUBLEST
) x
*scaling_factor (type
);
7706 /* The representation of a fixed-point value of type TYPE
7707 corresponding to the value X. */
7710 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
7712 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
7716 /* VAX floating formats */
7718 /* Non-zero iff TYPE represents one of the special VAX floating-point
7721 ada_is_vax_floating_type (struct type
*type
)
7724 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
7727 && (TYPE_CODE (type
) == TYPE_CODE_INT
7728 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7729 && STREQN (ada_type_name (type
) + name_len
- 6, "___XF", 5);
7732 /* The type of special VAX floating-point type this is, assuming
7733 ada_is_vax_floating_point */
7735 ada_vax_float_type_suffix (struct type
*type
)
7737 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
7740 /* A value representing the special debugging function that outputs
7741 VAX floating-point values of the type represented by TYPE. Assumes
7742 ada_is_vax_floating_type (TYPE). */
7744 ada_vax_float_print_function (struct type
*type
)
7746 switch (ada_vax_float_type_suffix (type
))
7749 return get_var_value ("DEBUG_STRING_F", 0);
7751 return get_var_value ("DEBUG_STRING_D", 0);
7753 return get_var_value ("DEBUG_STRING_G", 0);
7755 error ("invalid VAX floating-point type");
7762 /* Scan STR beginning at position K for a discriminant name, and
7763 return the value of that discriminant field of DVAL in *PX. If
7764 PNEW_K is not null, put the position of the character beyond the
7765 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
7766 not alter *PX and *PNEW_K if unsuccessful. */
7769 scan_discrim_bound (char *, int k
, struct value
*dval
, LONGEST
* px
,
7772 static char *bound_buffer
= NULL
;
7773 static size_t bound_buffer_len
= 0;
7776 struct value
*bound_val
;
7778 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
7781 pend
= strstr (str
+ k
, "__");
7785 k
+= strlen (bound
);
7789 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
7790 bound
= bound_buffer
;
7791 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
7792 bound
[pend
- (str
+ k
)] = '\0';
7796 bound_val
= ada_search_struct_field (bound
, dval
, 0, VALUE_TYPE (dval
));
7797 if (bound_val
== NULL
)
7800 *px
= value_as_long (bound_val
);
7806 /* Value of variable named NAME in the current environment. If
7807 no such variable found, then if ERR_MSG is null, returns 0, and
7808 otherwise causes an error with message ERR_MSG. */
7809 static struct value
*
7810 get_var_value (char *name
, char *err_msg
)
7812 struct symbol
**syms
;
7813 struct block
**blocks
;
7817 ada_lookup_symbol_list (name
, get_selected_block (NULL
), VAR_NAMESPACE
,
7822 if (err_msg
== NULL
)
7825 error ("%s", err_msg
);
7828 return value_of_variable (syms
[0], blocks
[0]);
7831 /* Value of integer variable named NAME in the current environment. If
7832 no such variable found, then if ERR_MSG is null, returns 0, and sets
7833 *FLAG to 0. If successful, sets *FLAG to 1. */
7835 get_int_var_value (char *name
, char *err_msg
, int *flag
)
7837 struct value
*var_val
= get_var_value (name
, err_msg
);
7849 return value_as_long (var_val
);
7854 /* Return a range type whose base type is that of the range type named
7855 NAME in the current environment, and whose bounds are calculated
7856 from NAME according to the GNAT range encoding conventions.
7857 Extract discriminant values, if needed, from DVAL. If a new type
7858 must be created, allocate in OBJFILE's space. The bounds
7859 information, in general, is encoded in NAME, the base type given in
7860 the named range type. */
7862 static struct type
*
7863 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
7865 struct type
*raw_type
= ada_find_any_type (name
);
7866 struct type
*base_type
;
7870 if (raw_type
== NULL
)
7871 base_type
= builtin_type_int
;
7872 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
7873 base_type
= TYPE_TARGET_TYPE (raw_type
);
7875 base_type
= raw_type
;
7877 subtype_info
= strstr (name
, "___XD");
7878 if (subtype_info
== NULL
)
7882 static char *name_buf
= NULL
;
7883 static size_t name_len
= 0;
7884 int prefix_len
= subtype_info
- name
;
7890 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
7891 strncpy (name_buf
, name
, prefix_len
);
7892 name_buf
[prefix_len
] = '\0';
7895 bounds_str
= strchr (subtype_info
, '_');
7898 if (*subtype_info
== 'L')
7900 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
7901 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
7903 if (bounds_str
[n
] == '_')
7905 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
7911 strcpy (name_buf
+ prefix_len
, "___L");
7912 L
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7915 if (*subtype_info
== 'U')
7917 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
7918 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
7923 strcpy (name_buf
+ prefix_len
, "___U");
7924 U
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7927 if (objfile
== NULL
)
7928 objfile
= TYPE_OBJFILE (base_type
);
7929 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
7930 TYPE_NAME (type
) = name
;
7935 /* True iff NAME is the name of a range type. */
7937 ada_is_range_type_name (const char *name
)
7939 return (name
!= NULL
&& strstr (name
, "___XD"));
7945 /* True iff TYPE is an Ada modular type. */
7947 ada_is_modular_type (struct type
*type
)
7949 /* FIXME: base_type should be declared in gdbtypes.h, implemented in
7951 struct type
*subranged_type
; /* = base_type (type); */
7953 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
7954 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
7955 && TYPE_UNSIGNED (subranged_type
));
7958 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
7960 ada_modulus (struct type
* type
)
7962 return TYPE_HIGH_BOUND (type
) + 1;
7969 /* Table mapping opcodes into strings for printing operators
7970 and precedences of the operators. */
7972 static const struct op_print ada_op_print_tab
[] = {
7973 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
7974 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
7975 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
7976 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
7977 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
7978 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
7979 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
7980 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
7981 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
7982 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
7983 {">", BINOP_GTR
, PREC_ORDER
, 0},
7984 {"<", BINOP_LESS
, PREC_ORDER
, 0},
7985 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
7986 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
7987 {"+", BINOP_ADD
, PREC_ADD
, 0},
7988 {"-", BINOP_SUB
, PREC_ADD
, 0},
7989 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
7990 {"*", BINOP_MUL
, PREC_MUL
, 0},
7991 {"/", BINOP_DIV
, PREC_MUL
, 0},
7992 {"rem", BINOP_REM
, PREC_MUL
, 0},
7993 {"mod", BINOP_MOD
, PREC_MUL
, 0},
7994 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
7995 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
7996 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
7997 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
7998 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
7999 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
8000 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
8001 {".all", UNOP_IND
, PREC_SUFFIX
, 1}, /* FIXME: postfix .ALL */
8002 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1}, /* FIXME: postfix 'ACCESS */
8006 /* Assorted Types and Interfaces */
8008 struct type
*builtin_type_ada_int
;
8009 struct type
*builtin_type_ada_short
;
8010 struct type
*builtin_type_ada_long
;
8011 struct type
*builtin_type_ada_long_long
;
8012 struct type
*builtin_type_ada_char
;
8013 struct type
*builtin_type_ada_float
;
8014 struct type
*builtin_type_ada_double
;
8015 struct type
*builtin_type_ada_long_double
;
8016 struct type
*builtin_type_ada_natural
;
8017 struct type
*builtin_type_ada_positive
;
8018 struct type
*builtin_type_ada_system_address
;
8020 struct type
**const (ada_builtin_types
[]) =
8023 &builtin_type_ada_int
,
8024 &builtin_type_ada_long
,
8025 &builtin_type_ada_short
,
8026 &builtin_type_ada_char
,
8027 &builtin_type_ada_float
,
8028 &builtin_type_ada_double
,
8029 &builtin_type_ada_long_long
,
8030 &builtin_type_ada_long_double
,
8031 &builtin_type_ada_natural
, &builtin_type_ada_positive
,
8032 /* The following types are carried over from C for convenience. */
8035 &builtin_type_short
,
8037 &builtin_type_float
,
8038 &builtin_type_double
,
8039 &builtin_type_long_long
,
8041 &builtin_type_signed_char
,
8042 &builtin_type_unsigned_char
,
8043 &builtin_type_unsigned_short
,
8044 &builtin_type_unsigned_int
,
8045 &builtin_type_unsigned_long
,
8046 &builtin_type_unsigned_long_long
,
8047 &builtin_type_long_double
,
8048 &builtin_type_complex
, &builtin_type_double_complex
, 0};
8050 /* Not really used, but needed in the ada_language_defn. */
8052 emit_char (int c
, struct ui_file
*stream
, int quoter
)
8054 ada_emit_char (c
, stream
, quoter
, 1);
8057 const struct language_defn ada_language_defn
= {
8058 "ada", /* Language name */
8061 /* FIXME: language_ada should be defined in defs.h */
8065 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8066 * that's not quite what this means. */
8069 ada_evaluate_subexp
,
8070 ada_printchar
, /* Print a character constant */
8071 ada_printstr
, /* Function to print string constant */
8072 emit_char
, /* Function to print single char (not used) */
8073 ada_create_fundamental_type
, /* Create fundamental type in this language */
8074 ada_print_type
, /* Print a type using appropriate syntax */
8075 ada_val_print
, /* Print a value using appropriate syntax */
8076 ada_value_print
, /* Print a top-level value */
8077 {"", "", "", ""}, /* Binary format info */
8079 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
8080 {"%ld", "", "d", ""}, /* Decimal format info */
8081 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
8083 /* Copied from c-lang.c. */
8084 {"0%lo", "0", "o", ""}, /* Octal format info */
8085 {"%ld", "", "d", ""}, /* Decimal format info */
8086 {"0x%lx", "0x", "x", ""}, /* Hex format info */
8088 ada_op_print_tab
, /* expression operators for printing */
8089 1, /* c-style arrays (FIXME?) */
8090 0, /* String lower bound (FIXME?) */
8091 &builtin_type_ada_char
,
8096 _initialize_ada_language (void)
8098 builtin_type_ada_int
=
8099 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8100 0, "integer", (struct objfile
*) NULL
);
8101 builtin_type_ada_long
=
8102 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8103 0, "long_integer", (struct objfile
*) NULL
);
8104 builtin_type_ada_short
=
8105 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8106 0, "short_integer", (struct objfile
*) NULL
);
8107 builtin_type_ada_char
=
8108 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8109 0, "character", (struct objfile
*) NULL
);
8110 builtin_type_ada_float
=
8111 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8112 0, "float", (struct objfile
*) NULL
);
8113 builtin_type_ada_double
=
8114 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8115 0, "long_float", (struct objfile
*) NULL
);
8116 builtin_type_ada_long_long
=
8117 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8118 0, "long_long_integer", (struct objfile
*) NULL
);
8119 builtin_type_ada_long_double
=
8120 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8121 0, "long_long_float", (struct objfile
*) NULL
);
8122 builtin_type_ada_natural
=
8123 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8124 0, "natural", (struct objfile
*) NULL
);
8125 builtin_type_ada_positive
=
8126 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8127 0, "positive", (struct objfile
*) NULL
);
8130 builtin_type_ada_system_address
=
8131 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8132 (struct objfile
*) NULL
));
8133 TYPE_NAME (builtin_type_ada_system_address
) = "system__address";
8135 add_language (&ada_language_defn
);
8138 (add_set_cmd ("varsize-limit", class_support
, var_uinteger
,
8139 (char *) &varsize_limit
,
8140 "Set maximum bytes in dynamic-sized object.",
8141 &setlist
), &showlist
);
8142 varsize_limit
= 65536;
8144 add_com ("begin", class_breakpoint
, begin_command
,
8145 "Start the debugged program, stopping at the beginning of the\n\
8146 main program. You may specify command-line arguments to give it, as for\n\
8147 the \"run\" command (q.v.).");
8151 /* Create a fundamental Ada type using default reasonable for the current
8154 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8155 define fundamental types such as "int" or "double". Others (stabs or
8156 DWARF version 2, etc) do define fundamental types. For the formats which
8157 don't provide fundamental types, gdb can create such types using this
8160 FIXME: Some compilers distinguish explicitly signed integral types
8161 (signed short, signed int, signed long) from "regular" integral types
8162 (short, int, long) in the debugging information. There is some dis-
8163 agreement as to how useful this feature is. In particular, gcc does
8164 not support this. Also, only some debugging formats allow the
8165 distinction to be passed on to a debugger. For now, we always just
8166 use "short", "int", or "long" as the type name, for both the implicit
8167 and explicitly signed types. This also makes life easier for the
8168 gdb test suite since we don't have to account for the differences
8169 in output depending upon what the compiler and debugging format
8170 support. We will probably have to re-examine the issue when gdb
8171 starts taking it's fundamental type information directly from the
8172 debugging information supplied by the compiler. fnf@cygnus.com */
8174 static struct type
*
8175 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8177 struct type
*type
= NULL
;
8182 /* FIXME: For now, if we are asked to produce a type not in this
8183 language, create the equivalent of a C integer type with the
8184 name "<?type?>". When all the dust settles from the type
8185 reconstruction work, this should probably become an error. */
8186 type
= init_type (TYPE_CODE_INT
,
8187 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8188 0, "<?type?>", objfile
);
8189 warning ("internal error: no Ada fundamental type %d", typeid);
8192 type
= init_type (TYPE_CODE_VOID
,
8193 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8194 0, "void", objfile
);
8197 type
= init_type (TYPE_CODE_INT
,
8198 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8199 0, "character", objfile
);
8201 case FT_SIGNED_CHAR
:
8202 type
= init_type (TYPE_CODE_INT
,
8203 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8204 0, "signed char", objfile
);
8206 case FT_UNSIGNED_CHAR
:
8207 type
= init_type (TYPE_CODE_INT
,
8208 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8209 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8212 type
= init_type (TYPE_CODE_INT
,
8213 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8214 0, "short_integer", objfile
);
8216 case FT_SIGNED_SHORT
:
8217 type
= init_type (TYPE_CODE_INT
,
8218 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8219 0, "short_integer", objfile
);
8221 case FT_UNSIGNED_SHORT
:
8222 type
= init_type (TYPE_CODE_INT
,
8223 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8224 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8227 type
= init_type (TYPE_CODE_INT
,
8228 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8229 0, "integer", objfile
);
8231 case FT_SIGNED_INTEGER
:
8232 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
, 0, "integer", objfile
); /* FIXME -fnf */
8234 case FT_UNSIGNED_INTEGER
:
8235 type
= init_type (TYPE_CODE_INT
,
8236 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8237 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8240 type
= init_type (TYPE_CODE_INT
,
8241 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8242 0, "long_integer", objfile
);
8244 case FT_SIGNED_LONG
:
8245 type
= init_type (TYPE_CODE_INT
,
8246 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8247 0, "long_integer", objfile
);
8249 case FT_UNSIGNED_LONG
:
8250 type
= init_type (TYPE_CODE_INT
,
8251 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8252 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8255 type
= init_type (TYPE_CODE_INT
,
8256 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8257 0, "long_long_integer", objfile
);
8259 case FT_SIGNED_LONG_LONG
:
8260 type
= init_type (TYPE_CODE_INT
,
8261 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8262 0, "long_long_integer", objfile
);
8264 case FT_UNSIGNED_LONG_LONG
:
8265 type
= init_type (TYPE_CODE_INT
,
8266 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8267 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8270 type
= init_type (TYPE_CODE_FLT
,
8271 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8272 0, "float", objfile
);
8274 case FT_DBL_PREC_FLOAT
:
8275 type
= init_type (TYPE_CODE_FLT
,
8276 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8277 0, "long_float", objfile
);
8279 case FT_EXT_PREC_FLOAT
:
8280 type
= init_type (TYPE_CODE_FLT
,
8281 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8282 0, "long_long_float", objfile
);
8289 ada_dump_symtab (struct symtab
*s
)
8292 fprintf (stderr
, "New symtab: [\n");
8293 fprintf (stderr
, " Name: %s/%s;\n",
8294 s
->dirname
? s
->dirname
: "?", s
->filename
? s
->filename
: "?");
8295 fprintf (stderr
, " Format: %s;\n", s
->debugformat
);
8296 if (s
->linetable
!= NULL
)
8298 fprintf (stderr
, " Line table (section %d):\n", s
->block_line_section
);
8299 for (i
= 0; i
< s
->linetable
->nitems
; i
+= 1)
8301 struct linetable_entry
*e
= s
->linetable
->item
+ i
;
8302 fprintf (stderr
, " %4ld: %8lx\n", (long) e
->line
, (long) e
->pc
);
8305 fprintf (stderr
, "]\n");