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
5036 fi->pc points at the return instruction (which is *after* the
5037 call instruction), and we want to get the line containing the
5038 call (because the call is where the user thinks the program
5039 is). However, if the next frame is either a SIGTRAMP_FRAME
5040 or a DUMMY_FRAME, then the next frame will contain a saved
5041 interrupt PC and such a PC indicates the current (rather than
5042 next) instruction/line, consequently, for such cases, want to
5043 get the line containing fi->pc. */
5045 find_pc_line (fi
->pc
,
5047 && !(get_frame_type (fi
->next
) == SIGTRAMP_FRAME
)
5048 && !deprecated_frame_in_dummy (fi
->next
));
5049 if (sal
.symtab
&& !is_ada_runtime_file (sal
.symtab
->filename
))
5051 #if defined(__alpha__) && defined(__osf__) && !defined(VXWORKS_TARGET)
5052 /* libpthread.so contains some debugging information that prevents us
5053 from finding the right frame */
5055 if (sal
.symtab
->objfile
&&
5056 STREQ (sal
.symtab
->objfile
->name
, "/usr/shlib/libpthread.so"))
5059 selected_frame
= fi
;
5068 ada_report_exception_break (struct breakpoint
*b
)
5071 /* FIXME: break_on_exception should be defined in breakpoint.h */
5072 /* if (b->break_on_exception == 1)
5074 /* Assume that cond has 16 elements, the 15th
5075 being the exception *//*
5076 if (b->cond && b->cond->nelts == 16)
5078 ui_out_text (uiout, "on ");
5079 ui_out_field_string (uiout, "exception",
5080 SYMBOL_NAME (b->cond->elts[14].symbol));
5083 ui_out_text (uiout, "on all exceptions");
5085 else if (b->break_on_exception == 2)
5086 ui_out_text (uiout, "on unhandled exception");
5087 else if (b->break_on_exception == 3)
5088 ui_out_text (uiout, "on assert failure");
5090 if (b->break_on_exception == 1)
5092 /* Assume that cond has 16 elements, the 15th
5093 being the exception *//*
5094 if (b->cond && b->cond->nelts == 16)
5096 fputs_filtered ("on ", gdb_stdout);
5097 fputs_filtered (SYMBOL_NAME
5098 (b->cond->elts[14].symbol), gdb_stdout);
5101 fputs_filtered ("on all exceptions", gdb_stdout);
5103 else if (b->break_on_exception == 2)
5104 fputs_filtered ("on unhandled exception", gdb_stdout);
5105 else if (b->break_on_exception == 3)
5106 fputs_filtered ("on assert failure", gdb_stdout);
5112 ada_is_exception_sym (struct symbol
*sym
)
5114 char *type_name
= type_name_no_tag (SYMBOL_TYPE (sym
));
5116 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5117 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5118 && SYMBOL_CLASS (sym
) != LOC_CONST
5119 && type_name
!= NULL
&& STREQ (type_name
, "exception"));
5123 ada_maybe_exception_partial_symbol (struct partial_symbol
*sym
)
5125 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5126 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5127 && SYMBOL_CLASS (sym
) != LOC_CONST
);
5130 /* If ARG points to an Ada exception or assert breakpoint, rewrite
5131 into equivalent form. Return resulting argument string. Set
5132 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
5133 break on unhandled, 3 for assert, 0 otherwise. */
5135 ada_breakpoint_rewrite (char *arg
, int *break_on_exceptionp
)
5139 *break_on_exceptionp
= 0;
5140 /* FIXME: language_ada should be defined in defs.h */
5141 /* if (current_language->la_language == language_ada
5142 && STREQN (arg, "exception", 9) &&
5143 (arg[9] == ' ' || arg[9] == '\t' || arg[9] == '\0'))
5145 char *tok, *end_tok;
5148 *break_on_exceptionp = 1;
5151 while (*tok == ' ' || *tok == '\t')
5156 while (*end_tok != ' ' && *end_tok != '\t' && *end_tok != '\000')
5159 toklen = end_tok - tok;
5161 arg = (char*) xmalloc (sizeof ("__gnat_raise_nodefer_with_msg if "
5162 "long_integer(e) = long_integer(&)")
5164 make_cleanup (xfree, arg);
5166 strcpy (arg, "__gnat_raise_nodefer_with_msg");
5167 else if (STREQN (tok, "unhandled", toklen))
5169 *break_on_exceptionp = 2;
5170 strcpy (arg, "__gnat_unhandled_exception");
5174 sprintf (arg, "__gnat_raise_nodefer_with_msg if "
5175 "long_integer(e) = long_integer(&%.*s)",
5179 else if (current_language->la_language == language_ada
5180 && STREQN (arg, "assert", 6) &&
5181 (arg[6] == ' ' || arg[6] == '\t' || arg[6] == '\0'))
5183 char *tok = arg + 6;
5185 *break_on_exceptionp = 3;
5188 xmalloc (sizeof ("system__assertions__raise_assert_failure")
5189 + strlen (tok) + 1);
5190 make_cleanup (xfree, arg);
5191 sprintf (arg, "system__assertions__raise_assert_failure%s", tok);
5200 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5201 to be invisible to users. */
5204 ada_is_ignored_field (struct type
*type
, int field_num
)
5206 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5210 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5211 return (name
== NULL
5212 || (name
[0] == '_' && !STREQN (name
, "_parent", 7)));
5216 /* True iff structure type TYPE has a tag field. */
5219 ada_is_tagged_type (struct type
*type
)
5221 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5224 return (ada_lookup_struct_elt_type (type
, "_tag", 1, NULL
) != NULL
);
5227 /* The type of the tag on VAL. */
5230 ada_tag_type (struct value
*val
)
5232 return ada_lookup_struct_elt_type (VALUE_TYPE (val
), "_tag", 0, NULL
);
5235 /* The value of the tag on VAL. */
5238 ada_value_tag (struct value
*val
)
5240 return ada_value_struct_elt (val
, "_tag", "record");
5243 /* The parent type of TYPE, or NULL if none. */
5246 ada_parent_type (struct type
*type
)
5250 CHECK_TYPEDEF (type
);
5252 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5255 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5256 if (ada_is_parent_field (type
, i
))
5257 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5262 /* True iff field number FIELD_NUM of structure type TYPE contains the
5263 parent-type (inherited) fields of a derived type. Assumes TYPE is
5264 a structure type with at least FIELD_NUM+1 fields. */
5267 ada_is_parent_field (struct type
*type
, int field_num
)
5269 const char *name
= TYPE_FIELD_NAME (check_typedef (type
), field_num
);
5270 return (name
!= NULL
&&
5271 (STREQN (name
, "PARENT", 6) || STREQN (name
, "_parent", 7)));
5274 /* True iff field number FIELD_NUM of structure type TYPE is a
5275 transparent wrapper field (which should be silently traversed when doing
5276 field selection and flattened when printing). Assumes TYPE is a
5277 structure type with at least FIELD_NUM+1 fields. Such fields are always
5281 ada_is_wrapper_field (struct type
*type
, int field_num
)
5283 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5284 return (name
!= NULL
5285 && (STREQN (name
, "PARENT", 6) || STREQ (name
, "REP")
5286 || STREQN (name
, "_parent", 7)
5287 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5290 /* True iff field number FIELD_NUM of structure or union type TYPE
5291 is a variant wrapper. Assumes TYPE is a structure type with at least
5292 FIELD_NUM+1 fields. */
5295 ada_is_variant_part (struct type
*type
, int field_num
)
5297 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5298 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5299 || (is_dynamic_field (type
, field_num
)
5300 && TYPE_CODE (TYPE_TARGET_TYPE (field_type
)) ==
5304 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5305 whose discriminants are contained in the record type OUTER_TYPE,
5306 returns the type of the controlling discriminant for the variant. */
5309 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5311 char *name
= ada_variant_discrim_name (var_type
);
5312 struct type
*type
= ada_lookup_struct_elt_type (outer_type
, name
, 1, NULL
);
5314 return builtin_type_int
;
5319 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5320 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5321 represents a 'when others' clause; otherwise 0. */
5324 ada_is_others_clause (struct type
*type
, int field_num
)
5326 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5327 return (name
!= NULL
&& name
[0] == 'O');
5330 /* Assuming that TYPE0 is the type of the variant part of a record,
5331 returns the name of the discriminant controlling the variant. The
5332 value is valid until the next call to ada_variant_discrim_name. */
5335 ada_variant_discrim_name (struct type
*type0
)
5337 static char *result
= NULL
;
5338 static size_t result_len
= 0;
5341 const char *discrim_end
;
5342 const char *discrim_start
;
5344 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5345 type
= TYPE_TARGET_TYPE (type0
);
5349 name
= ada_type_name (type
);
5351 if (name
== NULL
|| name
[0] == '\000')
5354 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5357 if (STREQN (discrim_end
, "___XVN", 6))
5360 if (discrim_end
== name
)
5363 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5366 if (discrim_start
== name
+ 1)
5368 if ((discrim_start
> name
+ 3 && STREQN (discrim_start
- 3, "___", 3))
5369 || discrim_start
[-1] == '.')
5373 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5374 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5375 result
[discrim_end
- discrim_start
] = '\0';
5379 /* Scan STR for a subtype-encoded number, beginning at position K. Put the
5380 position of the character just past the number scanned in *NEW_K,
5381 if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL. Return 1
5382 if there was a valid number at the given position, and 0 otherwise. A
5383 "subtype-encoded" number consists of the absolute value in decimal,
5384 followed by the letter 'm' to indicate a negative number. Assumes 0m
5388 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5392 if (!isdigit (str
[k
]))
5395 /* Do it the hard way so as not to make any assumption about
5396 the relationship of unsigned long (%lu scan format code) and
5399 while (isdigit (str
[k
]))
5401 RU
= RU
* 10 + (str
[k
] - '0');
5408 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5414 /* NOTE on the above: Technically, C does not say what the results of
5415 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5416 number representable as a LONGEST (although either would probably work
5417 in most implementations). When RU>0, the locution in the then branch
5418 above is always equivalent to the negative of RU. */
5425 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5426 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5427 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5430 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5432 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5445 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5454 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5455 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5457 if (val
>= L
&& val
<= U
)
5469 /* Given a value ARG1 (offset by OFFSET bytes)
5470 of a struct or union type ARG_TYPE,
5471 extract and return the value of one of its (non-static) fields.
5472 FIELDNO says which field. Differs from value_primitive_field only
5473 in that it can handle packed values of arbitrary type. */
5476 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5477 struct type
*arg_type
)
5482 CHECK_TYPEDEF (arg_type
);
5483 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5485 /* Handle packed fields */
5487 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5489 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5490 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5492 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
5493 offset
+ bit_pos
/ 8,
5494 bit_pos
% 8, bit_size
, type
);
5497 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5501 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5502 and search in it assuming it has (class) type TYPE.
5503 If found, return value, else return NULL.
5505 Searches recursively through wrapper fields (e.g., '_parent'). */
5508 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5512 CHECK_TYPEDEF (type
);
5514 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5516 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5518 if (t_field_name
== NULL
)
5521 else if (field_name_match (t_field_name
, name
))
5522 return ada_value_primitive_field (arg
, offset
, i
, type
);
5524 else if (ada_is_wrapper_field (type
, i
))
5526 struct value
*v
= ada_search_struct_field (name
, arg
,
5528 TYPE_FIELD_BITPOS (type
,
5531 TYPE_FIELD_TYPE (type
,
5537 else if (ada_is_variant_part (type
, i
))
5540 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5541 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5543 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5545 struct value
*v
= ada_search_struct_field (name
, arg
,
5549 (field_type
, j
) / 8,
5560 /* Given ARG, a value of type (pointer to a)* structure/union,
5561 extract the component named NAME from the ultimate target structure/union
5562 and return it as a value with its appropriate type.
5564 The routine searches for NAME among all members of the structure itself
5565 and (recursively) among all members of any wrapper members
5568 ERR is a name (for use in error messages) that identifies the class
5569 of entity that ARG is supposed to be. */
5572 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5577 arg
= ada_coerce_ref (arg
);
5578 t
= check_typedef (VALUE_TYPE (arg
));
5580 /* Follow pointers until we get to a non-pointer. */
5582 while (TYPE_CODE (t
) == TYPE_CODE_PTR
|| TYPE_CODE (t
) == TYPE_CODE_REF
)
5584 arg
= ada_value_ind (arg
);
5585 t
= check_typedef (VALUE_TYPE (arg
));
5588 if (TYPE_CODE (t
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t
) != TYPE_CODE_UNION
)
5589 error ("Attempt to extract a component of a value that is not a %s.",
5592 v
= ada_search_struct_field (name
, arg
, 0, t
);
5594 error ("There is no member named %s.", name
);
5599 /* Given a type TYPE, look up the type of the component of type named NAME.
5600 If DISPP is non-null, add its byte displacement from the beginning of a
5601 structure (pointed to by a value) of type TYPE to *DISPP (does not
5602 work for packed fields).
5604 Matches any field whose name has NAME as a prefix, possibly
5607 TYPE can be either a struct or union, or a pointer or reference to
5608 a struct or union. If it is a pointer or reference, its target
5609 type is automatically used.
5611 Looks recursively into variant clauses and parent types.
5613 If NOERR is nonzero, return NULL if NAME is not suitably defined. */
5616 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int noerr
,
5626 CHECK_TYPEDEF (type
);
5627 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5628 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5630 type
= TYPE_TARGET_TYPE (type
);
5633 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
&&
5634 TYPE_CODE (type
) != TYPE_CODE_UNION
)
5636 target_terminal_ours ();
5637 gdb_flush (gdb_stdout
);
5638 fprintf_unfiltered (gdb_stderr
, "Type ");
5639 type_print (type
, "", gdb_stderr
, -1);
5640 error (" is not a structure or union type");
5643 type
= to_static_fixed_type (type
);
5645 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5647 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5651 if (t_field_name
== NULL
)
5654 else if (field_name_match (t_field_name
, name
))
5657 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5658 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5661 else if (ada_is_wrapper_field (type
, i
))
5664 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5669 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5674 else if (ada_is_variant_part (type
, i
))
5677 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5679 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5682 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5687 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5698 target_terminal_ours ();
5699 gdb_flush (gdb_stdout
);
5700 fprintf_unfiltered (gdb_stderr
, "Type ");
5701 type_print (type
, "", gdb_stderr
, -1);
5702 fprintf_unfiltered (gdb_stderr
, " has no component named ");
5703 error ("%s", name
== NULL
? "<null>" : name
);
5709 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5710 within a value of type OUTER_TYPE that is stored in GDB at
5711 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5712 numbering from 0) is applicable. Returns -1 if none are. */
5715 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5716 char *outer_valaddr
)
5721 struct type
*discrim_type
;
5722 char *discrim_name
= ada_variant_discrim_name (var_type
);
5723 LONGEST discrim_val
;
5727 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, &disp
);
5728 if (discrim_type
== NULL
)
5730 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5733 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5735 if (ada_is_others_clause (var_type
, i
))
5737 else if (ada_in_variant (discrim_val
, var_type
, i
))
5741 return others_clause
;
5746 /* Dynamic-Sized Records */
5748 /* Strategy: The type ostensibly attached to a value with dynamic size
5749 (i.e., a size that is not statically recorded in the debugging
5750 data) does not accurately reflect the size or layout of the value.
5751 Our strategy is to convert these values to values with accurate,
5752 conventional types that are constructed on the fly. */
5754 /* There is a subtle and tricky problem here. In general, we cannot
5755 determine the size of dynamic records without its data. However,
5756 the 'struct value' data structure, which GDB uses to represent
5757 quantities in the inferior process (the target), requires the size
5758 of the type at the time of its allocation in order to reserve space
5759 for GDB's internal copy of the data. That's why the
5760 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5761 rather than struct value*s.
5763 However, GDB's internal history variables ($1, $2, etc.) are
5764 struct value*s containing internal copies of the data that are not, in
5765 general, the same as the data at their corresponding addresses in
5766 the target. Fortunately, the types we give to these values are all
5767 conventional, fixed-size types (as per the strategy described
5768 above), so that we don't usually have to perform the
5769 'to_fixed_xxx_type' conversions to look at their values.
5770 Unfortunately, there is one exception: if one of the internal
5771 history variables is an array whose elements are unconstrained
5772 records, then we will need to create distinct fixed types for each
5773 element selected. */
5775 /* The upshot of all of this is that many routines take a (type, host
5776 address, target address) triple as arguments to represent a value.
5777 The host address, if non-null, is supposed to contain an internal
5778 copy of the relevant data; otherwise, the program is to consult the
5779 target at the target address. */
5781 /* Assuming that VAL0 represents a pointer value, the result of
5782 dereferencing it. Differs from value_ind in its treatment of
5783 dynamic-sized types. */
5786 ada_value_ind (struct value
*val0
)
5788 struct value
*val
= unwrap_value (value_ind (val0
));
5789 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5790 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
), val
);
5793 /* The value resulting from dereferencing any "reference to"
5794 * qualifiers on VAL0. */
5795 static struct value
*
5796 ada_coerce_ref (struct value
*val0
)
5798 if (TYPE_CODE (VALUE_TYPE (val0
)) == TYPE_CODE_REF
)
5800 struct value
*val
= val0
;
5802 val
= unwrap_value (val
);
5803 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5804 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
5811 /* Return OFF rounded upward if necessary to a multiple of
5812 ALIGNMENT (a power of 2). */
5815 align_value (unsigned int off
, unsigned int alignment
)
5817 return (off
+ alignment
- 1) & ~(alignment
- 1);
5820 /* Return the additional bit offset required by field F of template
5824 field_offset (struct type
*type
, int f
)
5826 int n
= TYPE_FIELD_BITPOS (type
, f
);
5827 /* Kludge (temporary?) to fix problem with dwarf output. */
5829 return (unsigned int) n
& 0xffff;
5835 /* Return the bit alignment required for field #F of template type TYPE. */
5838 field_alignment (struct type
*type
, int f
)
5840 const char *name
= TYPE_FIELD_NAME (type
, f
);
5841 int len
= (name
== NULL
) ? 0 : strlen (name
);
5844 if (len
< 8 || !isdigit (name
[len
- 1]))
5845 return TARGET_CHAR_BIT
;
5847 if (isdigit (name
[len
- 2]))
5848 align_offset
= len
- 2;
5850 align_offset
= len
- 1;
5852 if (align_offset
< 7 || !STREQN ("___XV", name
+ align_offset
- 6, 5))
5853 return TARGET_CHAR_BIT
;
5855 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
5858 /* Find a type named NAME. Ignores ambiguity. */
5860 ada_find_any_type (const char *name
)
5864 sym
= standard_lookup (name
, VAR_NAMESPACE
);
5865 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5866 return SYMBOL_TYPE (sym
);
5868 sym
= standard_lookup (name
, STRUCT_NAMESPACE
);
5870 return SYMBOL_TYPE (sym
);
5875 /* Because of GNAT encoding conventions, several GDB symbols may match a
5876 given type name. If the type denoted by TYPE0 is to be preferred to
5877 that of TYPE1 for purposes of type printing, return non-zero;
5878 otherwise return 0. */
5880 ada_prefer_type (struct type
*type0
, struct type
*type1
)
5884 else if (type0
== NULL
)
5886 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
5888 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
5890 else if (ada_is_packed_array_type (type0
))
5892 else if (ada_is_array_descriptor (type0
)
5893 && !ada_is_array_descriptor (type1
))
5895 else if (ada_renaming_type (type0
) != NULL
5896 && ada_renaming_type (type1
) == NULL
)
5901 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5902 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5904 ada_type_name (struct type
*type
)
5908 else if (TYPE_NAME (type
) != NULL
)
5909 return TYPE_NAME (type
);
5911 return TYPE_TAG_NAME (type
);
5914 /* Find a parallel type to TYPE whose name is formed by appending
5915 SUFFIX to the name of TYPE. */
5918 ada_find_parallel_type (struct type
*type
, const char *suffix
)
5921 static size_t name_len
= 0;
5922 struct symbol
**syms
;
5923 struct block
**blocks
;
5926 char *typename
= ada_type_name (type
);
5928 if (typename
== NULL
)
5931 len
= strlen (typename
);
5933 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
5935 strcpy (name
, typename
);
5936 strcpy (name
+ len
, suffix
);
5938 return ada_find_any_type (name
);
5942 /* If TYPE is a variable-size record type, return the corresponding template
5943 type describing its fields. Otherwise, return NULL. */
5945 static struct type
*
5946 dynamic_template_type (struct type
*type
)
5948 CHECK_TYPEDEF (type
);
5950 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5951 || ada_type_name (type
) == NULL
)
5955 int len
= strlen (ada_type_name (type
));
5956 if (len
> 6 && STREQ (ada_type_name (type
) + len
- 6, "___XVE"))
5959 return ada_find_parallel_type (type
, "___XVE");
5963 /* Assuming that TEMPL_TYPE is a union or struct type, returns
5964 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
5967 is_dynamic_field (struct type
*templ_type
, int field_num
)
5969 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
5971 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
5972 && strstr (name
, "___XVL") != NULL
;
5975 /* Assuming that TYPE is a struct type, returns non-zero iff TYPE
5976 contains a variant part. */
5979 contains_variant_part (struct type
*type
)
5983 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5984 || TYPE_NFIELDS (type
) <= 0)
5986 return ada_is_variant_part (type
, TYPE_NFIELDS (type
) - 1);
5989 /* A record type with no fields, . */
5990 static struct type
*
5991 empty_record (struct objfile
*objfile
)
5993 struct type
*type
= alloc_type (objfile
);
5994 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
5995 TYPE_NFIELDS (type
) = 0;
5996 TYPE_FIELDS (type
) = NULL
;
5997 TYPE_NAME (type
) = "<empty>";
5998 TYPE_TAG_NAME (type
) = NULL
;
5999 TYPE_FLAGS (type
) = 0;
6000 TYPE_LENGTH (type
) = 0;
6004 /* An ordinary record type (with fixed-length fields) that describes
6005 the value of type TYPE at VALADDR or ADDRESS (see comments at
6006 the beginning of this section) VAL according to GNAT conventions.
6007 DVAL0 should describe the (portion of a) record that contains any
6008 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
6009 an outer-level type (i.e., as opposed to a branch of a variant.) A
6010 variant field (unless unchecked) is replaced by a particular branch
6012 /* NOTE: Limitations: For now, we assume that dynamic fields and
6013 * variants occupy whole numbers of bytes. However, they need not be
6016 static struct type
*
6017 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
6018 CORE_ADDR address
, struct value
*dval0
)
6020 struct value
*mark
= value_mark ();
6023 int nfields
, bit_len
;
6027 nfields
= TYPE_NFIELDS (type
);
6028 rtype
= alloc_type (TYPE_OBJFILE (type
));
6029 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6030 INIT_CPLUS_SPECIFIC (rtype
);
6031 TYPE_NFIELDS (rtype
) = nfields
;
6032 TYPE_FIELDS (rtype
) = (struct field
*)
6033 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6034 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6035 TYPE_NAME (rtype
) = ada_type_name (type
);
6036 TYPE_TAG_NAME (rtype
) = NULL
;
6037 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in
6039 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6043 for (f
= 0; f
< nfields
; f
+= 1)
6045 int fld_bit_len
, bit_incr
;
6048 field_alignment (type
, f
)) + TYPE_FIELD_BITPOS (type
, f
);
6049 /* NOTE: used to use field_offset above, but that causes
6050 * problems with really negative bit positions. So, let's
6051 * rediscover why we needed field_offset and fix it properly. */
6052 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6053 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6054 TYPE_FIELD_STATIC_KIND (rtype
, f
) = 0;
6056 if (ada_is_variant_part (type
, f
))
6058 struct type
*branch_type
;
6061 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6066 to_fixed_variant_branch_type
6067 (TYPE_FIELD_TYPE (type
, f
),
6068 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6069 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6070 if (branch_type
== NULL
)
6071 TYPE_NFIELDS (rtype
) -= 1;
6074 TYPE_FIELD_TYPE (rtype
, f
) = branch_type
;
6075 TYPE_FIELD_NAME (rtype
, f
) = "S";
6079 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6081 else if (is_dynamic_field (type
, f
))
6084 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6088 TYPE_FIELD_TYPE (rtype
, f
) =
6091 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6092 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6093 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6094 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6095 bit_incr
= fld_bit_len
=
6096 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6100 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6101 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6102 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6103 bit_incr
= fld_bit_len
=
6104 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6106 bit_incr
= fld_bit_len
=
6107 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6109 if (off
+ fld_bit_len
> bit_len
)
6110 bit_len
= off
+ fld_bit_len
;
6112 TYPE_LENGTH (rtype
) = bit_len
/ TARGET_CHAR_BIT
;
6114 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
), TYPE_LENGTH (type
));
6116 value_free_to_mark (mark
);
6117 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6118 error ("record type with dynamic size is larger than varsize-limit");
6122 /* As for template_to_fixed_record_type, but uses no run-time values.
6123 As a result, this type can only be approximate, but that's OK,
6124 since it is used only for type determinations. Works on both
6126 Representation note: to save space, we memoize the result of this
6127 function in the TYPE_TARGET_TYPE of the template type. */
6129 static struct type
*
6130 template_to_static_fixed_type (struct type
*templ_type
)
6136 if (TYPE_TARGET_TYPE (templ_type
) != NULL
)
6137 return TYPE_TARGET_TYPE (templ_type
);
6139 nfields
= TYPE_NFIELDS (templ_type
);
6140 TYPE_TARGET_TYPE (templ_type
) = type
=
6141 alloc_type (TYPE_OBJFILE (templ_type
));
6142 TYPE_CODE (type
) = TYPE_CODE (templ_type
);
6143 INIT_CPLUS_SPECIFIC (type
);
6144 TYPE_NFIELDS (type
) = nfields
;
6145 TYPE_FIELDS (type
) = (struct field
*)
6146 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6147 memset (TYPE_FIELDS (type
), 0, sizeof (struct field
) * nfields
);
6148 TYPE_NAME (type
) = ada_type_name (templ_type
);
6149 TYPE_TAG_NAME (type
) = NULL
;
6150 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6151 /* TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE; */
6152 TYPE_LENGTH (type
) = 0;
6154 for (f
= 0; f
< nfields
; f
+= 1)
6156 TYPE_FIELD_BITPOS (type
, f
) = 0;
6157 TYPE_FIELD_BITSIZE (type
, f
) = 0;
6158 TYPE_FIELD_STATIC_KIND (type
, f
) = 0;
6160 if (is_dynamic_field (templ_type
, f
))
6162 TYPE_FIELD_TYPE (type
, f
) =
6163 to_static_fixed_type (TYPE_TARGET_TYPE
6164 (TYPE_FIELD_TYPE (templ_type
, f
)));
6165 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6169 TYPE_FIELD_TYPE (type
, f
) =
6170 check_typedef (TYPE_FIELD_TYPE (templ_type
, f
));
6171 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6178 /* A revision of TYPE0 -- a non-dynamic-sized record with a variant
6179 part -- in which the variant part is replaced with the appropriate
6181 static struct type
*
6182 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
6183 CORE_ADDR address
, struct value
*dval
)
6185 struct value
*mark
= value_mark ();
6187 struct type
*branch_type
;
6188 int nfields
= TYPE_NFIELDS (type
);
6193 rtype
= alloc_type (TYPE_OBJFILE (type
));
6194 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6195 INIT_CPLUS_SPECIFIC (type
);
6196 TYPE_NFIELDS (rtype
) = TYPE_NFIELDS (type
);
6197 TYPE_FIELDS (rtype
) =
6198 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6199 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6200 sizeof (struct field
) * nfields
);
6201 TYPE_NAME (rtype
) = ada_type_name (type
);
6202 TYPE_TAG_NAME (rtype
) = NULL
;
6203 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6204 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6205 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6208 to_fixed_variant_branch_type
6209 (TYPE_FIELD_TYPE (type
, nfields
- 1),
6210 cond_offset_host (valaddr
,
6211 TYPE_FIELD_BITPOS (type
,
6212 nfields
- 1) / TARGET_CHAR_BIT
),
6213 cond_offset_target (address
,
6214 TYPE_FIELD_BITPOS (type
,
6215 nfields
- 1) / TARGET_CHAR_BIT
),
6217 if (branch_type
== NULL
)
6219 TYPE_NFIELDS (rtype
) -= 1;
6220 TYPE_LENGTH (rtype
) -=
6221 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6225 TYPE_FIELD_TYPE (rtype
, nfields
- 1) = branch_type
;
6226 TYPE_FIELD_NAME (rtype
, nfields
- 1) = "S";
6227 TYPE_FIELD_BITSIZE (rtype
, nfields
- 1) = 0;
6228 TYPE_FIELD_STATIC_KIND (rtype
, nfields
- 1) = 0;
6229 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6230 -TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6236 /* An ordinary record type (with fixed-length fields) that describes
6237 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6238 beginning of this section]. Any necessary discriminants' values
6239 should be in DVAL, a record value; it should be NULL if the object
6240 at ADDR itself contains any necessary discriminant values. A
6241 variant field (unless unchecked) is replaced by a particular branch
6244 static struct type
*
6245 to_fixed_record_type (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6248 struct type
*templ_type
;
6250 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6251 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6254 templ_type
= dynamic_template_type (type0
);
6256 if (templ_type
!= NULL
)
6257 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6258 else if (contains_variant_part (type0
))
6259 return to_record_with_fixed_variant_part (type0
, valaddr
, address
, dval
);
6262 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6263 /* TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE; */
6269 /* An ordinary record type (with fixed-length fields) that describes
6270 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6271 union type. Any necessary discriminants' values should be in DVAL,
6272 a record value. That is, this routine selects the appropriate
6273 branch of the union at ADDR according to the discriminant value
6274 indicated in the union's type name. */
6276 static struct type
*
6277 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
6278 CORE_ADDR address
, struct value
*dval
)
6281 struct type
*templ_type
;
6282 struct type
*var_type
;
6284 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6285 var_type
= TYPE_TARGET_TYPE (var_type0
);
6287 var_type
= var_type0
;
6289 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6291 if (templ_type
!= NULL
)
6292 var_type
= templ_type
;
6295 ada_which_variant_applies (var_type
,
6296 VALUE_TYPE (dval
), VALUE_CONTENTS (dval
));
6299 return empty_record (TYPE_OBJFILE (var_type
));
6300 else if (is_dynamic_field (var_type
, which
))
6302 to_fixed_record_type
6303 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6304 valaddr
, address
, dval
);
6305 else if (contains_variant_part (TYPE_FIELD_TYPE (var_type
, which
)))
6307 to_fixed_record_type
6308 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6310 return TYPE_FIELD_TYPE (var_type
, which
);
6313 /* Assuming that TYPE0 is an array type describing the type of a value
6314 at ADDR, and that DVAL describes a record containing any
6315 discriminants used in TYPE0, returns a type for the value that
6316 contains no dynamic components (that is, no components whose sizes
6317 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6318 true, gives an error message if the resulting type's size is over
6322 static struct type
*
6323 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6326 struct type
*index_type_desc
;
6327 struct type
*result
;
6329 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6330 /* if (ada_is_packed_array_type (type0) /* revisit? *//*
6331 || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
6334 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6335 if (index_type_desc
== NULL
)
6337 struct type
*elt_type0
= check_typedef (TYPE_TARGET_TYPE (type0
));
6338 /* NOTE: elt_type---the fixed version of elt_type0---should never
6339 * depend on the contents of the array in properly constructed
6340 * debugging data. */
6341 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6343 if (elt_type0
== elt_type
)
6346 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6347 elt_type
, TYPE_INDEX_TYPE (type0
));
6352 struct type
*elt_type0
;
6355 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6356 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6358 /* NOTE: result---the fixed version of elt_type0---should never
6359 * depend on the contents of the array in properly constructed
6360 * debugging data. */
6361 result
= ada_to_fixed_type (check_typedef (elt_type0
), 0, 0, dval
);
6362 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6364 struct type
*range_type
=
6365 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6366 dval
, TYPE_OBJFILE (type0
));
6367 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6368 result
, range_type
);
6370 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6371 error ("array type with dynamic size is larger than varsize-limit");
6374 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6375 /* TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE; */
6380 /* A standard type (containing no dynamically sized components)
6381 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6382 DVAL describes a record containing any discriminants used in TYPE0,
6383 and may be NULL if there are none. */
6386 ada_to_fixed_type (struct type
*type
, char *valaddr
, CORE_ADDR address
,
6389 CHECK_TYPEDEF (type
);
6390 switch (TYPE_CODE (type
))
6394 case TYPE_CODE_STRUCT
:
6395 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6396 case TYPE_CODE_ARRAY
:
6397 return to_fixed_array_type (type
, dval
, 0);
6398 case TYPE_CODE_UNION
:
6402 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6406 /* A standard (static-sized) type corresponding as well as possible to
6407 TYPE0, but based on no runtime data. */
6409 static struct type
*
6410 to_static_fixed_type (struct type
*type0
)
6417 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6418 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6421 CHECK_TYPEDEF (type0
);
6423 switch (TYPE_CODE (type0
))
6427 case TYPE_CODE_STRUCT
:
6428 type
= dynamic_template_type (type0
);
6430 return template_to_static_fixed_type (type
);
6432 case TYPE_CODE_UNION
:
6433 type
= ada_find_parallel_type (type0
, "___XVU");
6435 return template_to_static_fixed_type (type
);
6440 /* A static approximation of TYPE with all type wrappers removed. */
6441 static struct type
*
6442 static_unwrap_type (struct type
*type
)
6444 if (ada_is_aligner_type (type
))
6446 struct type
*type1
= TYPE_FIELD_TYPE (check_typedef (type
), 0);
6447 if (ada_type_name (type1
) == NULL
)
6448 TYPE_NAME (type1
) = ada_type_name (type
);
6450 return static_unwrap_type (type1
);
6454 struct type
*raw_real_type
= ada_get_base_type (type
);
6455 if (raw_real_type
== type
)
6458 return to_static_fixed_type (raw_real_type
);
6462 /* In some cases, incomplete and private types require
6463 cross-references that are not resolved as records (for example,
6465 type FooP is access Foo;
6467 type Foo is array ...;
6468 ). In these cases, since there is no mechanism for producing
6469 cross-references to such types, we instead substitute for FooP a
6470 stub enumeration type that is nowhere resolved, and whose tag is
6471 the name of the actual type. Call these types "non-record stubs". */
6473 /* A type equivalent to TYPE that is not a non-record stub, if one
6474 exists, otherwise TYPE. */
6476 ada_completed_type (struct type
*type
)
6478 CHECK_TYPEDEF (type
);
6479 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6480 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
6481 || TYPE_TAG_NAME (type
) == NULL
)
6485 char *name
= TYPE_TAG_NAME (type
);
6486 struct type
*type1
= ada_find_any_type (name
);
6487 return (type1
== NULL
) ? type
: type1
;
6491 /* A value representing the data at VALADDR/ADDRESS as described by
6492 type TYPE0, but with a standard (static-sized) type that correctly
6493 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6494 type, then return VAL0 [this feature is simply to avoid redundant
6495 creation of struct values]. */
6498 ada_to_fixed_value (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6501 struct type
*type
= ada_to_fixed_type (type0
, valaddr
, address
, NULL
);
6502 if (type
== type0
&& val0
!= NULL
)
6505 return value_from_contents_and_address (type
, valaddr
, address
);
6508 /* A value representing VAL, but with a standard (static-sized) type
6509 chosen to approximate the real type of VAL as well as possible, but
6510 without consulting any runtime values. For Ada dynamic-sized
6511 types, therefore, the type of the result is likely to be inaccurate. */
6514 ada_to_static_fixed_value (struct value
*val
)
6517 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val
)));
6518 if (type
== VALUE_TYPE (val
))
6521 return coerce_unspec_val_to_type (val
, 0, type
);
6530 /* Table mapping attribute numbers to names */
6531 /* NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h */
6533 static const char *attribute_names
[] = {
6550 ada_attribute_name (int n
)
6552 if (n
> 0 && n
< (int) ATR_END
)
6553 return attribute_names
[n
];
6555 return attribute_names
[0];
6558 /* Evaluate the 'POS attribute applied to ARG. */
6560 static struct value
*
6561 value_pos_atr (struct value
*arg
)
6563 struct type
*type
= VALUE_TYPE (arg
);
6565 if (!discrete_type_p (type
))
6566 error ("'POS only defined on discrete types");
6568 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6571 LONGEST v
= value_as_long (arg
);
6573 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6575 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6576 return value_from_longest (builtin_type_ada_int
, i
);
6578 error ("enumeration value is invalid: can't find 'POS");
6581 return value_from_longest (builtin_type_ada_int
, value_as_long (arg
));
6584 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6586 static struct value
*
6587 value_val_atr (struct type
*type
, struct value
*arg
)
6589 if (!discrete_type_p (type
))
6590 error ("'VAL only defined on discrete types");
6591 if (!integer_type_p (VALUE_TYPE (arg
)))
6592 error ("'VAL requires integral argument");
6594 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6596 long pos
= value_as_long (arg
);
6597 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6598 error ("argument to 'VAL out of range");
6599 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6602 return value_from_longest (type
, value_as_long (arg
));
6608 /* True if TYPE appears to be an Ada character type.
6609 * [At the moment, this is true only for Character and Wide_Character;
6610 * It is a heuristic test that could stand improvement]. */
6613 ada_is_character_type (struct type
*type
)
6615 const char *name
= ada_type_name (type
);
6618 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6619 || TYPE_CODE (type
) == TYPE_CODE_INT
6620 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6621 && (STREQ (name
, "character") || STREQ (name
, "wide_character")
6622 || STREQ (name
, "unsigned char"));
6625 /* True if TYPE appears to be an Ada string type. */
6628 ada_is_string_type (struct type
*type
)
6630 CHECK_TYPEDEF (type
);
6632 && TYPE_CODE (type
) != TYPE_CODE_PTR
6633 && (ada_is_simple_array (type
) || ada_is_array_descriptor (type
))
6634 && ada_array_arity (type
) == 1)
6636 struct type
*elttype
= ada_array_element_type (type
, 1);
6638 return ada_is_character_type (elttype
);
6645 /* True if TYPE is a struct type introduced by the compiler to force the
6646 alignment of a value. Such types have a single field with a
6647 distinctive name. */
6650 ada_is_aligner_type (struct type
*type
)
6652 CHECK_TYPEDEF (type
);
6653 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
6654 && TYPE_NFIELDS (type
) == 1
6655 && STREQ (TYPE_FIELD_NAME (type
, 0), "F"));
6658 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6659 the parallel type. */
6662 ada_get_base_type (struct type
*raw_type
)
6664 struct type
*real_type_namer
;
6665 struct type
*raw_real_type
;
6666 struct type
*real_type
;
6668 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
6671 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
6672 if (real_type_namer
== NULL
6673 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
6674 || TYPE_NFIELDS (real_type_namer
) != 1)
6677 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
6678 if (raw_real_type
== NULL
)
6681 return raw_real_type
;
6684 /* The type of value designated by TYPE, with all aligners removed. */
6687 ada_aligned_type (struct type
*type
)
6689 if (ada_is_aligner_type (type
))
6690 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
6692 return ada_get_base_type (type
);
6696 /* The address of the aligned value in an object at address VALADDR
6697 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6700 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
6702 if (ada_is_aligner_type (type
))
6703 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
6705 TYPE_FIELD_BITPOS (type
,
6706 0) / TARGET_CHAR_BIT
);
6711 /* The printed representation of an enumeration literal with encoded
6712 name NAME. The value is good to the next call of ada_enum_name. */
6714 ada_enum_name (const char *name
)
6720 if ((tmp
= strstr (name
, "__")) != NULL
)
6722 else if ((tmp
= strchr (name
, '.')) != NULL
)
6730 static char result
[16];
6732 if (name
[1] == 'U' || name
[1] == 'W')
6734 if (sscanf (name
+ 2, "%x", &v
) != 1)
6740 if (isascii (v
) && isprint (v
))
6741 sprintf (result
, "'%c'", v
);
6742 else if (name
[1] == 'U')
6743 sprintf (result
, "[\"%02x\"]", v
);
6745 sprintf (result
, "[\"%04x\"]", v
);
6753 static struct value
*
6754 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
6757 return (*exp
->language_defn
->evaluate_exp
) (expect_type
, exp
, pos
, noside
);
6760 /* Evaluate the subexpression of EXP starting at *POS as for
6761 evaluate_type, updating *POS to point just past the evaluated
6764 static struct value
*
6765 evaluate_subexp_type (struct expression
*exp
, int *pos
)
6767 return (*exp
->language_defn
->evaluate_exp
)
6768 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
6771 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6774 static struct value
*
6775 unwrap_value (struct value
*val
)
6777 struct type
*type
= check_typedef (VALUE_TYPE (val
));
6778 if (ada_is_aligner_type (type
))
6780 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
6781 NULL
, "internal structure");
6782 struct type
*val_type
= check_typedef (VALUE_TYPE (v
));
6783 if (ada_type_name (val_type
) == NULL
)
6784 TYPE_NAME (val_type
) = ada_type_name (type
);
6786 return unwrap_value (v
);
6790 struct type
*raw_real_type
=
6791 ada_completed_type (ada_get_base_type (type
));
6793 if (type
== raw_real_type
)
6797 coerce_unspec_val_to_type
6798 (val
, 0, ada_to_fixed_type (raw_real_type
, 0,
6799 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
6804 static struct value
*
6805 cast_to_fixed (struct type
*type
, struct value
*arg
)
6809 if (type
== VALUE_TYPE (arg
))
6811 else if (ada_is_fixed_point_type (VALUE_TYPE (arg
)))
6812 val
= ada_float_to_fixed (type
,
6813 ada_fixed_to_float (VALUE_TYPE (arg
),
6814 value_as_long (arg
)));
6818 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
6819 val
= ada_float_to_fixed (type
, argd
);
6822 return value_from_longest (type
, val
);
6825 static struct value
*
6826 cast_from_fixed_to_double (struct value
*arg
)
6828 DOUBLEST val
= ada_fixed_to_float (VALUE_TYPE (arg
),
6829 value_as_long (arg
));
6830 return value_from_double (builtin_type_double
, val
);
6833 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
6834 * return the converted value. */
6835 static struct value
*
6836 coerce_for_assign (struct type
*type
, struct value
*val
)
6838 struct type
*type2
= VALUE_TYPE (val
);
6842 CHECK_TYPEDEF (type2
);
6843 CHECK_TYPEDEF (type
);
6845 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
6846 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6848 val
= ada_value_ind (val
);
6849 type2
= VALUE_TYPE (val
);
6852 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
6853 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6855 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
6856 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
6857 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
6858 error ("Incompatible types in assignment");
6859 VALUE_TYPE (val
) = type
;
6865 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
6866 int *pos
, enum noside noside
)
6869 enum ada_attribute atr
;
6870 int tem
, tem2
, tem3
;
6872 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
6875 struct value
**argvec
;
6879 op
= exp
->elts
[pc
].opcode
;
6886 unwrap_value (evaluate_subexp_standard
6887 (expect_type
, exp
, pos
, noside
));
6891 type
= exp
->elts
[pc
+ 1].type
;
6892 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
6893 if (noside
== EVAL_SKIP
)
6895 if (type
!= check_typedef (VALUE_TYPE (arg1
)))
6897 if (ada_is_fixed_point_type (type
))
6898 arg1
= cast_to_fixed (type
, arg1
);
6899 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6900 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
6901 else if (VALUE_LVAL (arg1
) == lval_memory
)
6903 /* This is in case of the really obscure (and undocumented,
6904 but apparently expected) case of (Foo) Bar.all, where Bar
6905 is an integer constant and Foo is a dynamic-sized type.
6906 If we don't do this, ARG1 will simply be relabeled with
6908 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
6909 return value_zero (to_static_fixed_type (type
), not_lval
);
6912 (type
, 0, VALUE_ADDRESS (arg1
) + VALUE_OFFSET (arg1
), 0);
6915 arg1
= value_cast (type
, arg1
);
6919 /* FIXME: UNOP_QUAL should be defined in expression.h */
6922 type = exp->elts[pc + 1].type;
6923 return ada_evaluate_subexp (type, exp, pos, noside);
6926 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6927 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
6928 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
6930 if (binop_user_defined_p (op
, arg1
, arg2
))
6931 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6934 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6935 arg2
= cast_to_fixed (VALUE_TYPE (arg1
), arg2
);
6936 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6938 ("Fixed-point values must be assigned to fixed-point variables");
6940 arg2
= coerce_for_assign (VALUE_TYPE (arg1
), arg2
);
6941 return ada_value_assign (arg1
, arg2
);
6945 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6946 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6947 if (noside
== EVAL_SKIP
)
6949 if (binop_user_defined_p (op
, arg1
, arg2
))
6950 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6953 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6954 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6955 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6957 ("Operands of fixed-point addition must have the same type");
6958 return value_cast (VALUE_TYPE (arg1
), value_add (arg1
, arg2
));
6962 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6963 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6964 if (noside
== EVAL_SKIP
)
6966 if (binop_user_defined_p (op
, arg1
, arg2
))
6967 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6970 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6971 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6972 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6974 ("Operands of fixed-point subtraction must have the same type");
6975 return value_cast (VALUE_TYPE (arg1
), value_sub (arg1
, arg2
));
6980 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6981 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6982 if (noside
== EVAL_SKIP
)
6984 if (binop_user_defined_p (op
, arg1
, arg2
))
6985 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6987 if (noside
== EVAL_AVOID_SIDE_EFFECTS
6988 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
6989 return value_zero (VALUE_TYPE (arg1
), not_lval
);
6992 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6993 arg1
= cast_from_fixed_to_double (arg1
);
6994 if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6995 arg2
= cast_from_fixed_to_double (arg2
);
6996 return value_binop (arg1
, arg2
, op
);
7000 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7001 if (noside
== EVAL_SKIP
)
7003 if (unop_user_defined_p (op
, arg1
))
7004 return value_x_unop (arg1
, op
, EVAL_NORMAL
);
7005 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
7006 return value_cast (VALUE_TYPE (arg1
), value_neg (arg1
));
7008 return value_neg (arg1
);
7010 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7011 /* case OP_UNRESOLVED_VALUE:
7012 /* Only encountered when an unresolved symbol occurs in a
7013 context other than a function call, in which case, it is
7016 if (noside == EVAL_SKIP)
7019 error ("Unexpected unresolved symbol, %s, during evaluation",
7020 ada_demangle (exp->elts[pc + 2].name));
7024 if (noside
== EVAL_SKIP
)
7029 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7033 (to_static_fixed_type
7034 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
7040 unwrap_value (evaluate_subexp_standard
7041 (expect_type
, exp
, pos
, noside
));
7042 return ada_to_fixed_value (VALUE_TYPE (arg1
), 0,
7043 VALUE_ADDRESS (arg1
) +
7044 VALUE_OFFSET (arg1
), arg1
);
7049 tem2
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7050 tem3
= longest_to_int (exp
->elts
[pc
+ 2].longconst
);
7051 nargs
= tem3
- tem2
+ 1;
7052 type
= expect_type
? check_typedef (expect_type
) : NULL_TYPE
;
7055 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
7056 for (tem
= 0; tem
== 0 || tem
< nargs
; tem
+= 1)
7057 /* At least one element gets inserted for the type */
7059 /* Ensure that array expressions are coerced into pointer objects. */
7060 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
7062 if (noside
== EVAL_SKIP
)
7064 return value_array (tem2
, tem3
, argvec
);
7069 /* Allocate arg vector, including space for the function to be
7070 called in argvec[0] and a terminating NULL */
7071 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7073 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 2));
7075 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7076 /* FIXME: name should be defined in expresion.h */
7077 /* if (exp->elts[*pos].opcode == OP_UNRESOLVED_VALUE)
7078 error ("Unexpected unresolved symbol, %s, during evaluation",
7079 ada_demangle (exp->elts[pc + 5].name));
7083 error ("unexpected code path, FIXME");
7087 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7088 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7091 if (noside
== EVAL_SKIP
)
7095 if (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_REF
)
7096 argvec
[0] = value_addr (argvec
[0]);
7098 if (ada_is_packed_array_type (VALUE_TYPE (argvec
[0])))
7099 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7101 type
= check_typedef (VALUE_TYPE (argvec
[0]));
7102 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7104 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type
))))
7106 case TYPE_CODE_FUNC
:
7107 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7109 case TYPE_CODE_ARRAY
:
7111 case TYPE_CODE_STRUCT
:
7112 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7113 argvec
[0] = ada_value_ind (argvec
[0]);
7114 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7117 error ("cannot subscript or call something of type `%s'",
7118 ada_type_name (VALUE_TYPE (argvec
[0])));
7123 switch (TYPE_CODE (type
))
7125 case TYPE_CODE_FUNC
:
7126 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7127 return allocate_value (TYPE_TARGET_TYPE (type
));
7128 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7129 case TYPE_CODE_STRUCT
:
7131 int arity
= ada_array_arity (type
);
7132 type
= ada_array_element_type (type
, nargs
);
7134 error ("cannot subscript or call a record");
7136 error ("wrong number of subscripts; expecting %d", arity
);
7137 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7138 return allocate_value (ada_aligned_type (type
));
7140 unwrap_value (ada_value_subscript
7141 (argvec
[0], nargs
, argvec
+ 1));
7143 case TYPE_CODE_ARRAY
:
7144 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7146 type
= ada_array_element_type (type
, nargs
);
7148 error ("element type of array unknown");
7150 return allocate_value (ada_aligned_type (type
));
7153 unwrap_value (ada_value_subscript
7154 (ada_coerce_to_simple_array (argvec
[0]),
7155 nargs
, argvec
+ 1));
7156 case TYPE_CODE_PTR
: /* Pointer to array */
7157 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7158 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7160 type
= ada_array_element_type (type
, nargs
);
7162 error ("element type of array unknown");
7164 return allocate_value (ada_aligned_type (type
));
7167 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7168 nargs
, argvec
+ 1));
7171 error ("Internal error in evaluate_subexp");
7176 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7178 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7180 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7181 if (noside
== EVAL_SKIP
)
7184 /* If this is a reference to an array, then dereference it */
7185 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
7186 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7187 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7189 && !ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7191 array
= ada_coerce_ref (array
);
7194 if (noside
== EVAL_AVOID_SIDE_EFFECTS
&&
7195 ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7197 /* Try to dereference the array, in case it is an access to array */
7198 struct type
*arrType
= ada_type_of_array (array
, 0);
7199 if (arrType
!= NULL
)
7200 array
= value_at_lazy (arrType
, 0, NULL
);
7202 if (ada_is_array_descriptor (VALUE_TYPE (array
)))
7203 array
= ada_coerce_to_simple_array (array
);
7205 /* If at this point we have a pointer to an array, it means that
7206 it is a pointer to a simple (non-ada) array. We just then
7208 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
7209 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7210 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7213 array
= ada_value_ind (array
);
7216 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7217 /* The following will get the bounds wrong, but only in contexts
7218 where the value is not being requested (FIXME?). */
7221 return value_slice (array
, lowbound
, upper
- lowbound
+ 1);
7224 /* FIXME: UNOP_MBR should be defined in expression.h */
7227 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7228 type = exp->elts[pc + 1].type;
7230 if (noside == EVAL_SKIP)
7233 switch (TYPE_CODE (type))
7236 warning ("Membership test incompletely implemented; always returns true");
7237 return value_from_longest (builtin_type_int, (LONGEST) 1);
7239 case TYPE_CODE_RANGE:
7240 arg2 = value_from_longest (builtin_type_int,
7241 (LONGEST) TYPE_LOW_BOUND (type));
7242 arg3 = value_from_longest (builtin_type_int,
7243 (LONGEST) TYPE_HIGH_BOUND (type));
7245 value_from_longest (builtin_type_int,
7246 (value_less (arg1,arg3)
7247 || value_equal (arg1,arg3))
7248 && (value_less (arg2,arg1)
7249 || value_equal (arg2,arg1)));
7252 /* FIXME: BINOP_MBR should be defined in expression.h */
7255 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7256 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7258 if (noside == EVAL_SKIP)
7261 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7262 return value_zero (builtin_type_int, not_lval);
7264 tem = longest_to_int (exp->elts[pc + 1].longconst);
7266 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
7267 error ("invalid dimension number to '%s", "range");
7269 arg3 = ada_array_bound (arg2, tem, 1);
7270 arg2 = ada_array_bound (arg2, tem, 0);
7273 value_from_longest (builtin_type_int,
7274 (value_less (arg1,arg3)
7275 || value_equal (arg1,arg3))
7276 && (value_less (arg2,arg1)
7277 || value_equal (arg2,arg1)));
7279 /* FIXME: TERNOP_MBR should be defined in expression.h */
7281 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7282 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7283 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7285 if (noside == EVAL_SKIP)
7289 value_from_longest (builtin_type_int,
7290 (value_less (arg1,arg3)
7291 || value_equal (arg1,arg3))
7292 && (value_less (arg2,arg1)
7293 || value_equal (arg2,arg1)));
7295 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
7296 /* case OP_ATTRIBUTE:
7298 atr = (enum ada_attribute) longest_to_int (exp->elts[pc + 2].longconst);
7302 error ("unexpected attribute encountered");
7308 struct type* type_arg;
7309 if (exp->elts[*pos].opcode == OP_TYPE)
7311 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7313 type_arg = exp->elts[pc + 5].type;
7317 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7321 if (exp->elts[*pos].opcode != OP_LONG)
7322 error ("illegal operand to '%s", ada_attribute_name (atr));
7323 tem = longest_to_int (exp->elts[*pos+2].longconst);
7326 if (noside == EVAL_SKIP)
7329 if (type_arg == NULL)
7331 arg1 = ada_coerce_ref (arg1);
7333 if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
7334 arg1 = ada_coerce_to_simple_array (arg1);
7336 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
7337 error ("invalid dimension number to '%s",
7338 ada_attribute_name (atr));
7340 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7342 type = ada_index_type (VALUE_TYPE (arg1), tem);
7344 error ("attempt to take bound of something that is not an array");
7345 return allocate_value (type);
7351 error ("unexpected attribute encountered");
7353 return ada_array_bound (arg1, tem, 0);
7355 return ada_array_bound (arg1, tem, 1);
7357 return ada_array_length (arg1, tem);
7360 else if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE
7361 || TYPE_CODE (type_arg) == TYPE_CODE_INT)
7363 struct type* range_type;
7364 char* name = ada_type_name (type_arg);
7367 if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE)
7368 range_type = type_arg;
7370 error ("unimplemented type attribute");
7374 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
7378 error ("unexpected attribute encountered");
7380 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7381 TYPE_LOW_BOUND (range_type));
7383 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7384 TYPE_HIGH_BOUND (range_type));
7387 else if (TYPE_CODE (type_arg) == TYPE_CODE_ENUM)
7392 error ("unexpected attribute encountered");
7394 return value_from_longest
7395 (type_arg, TYPE_FIELD_BITPOS (type_arg, 0));
7397 return value_from_longest
7399 TYPE_FIELD_BITPOS (type_arg,
7400 TYPE_NFIELDS (type_arg) - 1));
7403 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
7404 error ("unimplemented type attribute");
7409 if (ada_is_packed_array_type (type_arg))
7410 type_arg = decode_packed_array_type (type_arg);
7412 if (tem < 1 || tem > ada_array_arity (type_arg))
7413 error ("invalid dimension number to '%s",
7414 ada_attribute_name (atr));
7416 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7418 type = ada_index_type (type_arg, tem);
7420 error ("attempt to take bound of something that is not an array");
7421 return allocate_value (type);
7427 error ("unexpected attribute encountered");
7429 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7430 return value_from_longest (type, low);
7432 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
7433 return value_from_longest (type, high);
7435 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7436 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
7437 return value_from_longest (type, high-low+1);
7443 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7444 if (noside == EVAL_SKIP)
7447 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7449 value_zero (ada_tag_type (arg1), not_lval);
7451 return ada_value_tag (arg1);
7455 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7456 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7457 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7458 if (noside == EVAL_SKIP)
7460 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7461 return value_zero (VALUE_TYPE (arg1), not_lval);
7463 return value_binop (arg1, arg2,
7464 atr == ATR_MIN ? BINOP_MIN : BINOP_MAX);
7468 struct type* type_arg = exp->elts[pc + 5].type;
7469 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7472 if (noside == EVAL_SKIP)
7475 if (! ada_is_modular_type (type_arg))
7476 error ("'modulus must be applied to modular type");
7478 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
7479 ada_modulus (type_arg));
7484 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7485 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7486 if (noside == EVAL_SKIP)
7488 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7489 return value_zero (builtin_type_ada_int, not_lval);
7491 return value_pos_atr (arg1);
7494 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7495 if (noside == EVAL_SKIP)
7497 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7498 return value_zero (builtin_type_ada_int, not_lval);
7500 return value_from_longest (builtin_type_ada_int,
7502 * TYPE_LENGTH (VALUE_TYPE (arg1)));
7505 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7506 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7507 type = exp->elts[pc + 5].type;
7508 if (noside == EVAL_SKIP)
7510 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7511 return value_zero (type, not_lval);
7513 return value_val_atr (type, arg1);
7516 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7517 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7518 if (noside
== EVAL_SKIP
)
7520 if (binop_user_defined_p (op
, arg1
, arg2
))
7521 return unwrap_value (value_x_binop (arg1
, arg2
, op
, OP_NULL
,
7523 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7524 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7526 return value_binop (arg1
, arg2
, op
);
7529 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7530 if (noside
== EVAL_SKIP
)
7532 if (unop_user_defined_p (op
, arg1
))
7533 return unwrap_value (value_x_unop (arg1
, op
, EVAL_NORMAL
));
7538 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7539 if (noside
== EVAL_SKIP
)
7541 if (value_less (arg1
, value_zero (VALUE_TYPE (arg1
), not_lval
)))
7542 return value_neg (arg1
);
7547 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
7548 expect_type
= TYPE_TARGET_TYPE (check_typedef (expect_type
));
7549 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
7550 if (noside
== EVAL_SKIP
)
7552 type
= check_typedef (VALUE_TYPE (arg1
));
7553 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7555 if (ada_is_array_descriptor (type
))
7556 /* GDB allows dereferencing GNAT array descriptors. */
7558 struct type
*arrType
= ada_type_of_array (arg1
, 0);
7559 if (arrType
== NULL
)
7560 error ("Attempt to dereference null array pointer.");
7561 return value_at_lazy (arrType
, 0, NULL
);
7563 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
7564 || TYPE_CODE (type
) == TYPE_CODE_REF
7565 /* In C you can dereference an array to get the 1st elt. */
7566 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7569 (to_static_fixed_type
7570 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type
)))),
7572 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
7573 /* GDB allows dereferencing an int. */
7574 return value_zero (builtin_type_int
, lval_memory
);
7576 error ("Attempt to take contents of a non-pointer value.");
7578 arg1
= ada_coerce_ref (arg1
);
7579 type
= check_typedef (VALUE_TYPE (arg1
));
7581 if (ada_is_array_descriptor (type
))
7582 /* GDB allows dereferencing GNAT array descriptors. */
7583 return ada_coerce_to_simple_array (arg1
);
7585 return ada_value_ind (arg1
);
7587 case STRUCTOP_STRUCT
:
7588 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7589 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7590 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7591 if (noside
== EVAL_SKIP
)
7593 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7594 return value_zero (ada_aligned_type
7595 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7601 return unwrap_value (ada_value_struct_elt (arg1
,
7602 &exp
->elts
[pc
+ 2].string
,
7605 /* The value is not supposed to be used. This is here to make it
7606 easier to accommodate expressions that contain types. */
7608 if (noside
== EVAL_SKIP
)
7610 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7611 return allocate_value (builtin_type_void
);
7613 error ("Attempt to use a type name as an expression");
7616 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7617 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7618 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7619 if (noside
== EVAL_SKIP
)
7621 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7622 return value_zero (ada_aligned_type
7623 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7629 return unwrap_value (ada_value_struct_elt (arg1
,
7630 &exp
->elts
[pc
+ 2].string
,
7635 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
7641 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7642 type name that encodes the 'small and 'delta information.
7643 Otherwise, return NULL. */
7646 fixed_type_info (struct type
*type
)
7648 const char *name
= ada_type_name (type
);
7649 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
7651 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
7653 const char *tail
= strstr (name
, "___XF_");
7659 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
7660 return fixed_type_info (TYPE_TARGET_TYPE (type
));
7665 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7668 ada_is_fixed_point_type (struct type
*type
)
7670 return fixed_type_info (type
) != NULL
;
7673 /* Assuming that TYPE is the representation of an Ada fixed-point
7674 type, return its delta, or -1 if the type is malformed and the
7675 delta cannot be determined. */
7678 ada_delta (struct type
*type
)
7680 const char *encoding
= fixed_type_info (type
);
7683 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
7686 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
7689 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7690 factor ('SMALL value) associated with the type. */
7693 scaling_factor (struct type
*type
)
7695 const char *encoding
= fixed_type_info (type
);
7696 unsigned long num0
, den0
, num1
, den1
;
7699 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
7704 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
7706 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
7710 /* Assuming that X is the representation of a value of fixed-point
7711 type TYPE, return its floating-point equivalent. */
7714 ada_fixed_to_float (struct type
*type
, LONGEST x
)
7716 return (DOUBLEST
) x
*scaling_factor (type
);
7719 /* The representation of a fixed-point value of type TYPE
7720 corresponding to the value X. */
7723 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
7725 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
7729 /* VAX floating formats */
7731 /* Non-zero iff TYPE represents one of the special VAX floating-point
7734 ada_is_vax_floating_type (struct type
*type
)
7737 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
7740 && (TYPE_CODE (type
) == TYPE_CODE_INT
7741 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7742 && STREQN (ada_type_name (type
) + name_len
- 6, "___XF", 5);
7745 /* The type of special VAX floating-point type this is, assuming
7746 ada_is_vax_floating_point */
7748 ada_vax_float_type_suffix (struct type
*type
)
7750 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
7753 /* A value representing the special debugging function that outputs
7754 VAX floating-point values of the type represented by TYPE. Assumes
7755 ada_is_vax_floating_type (TYPE). */
7757 ada_vax_float_print_function (struct type
*type
)
7759 switch (ada_vax_float_type_suffix (type
))
7762 return get_var_value ("DEBUG_STRING_F", 0);
7764 return get_var_value ("DEBUG_STRING_D", 0);
7766 return get_var_value ("DEBUG_STRING_G", 0);
7768 error ("invalid VAX floating-point type");
7775 /* Scan STR beginning at position K for a discriminant name, and
7776 return the value of that discriminant field of DVAL in *PX. If
7777 PNEW_K is not null, put the position of the character beyond the
7778 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
7779 not alter *PX and *PNEW_K if unsuccessful. */
7782 scan_discrim_bound (char *, int k
, struct value
*dval
, LONGEST
* px
,
7785 static char *bound_buffer
= NULL
;
7786 static size_t bound_buffer_len
= 0;
7789 struct value
*bound_val
;
7791 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
7794 pend
= strstr (str
+ k
, "__");
7798 k
+= strlen (bound
);
7802 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
7803 bound
= bound_buffer
;
7804 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
7805 bound
[pend
- (str
+ k
)] = '\0';
7809 bound_val
= ada_search_struct_field (bound
, dval
, 0, VALUE_TYPE (dval
));
7810 if (bound_val
== NULL
)
7813 *px
= value_as_long (bound_val
);
7819 /* Value of variable named NAME in the current environment. If
7820 no such variable found, then if ERR_MSG is null, returns 0, and
7821 otherwise causes an error with message ERR_MSG. */
7822 static struct value
*
7823 get_var_value (char *name
, char *err_msg
)
7825 struct symbol
**syms
;
7826 struct block
**blocks
;
7830 ada_lookup_symbol_list (name
, get_selected_block (NULL
), VAR_NAMESPACE
,
7835 if (err_msg
== NULL
)
7838 error ("%s", err_msg
);
7841 return value_of_variable (syms
[0], blocks
[0]);
7844 /* Value of integer variable named NAME in the current environment. If
7845 no such variable found, then if ERR_MSG is null, returns 0, and sets
7846 *FLAG to 0. If successful, sets *FLAG to 1. */
7848 get_int_var_value (char *name
, char *err_msg
, int *flag
)
7850 struct value
*var_val
= get_var_value (name
, err_msg
);
7862 return value_as_long (var_val
);
7867 /* Return a range type whose base type is that of the range type named
7868 NAME in the current environment, and whose bounds are calculated
7869 from NAME according to the GNAT range encoding conventions.
7870 Extract discriminant values, if needed, from DVAL. If a new type
7871 must be created, allocate in OBJFILE's space. The bounds
7872 information, in general, is encoded in NAME, the base type given in
7873 the named range type. */
7875 static struct type
*
7876 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
7878 struct type
*raw_type
= ada_find_any_type (name
);
7879 struct type
*base_type
;
7883 if (raw_type
== NULL
)
7884 base_type
= builtin_type_int
;
7885 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
7886 base_type
= TYPE_TARGET_TYPE (raw_type
);
7888 base_type
= raw_type
;
7890 subtype_info
= strstr (name
, "___XD");
7891 if (subtype_info
== NULL
)
7895 static char *name_buf
= NULL
;
7896 static size_t name_len
= 0;
7897 int prefix_len
= subtype_info
- name
;
7903 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
7904 strncpy (name_buf
, name
, prefix_len
);
7905 name_buf
[prefix_len
] = '\0';
7908 bounds_str
= strchr (subtype_info
, '_');
7911 if (*subtype_info
== 'L')
7913 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
7914 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
7916 if (bounds_str
[n
] == '_')
7918 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
7924 strcpy (name_buf
+ prefix_len
, "___L");
7925 L
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7928 if (*subtype_info
== 'U')
7930 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
7931 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
7936 strcpy (name_buf
+ prefix_len
, "___U");
7937 U
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7940 if (objfile
== NULL
)
7941 objfile
= TYPE_OBJFILE (base_type
);
7942 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
7943 TYPE_NAME (type
) = name
;
7948 /* True iff NAME is the name of a range type. */
7950 ada_is_range_type_name (const char *name
)
7952 return (name
!= NULL
&& strstr (name
, "___XD"));
7958 /* True iff TYPE is an Ada modular type. */
7960 ada_is_modular_type (struct type
*type
)
7962 /* FIXME: base_type should be declared in gdbtypes.h, implemented in
7964 struct type
*subranged_type
; /* = base_type (type); */
7966 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
7967 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
7968 && TYPE_UNSIGNED (subranged_type
));
7971 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
7973 ada_modulus (struct type
* type
)
7975 return TYPE_HIGH_BOUND (type
) + 1;
7982 /* Table mapping opcodes into strings for printing operators
7983 and precedences of the operators. */
7985 static const struct op_print ada_op_print_tab
[] = {
7986 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
7987 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
7988 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
7989 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
7990 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
7991 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
7992 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
7993 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
7994 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
7995 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
7996 {">", BINOP_GTR
, PREC_ORDER
, 0},
7997 {"<", BINOP_LESS
, PREC_ORDER
, 0},
7998 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
7999 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
8000 {"+", BINOP_ADD
, PREC_ADD
, 0},
8001 {"-", BINOP_SUB
, PREC_ADD
, 0},
8002 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
8003 {"*", BINOP_MUL
, PREC_MUL
, 0},
8004 {"/", BINOP_DIV
, PREC_MUL
, 0},
8005 {"rem", BINOP_REM
, PREC_MUL
, 0},
8006 {"mod", BINOP_MOD
, PREC_MUL
, 0},
8007 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
8008 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
8009 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
8010 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
8011 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
8012 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
8013 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
8014 {".all", UNOP_IND
, PREC_SUFFIX
, 1}, /* FIXME: postfix .ALL */
8015 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1}, /* FIXME: postfix 'ACCESS */
8019 /* Assorted Types and Interfaces */
8021 struct type
*builtin_type_ada_int
;
8022 struct type
*builtin_type_ada_short
;
8023 struct type
*builtin_type_ada_long
;
8024 struct type
*builtin_type_ada_long_long
;
8025 struct type
*builtin_type_ada_char
;
8026 struct type
*builtin_type_ada_float
;
8027 struct type
*builtin_type_ada_double
;
8028 struct type
*builtin_type_ada_long_double
;
8029 struct type
*builtin_type_ada_natural
;
8030 struct type
*builtin_type_ada_positive
;
8031 struct type
*builtin_type_ada_system_address
;
8033 struct type
**const (ada_builtin_types
[]) =
8036 &builtin_type_ada_int
,
8037 &builtin_type_ada_long
,
8038 &builtin_type_ada_short
,
8039 &builtin_type_ada_char
,
8040 &builtin_type_ada_float
,
8041 &builtin_type_ada_double
,
8042 &builtin_type_ada_long_long
,
8043 &builtin_type_ada_long_double
,
8044 &builtin_type_ada_natural
, &builtin_type_ada_positive
,
8045 /* The following types are carried over from C for convenience. */
8048 &builtin_type_short
,
8050 &builtin_type_float
,
8051 &builtin_type_double
,
8052 &builtin_type_long_long
,
8054 &builtin_type_signed_char
,
8055 &builtin_type_unsigned_char
,
8056 &builtin_type_unsigned_short
,
8057 &builtin_type_unsigned_int
,
8058 &builtin_type_unsigned_long
,
8059 &builtin_type_unsigned_long_long
,
8060 &builtin_type_long_double
,
8061 &builtin_type_complex
, &builtin_type_double_complex
, 0};
8063 /* Not really used, but needed in the ada_language_defn. */
8065 emit_char (int c
, struct ui_file
*stream
, int quoter
)
8067 ada_emit_char (c
, stream
, quoter
, 1);
8070 const struct language_defn ada_language_defn
= {
8071 "ada", /* Language name */
8074 /* FIXME: language_ada should be defined in defs.h */
8078 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8079 * that's not quite what this means. */
8082 ada_evaluate_subexp
,
8083 ada_printchar
, /* Print a character constant */
8084 ada_printstr
, /* Function to print string constant */
8085 emit_char
, /* Function to print single char (not used) */
8086 ada_create_fundamental_type
, /* Create fundamental type in this language */
8087 ada_print_type
, /* Print a type using appropriate syntax */
8088 ada_val_print
, /* Print a value using appropriate syntax */
8089 ada_value_print
, /* Print a top-level value */
8090 {"", "", "", ""}, /* Binary format info */
8092 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
8093 {"%ld", "", "d", ""}, /* Decimal format info */
8094 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
8096 /* Copied from c-lang.c. */
8097 {"0%lo", "0", "o", ""}, /* Octal format info */
8098 {"%ld", "", "d", ""}, /* Decimal format info */
8099 {"0x%lx", "0x", "x", ""}, /* Hex format info */
8101 ada_op_print_tab
, /* expression operators for printing */
8102 1, /* c-style arrays (FIXME?) */
8103 0, /* String lower bound (FIXME?) */
8104 &builtin_type_ada_char
,
8109 _initialize_ada_language (void)
8111 builtin_type_ada_int
=
8112 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8113 0, "integer", (struct objfile
*) NULL
);
8114 builtin_type_ada_long
=
8115 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8116 0, "long_integer", (struct objfile
*) NULL
);
8117 builtin_type_ada_short
=
8118 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8119 0, "short_integer", (struct objfile
*) NULL
);
8120 builtin_type_ada_char
=
8121 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8122 0, "character", (struct objfile
*) NULL
);
8123 builtin_type_ada_float
=
8124 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8125 0, "float", (struct objfile
*) NULL
);
8126 builtin_type_ada_double
=
8127 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8128 0, "long_float", (struct objfile
*) NULL
);
8129 builtin_type_ada_long_long
=
8130 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8131 0, "long_long_integer", (struct objfile
*) NULL
);
8132 builtin_type_ada_long_double
=
8133 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8134 0, "long_long_float", (struct objfile
*) NULL
);
8135 builtin_type_ada_natural
=
8136 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8137 0, "natural", (struct objfile
*) NULL
);
8138 builtin_type_ada_positive
=
8139 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8140 0, "positive", (struct objfile
*) NULL
);
8143 builtin_type_ada_system_address
=
8144 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8145 (struct objfile
*) NULL
));
8146 TYPE_NAME (builtin_type_ada_system_address
) = "system__address";
8148 add_language (&ada_language_defn
);
8151 (add_set_cmd ("varsize-limit", class_support
, var_uinteger
,
8152 (char *) &varsize_limit
,
8153 "Set maximum bytes in dynamic-sized object.",
8154 &setlist
), &showlist
);
8155 varsize_limit
= 65536;
8157 add_com ("begin", class_breakpoint
, begin_command
,
8158 "Start the debugged program, stopping at the beginning of the\n\
8159 main program. You may specify command-line arguments to give it, as for\n\
8160 the \"run\" command (q.v.).");
8164 /* Create a fundamental Ada type using default reasonable for the current
8167 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8168 define fundamental types such as "int" or "double". Others (stabs or
8169 DWARF version 2, etc) do define fundamental types. For the formats which
8170 don't provide fundamental types, gdb can create such types using this
8173 FIXME: Some compilers distinguish explicitly signed integral types
8174 (signed short, signed int, signed long) from "regular" integral types
8175 (short, int, long) in the debugging information. There is some dis-
8176 agreement as to how useful this feature is. In particular, gcc does
8177 not support this. Also, only some debugging formats allow the
8178 distinction to be passed on to a debugger. For now, we always just
8179 use "short", "int", or "long" as the type name, for both the implicit
8180 and explicitly signed types. This also makes life easier for the
8181 gdb test suite since we don't have to account for the differences
8182 in output depending upon what the compiler and debugging format
8183 support. We will probably have to re-examine the issue when gdb
8184 starts taking it's fundamental type information directly from the
8185 debugging information supplied by the compiler. fnf@cygnus.com */
8187 static struct type
*
8188 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8190 struct type
*type
= NULL
;
8195 /* FIXME: For now, if we are asked to produce a type not in this
8196 language, create the equivalent of a C integer type with the
8197 name "<?type?>". When all the dust settles from the type
8198 reconstruction work, this should probably become an error. */
8199 type
= init_type (TYPE_CODE_INT
,
8200 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8201 0, "<?type?>", objfile
);
8202 warning ("internal error: no Ada fundamental type %d", typeid);
8205 type
= init_type (TYPE_CODE_VOID
,
8206 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8207 0, "void", objfile
);
8210 type
= init_type (TYPE_CODE_INT
,
8211 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8212 0, "character", objfile
);
8214 case FT_SIGNED_CHAR
:
8215 type
= init_type (TYPE_CODE_INT
,
8216 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8217 0, "signed char", objfile
);
8219 case FT_UNSIGNED_CHAR
:
8220 type
= init_type (TYPE_CODE_INT
,
8221 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8222 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8225 type
= init_type (TYPE_CODE_INT
,
8226 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8227 0, "short_integer", objfile
);
8229 case FT_SIGNED_SHORT
:
8230 type
= init_type (TYPE_CODE_INT
,
8231 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8232 0, "short_integer", objfile
);
8234 case FT_UNSIGNED_SHORT
:
8235 type
= init_type (TYPE_CODE_INT
,
8236 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8237 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8240 type
= init_type (TYPE_CODE_INT
,
8241 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8242 0, "integer", objfile
);
8244 case FT_SIGNED_INTEGER
:
8245 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
, 0, "integer", objfile
); /* FIXME -fnf */
8247 case FT_UNSIGNED_INTEGER
:
8248 type
= init_type (TYPE_CODE_INT
,
8249 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8250 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8253 type
= init_type (TYPE_CODE_INT
,
8254 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8255 0, "long_integer", objfile
);
8257 case FT_SIGNED_LONG
:
8258 type
= init_type (TYPE_CODE_INT
,
8259 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8260 0, "long_integer", objfile
);
8262 case FT_UNSIGNED_LONG
:
8263 type
= init_type (TYPE_CODE_INT
,
8264 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8265 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8268 type
= init_type (TYPE_CODE_INT
,
8269 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8270 0, "long_long_integer", objfile
);
8272 case FT_SIGNED_LONG_LONG
:
8273 type
= init_type (TYPE_CODE_INT
,
8274 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8275 0, "long_long_integer", objfile
);
8277 case FT_UNSIGNED_LONG_LONG
:
8278 type
= init_type (TYPE_CODE_INT
,
8279 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8280 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8283 type
= init_type (TYPE_CODE_FLT
,
8284 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8285 0, "float", objfile
);
8287 case FT_DBL_PREC_FLOAT
:
8288 type
= init_type (TYPE_CODE_FLT
,
8289 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8290 0, "long_float", objfile
);
8292 case FT_EXT_PREC_FLOAT
:
8293 type
= init_type (TYPE_CODE_FLT
,
8294 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8295 0, "long_long_float", objfile
);
8302 ada_dump_symtab (struct symtab
*s
)
8305 fprintf (stderr
, "New symtab: [\n");
8306 fprintf (stderr
, " Name: %s/%s;\n",
8307 s
->dirname
? s
->dirname
: "?", s
->filename
? s
->filename
: "?");
8308 fprintf (stderr
, " Format: %s;\n", s
->debugformat
);
8309 if (s
->linetable
!= NULL
)
8311 fprintf (stderr
, " Line table (section %d):\n", s
->block_line_section
);
8312 for (i
= 0; i
< s
->linetable
->nitems
; i
+= 1)
8314 struct linetable_entry
*e
= s
->linetable
->item
+ i
;
8315 fprintf (stderr
, " %4ld: %8lx\n", (long) e
->line
, (long) e
->pc
);
8318 fprintf (stderr
, "]\n");