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
= 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 /* If fi is not the innermost frame, that normally means that fi->pc
5036 points to *after* the call instruction, and we want to get the line
5037 containing the call, never the next line. But if the next frame is
5038 a signal_handler_caller or a dummy frame, then the next frame was
5039 not entered as the result of a call, and we want to get the line
5040 containing fi->pc. */
5042 find_pc_line (fi
->pc
,
5044 && !fi
->next
->signal_handler_caller
5045 && !deprecated_frame_in_dummy (fi
->next
));
5046 if (sal
.symtab
&& !is_ada_runtime_file (sal
.symtab
->filename
))
5048 #if defined(__alpha__) && defined(__osf__) && !defined(VXWORKS_TARGET)
5049 /* libpthread.so contains some debugging information that prevents us
5050 from finding the right frame */
5052 if (sal
.symtab
->objfile
&&
5053 STREQ (sal
.symtab
->objfile
->name
, "/usr/shlib/libpthread.so"))
5056 selected_frame
= fi
;
5065 ada_report_exception_break (struct breakpoint
*b
)
5068 /* FIXME: break_on_exception should be defined in breakpoint.h */
5069 /* if (b->break_on_exception == 1)
5071 /* Assume that cond has 16 elements, the 15th
5072 being the exception *//*
5073 if (b->cond && b->cond->nelts == 16)
5075 ui_out_text (uiout, "on ");
5076 ui_out_field_string (uiout, "exception",
5077 SYMBOL_NAME (b->cond->elts[14].symbol));
5080 ui_out_text (uiout, "on all exceptions");
5082 else if (b->break_on_exception == 2)
5083 ui_out_text (uiout, "on unhandled exception");
5084 else if (b->break_on_exception == 3)
5085 ui_out_text (uiout, "on assert failure");
5087 if (b->break_on_exception == 1)
5089 /* Assume that cond has 16 elements, the 15th
5090 being the exception *//*
5091 if (b->cond && b->cond->nelts == 16)
5093 fputs_filtered ("on ", gdb_stdout);
5094 fputs_filtered (SYMBOL_NAME
5095 (b->cond->elts[14].symbol), gdb_stdout);
5098 fputs_filtered ("on all exceptions", gdb_stdout);
5100 else if (b->break_on_exception == 2)
5101 fputs_filtered ("on unhandled exception", gdb_stdout);
5102 else if (b->break_on_exception == 3)
5103 fputs_filtered ("on assert failure", gdb_stdout);
5109 ada_is_exception_sym (struct symbol
*sym
)
5111 char *type_name
= type_name_no_tag (SYMBOL_TYPE (sym
));
5113 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5114 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5115 && SYMBOL_CLASS (sym
) != LOC_CONST
5116 && type_name
!= NULL
&& STREQ (type_name
, "exception"));
5120 ada_maybe_exception_partial_symbol (struct partial_symbol
*sym
)
5122 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5123 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5124 && SYMBOL_CLASS (sym
) != LOC_CONST
);
5127 /* If ARG points to an Ada exception or assert breakpoint, rewrite
5128 into equivalent form. Return resulting argument string. Set
5129 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
5130 break on unhandled, 3 for assert, 0 otherwise. */
5132 ada_breakpoint_rewrite (char *arg
, int *break_on_exceptionp
)
5136 *break_on_exceptionp
= 0;
5137 /* FIXME: language_ada should be defined in defs.h */
5138 /* if (current_language->la_language == language_ada
5139 && STREQN (arg, "exception", 9) &&
5140 (arg[9] == ' ' || arg[9] == '\t' || arg[9] == '\0'))
5142 char *tok, *end_tok;
5145 *break_on_exceptionp = 1;
5148 while (*tok == ' ' || *tok == '\t')
5153 while (*end_tok != ' ' && *end_tok != '\t' && *end_tok != '\000')
5156 toklen = end_tok - tok;
5158 arg = (char*) xmalloc (sizeof ("__gnat_raise_nodefer_with_msg if "
5159 "long_integer(e) = long_integer(&)")
5161 make_cleanup (xfree, arg);
5163 strcpy (arg, "__gnat_raise_nodefer_with_msg");
5164 else if (STREQN (tok, "unhandled", toklen))
5166 *break_on_exceptionp = 2;
5167 strcpy (arg, "__gnat_unhandled_exception");
5171 sprintf (arg, "__gnat_raise_nodefer_with_msg if "
5172 "long_integer(e) = long_integer(&%.*s)",
5176 else if (current_language->la_language == language_ada
5177 && STREQN (arg, "assert", 6) &&
5178 (arg[6] == ' ' || arg[6] == '\t' || arg[6] == '\0'))
5180 char *tok = arg + 6;
5182 *break_on_exceptionp = 3;
5185 xmalloc (sizeof ("system__assertions__raise_assert_failure")
5186 + strlen (tok) + 1);
5187 make_cleanup (xfree, arg);
5188 sprintf (arg, "system__assertions__raise_assert_failure%s", tok);
5197 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5198 to be invisible to users. */
5201 ada_is_ignored_field (struct type
*type
, int field_num
)
5203 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5207 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5208 return (name
== NULL
5209 || (name
[0] == '_' && !STREQN (name
, "_parent", 7)));
5213 /* True iff structure type TYPE has a tag field. */
5216 ada_is_tagged_type (struct type
*type
)
5218 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5221 return (ada_lookup_struct_elt_type (type
, "_tag", 1, NULL
) != NULL
);
5224 /* The type of the tag on VAL. */
5227 ada_tag_type (struct value
*val
)
5229 return ada_lookup_struct_elt_type (VALUE_TYPE (val
), "_tag", 0, NULL
);
5232 /* The value of the tag on VAL. */
5235 ada_value_tag (struct value
*val
)
5237 return ada_value_struct_elt (val
, "_tag", "record");
5240 /* The parent type of TYPE, or NULL if none. */
5243 ada_parent_type (struct type
*type
)
5247 CHECK_TYPEDEF (type
);
5249 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5252 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5253 if (ada_is_parent_field (type
, i
))
5254 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5259 /* True iff field number FIELD_NUM of structure type TYPE contains the
5260 parent-type (inherited) fields of a derived type. Assumes TYPE is
5261 a structure type with at least FIELD_NUM+1 fields. */
5264 ada_is_parent_field (struct type
*type
, int field_num
)
5266 const char *name
= TYPE_FIELD_NAME (check_typedef (type
), field_num
);
5267 return (name
!= NULL
&&
5268 (STREQN (name
, "PARENT", 6) || STREQN (name
, "_parent", 7)));
5271 /* True iff field number FIELD_NUM of structure type TYPE is a
5272 transparent wrapper field (which should be silently traversed when doing
5273 field selection and flattened when printing). Assumes TYPE is a
5274 structure type with at least FIELD_NUM+1 fields. Such fields are always
5278 ada_is_wrapper_field (struct type
*type
, int field_num
)
5280 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5281 return (name
!= NULL
5282 && (STREQN (name
, "PARENT", 6) || STREQ (name
, "REP")
5283 || STREQN (name
, "_parent", 7)
5284 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5287 /* True iff field number FIELD_NUM of structure or union type TYPE
5288 is a variant wrapper. Assumes TYPE is a structure type with at least
5289 FIELD_NUM+1 fields. */
5292 ada_is_variant_part (struct type
*type
, int field_num
)
5294 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5295 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5296 || (is_dynamic_field (type
, field_num
)
5297 && TYPE_CODE (TYPE_TARGET_TYPE (field_type
)) ==
5301 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5302 whose discriminants are contained in the record type OUTER_TYPE,
5303 returns the type of the controlling discriminant for the variant. */
5306 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5308 char *name
= ada_variant_discrim_name (var_type
);
5309 struct type
*type
= ada_lookup_struct_elt_type (outer_type
, name
, 1, NULL
);
5311 return builtin_type_int
;
5316 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5317 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5318 represents a 'when others' clause; otherwise 0. */
5321 ada_is_others_clause (struct type
*type
, int field_num
)
5323 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5324 return (name
!= NULL
&& name
[0] == 'O');
5327 /* Assuming that TYPE0 is the type of the variant part of a record,
5328 returns the name of the discriminant controlling the variant. The
5329 value is valid until the next call to ada_variant_discrim_name. */
5332 ada_variant_discrim_name (struct type
*type0
)
5334 static char *result
= NULL
;
5335 static size_t result_len
= 0;
5338 const char *discrim_end
;
5339 const char *discrim_start
;
5341 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5342 type
= TYPE_TARGET_TYPE (type0
);
5346 name
= ada_type_name (type
);
5348 if (name
== NULL
|| name
[0] == '\000')
5351 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5354 if (STREQN (discrim_end
, "___XVN", 6))
5357 if (discrim_end
== name
)
5360 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5363 if (discrim_start
== name
+ 1)
5365 if ((discrim_start
> name
+ 3 && STREQN (discrim_start
- 3, "___", 3))
5366 || discrim_start
[-1] == '.')
5370 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5371 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5372 result
[discrim_end
- discrim_start
] = '\0';
5376 /* Scan STR for a subtype-encoded number, beginning at position K. Put the
5377 position of the character just past the number scanned in *NEW_K,
5378 if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL. Return 1
5379 if there was a valid number at the given position, and 0 otherwise. A
5380 "subtype-encoded" number consists of the absolute value in decimal,
5381 followed by the letter 'm' to indicate a negative number. Assumes 0m
5385 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5389 if (!isdigit (str
[k
]))
5392 /* Do it the hard way so as not to make any assumption about
5393 the relationship of unsigned long (%lu scan format code) and
5396 while (isdigit (str
[k
]))
5398 RU
= RU
* 10 + (str
[k
] - '0');
5405 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5411 /* NOTE on the above: Technically, C does not say what the results of
5412 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5413 number representable as a LONGEST (although either would probably work
5414 in most implementations). When RU>0, the locution in the then branch
5415 above is always equivalent to the negative of RU. */
5422 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5423 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5424 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5427 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5429 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5442 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5451 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5452 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5454 if (val
>= L
&& val
<= U
)
5466 /* Given a value ARG1 (offset by OFFSET bytes)
5467 of a struct or union type ARG_TYPE,
5468 extract and return the value of one of its (non-static) fields.
5469 FIELDNO says which field. Differs from value_primitive_field only
5470 in that it can handle packed values of arbitrary type. */
5473 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5474 struct type
*arg_type
)
5479 CHECK_TYPEDEF (arg_type
);
5480 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5482 /* Handle packed fields */
5484 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5486 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5487 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5489 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
5490 offset
+ bit_pos
/ 8,
5491 bit_pos
% 8, bit_size
, type
);
5494 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5498 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5499 and search in it assuming it has (class) type TYPE.
5500 If found, return value, else return NULL.
5502 Searches recursively through wrapper fields (e.g., '_parent'). */
5505 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5509 CHECK_TYPEDEF (type
);
5511 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5513 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5515 if (t_field_name
== NULL
)
5518 else if (field_name_match (t_field_name
, name
))
5519 return ada_value_primitive_field (arg
, offset
, i
, type
);
5521 else if (ada_is_wrapper_field (type
, i
))
5523 struct value
*v
= ada_search_struct_field (name
, arg
,
5525 TYPE_FIELD_BITPOS (type
,
5528 TYPE_FIELD_TYPE (type
,
5534 else if (ada_is_variant_part (type
, i
))
5537 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5538 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5540 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5542 struct value
*v
= ada_search_struct_field (name
, arg
,
5546 (field_type
, j
) / 8,
5557 /* Given ARG, a value of type (pointer to a)* structure/union,
5558 extract the component named NAME from the ultimate target structure/union
5559 and return it as a value with its appropriate type.
5561 The routine searches for NAME among all members of the structure itself
5562 and (recursively) among all members of any wrapper members
5565 ERR is a name (for use in error messages) that identifies the class
5566 of entity that ARG is supposed to be. */
5569 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5574 arg
= ada_coerce_ref (arg
);
5575 t
= check_typedef (VALUE_TYPE (arg
));
5577 /* Follow pointers until we get to a non-pointer. */
5579 while (TYPE_CODE (t
) == TYPE_CODE_PTR
|| TYPE_CODE (t
) == TYPE_CODE_REF
)
5581 arg
= ada_value_ind (arg
);
5582 t
= check_typedef (VALUE_TYPE (arg
));
5585 if (TYPE_CODE (t
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t
) != TYPE_CODE_UNION
)
5586 error ("Attempt to extract a component of a value that is not a %s.",
5589 v
= ada_search_struct_field (name
, arg
, 0, t
);
5591 error ("There is no member named %s.", name
);
5596 /* Given a type TYPE, look up the type of the component of type named NAME.
5597 If DISPP is non-null, add its byte displacement from the beginning of a
5598 structure (pointed to by a value) of type TYPE to *DISPP (does not
5599 work for packed fields).
5601 Matches any field whose name has NAME as a prefix, possibly
5604 TYPE can be either a struct or union, or a pointer or reference to
5605 a struct or union. If it is a pointer or reference, its target
5606 type is automatically used.
5608 Looks recursively into variant clauses and parent types.
5610 If NOERR is nonzero, return NULL if NAME is not suitably defined. */
5613 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int noerr
,
5623 CHECK_TYPEDEF (type
);
5624 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5625 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5627 type
= TYPE_TARGET_TYPE (type
);
5630 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
&&
5631 TYPE_CODE (type
) != TYPE_CODE_UNION
)
5633 target_terminal_ours ();
5634 gdb_flush (gdb_stdout
);
5635 fprintf_unfiltered (gdb_stderr
, "Type ");
5636 type_print (type
, "", gdb_stderr
, -1);
5637 error (" is not a structure or union type");
5640 type
= to_static_fixed_type (type
);
5642 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5644 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5648 if (t_field_name
== NULL
)
5651 else if (field_name_match (t_field_name
, name
))
5654 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5655 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5658 else if (ada_is_wrapper_field (type
, i
))
5661 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5666 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5671 else if (ada_is_variant_part (type
, i
))
5674 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5676 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5679 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5684 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5695 target_terminal_ours ();
5696 gdb_flush (gdb_stdout
);
5697 fprintf_unfiltered (gdb_stderr
, "Type ");
5698 type_print (type
, "", gdb_stderr
, -1);
5699 fprintf_unfiltered (gdb_stderr
, " has no component named ");
5700 error ("%s", name
== NULL
? "<null>" : name
);
5706 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5707 within a value of type OUTER_TYPE that is stored in GDB at
5708 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5709 numbering from 0) is applicable. Returns -1 if none are. */
5712 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5713 char *outer_valaddr
)
5718 struct type
*discrim_type
;
5719 char *discrim_name
= ada_variant_discrim_name (var_type
);
5720 LONGEST discrim_val
;
5724 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, &disp
);
5725 if (discrim_type
== NULL
)
5727 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5730 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5732 if (ada_is_others_clause (var_type
, i
))
5734 else if (ada_in_variant (discrim_val
, var_type
, i
))
5738 return others_clause
;
5743 /* Dynamic-Sized Records */
5745 /* Strategy: The type ostensibly attached to a value with dynamic size
5746 (i.e., a size that is not statically recorded in the debugging
5747 data) does not accurately reflect the size or layout of the value.
5748 Our strategy is to convert these values to values with accurate,
5749 conventional types that are constructed on the fly. */
5751 /* There is a subtle and tricky problem here. In general, we cannot
5752 determine the size of dynamic records without its data. However,
5753 the 'struct value' data structure, which GDB uses to represent
5754 quantities in the inferior process (the target), requires the size
5755 of the type at the time of its allocation in order to reserve space
5756 for GDB's internal copy of the data. That's why the
5757 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5758 rather than struct value*s.
5760 However, GDB's internal history variables ($1, $2, etc.) are
5761 struct value*s containing internal copies of the data that are not, in
5762 general, the same as the data at their corresponding addresses in
5763 the target. Fortunately, the types we give to these values are all
5764 conventional, fixed-size types (as per the strategy described
5765 above), so that we don't usually have to perform the
5766 'to_fixed_xxx_type' conversions to look at their values.
5767 Unfortunately, there is one exception: if one of the internal
5768 history variables is an array whose elements are unconstrained
5769 records, then we will need to create distinct fixed types for each
5770 element selected. */
5772 /* The upshot of all of this is that many routines take a (type, host
5773 address, target address) triple as arguments to represent a value.
5774 The host address, if non-null, is supposed to contain an internal
5775 copy of the relevant data; otherwise, the program is to consult the
5776 target at the target address. */
5778 /* Assuming that VAL0 represents a pointer value, the result of
5779 dereferencing it. Differs from value_ind in its treatment of
5780 dynamic-sized types. */
5783 ada_value_ind (struct value
*val0
)
5785 struct value
*val
= unwrap_value (value_ind (val0
));
5786 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5787 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
), val
);
5790 /* The value resulting from dereferencing any "reference to"
5791 * qualifiers on VAL0. */
5792 static struct value
*
5793 ada_coerce_ref (struct value
*val0
)
5795 if (TYPE_CODE (VALUE_TYPE (val0
)) == TYPE_CODE_REF
)
5797 struct value
*val
= val0
;
5799 val
= unwrap_value (val
);
5800 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5801 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
5808 /* Return OFF rounded upward if necessary to a multiple of
5809 ALIGNMENT (a power of 2). */
5812 align_value (unsigned int off
, unsigned int alignment
)
5814 return (off
+ alignment
- 1) & ~(alignment
- 1);
5817 /* Return the additional bit offset required by field F of template
5821 field_offset (struct type
*type
, int f
)
5823 int n
= TYPE_FIELD_BITPOS (type
, f
);
5824 /* Kludge (temporary?) to fix problem with dwarf output. */
5826 return (unsigned int) n
& 0xffff;
5832 /* Return the bit alignment required for field #F of template type TYPE. */
5835 field_alignment (struct type
*type
, int f
)
5837 const char *name
= TYPE_FIELD_NAME (type
, f
);
5838 int len
= (name
== NULL
) ? 0 : strlen (name
);
5841 if (len
< 8 || !isdigit (name
[len
- 1]))
5842 return TARGET_CHAR_BIT
;
5844 if (isdigit (name
[len
- 2]))
5845 align_offset
= len
- 2;
5847 align_offset
= len
- 1;
5849 if (align_offset
< 7 || !STREQN ("___XV", name
+ align_offset
- 6, 5))
5850 return TARGET_CHAR_BIT
;
5852 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
5855 /* Find a type named NAME. Ignores ambiguity. */
5857 ada_find_any_type (const char *name
)
5861 sym
= standard_lookup (name
, VAR_NAMESPACE
);
5862 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5863 return SYMBOL_TYPE (sym
);
5865 sym
= standard_lookup (name
, STRUCT_NAMESPACE
);
5867 return SYMBOL_TYPE (sym
);
5872 /* Because of GNAT encoding conventions, several GDB symbols may match a
5873 given type name. If the type denoted by TYPE0 is to be preferred to
5874 that of TYPE1 for purposes of type printing, return non-zero;
5875 otherwise return 0. */
5877 ada_prefer_type (struct type
*type0
, struct type
*type1
)
5881 else if (type0
== NULL
)
5883 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
5885 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
5887 else if (ada_is_packed_array_type (type0
))
5889 else if (ada_is_array_descriptor (type0
)
5890 && !ada_is_array_descriptor (type1
))
5892 else if (ada_renaming_type (type0
) != NULL
5893 && ada_renaming_type (type1
) == NULL
)
5898 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5899 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5901 ada_type_name (struct type
*type
)
5905 else if (TYPE_NAME (type
) != NULL
)
5906 return TYPE_NAME (type
);
5908 return TYPE_TAG_NAME (type
);
5911 /* Find a parallel type to TYPE whose name is formed by appending
5912 SUFFIX to the name of TYPE. */
5915 ada_find_parallel_type (struct type
*type
, const char *suffix
)
5918 static size_t name_len
= 0;
5919 struct symbol
**syms
;
5920 struct block
**blocks
;
5923 char *typename
= ada_type_name (type
);
5925 if (typename
== NULL
)
5928 len
= strlen (typename
);
5930 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
5932 strcpy (name
, typename
);
5933 strcpy (name
+ len
, suffix
);
5935 return ada_find_any_type (name
);
5939 /* If TYPE is a variable-size record type, return the corresponding template
5940 type describing its fields. Otherwise, return NULL. */
5942 static struct type
*
5943 dynamic_template_type (struct type
*type
)
5945 CHECK_TYPEDEF (type
);
5947 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5948 || ada_type_name (type
) == NULL
)
5952 int len
= strlen (ada_type_name (type
));
5953 if (len
> 6 && STREQ (ada_type_name (type
) + len
- 6, "___XVE"))
5956 return ada_find_parallel_type (type
, "___XVE");
5960 /* Assuming that TEMPL_TYPE is a union or struct type, returns
5961 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
5964 is_dynamic_field (struct type
*templ_type
, int field_num
)
5966 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
5968 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
5969 && strstr (name
, "___XVL") != NULL
;
5972 /* Assuming that TYPE is a struct type, returns non-zero iff TYPE
5973 contains a variant part. */
5976 contains_variant_part (struct type
*type
)
5980 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5981 || TYPE_NFIELDS (type
) <= 0)
5983 return ada_is_variant_part (type
, TYPE_NFIELDS (type
) - 1);
5986 /* A record type with no fields, . */
5987 static struct type
*
5988 empty_record (struct objfile
*objfile
)
5990 struct type
*type
= alloc_type (objfile
);
5991 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
5992 TYPE_NFIELDS (type
) = 0;
5993 TYPE_FIELDS (type
) = NULL
;
5994 TYPE_NAME (type
) = "<empty>";
5995 TYPE_TAG_NAME (type
) = NULL
;
5996 TYPE_FLAGS (type
) = 0;
5997 TYPE_LENGTH (type
) = 0;
6001 /* An ordinary record type (with fixed-length fields) that describes
6002 the value of type TYPE at VALADDR or ADDRESS (see comments at
6003 the beginning of this section) VAL according to GNAT conventions.
6004 DVAL0 should describe the (portion of a) record that contains any
6005 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
6006 an outer-level type (i.e., as opposed to a branch of a variant.) A
6007 variant field (unless unchecked) is replaced by a particular branch
6009 /* NOTE: Limitations: For now, we assume that dynamic fields and
6010 * variants occupy whole numbers of bytes. However, they need not be
6013 static struct type
*
6014 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
6015 CORE_ADDR address
, struct value
*dval0
)
6017 struct value
*mark
= value_mark ();
6020 int nfields
, bit_len
;
6024 nfields
= TYPE_NFIELDS (type
);
6025 rtype
= alloc_type (TYPE_OBJFILE (type
));
6026 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6027 INIT_CPLUS_SPECIFIC (rtype
);
6028 TYPE_NFIELDS (rtype
) = nfields
;
6029 TYPE_FIELDS (rtype
) = (struct field
*)
6030 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6031 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6032 TYPE_NAME (rtype
) = ada_type_name (type
);
6033 TYPE_TAG_NAME (rtype
) = NULL
;
6034 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in
6036 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6040 for (f
= 0; f
< nfields
; f
+= 1)
6042 int fld_bit_len
, bit_incr
;
6045 field_alignment (type
, f
)) + TYPE_FIELD_BITPOS (type
, f
);
6046 /* NOTE: used to use field_offset above, but that causes
6047 * problems with really negative bit positions. So, let's
6048 * rediscover why we needed field_offset and fix it properly. */
6049 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6050 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6051 TYPE_FIELD_STATIC_KIND (rtype
, f
) = 0;
6053 if (ada_is_variant_part (type
, f
))
6055 struct type
*branch_type
;
6058 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6063 to_fixed_variant_branch_type
6064 (TYPE_FIELD_TYPE (type
, f
),
6065 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6066 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6067 if (branch_type
== NULL
)
6068 TYPE_NFIELDS (rtype
) -= 1;
6071 TYPE_FIELD_TYPE (rtype
, f
) = branch_type
;
6072 TYPE_FIELD_NAME (rtype
, f
) = "S";
6076 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6078 else if (is_dynamic_field (type
, f
))
6081 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6085 TYPE_FIELD_TYPE (rtype
, f
) =
6088 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6089 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6090 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6091 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6092 bit_incr
= fld_bit_len
=
6093 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6097 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6098 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6099 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6100 bit_incr
= fld_bit_len
=
6101 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6103 bit_incr
= fld_bit_len
=
6104 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6106 if (off
+ fld_bit_len
> bit_len
)
6107 bit_len
= off
+ fld_bit_len
;
6109 TYPE_LENGTH (rtype
) = bit_len
/ TARGET_CHAR_BIT
;
6111 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
), TYPE_LENGTH (type
));
6113 value_free_to_mark (mark
);
6114 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6115 error ("record type with dynamic size is larger than varsize-limit");
6119 /* As for template_to_fixed_record_type, but uses no run-time values.
6120 As a result, this type can only be approximate, but that's OK,
6121 since it is used only for type determinations. Works on both
6123 Representation note: to save space, we memoize the result of this
6124 function in the TYPE_TARGET_TYPE of the template type. */
6126 static struct type
*
6127 template_to_static_fixed_type (struct type
*templ_type
)
6133 if (TYPE_TARGET_TYPE (templ_type
) != NULL
)
6134 return TYPE_TARGET_TYPE (templ_type
);
6136 nfields
= TYPE_NFIELDS (templ_type
);
6137 TYPE_TARGET_TYPE (templ_type
) = type
=
6138 alloc_type (TYPE_OBJFILE (templ_type
));
6139 TYPE_CODE (type
) = TYPE_CODE (templ_type
);
6140 INIT_CPLUS_SPECIFIC (type
);
6141 TYPE_NFIELDS (type
) = nfields
;
6142 TYPE_FIELDS (type
) = (struct field
*)
6143 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6144 memset (TYPE_FIELDS (type
), 0, sizeof (struct field
) * nfields
);
6145 TYPE_NAME (type
) = ada_type_name (templ_type
);
6146 TYPE_TAG_NAME (type
) = NULL
;
6147 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6148 /* TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE; */
6149 TYPE_LENGTH (type
) = 0;
6151 for (f
= 0; f
< nfields
; f
+= 1)
6153 TYPE_FIELD_BITPOS (type
, f
) = 0;
6154 TYPE_FIELD_BITSIZE (type
, f
) = 0;
6155 TYPE_FIELD_STATIC_KIND (type
, f
) = 0;
6157 if (is_dynamic_field (templ_type
, f
))
6159 TYPE_FIELD_TYPE (type
, f
) =
6160 to_static_fixed_type (TYPE_TARGET_TYPE
6161 (TYPE_FIELD_TYPE (templ_type
, f
)));
6162 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6166 TYPE_FIELD_TYPE (type
, f
) =
6167 check_typedef (TYPE_FIELD_TYPE (templ_type
, f
));
6168 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6175 /* A revision of TYPE0 -- a non-dynamic-sized record with a variant
6176 part -- in which the variant part is replaced with the appropriate
6178 static struct type
*
6179 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
6180 CORE_ADDR address
, struct value
*dval
)
6182 struct value
*mark
= value_mark ();
6184 struct type
*branch_type
;
6185 int nfields
= TYPE_NFIELDS (type
);
6190 rtype
= alloc_type (TYPE_OBJFILE (type
));
6191 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6192 INIT_CPLUS_SPECIFIC (type
);
6193 TYPE_NFIELDS (rtype
) = TYPE_NFIELDS (type
);
6194 TYPE_FIELDS (rtype
) =
6195 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6196 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6197 sizeof (struct field
) * nfields
);
6198 TYPE_NAME (rtype
) = ada_type_name (type
);
6199 TYPE_TAG_NAME (rtype
) = NULL
;
6200 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6201 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6202 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6205 to_fixed_variant_branch_type
6206 (TYPE_FIELD_TYPE (type
, nfields
- 1),
6207 cond_offset_host (valaddr
,
6208 TYPE_FIELD_BITPOS (type
,
6209 nfields
- 1) / TARGET_CHAR_BIT
),
6210 cond_offset_target (address
,
6211 TYPE_FIELD_BITPOS (type
,
6212 nfields
- 1) / TARGET_CHAR_BIT
),
6214 if (branch_type
== NULL
)
6216 TYPE_NFIELDS (rtype
) -= 1;
6217 TYPE_LENGTH (rtype
) -=
6218 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6222 TYPE_FIELD_TYPE (rtype
, nfields
- 1) = branch_type
;
6223 TYPE_FIELD_NAME (rtype
, nfields
- 1) = "S";
6224 TYPE_FIELD_BITSIZE (rtype
, nfields
- 1) = 0;
6225 TYPE_FIELD_STATIC_KIND (rtype
, nfields
- 1) = 0;
6226 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6227 -TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6233 /* An ordinary record type (with fixed-length fields) that describes
6234 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6235 beginning of this section]. Any necessary discriminants' values
6236 should be in DVAL, a record value; it should be NULL if the object
6237 at ADDR itself contains any necessary discriminant values. A
6238 variant field (unless unchecked) is replaced by a particular branch
6241 static struct type
*
6242 to_fixed_record_type (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6245 struct type
*templ_type
;
6247 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6248 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6251 templ_type
= dynamic_template_type (type0
);
6253 if (templ_type
!= NULL
)
6254 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6255 else if (contains_variant_part (type0
))
6256 return to_record_with_fixed_variant_part (type0
, valaddr
, address
, dval
);
6259 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6260 /* TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE; */
6266 /* An ordinary record type (with fixed-length fields) that describes
6267 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6268 union type. Any necessary discriminants' values should be in DVAL,
6269 a record value. That is, this routine selects the appropriate
6270 branch of the union at ADDR according to the discriminant value
6271 indicated in the union's type name. */
6273 static struct type
*
6274 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
6275 CORE_ADDR address
, struct value
*dval
)
6278 struct type
*templ_type
;
6279 struct type
*var_type
;
6281 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6282 var_type
= TYPE_TARGET_TYPE (var_type0
);
6284 var_type
= var_type0
;
6286 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6288 if (templ_type
!= NULL
)
6289 var_type
= templ_type
;
6292 ada_which_variant_applies (var_type
,
6293 VALUE_TYPE (dval
), VALUE_CONTENTS (dval
));
6296 return empty_record (TYPE_OBJFILE (var_type
));
6297 else if (is_dynamic_field (var_type
, which
))
6299 to_fixed_record_type
6300 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6301 valaddr
, address
, dval
);
6302 else if (contains_variant_part (TYPE_FIELD_TYPE (var_type
, which
)))
6304 to_fixed_record_type
6305 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6307 return TYPE_FIELD_TYPE (var_type
, which
);
6310 /* Assuming that TYPE0 is an array type describing the type of a value
6311 at ADDR, and that DVAL describes a record containing any
6312 discriminants used in TYPE0, returns a type for the value that
6313 contains no dynamic components (that is, no components whose sizes
6314 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6315 true, gives an error message if the resulting type's size is over
6319 static struct type
*
6320 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6323 struct type
*index_type_desc
;
6324 struct type
*result
;
6326 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6327 /* if (ada_is_packed_array_type (type0) /* revisit? *//*
6328 || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
6331 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6332 if (index_type_desc
== NULL
)
6334 struct type
*elt_type0
= check_typedef (TYPE_TARGET_TYPE (type0
));
6335 /* NOTE: elt_type---the fixed version of elt_type0---should never
6336 * depend on the contents of the array in properly constructed
6337 * debugging data. */
6338 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6340 if (elt_type0
== elt_type
)
6343 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6344 elt_type
, TYPE_INDEX_TYPE (type0
));
6349 struct type
*elt_type0
;
6352 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6353 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6355 /* NOTE: result---the fixed version of elt_type0---should never
6356 * depend on the contents of the array in properly constructed
6357 * debugging data. */
6358 result
= ada_to_fixed_type (check_typedef (elt_type0
), 0, 0, dval
);
6359 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6361 struct type
*range_type
=
6362 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6363 dval
, TYPE_OBJFILE (type0
));
6364 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6365 result
, range_type
);
6367 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6368 error ("array type with dynamic size is larger than varsize-limit");
6371 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6372 /* TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE; */
6377 /* A standard type (containing no dynamically sized components)
6378 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6379 DVAL describes a record containing any discriminants used in TYPE0,
6380 and may be NULL if there are none. */
6383 ada_to_fixed_type (struct type
*type
, char *valaddr
, CORE_ADDR address
,
6386 CHECK_TYPEDEF (type
);
6387 switch (TYPE_CODE (type
))
6391 case TYPE_CODE_STRUCT
:
6392 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6393 case TYPE_CODE_ARRAY
:
6394 return to_fixed_array_type (type
, dval
, 0);
6395 case TYPE_CODE_UNION
:
6399 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6403 /* A standard (static-sized) type corresponding as well as possible to
6404 TYPE0, but based on no runtime data. */
6406 static struct type
*
6407 to_static_fixed_type (struct type
*type0
)
6414 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6415 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6418 CHECK_TYPEDEF (type0
);
6420 switch (TYPE_CODE (type0
))
6424 case TYPE_CODE_STRUCT
:
6425 type
= dynamic_template_type (type0
);
6427 return template_to_static_fixed_type (type
);
6429 case TYPE_CODE_UNION
:
6430 type
= ada_find_parallel_type (type0
, "___XVU");
6432 return template_to_static_fixed_type (type
);
6437 /* A static approximation of TYPE with all type wrappers removed. */
6438 static struct type
*
6439 static_unwrap_type (struct type
*type
)
6441 if (ada_is_aligner_type (type
))
6443 struct type
*type1
= TYPE_FIELD_TYPE (check_typedef (type
), 0);
6444 if (ada_type_name (type1
) == NULL
)
6445 TYPE_NAME (type1
) = ada_type_name (type
);
6447 return static_unwrap_type (type1
);
6451 struct type
*raw_real_type
= ada_get_base_type (type
);
6452 if (raw_real_type
== type
)
6455 return to_static_fixed_type (raw_real_type
);
6459 /* In some cases, incomplete and private types require
6460 cross-references that are not resolved as records (for example,
6462 type FooP is access Foo;
6464 type Foo is array ...;
6465 ). In these cases, since there is no mechanism for producing
6466 cross-references to such types, we instead substitute for FooP a
6467 stub enumeration type that is nowhere resolved, and whose tag is
6468 the name of the actual type. Call these types "non-record stubs". */
6470 /* A type equivalent to TYPE that is not a non-record stub, if one
6471 exists, otherwise TYPE. */
6473 ada_completed_type (struct type
*type
)
6475 CHECK_TYPEDEF (type
);
6476 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6477 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
6478 || TYPE_TAG_NAME (type
) == NULL
)
6482 char *name
= TYPE_TAG_NAME (type
);
6483 struct type
*type1
= ada_find_any_type (name
);
6484 return (type1
== NULL
) ? type
: type1
;
6488 /* A value representing the data at VALADDR/ADDRESS as described by
6489 type TYPE0, but with a standard (static-sized) type that correctly
6490 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6491 type, then return VAL0 [this feature is simply to avoid redundant
6492 creation of struct values]. */
6495 ada_to_fixed_value (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6498 struct type
*type
= ada_to_fixed_type (type0
, valaddr
, address
, NULL
);
6499 if (type
== type0
&& val0
!= NULL
)
6502 return value_from_contents_and_address (type
, valaddr
, address
);
6505 /* A value representing VAL, but with a standard (static-sized) type
6506 chosen to approximate the real type of VAL as well as possible, but
6507 without consulting any runtime values. For Ada dynamic-sized
6508 types, therefore, the type of the result is likely to be inaccurate. */
6511 ada_to_static_fixed_value (struct value
*val
)
6514 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val
)));
6515 if (type
== VALUE_TYPE (val
))
6518 return coerce_unspec_val_to_type (val
, 0, type
);
6527 /* Table mapping attribute numbers to names */
6528 /* NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h */
6530 static const char *attribute_names
[] = {
6547 ada_attribute_name (int n
)
6549 if (n
> 0 && n
< (int) ATR_END
)
6550 return attribute_names
[n
];
6552 return attribute_names
[0];
6555 /* Evaluate the 'POS attribute applied to ARG. */
6557 static struct value
*
6558 value_pos_atr (struct value
*arg
)
6560 struct type
*type
= VALUE_TYPE (arg
);
6562 if (!discrete_type_p (type
))
6563 error ("'POS only defined on discrete types");
6565 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6568 LONGEST v
= value_as_long (arg
);
6570 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6572 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6573 return value_from_longest (builtin_type_ada_int
, i
);
6575 error ("enumeration value is invalid: can't find 'POS");
6578 return value_from_longest (builtin_type_ada_int
, value_as_long (arg
));
6581 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6583 static struct value
*
6584 value_val_atr (struct type
*type
, struct value
*arg
)
6586 if (!discrete_type_p (type
))
6587 error ("'VAL only defined on discrete types");
6588 if (!integer_type_p (VALUE_TYPE (arg
)))
6589 error ("'VAL requires integral argument");
6591 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6593 long pos
= value_as_long (arg
);
6594 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6595 error ("argument to 'VAL out of range");
6596 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6599 return value_from_longest (type
, value_as_long (arg
));
6605 /* True if TYPE appears to be an Ada character type.
6606 * [At the moment, this is true only for Character and Wide_Character;
6607 * It is a heuristic test that could stand improvement]. */
6610 ada_is_character_type (struct type
*type
)
6612 const char *name
= ada_type_name (type
);
6615 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6616 || TYPE_CODE (type
) == TYPE_CODE_INT
6617 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6618 && (STREQ (name
, "character") || STREQ (name
, "wide_character")
6619 || STREQ (name
, "unsigned char"));
6622 /* True if TYPE appears to be an Ada string type. */
6625 ada_is_string_type (struct type
*type
)
6627 CHECK_TYPEDEF (type
);
6629 && TYPE_CODE (type
) != TYPE_CODE_PTR
6630 && (ada_is_simple_array (type
) || ada_is_array_descriptor (type
))
6631 && ada_array_arity (type
) == 1)
6633 struct type
*elttype
= ada_array_element_type (type
, 1);
6635 return ada_is_character_type (elttype
);
6642 /* True if TYPE is a struct type introduced by the compiler to force the
6643 alignment of a value. Such types have a single field with a
6644 distinctive name. */
6647 ada_is_aligner_type (struct type
*type
)
6649 CHECK_TYPEDEF (type
);
6650 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
6651 && TYPE_NFIELDS (type
) == 1
6652 && STREQ (TYPE_FIELD_NAME (type
, 0), "F"));
6655 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6656 the parallel type. */
6659 ada_get_base_type (struct type
*raw_type
)
6661 struct type
*real_type_namer
;
6662 struct type
*raw_real_type
;
6663 struct type
*real_type
;
6665 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
6668 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
6669 if (real_type_namer
== NULL
6670 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
6671 || TYPE_NFIELDS (real_type_namer
) != 1)
6674 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
6675 if (raw_real_type
== NULL
)
6678 return raw_real_type
;
6681 /* The type of value designated by TYPE, with all aligners removed. */
6684 ada_aligned_type (struct type
*type
)
6686 if (ada_is_aligner_type (type
))
6687 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
6689 return ada_get_base_type (type
);
6693 /* The address of the aligned value in an object at address VALADDR
6694 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6697 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
6699 if (ada_is_aligner_type (type
))
6700 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
6702 TYPE_FIELD_BITPOS (type
,
6703 0) / TARGET_CHAR_BIT
);
6708 /* The printed representation of an enumeration literal with encoded
6709 name NAME. The value is good to the next call of ada_enum_name. */
6711 ada_enum_name (const char *name
)
6717 if ((tmp
= strstr (name
, "__")) != NULL
)
6719 else if ((tmp
= strchr (name
, '.')) != NULL
)
6727 static char result
[16];
6729 if (name
[1] == 'U' || name
[1] == 'W')
6731 if (sscanf (name
+ 2, "%x", &v
) != 1)
6737 if (isascii (v
) && isprint (v
))
6738 sprintf (result
, "'%c'", v
);
6739 else if (name
[1] == 'U')
6740 sprintf (result
, "[\"%02x\"]", v
);
6742 sprintf (result
, "[\"%04x\"]", v
);
6750 static struct value
*
6751 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
6754 return (*exp
->language_defn
->evaluate_exp
) (expect_type
, exp
, pos
, noside
);
6757 /* Evaluate the subexpression of EXP starting at *POS as for
6758 evaluate_type, updating *POS to point just past the evaluated
6761 static struct value
*
6762 evaluate_subexp_type (struct expression
*exp
, int *pos
)
6764 return (*exp
->language_defn
->evaluate_exp
)
6765 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
6768 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6771 static struct value
*
6772 unwrap_value (struct value
*val
)
6774 struct type
*type
= check_typedef (VALUE_TYPE (val
));
6775 if (ada_is_aligner_type (type
))
6777 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
6778 NULL
, "internal structure");
6779 struct type
*val_type
= check_typedef (VALUE_TYPE (v
));
6780 if (ada_type_name (val_type
) == NULL
)
6781 TYPE_NAME (val_type
) = ada_type_name (type
);
6783 return unwrap_value (v
);
6787 struct type
*raw_real_type
=
6788 ada_completed_type (ada_get_base_type (type
));
6790 if (type
== raw_real_type
)
6794 coerce_unspec_val_to_type
6795 (val
, 0, ada_to_fixed_type (raw_real_type
, 0,
6796 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
6801 static struct value
*
6802 cast_to_fixed (struct type
*type
, struct value
*arg
)
6806 if (type
== VALUE_TYPE (arg
))
6808 else if (ada_is_fixed_point_type (VALUE_TYPE (arg
)))
6809 val
= ada_float_to_fixed (type
,
6810 ada_fixed_to_float (VALUE_TYPE (arg
),
6811 value_as_long (arg
)));
6815 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
6816 val
= ada_float_to_fixed (type
, argd
);
6819 return value_from_longest (type
, val
);
6822 static struct value
*
6823 cast_from_fixed_to_double (struct value
*arg
)
6825 DOUBLEST val
= ada_fixed_to_float (VALUE_TYPE (arg
),
6826 value_as_long (arg
));
6827 return value_from_double (builtin_type_double
, val
);
6830 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
6831 * return the converted value. */
6832 static struct value
*
6833 coerce_for_assign (struct type
*type
, struct value
*val
)
6835 struct type
*type2
= VALUE_TYPE (val
);
6839 CHECK_TYPEDEF (type2
);
6840 CHECK_TYPEDEF (type
);
6842 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
6843 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6845 val
= ada_value_ind (val
);
6846 type2
= VALUE_TYPE (val
);
6849 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
6850 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6852 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
6853 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
6854 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
6855 error ("Incompatible types in assignment");
6856 VALUE_TYPE (val
) = type
;
6862 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
6863 int *pos
, enum noside noside
)
6866 enum ada_attribute atr
;
6867 int tem
, tem2
, tem3
;
6869 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
6872 struct value
**argvec
;
6876 op
= exp
->elts
[pc
].opcode
;
6883 unwrap_value (evaluate_subexp_standard
6884 (expect_type
, exp
, pos
, noside
));
6888 type
= exp
->elts
[pc
+ 1].type
;
6889 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
6890 if (noside
== EVAL_SKIP
)
6892 if (type
!= check_typedef (VALUE_TYPE (arg1
)))
6894 if (ada_is_fixed_point_type (type
))
6895 arg1
= cast_to_fixed (type
, arg1
);
6896 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6897 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
6898 else if (VALUE_LVAL (arg1
) == lval_memory
)
6900 /* This is in case of the really obscure (and undocumented,
6901 but apparently expected) case of (Foo) Bar.all, where Bar
6902 is an integer constant and Foo is a dynamic-sized type.
6903 If we don't do this, ARG1 will simply be relabeled with
6905 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
6906 return value_zero (to_static_fixed_type (type
), not_lval
);
6909 (type
, 0, VALUE_ADDRESS (arg1
) + VALUE_OFFSET (arg1
), 0);
6912 arg1
= value_cast (type
, arg1
);
6916 /* FIXME: UNOP_QUAL should be defined in expression.h */
6919 type = exp->elts[pc + 1].type;
6920 return ada_evaluate_subexp (type, exp, pos, noside);
6923 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6924 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
6925 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
6927 if (binop_user_defined_p (op
, arg1
, arg2
))
6928 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6931 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6932 arg2
= cast_to_fixed (VALUE_TYPE (arg1
), arg2
);
6933 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6935 ("Fixed-point values must be assigned to fixed-point variables");
6937 arg2
= coerce_for_assign (VALUE_TYPE (arg1
), arg2
);
6938 return ada_value_assign (arg1
, arg2
);
6942 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6943 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6944 if (noside
== EVAL_SKIP
)
6946 if (binop_user_defined_p (op
, arg1
, arg2
))
6947 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6950 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6951 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6952 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6954 ("Operands of fixed-point addition must have the same type");
6955 return value_cast (VALUE_TYPE (arg1
), value_add (arg1
, arg2
));
6959 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6960 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6961 if (noside
== EVAL_SKIP
)
6963 if (binop_user_defined_p (op
, arg1
, arg2
))
6964 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6967 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6968 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6969 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6971 ("Operands of fixed-point subtraction must have the same type");
6972 return value_cast (VALUE_TYPE (arg1
), value_sub (arg1
, arg2
));
6977 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6978 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6979 if (noside
== EVAL_SKIP
)
6981 if (binop_user_defined_p (op
, arg1
, arg2
))
6982 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6984 if (noside
== EVAL_AVOID_SIDE_EFFECTS
6985 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
6986 return value_zero (VALUE_TYPE (arg1
), not_lval
);
6989 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6990 arg1
= cast_from_fixed_to_double (arg1
);
6991 if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6992 arg2
= cast_from_fixed_to_double (arg2
);
6993 return value_binop (arg1
, arg2
, op
);
6997 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6998 if (noside
== EVAL_SKIP
)
7000 if (unop_user_defined_p (op
, arg1
))
7001 return value_x_unop (arg1
, op
, EVAL_NORMAL
);
7002 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
7003 return value_cast (VALUE_TYPE (arg1
), value_neg (arg1
));
7005 return value_neg (arg1
);
7007 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7008 /* case OP_UNRESOLVED_VALUE:
7009 /* Only encountered when an unresolved symbol occurs in a
7010 context other than a function call, in which case, it is
7013 if (noside == EVAL_SKIP)
7016 error ("Unexpected unresolved symbol, %s, during evaluation",
7017 ada_demangle (exp->elts[pc + 2].name));
7021 if (noside
== EVAL_SKIP
)
7026 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7030 (to_static_fixed_type
7031 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
7037 unwrap_value (evaluate_subexp_standard
7038 (expect_type
, exp
, pos
, noside
));
7039 return ada_to_fixed_value (VALUE_TYPE (arg1
), 0,
7040 VALUE_ADDRESS (arg1
) +
7041 VALUE_OFFSET (arg1
), arg1
);
7046 tem2
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7047 tem3
= longest_to_int (exp
->elts
[pc
+ 2].longconst
);
7048 nargs
= tem3
- tem2
+ 1;
7049 type
= expect_type
? check_typedef (expect_type
) : NULL_TYPE
;
7052 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
7053 for (tem
= 0; tem
== 0 || tem
< nargs
; tem
+= 1)
7054 /* At least one element gets inserted for the type */
7056 /* Ensure that array expressions are coerced into pointer objects. */
7057 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
7059 if (noside
== EVAL_SKIP
)
7061 return value_array (tem2
, tem3
, argvec
);
7066 /* Allocate arg vector, including space for the function to be
7067 called in argvec[0] and a terminating NULL */
7068 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7070 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 2));
7072 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7073 /* FIXME: name should be defined in expresion.h */
7074 /* if (exp->elts[*pos].opcode == OP_UNRESOLVED_VALUE)
7075 error ("Unexpected unresolved symbol, %s, during evaluation",
7076 ada_demangle (exp->elts[pc + 5].name));
7080 error ("unexpected code path, FIXME");
7084 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7085 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7088 if (noside
== EVAL_SKIP
)
7092 if (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_REF
)
7093 argvec
[0] = value_addr (argvec
[0]);
7095 if (ada_is_packed_array_type (VALUE_TYPE (argvec
[0])))
7096 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7098 type
= check_typedef (VALUE_TYPE (argvec
[0]));
7099 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7101 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type
))))
7103 case TYPE_CODE_FUNC
:
7104 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7106 case TYPE_CODE_ARRAY
:
7108 case TYPE_CODE_STRUCT
:
7109 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7110 argvec
[0] = ada_value_ind (argvec
[0]);
7111 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7114 error ("cannot subscript or call something of type `%s'",
7115 ada_type_name (VALUE_TYPE (argvec
[0])));
7120 switch (TYPE_CODE (type
))
7122 case TYPE_CODE_FUNC
:
7123 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7124 return allocate_value (TYPE_TARGET_TYPE (type
));
7125 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7126 case TYPE_CODE_STRUCT
:
7128 int arity
= ada_array_arity (type
);
7129 type
= ada_array_element_type (type
, nargs
);
7131 error ("cannot subscript or call a record");
7133 error ("wrong number of subscripts; expecting %d", arity
);
7134 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7135 return allocate_value (ada_aligned_type (type
));
7137 unwrap_value (ada_value_subscript
7138 (argvec
[0], nargs
, argvec
+ 1));
7140 case TYPE_CODE_ARRAY
:
7141 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7143 type
= ada_array_element_type (type
, nargs
);
7145 error ("element type of array unknown");
7147 return allocate_value (ada_aligned_type (type
));
7150 unwrap_value (ada_value_subscript
7151 (ada_coerce_to_simple_array (argvec
[0]),
7152 nargs
, argvec
+ 1));
7153 case TYPE_CODE_PTR
: /* Pointer to array */
7154 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7155 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7157 type
= ada_array_element_type (type
, nargs
);
7159 error ("element type of array unknown");
7161 return allocate_value (ada_aligned_type (type
));
7164 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7165 nargs
, argvec
+ 1));
7168 error ("Internal error in evaluate_subexp");
7173 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7175 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7177 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7178 if (noside
== EVAL_SKIP
)
7181 /* If this is a reference to an array, then dereference it */
7182 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
7183 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7184 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7186 && !ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7188 array
= ada_coerce_ref (array
);
7191 if (noside
== EVAL_AVOID_SIDE_EFFECTS
&&
7192 ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7194 /* Try to dereference the array, in case it is an access to array */
7195 struct type
*arrType
= ada_type_of_array (array
, 0);
7196 if (arrType
!= NULL
)
7197 array
= value_at_lazy (arrType
, 0, NULL
);
7199 if (ada_is_array_descriptor (VALUE_TYPE (array
)))
7200 array
= ada_coerce_to_simple_array (array
);
7202 /* If at this point we have a pointer to an array, it means that
7203 it is a pointer to a simple (non-ada) array. We just then
7205 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
7206 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7207 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7210 array
= ada_value_ind (array
);
7213 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7214 /* The following will get the bounds wrong, but only in contexts
7215 where the value is not being requested (FIXME?). */
7218 return value_slice (array
, lowbound
, upper
- lowbound
+ 1);
7221 /* FIXME: UNOP_MBR should be defined in expression.h */
7224 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7225 type = exp->elts[pc + 1].type;
7227 if (noside == EVAL_SKIP)
7230 switch (TYPE_CODE (type))
7233 warning ("Membership test incompletely implemented; always returns true");
7234 return value_from_longest (builtin_type_int, (LONGEST) 1);
7236 case TYPE_CODE_RANGE:
7237 arg2 = value_from_longest (builtin_type_int,
7238 (LONGEST) TYPE_LOW_BOUND (type));
7239 arg3 = value_from_longest (builtin_type_int,
7240 (LONGEST) TYPE_HIGH_BOUND (type));
7242 value_from_longest (builtin_type_int,
7243 (value_less (arg1,arg3)
7244 || value_equal (arg1,arg3))
7245 && (value_less (arg2,arg1)
7246 || value_equal (arg2,arg1)));
7249 /* FIXME: BINOP_MBR should be defined in expression.h */
7252 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7253 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7255 if (noside == EVAL_SKIP)
7258 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7259 return value_zero (builtin_type_int, not_lval);
7261 tem = longest_to_int (exp->elts[pc + 1].longconst);
7263 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
7264 error ("invalid dimension number to '%s", "range");
7266 arg3 = ada_array_bound (arg2, tem, 1);
7267 arg2 = ada_array_bound (arg2, tem, 0);
7270 value_from_longest (builtin_type_int,
7271 (value_less (arg1,arg3)
7272 || value_equal (arg1,arg3))
7273 && (value_less (arg2,arg1)
7274 || value_equal (arg2,arg1)));
7276 /* FIXME: TERNOP_MBR should be defined in expression.h */
7278 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7279 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7280 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7282 if (noside == EVAL_SKIP)
7286 value_from_longest (builtin_type_int,
7287 (value_less (arg1,arg3)
7288 || value_equal (arg1,arg3))
7289 && (value_less (arg2,arg1)
7290 || value_equal (arg2,arg1)));
7292 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
7293 /* case OP_ATTRIBUTE:
7295 atr = (enum ada_attribute) longest_to_int (exp->elts[pc + 2].longconst);
7299 error ("unexpected attribute encountered");
7305 struct type* type_arg;
7306 if (exp->elts[*pos].opcode == OP_TYPE)
7308 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7310 type_arg = exp->elts[pc + 5].type;
7314 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7318 if (exp->elts[*pos].opcode != OP_LONG)
7319 error ("illegal operand to '%s", ada_attribute_name (atr));
7320 tem = longest_to_int (exp->elts[*pos+2].longconst);
7323 if (noside == EVAL_SKIP)
7326 if (type_arg == NULL)
7328 arg1 = ada_coerce_ref (arg1);
7330 if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
7331 arg1 = ada_coerce_to_simple_array (arg1);
7333 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
7334 error ("invalid dimension number to '%s",
7335 ada_attribute_name (atr));
7337 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7339 type = ada_index_type (VALUE_TYPE (arg1), tem);
7341 error ("attempt to take bound of something that is not an array");
7342 return allocate_value (type);
7348 error ("unexpected attribute encountered");
7350 return ada_array_bound (arg1, tem, 0);
7352 return ada_array_bound (arg1, tem, 1);
7354 return ada_array_length (arg1, tem);
7357 else if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE
7358 || TYPE_CODE (type_arg) == TYPE_CODE_INT)
7360 struct type* range_type;
7361 char* name = ada_type_name (type_arg);
7364 if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE)
7365 range_type = type_arg;
7367 error ("unimplemented type attribute");
7371 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
7375 error ("unexpected attribute encountered");
7377 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7378 TYPE_LOW_BOUND (range_type));
7380 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7381 TYPE_HIGH_BOUND (range_type));
7384 else if (TYPE_CODE (type_arg) == TYPE_CODE_ENUM)
7389 error ("unexpected attribute encountered");
7391 return value_from_longest
7392 (type_arg, TYPE_FIELD_BITPOS (type_arg, 0));
7394 return value_from_longest
7396 TYPE_FIELD_BITPOS (type_arg,
7397 TYPE_NFIELDS (type_arg) - 1));
7400 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
7401 error ("unimplemented type attribute");
7406 if (ada_is_packed_array_type (type_arg))
7407 type_arg = decode_packed_array_type (type_arg);
7409 if (tem < 1 || tem > ada_array_arity (type_arg))
7410 error ("invalid dimension number to '%s",
7411 ada_attribute_name (atr));
7413 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7415 type = ada_index_type (type_arg, tem);
7417 error ("attempt to take bound of something that is not an array");
7418 return allocate_value (type);
7424 error ("unexpected attribute encountered");
7426 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7427 return value_from_longest (type, low);
7429 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
7430 return value_from_longest (type, high);
7432 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7433 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
7434 return value_from_longest (type, high-low+1);
7440 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7441 if (noside == EVAL_SKIP)
7444 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7446 value_zero (ada_tag_type (arg1), not_lval);
7448 return ada_value_tag (arg1);
7452 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7453 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7454 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7455 if (noside == EVAL_SKIP)
7457 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7458 return value_zero (VALUE_TYPE (arg1), not_lval);
7460 return value_binop (arg1, arg2,
7461 atr == ATR_MIN ? BINOP_MIN : BINOP_MAX);
7465 struct type* type_arg = exp->elts[pc + 5].type;
7466 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7469 if (noside == EVAL_SKIP)
7472 if (! ada_is_modular_type (type_arg))
7473 error ("'modulus must be applied to modular type");
7475 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
7476 ada_modulus (type_arg));
7481 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7482 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7483 if (noside == EVAL_SKIP)
7485 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7486 return value_zero (builtin_type_ada_int, not_lval);
7488 return value_pos_atr (arg1);
7491 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7492 if (noside == EVAL_SKIP)
7494 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7495 return value_zero (builtin_type_ada_int, not_lval);
7497 return value_from_longest (builtin_type_ada_int,
7499 * TYPE_LENGTH (VALUE_TYPE (arg1)));
7502 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7503 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7504 type = exp->elts[pc + 5].type;
7505 if (noside == EVAL_SKIP)
7507 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7508 return value_zero (type, not_lval);
7510 return value_val_atr (type, arg1);
7513 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7514 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7515 if (noside
== EVAL_SKIP
)
7517 if (binop_user_defined_p (op
, arg1
, arg2
))
7518 return unwrap_value (value_x_binop (arg1
, arg2
, op
, OP_NULL
,
7520 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7521 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7523 return value_binop (arg1
, arg2
, op
);
7526 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7527 if (noside
== EVAL_SKIP
)
7529 if (unop_user_defined_p (op
, arg1
))
7530 return unwrap_value (value_x_unop (arg1
, op
, EVAL_NORMAL
));
7535 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7536 if (noside
== EVAL_SKIP
)
7538 if (value_less (arg1
, value_zero (VALUE_TYPE (arg1
), not_lval
)))
7539 return value_neg (arg1
);
7544 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
7545 expect_type
= TYPE_TARGET_TYPE (check_typedef (expect_type
));
7546 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
7547 if (noside
== EVAL_SKIP
)
7549 type
= check_typedef (VALUE_TYPE (arg1
));
7550 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7552 if (ada_is_array_descriptor (type
))
7553 /* GDB allows dereferencing GNAT array descriptors. */
7555 struct type
*arrType
= ada_type_of_array (arg1
, 0);
7556 if (arrType
== NULL
)
7557 error ("Attempt to dereference null array pointer.");
7558 return value_at_lazy (arrType
, 0, NULL
);
7560 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
7561 || TYPE_CODE (type
) == TYPE_CODE_REF
7562 /* In C you can dereference an array to get the 1st elt. */
7563 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7566 (to_static_fixed_type
7567 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type
)))),
7569 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
7570 /* GDB allows dereferencing an int. */
7571 return value_zero (builtin_type_int
, lval_memory
);
7573 error ("Attempt to take contents of a non-pointer value.");
7575 arg1
= ada_coerce_ref (arg1
);
7576 type
= check_typedef (VALUE_TYPE (arg1
));
7578 if (ada_is_array_descriptor (type
))
7579 /* GDB allows dereferencing GNAT array descriptors. */
7580 return ada_coerce_to_simple_array (arg1
);
7582 return ada_value_ind (arg1
);
7584 case STRUCTOP_STRUCT
:
7585 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7586 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7587 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7588 if (noside
== EVAL_SKIP
)
7590 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7591 return value_zero (ada_aligned_type
7592 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7598 return unwrap_value (ada_value_struct_elt (arg1
,
7599 &exp
->elts
[pc
+ 2].string
,
7602 /* The value is not supposed to be used. This is here to make it
7603 easier to accommodate expressions that contain types. */
7605 if (noside
== EVAL_SKIP
)
7607 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7608 return allocate_value (builtin_type_void
);
7610 error ("Attempt to use a type name as an expression");
7613 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7614 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7615 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7616 if (noside
== EVAL_SKIP
)
7618 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7619 return value_zero (ada_aligned_type
7620 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7626 return unwrap_value (ada_value_struct_elt (arg1
,
7627 &exp
->elts
[pc
+ 2].string
,
7632 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
7638 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7639 type name that encodes the 'small and 'delta information.
7640 Otherwise, return NULL. */
7643 fixed_type_info (struct type
*type
)
7645 const char *name
= ada_type_name (type
);
7646 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
7648 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
7650 const char *tail
= strstr (name
, "___XF_");
7656 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
7657 return fixed_type_info (TYPE_TARGET_TYPE (type
));
7662 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7665 ada_is_fixed_point_type (struct type
*type
)
7667 return fixed_type_info (type
) != NULL
;
7670 /* Assuming that TYPE is the representation of an Ada fixed-point
7671 type, return its delta, or -1 if the type is malformed and the
7672 delta cannot be determined. */
7675 ada_delta (struct type
*type
)
7677 const char *encoding
= fixed_type_info (type
);
7680 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
7683 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
7686 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7687 factor ('SMALL value) associated with the type. */
7690 scaling_factor (struct type
*type
)
7692 const char *encoding
= fixed_type_info (type
);
7693 unsigned long num0
, den0
, num1
, den1
;
7696 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
7701 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
7703 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
7707 /* Assuming that X is the representation of a value of fixed-point
7708 type TYPE, return its floating-point equivalent. */
7711 ada_fixed_to_float (struct type
*type
, LONGEST x
)
7713 return (DOUBLEST
) x
*scaling_factor (type
);
7716 /* The representation of a fixed-point value of type TYPE
7717 corresponding to the value X. */
7720 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
7722 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
7726 /* VAX floating formats */
7728 /* Non-zero iff TYPE represents one of the special VAX floating-point
7731 ada_is_vax_floating_type (struct type
*type
)
7734 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
7737 && (TYPE_CODE (type
) == TYPE_CODE_INT
7738 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7739 && STREQN (ada_type_name (type
) + name_len
- 6, "___XF", 5);
7742 /* The type of special VAX floating-point type this is, assuming
7743 ada_is_vax_floating_point */
7745 ada_vax_float_type_suffix (struct type
*type
)
7747 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
7750 /* A value representing the special debugging function that outputs
7751 VAX floating-point values of the type represented by TYPE. Assumes
7752 ada_is_vax_floating_type (TYPE). */
7754 ada_vax_float_print_function (struct type
*type
)
7756 switch (ada_vax_float_type_suffix (type
))
7759 return get_var_value ("DEBUG_STRING_F", 0);
7761 return get_var_value ("DEBUG_STRING_D", 0);
7763 return get_var_value ("DEBUG_STRING_G", 0);
7765 error ("invalid VAX floating-point type");
7772 /* Scan STR beginning at position K for a discriminant name, and
7773 return the value of that discriminant field of DVAL in *PX. If
7774 PNEW_K is not null, put the position of the character beyond the
7775 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
7776 not alter *PX and *PNEW_K if unsuccessful. */
7779 scan_discrim_bound (char *, int k
, struct value
*dval
, LONGEST
* px
,
7782 static char *bound_buffer
= NULL
;
7783 static size_t bound_buffer_len
= 0;
7786 struct value
*bound_val
;
7788 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
7791 pend
= strstr (str
+ k
, "__");
7795 k
+= strlen (bound
);
7799 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
7800 bound
= bound_buffer
;
7801 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
7802 bound
[pend
- (str
+ k
)] = '\0';
7806 bound_val
= ada_search_struct_field (bound
, dval
, 0, VALUE_TYPE (dval
));
7807 if (bound_val
== NULL
)
7810 *px
= value_as_long (bound_val
);
7816 /* Value of variable named NAME in the current environment. If
7817 no such variable found, then if ERR_MSG is null, returns 0, and
7818 otherwise causes an error with message ERR_MSG. */
7819 static struct value
*
7820 get_var_value (char *name
, char *err_msg
)
7822 struct symbol
**syms
;
7823 struct block
**blocks
;
7827 ada_lookup_symbol_list (name
, get_selected_block (NULL
), VAR_NAMESPACE
,
7832 if (err_msg
== NULL
)
7835 error ("%s", err_msg
);
7838 return value_of_variable (syms
[0], blocks
[0]);
7841 /* Value of integer variable named NAME in the current environment. If
7842 no such variable found, then if ERR_MSG is null, returns 0, and sets
7843 *FLAG to 0. If successful, sets *FLAG to 1. */
7845 get_int_var_value (char *name
, char *err_msg
, int *flag
)
7847 struct value
*var_val
= get_var_value (name
, err_msg
);
7859 return value_as_long (var_val
);
7864 /* Return a range type whose base type is that of the range type named
7865 NAME in the current environment, and whose bounds are calculated
7866 from NAME according to the GNAT range encoding conventions.
7867 Extract discriminant values, if needed, from DVAL. If a new type
7868 must be created, allocate in OBJFILE's space. The bounds
7869 information, in general, is encoded in NAME, the base type given in
7870 the named range type. */
7872 static struct type
*
7873 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
7875 struct type
*raw_type
= ada_find_any_type (name
);
7876 struct type
*base_type
;
7880 if (raw_type
== NULL
)
7881 base_type
= builtin_type_int
;
7882 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
7883 base_type
= TYPE_TARGET_TYPE (raw_type
);
7885 base_type
= raw_type
;
7887 subtype_info
= strstr (name
, "___XD");
7888 if (subtype_info
== NULL
)
7892 static char *name_buf
= NULL
;
7893 static size_t name_len
= 0;
7894 int prefix_len
= subtype_info
- name
;
7900 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
7901 strncpy (name_buf
, name
, prefix_len
);
7902 name_buf
[prefix_len
] = '\0';
7905 bounds_str
= strchr (subtype_info
, '_');
7908 if (*subtype_info
== 'L')
7910 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
7911 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
7913 if (bounds_str
[n
] == '_')
7915 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
7921 strcpy (name_buf
+ prefix_len
, "___L");
7922 L
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7925 if (*subtype_info
== 'U')
7927 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
7928 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
7933 strcpy (name_buf
+ prefix_len
, "___U");
7934 U
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7937 if (objfile
== NULL
)
7938 objfile
= TYPE_OBJFILE (base_type
);
7939 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
7940 TYPE_NAME (type
) = name
;
7945 /* True iff NAME is the name of a range type. */
7947 ada_is_range_type_name (const char *name
)
7949 return (name
!= NULL
&& strstr (name
, "___XD"));
7955 /* True iff TYPE is an Ada modular type. */
7957 ada_is_modular_type (struct type
*type
)
7959 /* FIXME: base_type should be declared in gdbtypes.h, implemented in
7961 struct type
*subranged_type
; /* = base_type (type); */
7963 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
7964 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
7965 && TYPE_UNSIGNED (subranged_type
));
7968 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
7970 ada_modulus (struct type
* type
)
7972 return TYPE_HIGH_BOUND (type
) + 1;
7979 /* Table mapping opcodes into strings for printing operators
7980 and precedences of the operators. */
7982 static const struct op_print ada_op_print_tab
[] = {
7983 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
7984 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
7985 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
7986 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
7987 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
7988 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
7989 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
7990 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
7991 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
7992 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
7993 {">", BINOP_GTR
, PREC_ORDER
, 0},
7994 {"<", BINOP_LESS
, PREC_ORDER
, 0},
7995 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
7996 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
7997 {"+", BINOP_ADD
, PREC_ADD
, 0},
7998 {"-", BINOP_SUB
, PREC_ADD
, 0},
7999 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
8000 {"*", BINOP_MUL
, PREC_MUL
, 0},
8001 {"/", BINOP_DIV
, PREC_MUL
, 0},
8002 {"rem", BINOP_REM
, PREC_MUL
, 0},
8003 {"mod", BINOP_MOD
, PREC_MUL
, 0},
8004 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
8005 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
8006 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
8007 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
8008 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
8009 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
8010 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
8011 {".all", UNOP_IND
, PREC_SUFFIX
, 1}, /* FIXME: postfix .ALL */
8012 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1}, /* FIXME: postfix 'ACCESS */
8016 /* Assorted Types and Interfaces */
8018 struct type
*builtin_type_ada_int
;
8019 struct type
*builtin_type_ada_short
;
8020 struct type
*builtin_type_ada_long
;
8021 struct type
*builtin_type_ada_long_long
;
8022 struct type
*builtin_type_ada_char
;
8023 struct type
*builtin_type_ada_float
;
8024 struct type
*builtin_type_ada_double
;
8025 struct type
*builtin_type_ada_long_double
;
8026 struct type
*builtin_type_ada_natural
;
8027 struct type
*builtin_type_ada_positive
;
8028 struct type
*builtin_type_ada_system_address
;
8030 struct type
**const (ada_builtin_types
[]) =
8033 &builtin_type_ada_int
,
8034 &builtin_type_ada_long
,
8035 &builtin_type_ada_short
,
8036 &builtin_type_ada_char
,
8037 &builtin_type_ada_float
,
8038 &builtin_type_ada_double
,
8039 &builtin_type_ada_long_long
,
8040 &builtin_type_ada_long_double
,
8041 &builtin_type_ada_natural
, &builtin_type_ada_positive
,
8042 /* The following types are carried over from C for convenience. */
8045 &builtin_type_short
,
8047 &builtin_type_float
,
8048 &builtin_type_double
,
8049 &builtin_type_long_long
,
8051 &builtin_type_signed_char
,
8052 &builtin_type_unsigned_char
,
8053 &builtin_type_unsigned_short
,
8054 &builtin_type_unsigned_int
,
8055 &builtin_type_unsigned_long
,
8056 &builtin_type_unsigned_long_long
,
8057 &builtin_type_long_double
,
8058 &builtin_type_complex
, &builtin_type_double_complex
, 0};
8060 /* Not really used, but needed in the ada_language_defn. */
8062 emit_char (int c
, struct ui_file
*stream
, int quoter
)
8064 ada_emit_char (c
, stream
, quoter
, 1);
8067 const struct language_defn ada_language_defn
= {
8068 "ada", /* Language name */
8071 /* FIXME: language_ada should be defined in defs.h */
8075 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8076 * that's not quite what this means. */
8079 ada_evaluate_subexp
,
8080 ada_printchar
, /* Print a character constant */
8081 ada_printstr
, /* Function to print string constant */
8082 emit_char
, /* Function to print single char (not used) */
8083 ada_create_fundamental_type
, /* Create fundamental type in this language */
8084 ada_print_type
, /* Print a type using appropriate syntax */
8085 ada_val_print
, /* Print a value using appropriate syntax */
8086 ada_value_print
, /* Print a top-level value */
8087 {"", "", "", ""}, /* Binary format info */
8089 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
8090 {"%ld", "", "d", ""}, /* Decimal format info */
8091 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
8093 /* Copied from c-lang.c. */
8094 {"0%lo", "0", "o", ""}, /* Octal format info */
8095 {"%ld", "", "d", ""}, /* Decimal format info */
8096 {"0x%lx", "0x", "x", ""}, /* Hex format info */
8098 ada_op_print_tab
, /* expression operators for printing */
8099 1, /* c-style arrays (FIXME?) */
8100 0, /* String lower bound (FIXME?) */
8101 &builtin_type_ada_char
,
8106 _initialize_ada_language (void)
8108 builtin_type_ada_int
=
8109 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8110 0, "integer", (struct objfile
*) NULL
);
8111 builtin_type_ada_long
=
8112 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8113 0, "long_integer", (struct objfile
*) NULL
);
8114 builtin_type_ada_short
=
8115 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8116 0, "short_integer", (struct objfile
*) NULL
);
8117 builtin_type_ada_char
=
8118 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8119 0, "character", (struct objfile
*) NULL
);
8120 builtin_type_ada_float
=
8121 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8122 0, "float", (struct objfile
*) NULL
);
8123 builtin_type_ada_double
=
8124 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8125 0, "long_float", (struct objfile
*) NULL
);
8126 builtin_type_ada_long_long
=
8127 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8128 0, "long_long_integer", (struct objfile
*) NULL
);
8129 builtin_type_ada_long_double
=
8130 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8131 0, "long_long_float", (struct objfile
*) NULL
);
8132 builtin_type_ada_natural
=
8133 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8134 0, "natural", (struct objfile
*) NULL
);
8135 builtin_type_ada_positive
=
8136 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8137 0, "positive", (struct objfile
*) NULL
);
8140 builtin_type_ada_system_address
=
8141 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8142 (struct objfile
*) NULL
));
8143 TYPE_NAME (builtin_type_ada_system_address
) = "system__address";
8145 add_language (&ada_language_defn
);
8148 (add_set_cmd ("varsize-limit", class_support
, var_uinteger
,
8149 (char *) &varsize_limit
,
8150 "Set maximum bytes in dynamic-sized object.",
8151 &setlist
), &showlist
);
8152 varsize_limit
= 65536;
8154 add_com ("begin", class_breakpoint
, begin_command
,
8155 "Start the debugged program, stopping at the beginning of the\n\
8156 main program. You may specify command-line arguments to give it, as for\n\
8157 the \"run\" command (q.v.).");
8161 /* Create a fundamental Ada type using default reasonable for the current
8164 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8165 define fundamental types such as "int" or "double". Others (stabs or
8166 DWARF version 2, etc) do define fundamental types. For the formats which
8167 don't provide fundamental types, gdb can create such types using this
8170 FIXME: Some compilers distinguish explicitly signed integral types
8171 (signed short, signed int, signed long) from "regular" integral types
8172 (short, int, long) in the debugging information. There is some dis-
8173 agreement as to how useful this feature is. In particular, gcc does
8174 not support this. Also, only some debugging formats allow the
8175 distinction to be passed on to a debugger. For now, we always just
8176 use "short", "int", or "long" as the type name, for both the implicit
8177 and explicitly signed types. This also makes life easier for the
8178 gdb test suite since we don't have to account for the differences
8179 in output depending upon what the compiler and debugging format
8180 support. We will probably have to re-examine the issue when gdb
8181 starts taking it's fundamental type information directly from the
8182 debugging information supplied by the compiler. fnf@cygnus.com */
8184 static struct type
*
8185 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8187 struct type
*type
= NULL
;
8192 /* FIXME: For now, if we are asked to produce a type not in this
8193 language, create the equivalent of a C integer type with the
8194 name "<?type?>". When all the dust settles from the type
8195 reconstruction work, this should probably become an error. */
8196 type
= init_type (TYPE_CODE_INT
,
8197 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8198 0, "<?type?>", objfile
);
8199 warning ("internal error: no Ada fundamental type %d", typeid);
8202 type
= init_type (TYPE_CODE_VOID
,
8203 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8204 0, "void", objfile
);
8207 type
= init_type (TYPE_CODE_INT
,
8208 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8209 0, "character", objfile
);
8211 case FT_SIGNED_CHAR
:
8212 type
= init_type (TYPE_CODE_INT
,
8213 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8214 0, "signed char", objfile
);
8216 case FT_UNSIGNED_CHAR
:
8217 type
= init_type (TYPE_CODE_INT
,
8218 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8219 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8222 type
= init_type (TYPE_CODE_INT
,
8223 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8224 0, "short_integer", objfile
);
8226 case FT_SIGNED_SHORT
:
8227 type
= init_type (TYPE_CODE_INT
,
8228 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8229 0, "short_integer", objfile
);
8231 case FT_UNSIGNED_SHORT
:
8232 type
= init_type (TYPE_CODE_INT
,
8233 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8234 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8237 type
= init_type (TYPE_CODE_INT
,
8238 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8239 0, "integer", objfile
);
8241 case FT_SIGNED_INTEGER
:
8242 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
, 0, "integer", objfile
); /* FIXME -fnf */
8244 case FT_UNSIGNED_INTEGER
:
8245 type
= init_type (TYPE_CODE_INT
,
8246 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8247 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8250 type
= init_type (TYPE_CODE_INT
,
8251 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8252 0, "long_integer", objfile
);
8254 case FT_SIGNED_LONG
:
8255 type
= init_type (TYPE_CODE_INT
,
8256 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8257 0, "long_integer", objfile
);
8259 case FT_UNSIGNED_LONG
:
8260 type
= init_type (TYPE_CODE_INT
,
8261 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8262 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8265 type
= init_type (TYPE_CODE_INT
,
8266 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8267 0, "long_long_integer", objfile
);
8269 case FT_SIGNED_LONG_LONG
:
8270 type
= init_type (TYPE_CODE_INT
,
8271 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8272 0, "long_long_integer", objfile
);
8274 case FT_UNSIGNED_LONG_LONG
:
8275 type
= init_type (TYPE_CODE_INT
,
8276 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8277 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8280 type
= init_type (TYPE_CODE_FLT
,
8281 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8282 0, "float", objfile
);
8284 case FT_DBL_PREC_FLOAT
:
8285 type
= init_type (TYPE_CODE_FLT
,
8286 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8287 0, "long_float", objfile
);
8289 case FT_EXT_PREC_FLOAT
:
8290 type
= init_type (TYPE_CODE_FLT
,
8291 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8292 0, "long_long_float", objfile
);
8299 ada_dump_symtab (struct symtab
*s
)
8302 fprintf (stderr
, "New symtab: [\n");
8303 fprintf (stderr
, " Name: %s/%s;\n",
8304 s
->dirname
? s
->dirname
: "?", s
->filename
? s
->filename
: "?");
8305 fprintf (stderr
, " Format: %s;\n", s
->debugformat
);
8306 if (s
->linetable
!= NULL
)
8308 fprintf (stderr
, " Line table (section %d):\n", s
->block_line_section
);
8309 for (i
= 0; i
< s
->linetable
->nitems
; i
+= 1)
8311 struct linetable_entry
*e
= s
->linetable
->item
+ i
;
8312 fprintf (stderr
, " %4ld: %8lx\n", (long) e
->line
, (long) e
->pc
);
8315 fprintf (stderr
, "]\n");