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_TYPE (ftype
, nargs
) =
4193 lookup_pointer_type (check_typedef (SYMBOL_TYPE (sym
)));
4194 TYPE_FIELD_NAME (ftype
, nargs
) = SYMBOL_NAME (sym
);
4202 case LOC_BASEREG_ARG
:
4203 TYPE_FIELD_BITPOS (ftype
, nargs
) = nargs
;
4204 TYPE_FIELD_BITSIZE (ftype
, nargs
) = 0;
4205 TYPE_FIELD_TYPE (ftype
, nargs
) = check_typedef (SYMBOL_TYPE (sym
));
4206 TYPE_FIELD_NAME (ftype
, nargs
) = SYMBOL_NAME (sym
);
4216 /* Re-allocate fields vector; if there are no fields, make the */
4217 /* fields pointer non-null anyway, to mark that this function type */
4218 /* has been filled in. */
4220 TYPE_NFIELDS (ftype
) = nargs
;
4223 static struct field dummy_field
= { 0, 0, 0, 0 };
4224 xfree (TYPE_FIELDS (ftype
));
4225 TYPE_FIELDS (ftype
) = &dummy_field
;
4229 struct field
*fields
=
4230 (struct field
*) TYPE_ALLOC (ftype
, nargs
* sizeof (struct field
));
4231 memcpy ((char *) fields
,
4232 (char *) TYPE_FIELDS (ftype
), nargs
* sizeof (struct field
));
4233 xfree (TYPE_FIELDS (ftype
));
4234 TYPE_FIELDS (ftype
) = fields
;
4239 /* Breakpoint-related */
4241 char no_symtab_msg
[] =
4242 "No symbol table is loaded. Use the \"file\" command.";
4244 /* Assuming that LINE is pointing at the beginning of an argument to
4245 'break', return a pointer to the delimiter for the initial segment
4246 of that name. This is the first ':', ' ', or end of LINE.
4249 ada_start_decode_line_1 (char *line
)
4251 /* [NOTE: strpbrk would be more elegant, but I am reluctant to be
4252 the first to use such a library function in GDB code.] */
4254 for (p
= line
; *p
!= '\000' && *p
!= ' ' && *p
!= ':'; p
+= 1)
4259 /* *SPEC points to a function and line number spec (as in a break
4260 command), following any initial file name specification.
4262 Return all symbol table/line specfications (sals) consistent with the
4263 information in *SPEC and FILE_TABLE in the
4265 + FILE_TABLE is null, or the sal refers to a line in the file
4266 named by FILE_TABLE.
4267 + If *SPEC points to an argument with a trailing ':LINENUM',
4268 then the sal refers to that line (or one following it as closely as
4270 + If *SPEC does not start with '*', the sal is in a function with
4273 Returns with 0 elements if no matching non-minimal symbols found.
4275 If *SPEC begins with a function name of the form <NAME>, then NAME
4276 is taken as a literal name; otherwise the function name is subject
4277 to the usual mangling.
4279 *SPEC is updated to point after the function/line number specification.
4281 FUNFIRSTLINE is non-zero if we desire the first line of real code
4282 in each function (this is ignored in the presence of a LINENUM spec.).
4284 If CANONICAL is non-NULL, and if any of the sals require a
4285 'canonical line spec', then *CANONICAL is set to point to an array
4286 of strings, corresponding to and equal in length to the returned
4287 list of sals, such that (*CANONICAL)[i] is non-null and contains a
4288 canonical line spec for the ith returned sal, if needed. If no
4289 canonical line specs are required and CANONICAL is non-null,
4290 *CANONICAL is set to NULL.
4292 A 'canonical line spec' is simply a name (in the format of the
4293 breakpoint command) that uniquely identifies a breakpoint position,
4294 with no further contextual information or user selection. It is
4295 needed whenever the file name, function name, and line number
4296 information supplied is insufficient for this unique
4297 identification. Currently overloaded functions, the name '*',
4298 or static functions without a filename yield a canonical line spec.
4299 The array and the line spec strings are allocated on the heap; it
4300 is the caller's responsibility to free them. */
4302 struct symtabs_and_lines
4303 ada_finish_decode_line_1 (char **spec
, struct symtab
*file_table
,
4304 int funfirstline
, char ***canonical
)
4306 struct symbol
**symbols
;
4307 struct block
**blocks
;
4308 struct block
*block
;
4309 int n_matches
, i
, line_num
;
4310 struct symtabs_and_lines selected
;
4311 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
4316 char *unquoted_name
;
4318 if (file_table
== NULL
)
4319 block
= get_selected_block (NULL
);
4321 block
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (file_table
), STATIC_BLOCK
);
4323 if (canonical
!= NULL
)
4324 *canonical
= (char **) NULL
;
4331 while (**spec
!= '\000' &&
4332 !strchr (ada_completer_word_break_characters
, **spec
))
4338 if (file_table
!= NULL
&& (*spec
)[0] == ':' && isdigit ((*spec
)[1]))
4340 line_num
= strtol (*spec
+ 1, spec
, 10);
4341 while (**spec
== ' ' || **spec
== '\t')
4348 error ("Wild-card function with no line number or file name.");
4350 return all_sals_for_line (file_table
->filename
, line_num
, canonical
);
4353 if (name
[0] == '\'')
4361 unquoted_name
= (char *) alloca (len
- 1);
4362 memcpy (unquoted_name
, name
+ 1, len
- 2);
4363 unquoted_name
[len
- 2] = '\000';
4368 unquoted_name
= (char *) alloca (len
+ 1);
4369 memcpy (unquoted_name
, name
, len
);
4370 unquoted_name
[len
] = '\000';
4371 lower_name
= (char *) alloca (len
+ 1);
4372 for (i
= 0; i
< len
; i
+= 1)
4373 lower_name
[i
] = tolower (name
[i
]);
4374 lower_name
[len
] = '\000';
4378 if (lower_name
!= NULL
)
4379 n_matches
= ada_lookup_symbol_list (ada_mangle (lower_name
), block
,
4380 VAR_NAMESPACE
, &symbols
, &blocks
);
4382 n_matches
= ada_lookup_symbol_list (unquoted_name
, block
,
4383 VAR_NAMESPACE
, &symbols
, &blocks
);
4384 if (n_matches
== 0 && line_num
>= 0)
4385 error ("No line number information found for %s.", unquoted_name
);
4386 else if (n_matches
== 0)
4388 #ifdef HPPA_COMPILER_BUG
4389 /* FIXME: See comment in symtab.c::decode_line_1 */
4391 volatile struct symtab_and_line val
;
4392 #define volatile /*nothing */
4394 struct symtab_and_line val
;
4396 struct minimal_symbol
*msymbol
;
4401 if (lower_name
!= NULL
)
4402 msymbol
= ada_lookup_minimal_symbol (ada_mangle (lower_name
));
4403 if (msymbol
== NULL
)
4404 msymbol
= ada_lookup_minimal_symbol (unquoted_name
);
4405 if (msymbol
!= NULL
)
4407 val
.pc
= SYMBOL_VALUE_ADDRESS (msymbol
);
4408 val
.section
= SYMBOL_BFD_SECTION (msymbol
);
4411 val
.pc
+= FUNCTION_START_OFFSET
;
4412 SKIP_PROLOGUE (val
.pc
);
4414 selected
.sals
= (struct symtab_and_line
*)
4415 xmalloc (sizeof (struct symtab_and_line
));
4416 selected
.sals
[0] = val
;
4421 if (!have_full_symbols () &&
4422 !have_partial_symbols () && !have_minimal_symbols ())
4423 error (no_symtab_msg
);
4425 error ("Function \"%s\" not defined.", unquoted_name
);
4426 return selected
; /* for lint */
4432 find_sal_from_funcs_and_line (file_table
->filename
, line_num
,
4433 symbols
, n_matches
);
4438 user_select_syms (symbols
, blocks
, n_matches
, n_matches
);
4441 selected
.sals
= (struct symtab_and_line
*)
4442 xmalloc (sizeof (struct symtab_and_line
) * selected
.nelts
);
4443 memset (selected
.sals
, 0, selected
.nelts
* sizeof (selected
.sals
[i
]));
4444 make_cleanup (xfree
, selected
.sals
);
4447 while (i
< selected
.nelts
)
4449 if (SYMBOL_CLASS (symbols
[i
]) == LOC_BLOCK
)
4450 selected
.sals
[i
] = find_function_start_sal (symbols
[i
], funfirstline
);
4451 else if (SYMBOL_LINE (symbols
[i
]) != 0)
4453 selected
.sals
[i
].symtab
= symtab_for_sym (symbols
[i
]);
4454 selected
.sals
[i
].line
= SYMBOL_LINE (symbols
[i
]);
4456 else if (line_num
>= 0)
4458 /* Ignore this choice */
4459 symbols
[i
] = symbols
[selected
.nelts
- 1];
4460 blocks
[i
] = blocks
[selected
.nelts
- 1];
4461 selected
.nelts
-= 1;
4465 error ("Line number not known for symbol \"%s\"", unquoted_name
);
4469 if (canonical
!= NULL
&& (line_num
>= 0 || n_matches
> 1))
4471 *canonical
= (char **) xmalloc (sizeof (char *) * selected
.nelts
);
4472 for (i
= 0; i
< selected
.nelts
; i
+= 1)
4474 extended_canonical_line_spec (selected
.sals
[i
],
4475 SYMBOL_SOURCE_NAME (symbols
[i
]));
4478 discard_cleanups (old_chain
);
4482 /* The (single) sal corresponding to line LINE_NUM in a symbol table
4483 with file name FILENAME that occurs in one of the functions listed
4484 in SYMBOLS[0 .. NSYMS-1]. */
4485 static struct symtabs_and_lines
4486 find_sal_from_funcs_and_line (const char *filename
, int line_num
,
4487 struct symbol
**symbols
, int nsyms
)
4489 struct symtabs_and_lines sals
;
4490 int best_index
, best
;
4491 struct linetable
*best_linetable
;
4492 struct objfile
*objfile
;
4494 struct symtab
*best_symtab
;
4496 read_all_symtabs (filename
);
4499 best_linetable
= NULL
;
4502 ALL_SYMTABS (objfile
, s
)
4504 struct linetable
*l
;
4509 if (!STREQ (filename
, s
->filename
))
4512 ind
= find_line_in_linetable (l
, line_num
, symbols
, nsyms
, &exact
);
4522 if (best
== 0 || l
->item
[ind
].line
< best
)
4524 best
= l
->item
[ind
].line
;
4533 error ("Line number not found in designated function.");
4538 sals
.sals
= (struct symtab_and_line
*) xmalloc (sizeof (sals
.sals
[0]));
4540 INIT_SAL (&sals
.sals
[0]);
4542 sals
.sals
[0].line
= best_linetable
->item
[best_index
].line
;
4543 sals
.sals
[0].pc
= best_linetable
->item
[best_index
].pc
;
4544 sals
.sals
[0].symtab
= best_symtab
;
4549 /* Return the index in LINETABLE of the best match for LINE_NUM whose
4550 pc falls within one of the functions denoted by SYMBOLS[0..NSYMS-1].
4551 Set *EXACTP to the 1 if the match is exact, and 0 otherwise. */
4553 find_line_in_linetable (struct linetable
*linetable
, int line_num
,
4554 struct symbol
**symbols
, int nsyms
, int *exactp
)
4556 int i
, len
, best_index
, best
;
4558 if (line_num
<= 0 || linetable
== NULL
)
4561 len
= linetable
->nitems
;
4562 for (i
= 0, best_index
= -1, best
= 0; i
< len
; i
+= 1)
4565 struct linetable_entry
*item
= &(linetable
->item
[i
]);
4567 for (k
= 0; k
< nsyms
; k
+= 1)
4569 if (symbols
[k
] != NULL
&& SYMBOL_CLASS (symbols
[k
]) == LOC_BLOCK
4570 && item
->pc
>= BLOCK_START (SYMBOL_BLOCK_VALUE (symbols
[k
]))
4571 && item
->pc
< BLOCK_END (SYMBOL_BLOCK_VALUE (symbols
[k
])))
4578 if (item
->line
== line_num
)
4584 if (item
->line
> line_num
&& (best
== 0 || item
->line
< best
))
4595 /* Find the smallest k >= LINE_NUM such that k is a line number in
4596 LINETABLE, and k falls strictly within a named function that begins at
4597 or before LINE_NUM. Return -1 if there is no such k. */
4599 nearest_line_number_in_linetable (struct linetable
*linetable
, int line_num
)
4603 if (line_num
<= 0 || linetable
== NULL
|| linetable
->nitems
== 0)
4605 len
= linetable
->nitems
;
4612 struct linetable_entry
*item
= &(linetable
->item
[i
]);
4614 if (item
->line
>= line_num
&& item
->line
< best
)
4617 CORE_ADDR start
, end
;
4620 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
4622 if (func_name
!= NULL
&& item
->pc
< end
)
4624 if (item
->line
== line_num
)
4628 struct symbol
*sym
=
4629 standard_lookup (func_name
, VAR_NAMESPACE
);
4630 if (is_plausible_func_for_line (sym
, line_num
))
4636 while (i
< len
&& linetable
->item
[i
].pc
< end
);
4646 return (best
== INT_MAX
) ? -1 : best
;
4650 /* Return the next higher index, k, into LINETABLE such that k > IND,
4651 entry k in LINETABLE has a line number equal to LINE_NUM, k
4652 corresponds to a PC that is in a function different from that
4653 corresponding to IND, and falls strictly within a named function
4654 that begins at a line at or preceding STARTING_LINE.
4655 Return -1 if there is no such k.
4656 IND == -1 corresponds to no function. */
4659 find_next_line_in_linetable (struct linetable
*linetable
, int line_num
,
4660 int starting_line
, int ind
)
4664 if (line_num
<= 0 || linetable
== NULL
|| ind
>= linetable
->nitems
)
4666 len
= linetable
->nitems
;
4670 CORE_ADDR start
, end
;
4672 if (find_pc_partial_function (linetable
->item
[ind
].pc
,
4673 (char **) NULL
, &start
, &end
))
4675 while (ind
< len
&& linetable
->item
[ind
].pc
< end
)
4688 struct linetable_entry
*item
= &(linetable
->item
[i
]);
4690 if (item
->line
>= line_num
)
4693 CORE_ADDR start
, end
;
4696 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
4698 if (func_name
!= NULL
&& item
->pc
< end
)
4700 if (item
->line
== line_num
)
4702 struct symbol
*sym
=
4703 standard_lookup (func_name
, VAR_NAMESPACE
);
4704 if (is_plausible_func_for_line (sym
, starting_line
))
4708 while ((i
+ 1) < len
&& linetable
->item
[i
+ 1].pc
< end
)
4720 /* True iff function symbol SYM starts somewhere at or before line #
4723 is_plausible_func_for_line (struct symbol
*sym
, int line_num
)
4725 struct symtab_and_line start_sal
;
4730 start_sal
= find_function_start_sal (sym
, 0);
4732 return (start_sal
.line
!= 0 && line_num
>= start_sal
.line
);
4736 debug_print_lines (struct linetable
*lt
)
4743 fprintf (stderr
, "\t");
4744 for (i
= 0; i
< lt
->nitems
; i
+= 1)
4745 fprintf (stderr
, "(%d->%p) ", lt
->item
[i
].line
, (void *) lt
->item
[i
].pc
);
4746 fprintf (stderr
, "\n");
4750 debug_print_block (struct block
*b
)
4755 fprintf (stderr
, "Block: %p; [0x%lx, 0x%lx]",
4756 b
, BLOCK_START (b
), BLOCK_END (b
));
4757 if (BLOCK_FUNCTION (b
) != NULL
)
4758 fprintf (stderr
, " Function: %s", SYMBOL_NAME (BLOCK_FUNCTION (b
)));
4759 fprintf (stderr
, "\n");
4760 fprintf (stderr
, "\t Superblock: %p\n", BLOCK_SUPERBLOCK (b
));
4761 fprintf (stderr
, "\t Symbols:");
4762 ALL_BLOCK_SYMBOLS (b
, i
, sym
)
4764 if (i
> 0 && i
% 4 == 0)
4765 fprintf (stderr
, "\n\t\t ");
4766 fprintf (stderr
, " %s", SYMBOL_NAME (sym
));
4768 fprintf (stderr
, "\n");
4772 debug_print_blocks (struct blockvector
*bv
)
4778 for (i
= 0; i
< BLOCKVECTOR_NBLOCKS (bv
); i
+= 1)
4780 fprintf (stderr
, "%6d. ", i
);
4781 debug_print_block (BLOCKVECTOR_BLOCK (bv
, i
));
4786 debug_print_symtab (struct symtab
*s
)
4788 fprintf (stderr
, "Symtab %p\n File: %s; Dir: %s\n", s
,
4789 s
->filename
, s
->dirname
);
4790 fprintf (stderr
, " Blockvector: %p, Primary: %d\n",
4791 BLOCKVECTOR (s
), s
->primary
);
4792 debug_print_blocks (BLOCKVECTOR (s
));
4793 fprintf (stderr
, " Line table: %p\n", LINETABLE (s
));
4794 debug_print_lines (LINETABLE (s
));
4797 /* Read in all symbol tables corresponding to partial symbol tables
4798 with file name FILENAME. */
4800 read_all_symtabs (const char *filename
)
4802 struct partial_symtab
*ps
;
4803 struct objfile
*objfile
;
4805 ALL_PSYMTABS (objfile
, ps
)
4809 if (STREQ (filename
, ps
->filename
))
4810 PSYMTAB_TO_SYMTAB (ps
);
4814 /* All sals corresponding to line LINE_NUM in a symbol table from file
4815 FILENAME, as filtered by the user. If CANONICAL is not null, set
4816 it to a corresponding array of canonical line specs. */
4817 static struct symtabs_and_lines
4818 all_sals_for_line (const char *filename
, int line_num
, char ***canonical
)
4820 struct symtabs_and_lines result
;
4821 struct objfile
*objfile
;
4823 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
4826 read_all_symtabs (filename
);
4829 (struct symtab_and_line
*) xmalloc (4 * sizeof (result
.sals
[0]));
4832 make_cleanup (free_current_contents
, &result
.sals
);
4834 ALL_SYMTABS (objfile
, s
)
4836 int ind
, target_line_num
;
4840 if (!STREQ (s
->filename
, filename
))
4844 nearest_line_number_in_linetable (LINETABLE (s
), line_num
);
4845 if (target_line_num
== -1)
4852 find_next_line_in_linetable (LINETABLE (s
),
4853 target_line_num
, line_num
, ind
);
4858 GROW_VECT (result
.sals
, len
, result
.nelts
+ 1);
4859 INIT_SAL (&result
.sals
[result
.nelts
]);
4860 result
.sals
[result
.nelts
].line
= LINETABLE (s
)->item
[ind
].line
;
4861 result
.sals
[result
.nelts
].pc
= LINETABLE (s
)->item
[ind
].pc
;
4862 result
.sals
[result
.nelts
].symtab
= s
;
4867 if (canonical
!= NULL
|| result
.nelts
> 1)
4870 char **func_names
= (char **) alloca (result
.nelts
* sizeof (char *));
4871 int first_choice
= (result
.nelts
> 1) ? 2 : 1;
4873 int *choices
= (int *) alloca (result
.nelts
* sizeof (int));
4875 for (k
= 0; k
< result
.nelts
; k
+= 1)
4877 find_pc_partial_function (result
.sals
[k
].pc
, &func_names
[k
],
4878 (CORE_ADDR
*) NULL
, (CORE_ADDR
*) NULL
);
4879 if (func_names
[k
] == NULL
)
4880 error ("Could not find function for one or more breakpoints.");
4883 if (result
.nelts
> 1)
4885 printf_unfiltered ("[0] cancel\n");
4886 if (result
.nelts
> 1)
4887 printf_unfiltered ("[1] all\n");
4888 for (k
= 0; k
< result
.nelts
; k
+= 1)
4889 printf_unfiltered ("[%d] %s\n", k
+ first_choice
,
4890 ada_demangle (func_names
[k
]));
4892 n
= get_selections (choices
, result
.nelts
, result
.nelts
,
4893 result
.nelts
> 1, "instance-choice");
4895 for (k
= 0; k
< n
; k
+= 1)
4897 result
.sals
[k
] = result
.sals
[choices
[k
]];
4898 func_names
[k
] = func_names
[choices
[k
]];
4903 if (canonical
!= NULL
)
4905 *canonical
= (char **) xmalloc (result
.nelts
* sizeof (char **));
4906 make_cleanup (xfree
, *canonical
);
4907 for (k
= 0; k
< result
.nelts
; k
+= 1)
4910 extended_canonical_line_spec (result
.sals
[k
], func_names
[k
]);
4911 if ((*canonical
)[k
] == NULL
)
4912 error ("Could not locate one or more breakpoints.");
4913 make_cleanup (xfree
, (*canonical
)[k
]);
4918 discard_cleanups (old_chain
);
4923 /* A canonical line specification of the form FILE:NAME:LINENUM for
4924 symbol table and line data SAL. NULL if insufficient
4925 information. The caller is responsible for releasing any space
4929 extended_canonical_line_spec (struct symtab_and_line sal
, const char *name
)
4933 if (sal
.symtab
== NULL
|| sal
.symtab
->filename
== NULL
|| sal
.line
<= 0)
4936 r
= (char *) xmalloc (strlen (name
) + strlen (sal
.symtab
->filename
)
4937 + sizeof (sal
.line
) * 3 + 3);
4938 sprintf (r
, "%s:'%s':%d", sal
.symtab
->filename
, name
, sal
.line
);
4943 int begin_bnum
= -1;
4945 int begin_annotate_level
= 0;
4948 begin_cleanup (void *dummy
)
4950 begin_annotate_level
= 0;
4954 begin_command (char *args
, int from_tty
)
4956 struct minimal_symbol
*msym
;
4957 CORE_ADDR main_program_name_addr
;
4958 char main_program_name
[1024];
4959 struct cleanup
*old_chain
= make_cleanup (begin_cleanup
, NULL
);
4960 begin_annotate_level
= 2;
4962 /* Check that there is a program to debug */
4963 if (!have_full_symbols () && !have_partial_symbols ())
4964 error ("No symbol table is loaded. Use the \"file\" command.");
4966 /* Check that we are debugging an Ada program */
4967 /* if (ada_update_initial_language (language_unknown, NULL) != language_ada)
4968 error ("Cannot find the Ada initialization procedure. Is this an Ada main program?");
4970 /* FIXME: language_ada should be defined in defs.h */
4972 /* Get the address of the name of the main procedure */
4973 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
4977 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
4978 if (main_program_name_addr
== 0)
4979 error ("Invalid address for Ada main program name.");
4981 /* Read the name of the main procedure */
4982 extract_string (main_program_name_addr
, main_program_name
);
4984 /* Put a temporary breakpoint in the Ada main program and run */
4985 do_command ("tbreak ", main_program_name
, 0);
4986 do_command ("run ", args
, 0);
4990 /* If we could not find the symbol containing the name of the
4991 main program, that means that the compiler that was used to build
4992 was not recent enough. In that case, we fallback to the previous
4993 mechanism, which is a little bit less reliable, but has proved to work
4994 in most cases. The only cases where it will fail is when the user
4995 has set some breakpoints which will be hit before the end of the
4996 begin command processing (eg in the initialization code).
4998 The begining of the main Ada subprogram is located by breaking
4999 on the adainit procedure. Since we know that the binder generates
5000 the call to this procedure exactly 2 calls before the call to the
5001 Ada main subprogram, it is then easy to put a breakpoint on this
5002 Ada main subprogram once we hit adainit.
5004 do_command ("tbreak adainit", 0);
5005 do_command ("run ", args
, 0);
5006 do_command ("up", 0);
5007 do_command ("tbreak +2", 0);
5008 do_command ("continue", 0);
5009 do_command ("step", 0);
5012 do_cleanups (old_chain
);
5016 is_ada_runtime_file (char *filename
)
5018 return (STREQN (filename
, "s-", 2) ||
5019 STREQN (filename
, "a-", 2) ||
5020 STREQN (filename
, "g-", 2) || STREQN (filename
, "i-", 2));
5023 /* find the first frame that contains debugging information and that is not
5024 part of the Ada run-time, starting from fi and moving upward. */
5027 find_printable_frame (struct frame_info
*fi
, int level
)
5029 struct symtab_and_line sal
;
5031 for (; fi
!= NULL
; level
+= 1, fi
= get_prev_frame (fi
))
5033 /* If fi is not the innermost frame, that normally means that fi->pc
5034 points to *after* the call instruction, and we want to get the line
5035 containing the call, never the next line. But if the next frame is
5036 a signal_handler_caller or a dummy frame, then the next frame was
5037 not entered as the result of a call, and we want to get the line
5038 containing fi->pc. */
5040 find_pc_line (fi
->pc
,
5042 && !fi
->next
->signal_handler_caller
5043 && !frame_in_dummy (fi
->next
));
5044 if (sal
.symtab
&& !is_ada_runtime_file (sal
.symtab
->filename
))
5046 #if defined(__alpha__) && defined(__osf__) && !defined(VXWORKS_TARGET)
5047 /* libpthread.so contains some debugging information that prevents us
5048 from finding the right frame */
5050 if (sal
.symtab
->objfile
&&
5051 STREQ (sal
.symtab
->objfile
->name
, "/usr/shlib/libpthread.so"))
5054 selected_frame
= fi
;
5063 ada_report_exception_break (struct breakpoint
*b
)
5066 /* FIXME: break_on_exception should be defined in breakpoint.h */
5067 /* if (b->break_on_exception == 1)
5069 /* Assume that cond has 16 elements, the 15th
5070 being the exception *//*
5071 if (b->cond && b->cond->nelts == 16)
5073 ui_out_text (uiout, "on ");
5074 ui_out_field_string (uiout, "exception",
5075 SYMBOL_NAME (b->cond->elts[14].symbol));
5078 ui_out_text (uiout, "on all exceptions");
5080 else if (b->break_on_exception == 2)
5081 ui_out_text (uiout, "on unhandled exception");
5082 else if (b->break_on_exception == 3)
5083 ui_out_text (uiout, "on assert failure");
5085 if (b->break_on_exception == 1)
5087 /* Assume that cond has 16 elements, the 15th
5088 being the exception *//*
5089 if (b->cond && b->cond->nelts == 16)
5091 fputs_filtered ("on ", gdb_stdout);
5092 fputs_filtered (SYMBOL_NAME
5093 (b->cond->elts[14].symbol), gdb_stdout);
5096 fputs_filtered ("on all exceptions", gdb_stdout);
5098 else if (b->break_on_exception == 2)
5099 fputs_filtered ("on unhandled exception", gdb_stdout);
5100 else if (b->break_on_exception == 3)
5101 fputs_filtered ("on assert failure", gdb_stdout);
5107 ada_is_exception_sym (struct symbol
*sym
)
5109 char *type_name
= type_name_no_tag (SYMBOL_TYPE (sym
));
5111 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5112 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5113 && SYMBOL_CLASS (sym
) != LOC_CONST
5114 && type_name
!= NULL
&& STREQ (type_name
, "exception"));
5118 ada_maybe_exception_partial_symbol (struct partial_symbol
*sym
)
5120 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5121 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5122 && SYMBOL_CLASS (sym
) != LOC_CONST
);
5125 /* If ARG points to an Ada exception or assert breakpoint, rewrite
5126 into equivalent form. Return resulting argument string. Set
5127 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
5128 break on unhandled, 3 for assert, 0 otherwise. */
5130 ada_breakpoint_rewrite (char *arg
, int *break_on_exceptionp
)
5134 *break_on_exceptionp
= 0;
5135 /* FIXME: language_ada should be defined in defs.h */
5136 /* if (current_language->la_language == language_ada
5137 && STREQN (arg, "exception", 9) &&
5138 (arg[9] == ' ' || arg[9] == '\t' || arg[9] == '\0'))
5140 char *tok, *end_tok;
5143 *break_on_exceptionp = 1;
5146 while (*tok == ' ' || *tok == '\t')
5151 while (*end_tok != ' ' && *end_tok != '\t' && *end_tok != '\000')
5154 toklen = end_tok - tok;
5156 arg = (char*) xmalloc (sizeof ("__gnat_raise_nodefer_with_msg if "
5157 "long_integer(e) = long_integer(&)")
5159 make_cleanup (xfree, arg);
5161 strcpy (arg, "__gnat_raise_nodefer_with_msg");
5162 else if (STREQN (tok, "unhandled", toklen))
5164 *break_on_exceptionp = 2;
5165 strcpy (arg, "__gnat_unhandled_exception");
5169 sprintf (arg, "__gnat_raise_nodefer_with_msg if "
5170 "long_integer(e) = long_integer(&%.*s)",
5174 else if (current_language->la_language == language_ada
5175 && STREQN (arg, "assert", 6) &&
5176 (arg[6] == ' ' || arg[6] == '\t' || arg[6] == '\0'))
5178 char *tok = arg + 6;
5180 *break_on_exceptionp = 3;
5183 xmalloc (sizeof ("system__assertions__raise_assert_failure")
5184 + strlen (tok) + 1);
5185 make_cleanup (xfree, arg);
5186 sprintf (arg, "system__assertions__raise_assert_failure%s", tok);
5195 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5196 to be invisible to users. */
5199 ada_is_ignored_field (struct type
*type
, int field_num
)
5201 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5205 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5206 return (name
== NULL
5207 || (name
[0] == '_' && !STREQN (name
, "_parent", 7)));
5211 /* True iff structure type TYPE has a tag field. */
5214 ada_is_tagged_type (struct type
*type
)
5216 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5219 return (ada_lookup_struct_elt_type (type
, "_tag", 1, NULL
) != NULL
);
5222 /* The type of the tag on VAL. */
5225 ada_tag_type (struct value
*val
)
5227 return ada_lookup_struct_elt_type (VALUE_TYPE (val
), "_tag", 0, NULL
);
5230 /* The value of the tag on VAL. */
5233 ada_value_tag (struct value
*val
)
5235 return ada_value_struct_elt (val
, "_tag", "record");
5238 /* The parent type of TYPE, or NULL if none. */
5241 ada_parent_type (struct type
*type
)
5245 CHECK_TYPEDEF (type
);
5247 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5250 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5251 if (ada_is_parent_field (type
, i
))
5252 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5257 /* True iff field number FIELD_NUM of structure type TYPE contains the
5258 parent-type (inherited) fields of a derived type. Assumes TYPE is
5259 a structure type with at least FIELD_NUM+1 fields. */
5262 ada_is_parent_field (struct type
*type
, int field_num
)
5264 const char *name
= TYPE_FIELD_NAME (check_typedef (type
), field_num
);
5265 return (name
!= NULL
&&
5266 (STREQN (name
, "PARENT", 6) || STREQN (name
, "_parent", 7)));
5269 /* True iff field number FIELD_NUM of structure type TYPE is a
5270 transparent wrapper field (which should be silently traversed when doing
5271 field selection and flattened when printing). Assumes TYPE is a
5272 structure type with at least FIELD_NUM+1 fields. Such fields are always
5276 ada_is_wrapper_field (struct type
*type
, int field_num
)
5278 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5279 return (name
!= NULL
5280 && (STREQN (name
, "PARENT", 6) || STREQ (name
, "REP")
5281 || STREQN (name
, "_parent", 7)
5282 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5285 /* True iff field number FIELD_NUM of structure or union type TYPE
5286 is a variant wrapper. Assumes TYPE is a structure type with at least
5287 FIELD_NUM+1 fields. */
5290 ada_is_variant_part (struct type
*type
, int field_num
)
5292 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5293 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5294 || (is_dynamic_field (type
, field_num
)
5295 && TYPE_CODE (TYPE_TARGET_TYPE (field_type
)) ==
5299 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5300 whose discriminants are contained in the record type OUTER_TYPE,
5301 returns the type of the controlling discriminant for the variant. */
5304 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5306 char *name
= ada_variant_discrim_name (var_type
);
5307 struct type
*type
= ada_lookup_struct_elt_type (outer_type
, name
, 1, NULL
);
5309 return builtin_type_int
;
5314 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5315 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5316 represents a 'when others' clause; otherwise 0. */
5319 ada_is_others_clause (struct type
*type
, int field_num
)
5321 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5322 return (name
!= NULL
&& name
[0] == 'O');
5325 /* Assuming that TYPE0 is the type of the variant part of a record,
5326 returns the name of the discriminant controlling the variant. The
5327 value is valid until the next call to ada_variant_discrim_name. */
5330 ada_variant_discrim_name (struct type
*type0
)
5332 static char *result
= NULL
;
5333 static size_t result_len
= 0;
5336 const char *discrim_end
;
5337 const char *discrim_start
;
5339 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5340 type
= TYPE_TARGET_TYPE (type0
);
5344 name
= ada_type_name (type
);
5346 if (name
== NULL
|| name
[0] == '\000')
5349 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5352 if (STREQN (discrim_end
, "___XVN", 6))
5355 if (discrim_end
== name
)
5358 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5361 if (discrim_start
== name
+ 1)
5363 if ((discrim_start
> name
+ 3 && STREQN (discrim_start
- 3, "___", 3))
5364 || discrim_start
[-1] == '.')
5368 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5369 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5370 result
[discrim_end
- discrim_start
] = '\0';
5374 /* Scan STR for a subtype-encoded number, beginning at position K. Put the
5375 position of the character just past the number scanned in *NEW_K,
5376 if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL. Return 1
5377 if there was a valid number at the given position, and 0 otherwise. A
5378 "subtype-encoded" number consists of the absolute value in decimal,
5379 followed by the letter 'm' to indicate a negative number. Assumes 0m
5383 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5387 if (!isdigit (str
[k
]))
5390 /* Do it the hard way so as not to make any assumption about
5391 the relationship of unsigned long (%lu scan format code) and
5394 while (isdigit (str
[k
]))
5396 RU
= RU
* 10 + (str
[k
] - '0');
5403 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5409 /* NOTE on the above: Technically, C does not say what the results of
5410 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5411 number representable as a LONGEST (although either would probably work
5412 in most implementations). When RU>0, the locution in the then branch
5413 above is always equivalent to the negative of RU. */
5420 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5421 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5422 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5425 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5427 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5440 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5449 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5450 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5452 if (val
>= L
&& val
<= U
)
5464 /* Given a value ARG1 (offset by OFFSET bytes)
5465 of a struct or union type ARG_TYPE,
5466 extract and return the value of one of its (non-static) fields.
5467 FIELDNO says which field. Differs from value_primitive_field only
5468 in that it can handle packed values of arbitrary type. */
5471 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5472 struct type
*arg_type
)
5477 CHECK_TYPEDEF (arg_type
);
5478 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5480 /* Handle packed fields */
5482 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5484 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5485 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5487 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
5488 offset
+ bit_pos
/ 8,
5489 bit_pos
% 8, bit_size
, type
);
5492 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5496 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5497 and search in it assuming it has (class) type TYPE.
5498 If found, return value, else return NULL.
5500 Searches recursively through wrapper fields (e.g., '_parent'). */
5503 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5507 CHECK_TYPEDEF (type
);
5509 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5511 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5513 if (t_field_name
== NULL
)
5516 else if (field_name_match (t_field_name
, name
))
5517 return ada_value_primitive_field (arg
, offset
, i
, type
);
5519 else if (ada_is_wrapper_field (type
, i
))
5521 struct value
*v
= ada_search_struct_field (name
, arg
,
5523 TYPE_FIELD_BITPOS (type
,
5526 TYPE_FIELD_TYPE (type
,
5532 else if (ada_is_variant_part (type
, i
))
5535 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5536 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5538 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5540 struct value
*v
= ada_search_struct_field (name
, arg
,
5544 (field_type
, j
) / 8,
5555 /* Given ARG, a value of type (pointer to a)* structure/union,
5556 extract the component named NAME from the ultimate target structure/union
5557 and return it as a value with its appropriate type.
5559 The routine searches for NAME among all members of the structure itself
5560 and (recursively) among all members of any wrapper members
5563 ERR is a name (for use in error messages) that identifies the class
5564 of entity that ARG is supposed to be. */
5567 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5572 arg
= ada_coerce_ref (arg
);
5573 t
= check_typedef (VALUE_TYPE (arg
));
5575 /* Follow pointers until we get to a non-pointer. */
5577 while (TYPE_CODE (t
) == TYPE_CODE_PTR
|| TYPE_CODE (t
) == TYPE_CODE_REF
)
5579 arg
= ada_value_ind (arg
);
5580 t
= check_typedef (VALUE_TYPE (arg
));
5583 if (TYPE_CODE (t
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t
) != TYPE_CODE_UNION
)
5584 error ("Attempt to extract a component of a value that is not a %s.",
5587 v
= ada_search_struct_field (name
, arg
, 0, t
);
5589 error ("There is no member named %s.", name
);
5594 /* Given a type TYPE, look up the type of the component of type named NAME.
5595 If DISPP is non-null, add its byte displacement from the beginning of a
5596 structure (pointed to by a value) of type TYPE to *DISPP (does not
5597 work for packed fields).
5599 Matches any field whose name has NAME as a prefix, possibly
5602 TYPE can be either a struct or union, or a pointer or reference to
5603 a struct or union. If it is a pointer or reference, its target
5604 type is automatically used.
5606 Looks recursively into variant clauses and parent types.
5608 If NOERR is nonzero, return NULL if NAME is not suitably defined. */
5611 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int noerr
,
5621 CHECK_TYPEDEF (type
);
5622 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5623 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5625 type
= TYPE_TARGET_TYPE (type
);
5628 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
&&
5629 TYPE_CODE (type
) != TYPE_CODE_UNION
)
5631 target_terminal_ours ();
5632 gdb_flush (gdb_stdout
);
5633 fprintf_unfiltered (gdb_stderr
, "Type ");
5634 type_print (type
, "", gdb_stderr
, -1);
5635 error (" is not a structure or union type");
5638 type
= to_static_fixed_type (type
);
5640 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5642 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5646 if (t_field_name
== NULL
)
5649 else if (field_name_match (t_field_name
, name
))
5652 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5653 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5656 else if (ada_is_wrapper_field (type
, i
))
5659 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5664 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5669 else if (ada_is_variant_part (type
, i
))
5672 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5674 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5677 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5682 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5693 target_terminal_ours ();
5694 gdb_flush (gdb_stdout
);
5695 fprintf_unfiltered (gdb_stderr
, "Type ");
5696 type_print (type
, "", gdb_stderr
, -1);
5697 fprintf_unfiltered (gdb_stderr
, " has no component named ");
5698 error ("%s", name
== NULL
? "<null>" : name
);
5704 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5705 within a value of type OUTER_TYPE that is stored in GDB at
5706 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5707 numbering from 0) is applicable. Returns -1 if none are. */
5710 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5711 char *outer_valaddr
)
5716 struct type
*discrim_type
;
5717 char *discrim_name
= ada_variant_discrim_name (var_type
);
5718 LONGEST discrim_val
;
5722 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, &disp
);
5723 if (discrim_type
== NULL
)
5725 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5728 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5730 if (ada_is_others_clause (var_type
, i
))
5732 else if (ada_in_variant (discrim_val
, var_type
, i
))
5736 return others_clause
;
5741 /* Dynamic-Sized Records */
5743 /* Strategy: The type ostensibly attached to a value with dynamic size
5744 (i.e., a size that is not statically recorded in the debugging
5745 data) does not accurately reflect the size or layout of the value.
5746 Our strategy is to convert these values to values with accurate,
5747 conventional types that are constructed on the fly. */
5749 /* There is a subtle and tricky problem here. In general, we cannot
5750 determine the size of dynamic records without its data. However,
5751 the 'struct value' data structure, which GDB uses to represent
5752 quantities in the inferior process (the target), requires the size
5753 of the type at the time of its allocation in order to reserve space
5754 for GDB's internal copy of the data. That's why the
5755 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5756 rather than struct value*s.
5758 However, GDB's internal history variables ($1, $2, etc.) are
5759 struct value*s containing internal copies of the data that are not, in
5760 general, the same as the data at their corresponding addresses in
5761 the target. Fortunately, the types we give to these values are all
5762 conventional, fixed-size types (as per the strategy described
5763 above), so that we don't usually have to perform the
5764 'to_fixed_xxx_type' conversions to look at their values.
5765 Unfortunately, there is one exception: if one of the internal
5766 history variables is an array whose elements are unconstrained
5767 records, then we will need to create distinct fixed types for each
5768 element selected. */
5770 /* The upshot of all of this is that many routines take a (type, host
5771 address, target address) triple as arguments to represent a value.
5772 The host address, if non-null, is supposed to contain an internal
5773 copy of the relevant data; otherwise, the program is to consult the
5774 target at the target address. */
5776 /* Assuming that VAL0 represents a pointer value, the result of
5777 dereferencing it. Differs from value_ind in its treatment of
5778 dynamic-sized types. */
5781 ada_value_ind (struct value
*val0
)
5783 struct value
*val
= unwrap_value (value_ind (val0
));
5784 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5785 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
), val
);
5788 /* The value resulting from dereferencing any "reference to"
5789 * qualifiers on VAL0. */
5790 static struct value
*
5791 ada_coerce_ref (struct value
*val0
)
5793 if (TYPE_CODE (VALUE_TYPE (val0
)) == TYPE_CODE_REF
)
5795 struct value
*val
= val0
;
5797 val
= unwrap_value (val
);
5798 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5799 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
5806 /* Return OFF rounded upward if necessary to a multiple of
5807 ALIGNMENT (a power of 2). */
5810 align_value (unsigned int off
, unsigned int alignment
)
5812 return (off
+ alignment
- 1) & ~(alignment
- 1);
5815 /* Return the additional bit offset required by field F of template
5819 field_offset (struct type
*type
, int f
)
5821 int n
= TYPE_FIELD_BITPOS (type
, f
);
5822 /* Kludge (temporary?) to fix problem with dwarf output. */
5824 return (unsigned int) n
& 0xffff;
5830 /* Return the bit alignment required for field #F of template type TYPE. */
5833 field_alignment (struct type
*type
, int f
)
5835 const char *name
= TYPE_FIELD_NAME (type
, f
);
5836 int len
= (name
== NULL
) ? 0 : strlen (name
);
5839 if (len
< 8 || !isdigit (name
[len
- 1]))
5840 return TARGET_CHAR_BIT
;
5842 if (isdigit (name
[len
- 2]))
5843 align_offset
= len
- 2;
5845 align_offset
= len
- 1;
5847 if (align_offset
< 7 || !STREQN ("___XV", name
+ align_offset
- 6, 5))
5848 return TARGET_CHAR_BIT
;
5850 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
5853 /* Find a type named NAME. Ignores ambiguity. */
5855 ada_find_any_type (const char *name
)
5859 sym
= standard_lookup (name
, VAR_NAMESPACE
);
5860 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5861 return SYMBOL_TYPE (sym
);
5863 sym
= standard_lookup (name
, STRUCT_NAMESPACE
);
5865 return SYMBOL_TYPE (sym
);
5870 /* Because of GNAT encoding conventions, several GDB symbols may match a
5871 given type name. If the type denoted by TYPE0 is to be preferred to
5872 that of TYPE1 for purposes of type printing, return non-zero;
5873 otherwise return 0. */
5875 ada_prefer_type (struct type
*type0
, struct type
*type1
)
5879 else if (type0
== NULL
)
5881 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
5883 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
5885 else if (ada_is_packed_array_type (type0
))
5887 else if (ada_is_array_descriptor (type0
)
5888 && !ada_is_array_descriptor (type1
))
5890 else if (ada_renaming_type (type0
) != NULL
5891 && ada_renaming_type (type1
) == NULL
)
5896 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5897 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5899 ada_type_name (struct type
*type
)
5903 else if (TYPE_NAME (type
) != NULL
)
5904 return TYPE_NAME (type
);
5906 return TYPE_TAG_NAME (type
);
5909 /* Find a parallel type to TYPE whose name is formed by appending
5910 SUFFIX to the name of TYPE. */
5913 ada_find_parallel_type (struct type
*type
, const char *suffix
)
5916 static size_t name_len
= 0;
5917 struct symbol
**syms
;
5918 struct block
**blocks
;
5921 char *typename
= ada_type_name (type
);
5923 if (typename
== NULL
)
5926 len
= strlen (typename
);
5928 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
5930 strcpy (name
, typename
);
5931 strcpy (name
+ len
, suffix
);
5933 return ada_find_any_type (name
);
5937 /* If TYPE is a variable-size record type, return the corresponding template
5938 type describing its fields. Otherwise, return NULL. */
5940 static struct type
*
5941 dynamic_template_type (struct type
*type
)
5943 CHECK_TYPEDEF (type
);
5945 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5946 || ada_type_name (type
) == NULL
)
5950 int len
= strlen (ada_type_name (type
));
5951 if (len
> 6 && STREQ (ada_type_name (type
) + len
- 6, "___XVE"))
5954 return ada_find_parallel_type (type
, "___XVE");
5958 /* Assuming that TEMPL_TYPE is a union or struct type, returns
5959 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
5962 is_dynamic_field (struct type
*templ_type
, int field_num
)
5964 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
5966 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
5967 && strstr (name
, "___XVL") != NULL
;
5970 /* Assuming that TYPE is a struct type, returns non-zero iff TYPE
5971 contains a variant part. */
5974 contains_variant_part (struct type
*type
)
5978 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5979 || TYPE_NFIELDS (type
) <= 0)
5981 return ada_is_variant_part (type
, TYPE_NFIELDS (type
) - 1);
5984 /* A record type with no fields, . */
5985 static struct type
*
5986 empty_record (struct objfile
*objfile
)
5988 struct type
*type
= alloc_type (objfile
);
5989 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
5990 TYPE_NFIELDS (type
) = 0;
5991 TYPE_FIELDS (type
) = NULL
;
5992 TYPE_NAME (type
) = "<empty>";
5993 TYPE_TAG_NAME (type
) = NULL
;
5994 TYPE_FLAGS (type
) = 0;
5995 TYPE_LENGTH (type
) = 0;
5999 /* An ordinary record type (with fixed-length fields) that describes
6000 the value of type TYPE at VALADDR or ADDRESS (see comments at
6001 the beginning of this section) VAL according to GNAT conventions.
6002 DVAL0 should describe the (portion of a) record that contains any
6003 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
6004 an outer-level type (i.e., as opposed to a branch of a variant.) A
6005 variant field (unless unchecked) is replaced by a particular branch
6007 /* NOTE: Limitations: For now, we assume that dynamic fields and
6008 * variants occupy whole numbers of bytes. However, they need not be
6011 static struct type
*
6012 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
6013 CORE_ADDR address
, struct value
*dval0
)
6015 struct value
*mark
= value_mark ();
6018 int nfields
, bit_len
;
6022 nfields
= TYPE_NFIELDS (type
);
6023 rtype
= alloc_type (TYPE_OBJFILE (type
));
6024 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6025 INIT_CPLUS_SPECIFIC (rtype
);
6026 TYPE_NFIELDS (rtype
) = nfields
;
6027 TYPE_FIELDS (rtype
) = (struct field
*)
6028 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6029 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6030 TYPE_NAME (rtype
) = ada_type_name (type
);
6031 TYPE_TAG_NAME (rtype
) = NULL
;
6032 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in
6034 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6038 for (f
= 0; f
< nfields
; f
+= 1)
6040 int fld_bit_len
, bit_incr
;
6043 field_alignment (type
, f
)) + TYPE_FIELD_BITPOS (type
, f
);
6044 /* NOTE: used to use field_offset above, but that causes
6045 * problems with really negative bit positions. So, let's
6046 * rediscover why we needed field_offset and fix it properly. */
6047 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6048 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6050 if (ada_is_variant_part (type
, f
))
6052 struct type
*branch_type
;
6055 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6060 to_fixed_variant_branch_type
6061 (TYPE_FIELD_TYPE (type
, f
),
6062 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6063 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6064 if (branch_type
== NULL
)
6065 TYPE_NFIELDS (rtype
) -= 1;
6068 TYPE_FIELD_TYPE (rtype
, f
) = branch_type
;
6069 TYPE_FIELD_NAME (rtype
, f
) = "S";
6073 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6075 else if (is_dynamic_field (type
, f
))
6078 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6082 TYPE_FIELD_TYPE (rtype
, f
) =
6085 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6086 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6087 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6088 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6089 bit_incr
= fld_bit_len
=
6090 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6094 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6095 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6096 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6097 bit_incr
= fld_bit_len
=
6098 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6100 bit_incr
= fld_bit_len
=
6101 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6103 if (off
+ fld_bit_len
> bit_len
)
6104 bit_len
= off
+ fld_bit_len
;
6106 TYPE_LENGTH (rtype
) = bit_len
/ TARGET_CHAR_BIT
;
6108 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
), TYPE_LENGTH (type
));
6110 value_free_to_mark (mark
);
6111 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6112 error ("record type with dynamic size is larger than varsize-limit");
6116 /* As for template_to_fixed_record_type, but uses no run-time values.
6117 As a result, this type can only be approximate, but that's OK,
6118 since it is used only for type determinations. Works on both
6120 Representation note: to save space, we memoize the result of this
6121 function in the TYPE_TARGET_TYPE of the template type. */
6123 static struct type
*
6124 template_to_static_fixed_type (struct type
*templ_type
)
6130 if (TYPE_TARGET_TYPE (templ_type
) != NULL
)
6131 return TYPE_TARGET_TYPE (templ_type
);
6133 nfields
= TYPE_NFIELDS (templ_type
);
6134 TYPE_TARGET_TYPE (templ_type
) = type
=
6135 alloc_type (TYPE_OBJFILE (templ_type
));
6136 TYPE_CODE (type
) = TYPE_CODE (templ_type
);
6137 INIT_CPLUS_SPECIFIC (type
);
6138 TYPE_NFIELDS (type
) = nfields
;
6139 TYPE_FIELDS (type
) = (struct field
*)
6140 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6141 memset (TYPE_FIELDS (type
), 0, sizeof (struct field
) * nfields
);
6142 TYPE_NAME (type
) = ada_type_name (templ_type
);
6143 TYPE_TAG_NAME (type
) = NULL
;
6144 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6145 /* TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE; */
6146 TYPE_LENGTH (type
) = 0;
6148 for (f
= 0; f
< nfields
; f
+= 1)
6150 TYPE_FIELD_BITPOS (type
, f
) = 0;
6151 TYPE_FIELD_BITSIZE (type
, f
) = 0;
6153 if (is_dynamic_field (templ_type
, f
))
6155 TYPE_FIELD_TYPE (type
, f
) =
6156 to_static_fixed_type (TYPE_TARGET_TYPE
6157 (TYPE_FIELD_TYPE (templ_type
, f
)));
6158 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6162 TYPE_FIELD_TYPE (type
, f
) =
6163 check_typedef (TYPE_FIELD_TYPE (templ_type
, f
));
6164 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6171 /* A revision of TYPE0 -- a non-dynamic-sized record with a variant
6172 part -- in which the variant part is replaced with the appropriate
6174 static struct type
*
6175 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
6176 CORE_ADDR address
, struct value
*dval
)
6178 struct value
*mark
= value_mark ();
6180 struct type
*branch_type
;
6181 int nfields
= TYPE_NFIELDS (type
);
6186 rtype
= alloc_type (TYPE_OBJFILE (type
));
6187 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6188 INIT_CPLUS_SPECIFIC (type
);
6189 TYPE_NFIELDS (rtype
) = TYPE_NFIELDS (type
);
6190 TYPE_FIELDS (rtype
) =
6191 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6192 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6193 sizeof (struct field
) * nfields
);
6194 TYPE_NAME (rtype
) = ada_type_name (type
);
6195 TYPE_TAG_NAME (rtype
) = NULL
;
6196 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6197 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6198 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6201 to_fixed_variant_branch_type
6202 (TYPE_FIELD_TYPE (type
, nfields
- 1),
6203 cond_offset_host (valaddr
,
6204 TYPE_FIELD_BITPOS (type
,
6205 nfields
- 1) / TARGET_CHAR_BIT
),
6206 cond_offset_target (address
,
6207 TYPE_FIELD_BITPOS (type
,
6208 nfields
- 1) / TARGET_CHAR_BIT
),
6210 if (branch_type
== NULL
)
6212 TYPE_NFIELDS (rtype
) -= 1;
6213 TYPE_LENGTH (rtype
) -=
6214 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6218 TYPE_FIELD_TYPE (rtype
, nfields
- 1) = branch_type
;
6219 TYPE_FIELD_NAME (rtype
, nfields
- 1) = "S";
6220 TYPE_FIELD_BITSIZE (rtype
, nfields
- 1) = 0;
6221 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6222 -TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6228 /* An ordinary record type (with fixed-length fields) that describes
6229 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6230 beginning of this section]. Any necessary discriminants' values
6231 should be in DVAL, a record value; it should be NULL if the object
6232 at ADDR itself contains any necessary discriminant values. A
6233 variant field (unless unchecked) is replaced by a particular branch
6236 static struct type
*
6237 to_fixed_record_type (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6240 struct type
*templ_type
;
6242 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6243 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6246 templ_type
= dynamic_template_type (type0
);
6248 if (templ_type
!= NULL
)
6249 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6250 else if (contains_variant_part (type0
))
6251 return to_record_with_fixed_variant_part (type0
, valaddr
, address
, dval
);
6254 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6255 /* TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE; */
6261 /* An ordinary record type (with fixed-length fields) that describes
6262 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6263 union type. Any necessary discriminants' values should be in DVAL,
6264 a record value. That is, this routine selects the appropriate
6265 branch of the union at ADDR according to the discriminant value
6266 indicated in the union's type name. */
6268 static struct type
*
6269 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
6270 CORE_ADDR address
, struct value
*dval
)
6273 struct type
*templ_type
;
6274 struct type
*var_type
;
6276 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6277 var_type
= TYPE_TARGET_TYPE (var_type0
);
6279 var_type
= var_type0
;
6281 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6283 if (templ_type
!= NULL
)
6284 var_type
= templ_type
;
6287 ada_which_variant_applies (var_type
,
6288 VALUE_TYPE (dval
), VALUE_CONTENTS (dval
));
6291 return empty_record (TYPE_OBJFILE (var_type
));
6292 else if (is_dynamic_field (var_type
, which
))
6294 to_fixed_record_type
6295 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6296 valaddr
, address
, dval
);
6297 else if (contains_variant_part (TYPE_FIELD_TYPE (var_type
, which
)))
6299 to_fixed_record_type
6300 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6302 return TYPE_FIELD_TYPE (var_type
, which
);
6305 /* Assuming that TYPE0 is an array type describing the type of a value
6306 at ADDR, and that DVAL describes a record containing any
6307 discriminants used in TYPE0, returns a type for the value that
6308 contains no dynamic components (that is, no components whose sizes
6309 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6310 true, gives an error message if the resulting type's size is over
6314 static struct type
*
6315 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6318 struct type
*index_type_desc
;
6319 struct type
*result
;
6321 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6322 /* if (ada_is_packed_array_type (type0) /* revisit? *//*
6323 || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
6326 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6327 if (index_type_desc
== NULL
)
6329 struct type
*elt_type0
= check_typedef (TYPE_TARGET_TYPE (type0
));
6330 /* NOTE: elt_type---the fixed version of elt_type0---should never
6331 * depend on the contents of the array in properly constructed
6332 * debugging data. */
6333 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6335 if (elt_type0
== elt_type
)
6338 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6339 elt_type
, TYPE_INDEX_TYPE (type0
));
6344 struct type
*elt_type0
;
6347 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6348 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6350 /* NOTE: result---the fixed version of elt_type0---should never
6351 * depend on the contents of the array in properly constructed
6352 * debugging data. */
6353 result
= ada_to_fixed_type (check_typedef (elt_type0
), 0, 0, dval
);
6354 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6356 struct type
*range_type
=
6357 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6358 dval
, TYPE_OBJFILE (type0
));
6359 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6360 result
, range_type
);
6362 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6363 error ("array type with dynamic size is larger than varsize-limit");
6366 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6367 /* TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE; */
6372 /* A standard type (containing no dynamically sized components)
6373 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6374 DVAL describes a record containing any discriminants used in TYPE0,
6375 and may be NULL if there are none. */
6378 ada_to_fixed_type (struct type
*type
, char *valaddr
, CORE_ADDR address
,
6381 CHECK_TYPEDEF (type
);
6382 switch (TYPE_CODE (type
))
6386 case TYPE_CODE_STRUCT
:
6387 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6388 case TYPE_CODE_ARRAY
:
6389 return to_fixed_array_type (type
, dval
, 0);
6390 case TYPE_CODE_UNION
:
6394 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6398 /* A standard (static-sized) type corresponding as well as possible to
6399 TYPE0, but based on no runtime data. */
6401 static struct type
*
6402 to_static_fixed_type (struct type
*type0
)
6409 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6410 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6413 CHECK_TYPEDEF (type0
);
6415 switch (TYPE_CODE (type0
))
6419 case TYPE_CODE_STRUCT
:
6420 type
= dynamic_template_type (type0
);
6422 return template_to_static_fixed_type (type
);
6424 case TYPE_CODE_UNION
:
6425 type
= ada_find_parallel_type (type0
, "___XVU");
6427 return template_to_static_fixed_type (type
);
6432 /* A static approximation of TYPE with all type wrappers removed. */
6433 static struct type
*
6434 static_unwrap_type (struct type
*type
)
6436 if (ada_is_aligner_type (type
))
6438 struct type
*type1
= TYPE_FIELD_TYPE (check_typedef (type
), 0);
6439 if (ada_type_name (type1
) == NULL
)
6440 TYPE_NAME (type1
) = ada_type_name (type
);
6442 return static_unwrap_type (type1
);
6446 struct type
*raw_real_type
= ada_get_base_type (type
);
6447 if (raw_real_type
== type
)
6450 return to_static_fixed_type (raw_real_type
);
6454 /* In some cases, incomplete and private types require
6455 cross-references that are not resolved as records (for example,
6457 type FooP is access Foo;
6459 type Foo is array ...;
6460 ). In these cases, since there is no mechanism for producing
6461 cross-references to such types, we instead substitute for FooP a
6462 stub enumeration type that is nowhere resolved, and whose tag is
6463 the name of the actual type. Call these types "non-record stubs". */
6465 /* A type equivalent to TYPE that is not a non-record stub, if one
6466 exists, otherwise TYPE. */
6468 ada_completed_type (struct type
*type
)
6470 CHECK_TYPEDEF (type
);
6471 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6472 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
6473 || TYPE_TAG_NAME (type
) == NULL
)
6477 char *name
= TYPE_TAG_NAME (type
);
6478 struct type
*type1
= ada_find_any_type (name
);
6479 return (type1
== NULL
) ? type
: type1
;
6483 /* A value representing the data at VALADDR/ADDRESS as described by
6484 type TYPE0, but with a standard (static-sized) type that correctly
6485 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6486 type, then return VAL0 [this feature is simply to avoid redundant
6487 creation of struct values]. */
6490 ada_to_fixed_value (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6493 struct type
*type
= ada_to_fixed_type (type0
, valaddr
, address
, NULL
);
6494 if (type
== type0
&& val0
!= NULL
)
6497 return value_from_contents_and_address (type
, valaddr
, address
);
6500 /* A value representing VAL, but with a standard (static-sized) type
6501 chosen to approximate the real type of VAL as well as possible, but
6502 without consulting any runtime values. For Ada dynamic-sized
6503 types, therefore, the type of the result is likely to be inaccurate. */
6506 ada_to_static_fixed_value (struct value
*val
)
6509 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val
)));
6510 if (type
== VALUE_TYPE (val
))
6513 return coerce_unspec_val_to_type (val
, 0, type
);
6522 /* Table mapping attribute numbers to names */
6523 /* NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h */
6525 static const char *attribute_names
[] = {
6542 ada_attribute_name (int n
)
6544 if (n
> 0 && n
< (int) ATR_END
)
6545 return attribute_names
[n
];
6547 return attribute_names
[0];
6550 /* Evaluate the 'POS attribute applied to ARG. */
6552 static struct value
*
6553 value_pos_atr (struct value
*arg
)
6555 struct type
*type
= VALUE_TYPE (arg
);
6557 if (!discrete_type_p (type
))
6558 error ("'POS only defined on discrete types");
6560 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6563 LONGEST v
= value_as_long (arg
);
6565 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6567 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6568 return value_from_longest (builtin_type_ada_int
, i
);
6570 error ("enumeration value is invalid: can't find 'POS");
6573 return value_from_longest (builtin_type_ada_int
, value_as_long (arg
));
6576 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6578 static struct value
*
6579 value_val_atr (struct type
*type
, struct value
*arg
)
6581 if (!discrete_type_p (type
))
6582 error ("'VAL only defined on discrete types");
6583 if (!integer_type_p (VALUE_TYPE (arg
)))
6584 error ("'VAL requires integral argument");
6586 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6588 long pos
= value_as_long (arg
);
6589 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6590 error ("argument to 'VAL out of range");
6591 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6594 return value_from_longest (type
, value_as_long (arg
));
6600 /* True if TYPE appears to be an Ada character type.
6601 * [At the moment, this is true only for Character and Wide_Character;
6602 * It is a heuristic test that could stand improvement]. */
6605 ada_is_character_type (struct type
*type
)
6607 const char *name
= ada_type_name (type
);
6610 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6611 || TYPE_CODE (type
) == TYPE_CODE_INT
6612 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6613 && (STREQ (name
, "character") || STREQ (name
, "wide_character")
6614 || STREQ (name
, "unsigned char"));
6617 /* True if TYPE appears to be an Ada string type. */
6620 ada_is_string_type (struct type
*type
)
6622 CHECK_TYPEDEF (type
);
6624 && TYPE_CODE (type
) != TYPE_CODE_PTR
6625 && (ada_is_simple_array (type
) || ada_is_array_descriptor (type
))
6626 && ada_array_arity (type
) == 1)
6628 struct type
*elttype
= ada_array_element_type (type
, 1);
6630 return ada_is_character_type (elttype
);
6637 /* True if TYPE is a struct type introduced by the compiler to force the
6638 alignment of a value. Such types have a single field with a
6639 distinctive name. */
6642 ada_is_aligner_type (struct type
*type
)
6644 CHECK_TYPEDEF (type
);
6645 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
6646 && TYPE_NFIELDS (type
) == 1
6647 && STREQ (TYPE_FIELD_NAME (type
, 0), "F"));
6650 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6651 the parallel type. */
6654 ada_get_base_type (struct type
*raw_type
)
6656 struct type
*real_type_namer
;
6657 struct type
*raw_real_type
;
6658 struct type
*real_type
;
6660 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
6663 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
6664 if (real_type_namer
== NULL
6665 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
6666 || TYPE_NFIELDS (real_type_namer
) != 1)
6669 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
6670 if (raw_real_type
== NULL
)
6673 return raw_real_type
;
6676 /* The type of value designated by TYPE, with all aligners removed. */
6679 ada_aligned_type (struct type
*type
)
6681 if (ada_is_aligner_type (type
))
6682 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
6684 return ada_get_base_type (type
);
6688 /* The address of the aligned value in an object at address VALADDR
6689 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6692 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
6694 if (ada_is_aligner_type (type
))
6695 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
6697 TYPE_FIELD_BITPOS (type
,
6698 0) / TARGET_CHAR_BIT
);
6703 /* The printed representation of an enumeration literal with encoded
6704 name NAME. The value is good to the next call of ada_enum_name. */
6706 ada_enum_name (const char *name
)
6712 if ((tmp
= strstr (name
, "__")) != NULL
)
6714 else if ((tmp
= strchr (name
, '.')) != NULL
)
6722 static char result
[16];
6724 if (name
[1] == 'U' || name
[1] == 'W')
6726 if (sscanf (name
+ 2, "%x", &v
) != 1)
6732 if (isascii (v
) && isprint (v
))
6733 sprintf (result
, "'%c'", v
);
6734 else if (name
[1] == 'U')
6735 sprintf (result
, "[\"%02x\"]", v
);
6737 sprintf (result
, "[\"%04x\"]", v
);
6745 static struct value
*
6746 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
6749 return (*exp
->language_defn
->evaluate_exp
) (expect_type
, exp
, pos
, noside
);
6752 /* Evaluate the subexpression of EXP starting at *POS as for
6753 evaluate_type, updating *POS to point just past the evaluated
6756 static struct value
*
6757 evaluate_subexp_type (struct expression
*exp
, int *pos
)
6759 return (*exp
->language_defn
->evaluate_exp
)
6760 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
6763 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6766 static struct value
*
6767 unwrap_value (struct value
*val
)
6769 struct type
*type
= check_typedef (VALUE_TYPE (val
));
6770 if (ada_is_aligner_type (type
))
6772 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
6773 NULL
, "internal structure");
6774 struct type
*val_type
= check_typedef (VALUE_TYPE (v
));
6775 if (ada_type_name (val_type
) == NULL
)
6776 TYPE_NAME (val_type
) = ada_type_name (type
);
6778 return unwrap_value (v
);
6782 struct type
*raw_real_type
=
6783 ada_completed_type (ada_get_base_type (type
));
6785 if (type
== raw_real_type
)
6789 coerce_unspec_val_to_type
6790 (val
, 0, ada_to_fixed_type (raw_real_type
, 0,
6791 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
6796 static struct value
*
6797 cast_to_fixed (struct type
*type
, struct value
*arg
)
6801 if (type
== VALUE_TYPE (arg
))
6803 else if (ada_is_fixed_point_type (VALUE_TYPE (arg
)))
6804 val
= ada_float_to_fixed (type
,
6805 ada_fixed_to_float (VALUE_TYPE (arg
),
6806 value_as_long (arg
)));
6810 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
6811 val
= ada_float_to_fixed (type
, argd
);
6814 return value_from_longest (type
, val
);
6817 static struct value
*
6818 cast_from_fixed_to_double (struct value
*arg
)
6820 DOUBLEST val
= ada_fixed_to_float (VALUE_TYPE (arg
),
6821 value_as_long (arg
));
6822 return value_from_double (builtin_type_double
, val
);
6825 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
6826 * return the converted value. */
6827 static struct value
*
6828 coerce_for_assign (struct type
*type
, struct value
*val
)
6830 struct type
*type2
= VALUE_TYPE (val
);
6834 CHECK_TYPEDEF (type2
);
6835 CHECK_TYPEDEF (type
);
6837 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
6838 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6840 val
= ada_value_ind (val
);
6841 type2
= VALUE_TYPE (val
);
6844 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
6845 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6847 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
6848 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
6849 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
6850 error ("Incompatible types in assignment");
6851 VALUE_TYPE (val
) = type
;
6857 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
6858 int *pos
, enum noside noside
)
6861 enum ada_attribute atr
;
6862 int tem
, tem2
, tem3
;
6864 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
6867 struct value
**argvec
;
6871 op
= exp
->elts
[pc
].opcode
;
6878 unwrap_value (evaluate_subexp_standard
6879 (expect_type
, exp
, pos
, noside
));
6883 type
= exp
->elts
[pc
+ 1].type
;
6884 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
6885 if (noside
== EVAL_SKIP
)
6887 if (type
!= check_typedef (VALUE_TYPE (arg1
)))
6889 if (ada_is_fixed_point_type (type
))
6890 arg1
= cast_to_fixed (type
, arg1
);
6891 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6892 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
6893 else if (VALUE_LVAL (arg1
) == lval_memory
)
6895 /* This is in case of the really obscure (and undocumented,
6896 but apparently expected) case of (Foo) Bar.all, where Bar
6897 is an integer constant and Foo is a dynamic-sized type.
6898 If we don't do this, ARG1 will simply be relabeled with
6900 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
6901 return value_zero (to_static_fixed_type (type
), not_lval
);
6904 (type
, 0, VALUE_ADDRESS (arg1
) + VALUE_OFFSET (arg1
), 0);
6907 arg1
= value_cast (type
, arg1
);
6911 /* FIXME: UNOP_QUAL should be defined in expression.h */
6914 type = exp->elts[pc + 1].type;
6915 return ada_evaluate_subexp (type, exp, pos, noside);
6918 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6919 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
6920 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
6922 if (binop_user_defined_p (op
, arg1
, arg2
))
6923 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6926 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6927 arg2
= cast_to_fixed (VALUE_TYPE (arg1
), arg2
);
6928 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6930 ("Fixed-point values must be assigned to fixed-point variables");
6932 arg2
= coerce_for_assign (VALUE_TYPE (arg1
), arg2
);
6933 return ada_value_assign (arg1
, arg2
);
6937 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6938 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6939 if (noside
== EVAL_SKIP
)
6941 if (binop_user_defined_p (op
, arg1
, arg2
))
6942 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6945 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6946 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6947 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6949 ("Operands of fixed-point addition must have the same type");
6950 return value_cast (VALUE_TYPE (arg1
), value_add (arg1
, arg2
));
6954 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6955 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6956 if (noside
== EVAL_SKIP
)
6958 if (binop_user_defined_p (op
, arg1
, arg2
))
6959 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6962 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6963 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6964 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6966 ("Operands of fixed-point subtraction must have the same type");
6967 return value_cast (VALUE_TYPE (arg1
), value_sub (arg1
, arg2
));
6972 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6973 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6974 if (noside
== EVAL_SKIP
)
6976 if (binop_user_defined_p (op
, arg1
, arg2
))
6977 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6979 if (noside
== EVAL_AVOID_SIDE_EFFECTS
6980 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
6981 return value_zero (VALUE_TYPE (arg1
), not_lval
);
6984 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6985 arg1
= cast_from_fixed_to_double (arg1
);
6986 if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6987 arg2
= cast_from_fixed_to_double (arg2
);
6988 return value_binop (arg1
, arg2
, op
);
6992 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6993 if (noside
== EVAL_SKIP
)
6995 if (unop_user_defined_p (op
, arg1
))
6996 return value_x_unop (arg1
, op
, EVAL_NORMAL
);
6997 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6998 return value_cast (VALUE_TYPE (arg1
), value_neg (arg1
));
7000 return value_neg (arg1
);
7002 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7003 /* case OP_UNRESOLVED_VALUE:
7004 /* Only encountered when an unresolved symbol occurs in a
7005 context other than a function call, in which case, it is
7008 if (noside == EVAL_SKIP)
7011 error ("Unexpected unresolved symbol, %s, during evaluation",
7012 ada_demangle (exp->elts[pc + 2].name));
7016 if (noside
== EVAL_SKIP
)
7021 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7025 (to_static_fixed_type
7026 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
7032 unwrap_value (evaluate_subexp_standard
7033 (expect_type
, exp
, pos
, noside
));
7034 return ada_to_fixed_value (VALUE_TYPE (arg1
), 0,
7035 VALUE_ADDRESS (arg1
) +
7036 VALUE_OFFSET (arg1
), arg1
);
7041 tem2
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7042 tem3
= longest_to_int (exp
->elts
[pc
+ 2].longconst
);
7043 nargs
= tem3
- tem2
+ 1;
7044 type
= expect_type
? check_typedef (expect_type
) : NULL_TYPE
;
7047 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
7048 for (tem
= 0; tem
== 0 || tem
< nargs
; tem
+= 1)
7049 /* At least one element gets inserted for the type */
7051 /* Ensure that array expressions are coerced into pointer objects. */
7052 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
7054 if (noside
== EVAL_SKIP
)
7056 return value_array (tem2
, tem3
, argvec
);
7061 /* Allocate arg vector, including space for the function to be
7062 called in argvec[0] and a terminating NULL */
7063 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7065 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 2));
7067 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7068 /* FIXME: name should be defined in expresion.h */
7069 /* if (exp->elts[*pos].opcode == OP_UNRESOLVED_VALUE)
7070 error ("Unexpected unresolved symbol, %s, during evaluation",
7071 ada_demangle (exp->elts[pc + 5].name));
7075 error ("unexpected code path, FIXME");
7079 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7080 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7083 if (noside
== EVAL_SKIP
)
7087 if (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_REF
)
7088 argvec
[0] = value_addr (argvec
[0]);
7090 if (ada_is_packed_array_type (VALUE_TYPE (argvec
[0])))
7091 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7093 type
= check_typedef (VALUE_TYPE (argvec
[0]));
7094 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7096 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type
))))
7098 case TYPE_CODE_FUNC
:
7099 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7101 case TYPE_CODE_ARRAY
:
7103 case TYPE_CODE_STRUCT
:
7104 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7105 argvec
[0] = ada_value_ind (argvec
[0]);
7106 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7109 error ("cannot subscript or call something of type `%s'",
7110 ada_type_name (VALUE_TYPE (argvec
[0])));
7115 switch (TYPE_CODE (type
))
7117 case TYPE_CODE_FUNC
:
7118 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7119 return allocate_value (TYPE_TARGET_TYPE (type
));
7120 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7121 case TYPE_CODE_STRUCT
:
7123 int arity
= ada_array_arity (type
);
7124 type
= ada_array_element_type (type
, nargs
);
7126 error ("cannot subscript or call a record");
7128 error ("wrong number of subscripts; expecting %d", arity
);
7129 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7130 return allocate_value (ada_aligned_type (type
));
7132 unwrap_value (ada_value_subscript
7133 (argvec
[0], nargs
, argvec
+ 1));
7135 case TYPE_CODE_ARRAY
:
7136 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7138 type
= ada_array_element_type (type
, nargs
);
7140 error ("element type of array unknown");
7142 return allocate_value (ada_aligned_type (type
));
7145 unwrap_value (ada_value_subscript
7146 (ada_coerce_to_simple_array (argvec
[0]),
7147 nargs
, argvec
+ 1));
7148 case TYPE_CODE_PTR
: /* Pointer to array */
7149 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7150 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7152 type
= ada_array_element_type (type
, nargs
);
7154 error ("element type of array unknown");
7156 return allocate_value (ada_aligned_type (type
));
7159 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7160 nargs
, argvec
+ 1));
7163 error ("Internal error in evaluate_subexp");
7168 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7170 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7172 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7173 if (noside
== EVAL_SKIP
)
7176 /* If this is a reference to an array, then dereference it */
7177 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
7178 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7179 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7181 && !ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7183 array
= ada_coerce_ref (array
);
7186 if (noside
== EVAL_AVOID_SIDE_EFFECTS
&&
7187 ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7189 /* Try to dereference the array, in case it is an access to array */
7190 struct type
*arrType
= ada_type_of_array (array
, 0);
7191 if (arrType
!= NULL
)
7192 array
= value_at_lazy (arrType
, 0, NULL
);
7194 if (ada_is_array_descriptor (VALUE_TYPE (array
)))
7195 array
= ada_coerce_to_simple_array (array
);
7197 /* If at this point we have a pointer to an array, it means that
7198 it is a pointer to a simple (non-ada) array. We just then
7200 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
7201 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7202 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7205 array
= ada_value_ind (array
);
7208 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7209 /* The following will get the bounds wrong, but only in contexts
7210 where the value is not being requested (FIXME?). */
7213 return value_slice (array
, lowbound
, upper
- lowbound
+ 1);
7216 /* FIXME: UNOP_MBR should be defined in expression.h */
7219 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7220 type = exp->elts[pc + 1].type;
7222 if (noside == EVAL_SKIP)
7225 switch (TYPE_CODE (type))
7228 warning ("Membership test incompletely implemented; always returns true");
7229 return value_from_longest (builtin_type_int, (LONGEST) 1);
7231 case TYPE_CODE_RANGE:
7232 arg2 = value_from_longest (builtin_type_int,
7233 (LONGEST) TYPE_LOW_BOUND (type));
7234 arg3 = value_from_longest (builtin_type_int,
7235 (LONGEST) TYPE_HIGH_BOUND (type));
7237 value_from_longest (builtin_type_int,
7238 (value_less (arg1,arg3)
7239 || value_equal (arg1,arg3))
7240 && (value_less (arg2,arg1)
7241 || value_equal (arg2,arg1)));
7244 /* FIXME: BINOP_MBR should be defined in expression.h */
7247 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7248 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7250 if (noside == EVAL_SKIP)
7253 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7254 return value_zero (builtin_type_int, not_lval);
7256 tem = longest_to_int (exp->elts[pc + 1].longconst);
7258 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
7259 error ("invalid dimension number to '%s", "range");
7261 arg3 = ada_array_bound (arg2, tem, 1);
7262 arg2 = ada_array_bound (arg2, tem, 0);
7265 value_from_longest (builtin_type_int,
7266 (value_less (arg1,arg3)
7267 || value_equal (arg1,arg3))
7268 && (value_less (arg2,arg1)
7269 || value_equal (arg2,arg1)));
7271 /* FIXME: TERNOP_MBR should be defined in expression.h */
7273 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7274 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7275 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7277 if (noside == EVAL_SKIP)
7281 value_from_longest (builtin_type_int,
7282 (value_less (arg1,arg3)
7283 || value_equal (arg1,arg3))
7284 && (value_less (arg2,arg1)
7285 || value_equal (arg2,arg1)));
7287 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
7288 /* case OP_ATTRIBUTE:
7290 atr = (enum ada_attribute) longest_to_int (exp->elts[pc + 2].longconst);
7294 error ("unexpected attribute encountered");
7300 struct type* type_arg;
7301 if (exp->elts[*pos].opcode == OP_TYPE)
7303 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7305 type_arg = exp->elts[pc + 5].type;
7309 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7313 if (exp->elts[*pos].opcode != OP_LONG)
7314 error ("illegal operand to '%s", ada_attribute_name (atr));
7315 tem = longest_to_int (exp->elts[*pos+2].longconst);
7318 if (noside == EVAL_SKIP)
7321 if (type_arg == NULL)
7323 arg1 = ada_coerce_ref (arg1);
7325 if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
7326 arg1 = ada_coerce_to_simple_array (arg1);
7328 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
7329 error ("invalid dimension number to '%s",
7330 ada_attribute_name (atr));
7332 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7334 type = ada_index_type (VALUE_TYPE (arg1), tem);
7336 error ("attempt to take bound of something that is not an array");
7337 return allocate_value (type);
7343 error ("unexpected attribute encountered");
7345 return ada_array_bound (arg1, tem, 0);
7347 return ada_array_bound (arg1, tem, 1);
7349 return ada_array_length (arg1, tem);
7352 else if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE
7353 || TYPE_CODE (type_arg) == TYPE_CODE_INT)
7355 struct type* range_type;
7356 char* name = ada_type_name (type_arg);
7359 if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE)
7360 range_type = type_arg;
7362 error ("unimplemented type attribute");
7366 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
7370 error ("unexpected attribute encountered");
7372 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7373 TYPE_LOW_BOUND (range_type));
7375 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7376 TYPE_HIGH_BOUND (range_type));
7379 else if (TYPE_CODE (type_arg) == TYPE_CODE_ENUM)
7384 error ("unexpected attribute encountered");
7386 return value_from_longest
7387 (type_arg, TYPE_FIELD_BITPOS (type_arg, 0));
7389 return value_from_longest
7391 TYPE_FIELD_BITPOS (type_arg,
7392 TYPE_NFIELDS (type_arg) - 1));
7395 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
7396 error ("unimplemented type attribute");
7401 if (ada_is_packed_array_type (type_arg))
7402 type_arg = decode_packed_array_type (type_arg);
7404 if (tem < 1 || tem > ada_array_arity (type_arg))
7405 error ("invalid dimension number to '%s",
7406 ada_attribute_name (atr));
7408 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7410 type = ada_index_type (type_arg, tem);
7412 error ("attempt to take bound of something that is not an array");
7413 return allocate_value (type);
7419 error ("unexpected attribute encountered");
7421 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7422 return value_from_longest (type, low);
7424 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
7425 return value_from_longest (type, high);
7427 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7428 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
7429 return value_from_longest (type, high-low+1);
7435 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7436 if (noside == EVAL_SKIP)
7439 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7441 value_zero (ada_tag_type (arg1), not_lval);
7443 return ada_value_tag (arg1);
7447 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7448 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7449 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7450 if (noside == EVAL_SKIP)
7452 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7453 return value_zero (VALUE_TYPE (arg1), not_lval);
7455 return value_binop (arg1, arg2,
7456 atr == ATR_MIN ? BINOP_MIN : BINOP_MAX);
7460 struct type* type_arg = exp->elts[pc + 5].type;
7461 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7464 if (noside == EVAL_SKIP)
7467 if (! ada_is_modular_type (type_arg))
7468 error ("'modulus must be applied to modular type");
7470 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
7471 ada_modulus (type_arg));
7476 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7477 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7478 if (noside == EVAL_SKIP)
7480 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7481 return value_zero (builtin_type_ada_int, not_lval);
7483 return value_pos_atr (arg1);
7486 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7487 if (noside == EVAL_SKIP)
7489 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7490 return value_zero (builtin_type_ada_int, not_lval);
7492 return value_from_longest (builtin_type_ada_int,
7494 * TYPE_LENGTH (VALUE_TYPE (arg1)));
7497 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7498 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7499 type = exp->elts[pc + 5].type;
7500 if (noside == EVAL_SKIP)
7502 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7503 return value_zero (type, not_lval);
7505 return value_val_atr (type, arg1);
7508 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7509 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7510 if (noside
== EVAL_SKIP
)
7512 if (binop_user_defined_p (op
, arg1
, arg2
))
7513 return unwrap_value (value_x_binop (arg1
, arg2
, op
, OP_NULL
,
7515 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7516 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7518 return value_binop (arg1
, arg2
, op
);
7521 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7522 if (noside
== EVAL_SKIP
)
7524 if (unop_user_defined_p (op
, arg1
))
7525 return unwrap_value (value_x_unop (arg1
, op
, EVAL_NORMAL
));
7530 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7531 if (noside
== EVAL_SKIP
)
7533 if (value_less (arg1
, value_zero (VALUE_TYPE (arg1
), not_lval
)))
7534 return value_neg (arg1
);
7539 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
7540 expect_type
= TYPE_TARGET_TYPE (check_typedef (expect_type
));
7541 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
7542 if (noside
== EVAL_SKIP
)
7544 type
= check_typedef (VALUE_TYPE (arg1
));
7545 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7547 if (ada_is_array_descriptor (type
))
7548 /* GDB allows dereferencing GNAT array descriptors. */
7550 struct type
*arrType
= ada_type_of_array (arg1
, 0);
7551 if (arrType
== NULL
)
7552 error ("Attempt to dereference null array pointer.");
7553 return value_at_lazy (arrType
, 0, NULL
);
7555 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
7556 || TYPE_CODE (type
) == TYPE_CODE_REF
7557 /* In C you can dereference an array to get the 1st elt. */
7558 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7561 (to_static_fixed_type
7562 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type
)))),
7564 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
7565 /* GDB allows dereferencing an int. */
7566 return value_zero (builtin_type_int
, lval_memory
);
7568 error ("Attempt to take contents of a non-pointer value.");
7570 arg1
= ada_coerce_ref (arg1
);
7571 type
= check_typedef (VALUE_TYPE (arg1
));
7573 if (ada_is_array_descriptor (type
))
7574 /* GDB allows dereferencing GNAT array descriptors. */
7575 return ada_coerce_to_simple_array (arg1
);
7577 return ada_value_ind (arg1
);
7579 case STRUCTOP_STRUCT
:
7580 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7581 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7582 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7583 if (noside
== EVAL_SKIP
)
7585 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7586 return value_zero (ada_aligned_type
7587 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7593 return unwrap_value (ada_value_struct_elt (arg1
,
7594 &exp
->elts
[pc
+ 2].string
,
7597 /* The value is not supposed to be used. This is here to make it
7598 easier to accommodate expressions that contain types. */
7600 if (noside
== EVAL_SKIP
)
7602 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7603 return allocate_value (builtin_type_void
);
7605 error ("Attempt to use a type name as an expression");
7608 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7609 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7610 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7611 if (noside
== EVAL_SKIP
)
7613 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7614 return value_zero (ada_aligned_type
7615 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7621 return unwrap_value (ada_value_struct_elt (arg1
,
7622 &exp
->elts
[pc
+ 2].string
,
7627 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
7633 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7634 type name that encodes the 'small and 'delta information.
7635 Otherwise, return NULL. */
7638 fixed_type_info (struct type
*type
)
7640 const char *name
= ada_type_name (type
);
7641 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
7643 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
7645 const char *tail
= strstr (name
, "___XF_");
7651 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
7652 return fixed_type_info (TYPE_TARGET_TYPE (type
));
7657 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7660 ada_is_fixed_point_type (struct type
*type
)
7662 return fixed_type_info (type
) != NULL
;
7665 /* Assuming that TYPE is the representation of an Ada fixed-point
7666 type, return its delta, or -1 if the type is malformed and the
7667 delta cannot be determined. */
7670 ada_delta (struct type
*type
)
7672 const char *encoding
= fixed_type_info (type
);
7675 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
7678 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
7681 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7682 factor ('SMALL value) associated with the type. */
7685 scaling_factor (struct type
*type
)
7687 const char *encoding
= fixed_type_info (type
);
7688 unsigned long num0
, den0
, num1
, den1
;
7691 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
7696 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
7698 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
7702 /* Assuming that X is the representation of a value of fixed-point
7703 type TYPE, return its floating-point equivalent. */
7706 ada_fixed_to_float (struct type
*type
, LONGEST x
)
7708 return (DOUBLEST
) x
*scaling_factor (type
);
7711 /* The representation of a fixed-point value of type TYPE
7712 corresponding to the value X. */
7715 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
7717 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
7721 /* VAX floating formats */
7723 /* Non-zero iff TYPE represents one of the special VAX floating-point
7726 ada_is_vax_floating_type (struct type
*type
)
7729 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
7732 && (TYPE_CODE (type
) == TYPE_CODE_INT
7733 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7734 && STREQN (ada_type_name (type
) + name_len
- 6, "___XF", 5);
7737 /* The type of special VAX floating-point type this is, assuming
7738 ada_is_vax_floating_point */
7740 ada_vax_float_type_suffix (struct type
*type
)
7742 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
7745 /* A value representing the special debugging function that outputs
7746 VAX floating-point values of the type represented by TYPE. Assumes
7747 ada_is_vax_floating_type (TYPE). */
7749 ada_vax_float_print_function (struct type
*type
)
7751 switch (ada_vax_float_type_suffix (type
))
7754 return get_var_value ("DEBUG_STRING_F", 0);
7756 return get_var_value ("DEBUG_STRING_D", 0);
7758 return get_var_value ("DEBUG_STRING_G", 0);
7760 error ("invalid VAX floating-point type");
7767 /* Scan STR beginning at position K for a discriminant name, and
7768 return the value of that discriminant field of DVAL in *PX. If
7769 PNEW_K is not null, put the position of the character beyond the
7770 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
7771 not alter *PX and *PNEW_K if unsuccessful. */
7774 scan_discrim_bound (char *, int k
, struct value
*dval
, LONGEST
* px
,
7777 static char *bound_buffer
= NULL
;
7778 static size_t bound_buffer_len
= 0;
7781 struct value
*bound_val
;
7783 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
7786 pend
= strstr (str
+ k
, "__");
7790 k
+= strlen (bound
);
7794 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
7795 bound
= bound_buffer
;
7796 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
7797 bound
[pend
- (str
+ k
)] = '\0';
7801 bound_val
= ada_search_struct_field (bound
, dval
, 0, VALUE_TYPE (dval
));
7802 if (bound_val
== NULL
)
7805 *px
= value_as_long (bound_val
);
7811 /* Value of variable named NAME in the current environment. If
7812 no such variable found, then if ERR_MSG is null, returns 0, and
7813 otherwise causes an error with message ERR_MSG. */
7814 static struct value
*
7815 get_var_value (char *name
, char *err_msg
)
7817 struct symbol
**syms
;
7818 struct block
**blocks
;
7822 ada_lookup_symbol_list (name
, get_selected_block (NULL
), VAR_NAMESPACE
,
7827 if (err_msg
== NULL
)
7830 error ("%s", err_msg
);
7833 return value_of_variable (syms
[0], blocks
[0]);
7836 /* Value of integer variable named NAME in the current environment. If
7837 no such variable found, then if ERR_MSG is null, returns 0, and sets
7838 *FLAG to 0. If successful, sets *FLAG to 1. */
7840 get_int_var_value (char *name
, char *err_msg
, int *flag
)
7842 struct value
*var_val
= get_var_value (name
, err_msg
);
7854 return value_as_long (var_val
);
7859 /* Return a range type whose base type is that of the range type named
7860 NAME in the current environment, and whose bounds are calculated
7861 from NAME according to the GNAT range encoding conventions.
7862 Extract discriminant values, if needed, from DVAL. If a new type
7863 must be created, allocate in OBJFILE's space. The bounds
7864 information, in general, is encoded in NAME, the base type given in
7865 the named range type. */
7867 static struct type
*
7868 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
7870 struct type
*raw_type
= ada_find_any_type (name
);
7871 struct type
*base_type
;
7875 if (raw_type
== NULL
)
7876 base_type
= builtin_type_int
;
7877 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
7878 base_type
= TYPE_TARGET_TYPE (raw_type
);
7880 base_type
= raw_type
;
7882 subtype_info
= strstr (name
, "___XD");
7883 if (subtype_info
== NULL
)
7887 static char *name_buf
= NULL
;
7888 static size_t name_len
= 0;
7889 int prefix_len
= subtype_info
- name
;
7895 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
7896 strncpy (name_buf
, name
, prefix_len
);
7897 name_buf
[prefix_len
] = '\0';
7900 bounds_str
= strchr (subtype_info
, '_');
7903 if (*subtype_info
== 'L')
7905 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
7906 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
7908 if (bounds_str
[n
] == '_')
7910 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
7916 strcpy (name_buf
+ prefix_len
, "___L");
7917 L
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7920 if (*subtype_info
== 'U')
7922 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
7923 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
7928 strcpy (name_buf
+ prefix_len
, "___U");
7929 U
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7932 if (objfile
== NULL
)
7933 objfile
= TYPE_OBJFILE (base_type
);
7934 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
7935 TYPE_NAME (type
) = name
;
7940 /* True iff NAME is the name of a range type. */
7942 ada_is_range_type_name (const char *name
)
7944 return (name
!= NULL
&& strstr (name
, "___XD"));
7950 /* True iff TYPE is an Ada modular type. */
7952 ada_is_modular_type (struct type
*type
)
7954 /* FIXME: base_type should be declared in gdbtypes.h, implemented in
7956 struct type
*subranged_type
; /* = base_type (type); */
7958 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
7959 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
7960 && TYPE_UNSIGNED (subranged_type
));
7963 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
7965 ada_modulus (struct type
* type
)
7967 return TYPE_HIGH_BOUND (type
) + 1;
7974 /* Table mapping opcodes into strings for printing operators
7975 and precedences of the operators. */
7977 static const struct op_print ada_op_print_tab
[] = {
7978 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
7979 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
7980 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
7981 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
7982 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
7983 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
7984 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
7985 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
7986 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
7987 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
7988 {">", BINOP_GTR
, PREC_ORDER
, 0},
7989 {"<", BINOP_LESS
, PREC_ORDER
, 0},
7990 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
7991 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
7992 {"+", BINOP_ADD
, PREC_ADD
, 0},
7993 {"-", BINOP_SUB
, PREC_ADD
, 0},
7994 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
7995 {"*", BINOP_MUL
, PREC_MUL
, 0},
7996 {"/", BINOP_DIV
, PREC_MUL
, 0},
7997 {"rem", BINOP_REM
, PREC_MUL
, 0},
7998 {"mod", BINOP_MOD
, PREC_MUL
, 0},
7999 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
8000 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
8001 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
8002 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
8003 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
8004 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
8005 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
8006 {".all", UNOP_IND
, PREC_SUFFIX
, 1}, /* FIXME: postfix .ALL */
8007 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1}, /* FIXME: postfix 'ACCESS */
8011 /* Assorted Types and Interfaces */
8013 struct type
*builtin_type_ada_int
;
8014 struct type
*builtin_type_ada_short
;
8015 struct type
*builtin_type_ada_long
;
8016 struct type
*builtin_type_ada_long_long
;
8017 struct type
*builtin_type_ada_char
;
8018 struct type
*builtin_type_ada_float
;
8019 struct type
*builtin_type_ada_double
;
8020 struct type
*builtin_type_ada_long_double
;
8021 struct type
*builtin_type_ada_natural
;
8022 struct type
*builtin_type_ada_positive
;
8023 struct type
*builtin_type_ada_system_address
;
8025 struct type
**const (ada_builtin_types
[]) =
8028 &builtin_type_ada_int
,
8029 &builtin_type_ada_long
,
8030 &builtin_type_ada_short
,
8031 &builtin_type_ada_char
,
8032 &builtin_type_ada_float
,
8033 &builtin_type_ada_double
,
8034 &builtin_type_ada_long_long
,
8035 &builtin_type_ada_long_double
,
8036 &builtin_type_ada_natural
, &builtin_type_ada_positive
,
8037 /* The following types are carried over from C for convenience. */
8040 &builtin_type_short
,
8042 &builtin_type_float
,
8043 &builtin_type_double
,
8044 &builtin_type_long_long
,
8046 &builtin_type_signed_char
,
8047 &builtin_type_unsigned_char
,
8048 &builtin_type_unsigned_short
,
8049 &builtin_type_unsigned_int
,
8050 &builtin_type_unsigned_long
,
8051 &builtin_type_unsigned_long_long
,
8052 &builtin_type_long_double
,
8053 &builtin_type_complex
, &builtin_type_double_complex
, 0};
8055 /* Not really used, but needed in the ada_language_defn. */
8057 emit_char (int c
, struct ui_file
*stream
, int quoter
)
8059 ada_emit_char (c
, stream
, quoter
, 1);
8062 const struct language_defn ada_language_defn
= {
8063 "ada", /* Language name */
8066 /* FIXME: language_ada should be defined in defs.h */
8070 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8071 * that's not quite what this means. */
8074 ada_evaluate_subexp
,
8075 ada_printchar
, /* Print a character constant */
8076 ada_printstr
, /* Function to print string constant */
8077 emit_char
, /* Function to print single char (not used) */
8078 ada_create_fundamental_type
, /* Create fundamental type in this language */
8079 ada_print_type
, /* Print a type using appropriate syntax */
8080 ada_val_print
, /* Print a value using appropriate syntax */
8081 ada_value_print
, /* Print a top-level value */
8082 {"", "", "", ""}, /* Binary format info */
8084 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
8085 {"%ld", "", "d", ""}, /* Decimal format info */
8086 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
8088 /* Copied from c-lang.c. */
8089 {"0%lo", "0", "o", ""}, /* Octal format info */
8090 {"%ld", "", "d", ""}, /* Decimal format info */
8091 {"0x%lx", "0x", "x", ""}, /* Hex format info */
8093 ada_op_print_tab
, /* expression operators for printing */
8094 1, /* c-style arrays (FIXME?) */
8095 0, /* String lower bound (FIXME?) */
8096 &builtin_type_ada_char
,
8101 _initialize_ada_language (void)
8103 builtin_type_ada_int
=
8104 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8105 0, "integer", (struct objfile
*) NULL
);
8106 builtin_type_ada_long
=
8107 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8108 0, "long_integer", (struct objfile
*) NULL
);
8109 builtin_type_ada_short
=
8110 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8111 0, "short_integer", (struct objfile
*) NULL
);
8112 builtin_type_ada_char
=
8113 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8114 0, "character", (struct objfile
*) NULL
);
8115 builtin_type_ada_float
=
8116 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8117 0, "float", (struct objfile
*) NULL
);
8118 builtin_type_ada_double
=
8119 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8120 0, "long_float", (struct objfile
*) NULL
);
8121 builtin_type_ada_long_long
=
8122 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8123 0, "long_long_integer", (struct objfile
*) NULL
);
8124 builtin_type_ada_long_double
=
8125 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8126 0, "long_long_float", (struct objfile
*) NULL
);
8127 builtin_type_ada_natural
=
8128 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8129 0, "natural", (struct objfile
*) NULL
);
8130 builtin_type_ada_positive
=
8131 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8132 0, "positive", (struct objfile
*) NULL
);
8135 builtin_type_ada_system_address
=
8136 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8137 (struct objfile
*) NULL
));
8138 TYPE_NAME (builtin_type_ada_system_address
) = "system__address";
8140 add_language (&ada_language_defn
);
8143 (add_set_cmd ("varsize-limit", class_support
, var_uinteger
,
8144 (char *) &varsize_limit
,
8145 "Set maximum bytes in dynamic-sized object.",
8146 &setlist
), &showlist
);
8147 varsize_limit
= 65536;
8149 add_com ("begin", class_breakpoint
, begin_command
,
8150 "Start the debugged program, stopping at the beginning of the\n\
8151 main program. You may specify command-line arguments to give it, as for\n\
8152 the \"run\" command (q.v.).");
8156 /* Create a fundamental Ada type using default reasonable for the current
8159 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8160 define fundamental types such as "int" or "double". Others (stabs or
8161 DWARF version 2, etc) do define fundamental types. For the formats which
8162 don't provide fundamental types, gdb can create such types using this
8165 FIXME: Some compilers distinguish explicitly signed integral types
8166 (signed short, signed int, signed long) from "regular" integral types
8167 (short, int, long) in the debugging information. There is some dis-
8168 agreement as to how useful this feature is. In particular, gcc does
8169 not support this. Also, only some debugging formats allow the
8170 distinction to be passed on to a debugger. For now, we always just
8171 use "short", "int", or "long" as the type name, for both the implicit
8172 and explicitly signed types. This also makes life easier for the
8173 gdb test suite since we don't have to account for the differences
8174 in output depending upon what the compiler and debugging format
8175 support. We will probably have to re-examine the issue when gdb
8176 starts taking it's fundamental type information directly from the
8177 debugging information supplied by the compiler. fnf@cygnus.com */
8179 static struct type
*
8180 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8182 struct type
*type
= NULL
;
8187 /* FIXME: For now, if we are asked to produce a type not in this
8188 language, create the equivalent of a C integer type with the
8189 name "<?type?>". When all the dust settles from the type
8190 reconstruction work, this should probably become an error. */
8191 type
= init_type (TYPE_CODE_INT
,
8192 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8193 0, "<?type?>", objfile
);
8194 warning ("internal error: no Ada fundamental type %d", typeid);
8197 type
= init_type (TYPE_CODE_VOID
,
8198 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8199 0, "void", objfile
);
8202 type
= init_type (TYPE_CODE_INT
,
8203 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8204 0, "character", objfile
);
8206 case FT_SIGNED_CHAR
:
8207 type
= init_type (TYPE_CODE_INT
,
8208 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8209 0, "signed char", objfile
);
8211 case FT_UNSIGNED_CHAR
:
8212 type
= init_type (TYPE_CODE_INT
,
8213 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8214 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8217 type
= init_type (TYPE_CODE_INT
,
8218 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8219 0, "short_integer", objfile
);
8221 case FT_SIGNED_SHORT
:
8222 type
= init_type (TYPE_CODE_INT
,
8223 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8224 0, "short_integer", objfile
);
8226 case FT_UNSIGNED_SHORT
:
8227 type
= init_type (TYPE_CODE_INT
,
8228 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8229 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8232 type
= init_type (TYPE_CODE_INT
,
8233 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8234 0, "integer", objfile
);
8236 case FT_SIGNED_INTEGER
:
8237 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
, 0, "integer", objfile
); /* FIXME -fnf */
8239 case FT_UNSIGNED_INTEGER
:
8240 type
= init_type (TYPE_CODE_INT
,
8241 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8242 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8245 type
= init_type (TYPE_CODE_INT
,
8246 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8247 0, "long_integer", objfile
);
8249 case FT_SIGNED_LONG
:
8250 type
= init_type (TYPE_CODE_INT
,
8251 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8252 0, "long_integer", objfile
);
8254 case FT_UNSIGNED_LONG
:
8255 type
= init_type (TYPE_CODE_INT
,
8256 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8257 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8260 type
= init_type (TYPE_CODE_INT
,
8261 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8262 0, "long_long_integer", objfile
);
8264 case FT_SIGNED_LONG_LONG
:
8265 type
= init_type (TYPE_CODE_INT
,
8266 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8267 0, "long_long_integer", objfile
);
8269 case FT_UNSIGNED_LONG_LONG
:
8270 type
= init_type (TYPE_CODE_INT
,
8271 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8272 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8275 type
= init_type (TYPE_CODE_FLT
,
8276 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8277 0, "float", objfile
);
8279 case FT_DBL_PREC_FLOAT
:
8280 type
= init_type (TYPE_CODE_FLT
,
8281 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8282 0, "long_float", objfile
);
8284 case FT_EXT_PREC_FLOAT
:
8285 type
= init_type (TYPE_CODE_FLT
,
8286 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8287 0, "long_long_float", objfile
);
8294 ada_dump_symtab (struct symtab
*s
)
8297 fprintf (stderr
, "New symtab: [\n");
8298 fprintf (stderr
, " Name: %s/%s;\n",
8299 s
->dirname
? s
->dirname
: "?", s
->filename
? s
->filename
: "?");
8300 fprintf (stderr
, " Format: %s;\n", s
->debugformat
);
8301 if (s
->linetable
!= NULL
)
8303 fprintf (stderr
, " Line table (section %d):\n", s
->block_line_section
);
8304 for (i
= 0; i
< s
->linetable
->nitems
; i
+= 1)
8306 struct linetable_entry
*e
= s
->linetable
->item
+ i
;
8307 fprintf (stderr
, " %4ld: %8lx\n", (long) e
->line
, (long) e
->pc
);
8310 fprintf (stderr
, "]\n");