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"
41 struct cleanup
*unresolved_names
;
43 void extract_string (CORE_ADDR addr
, char *buf
);
45 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
47 static void modify_general_field (char *, LONGEST
, int, int);
49 static struct type
*desc_base_type (struct type
*);
51 static struct type
*desc_bounds_type (struct type
*);
53 static struct value
*desc_bounds (struct value
*);
55 static int fat_pntr_bounds_bitpos (struct type
*);
57 static int fat_pntr_bounds_bitsize (struct type
*);
59 static struct type
*desc_data_type (struct type
*);
61 static struct value
*desc_data (struct value
*);
63 static int fat_pntr_data_bitpos (struct type
*);
65 static int fat_pntr_data_bitsize (struct type
*);
67 static struct value
*desc_one_bound (struct value
*, int, int);
69 static int desc_bound_bitpos (struct type
*, int, int);
71 static int desc_bound_bitsize (struct type
*, int, int);
73 static struct type
*desc_index_type (struct type
*, int);
75 static int desc_arity (struct type
*);
77 static int ada_type_match (struct type
*, struct type
*, int);
79 static int ada_args_match (struct symbol
*, struct value
**, int);
81 static struct value
*place_on_stack (struct value
*, CORE_ADDR
*);
83 static struct value
*convert_actual (struct value
*, struct type
*,
86 static struct value
*make_array_descriptor (struct type
*, struct value
*,
89 static void ada_add_block_symbols (struct block
*, const char *,
90 namespace_enum
, struct objfile
*, int);
92 static void fill_in_ada_prototype (struct symbol
*);
94 static int is_nonfunction (struct symbol
**, int);
96 static void add_defn_to_vec (struct symbol
*, struct block
*);
98 static struct partial_symbol
*ada_lookup_partial_symbol (struct partial_symtab
100 namespace_enum
, int);
102 static struct symtab
*symtab_for_sym (struct symbol
*);
104 static struct value
*ada_resolve_subexp (struct expression
**, int *, int,
107 static void replace_operator_with_call (struct expression
**, int, int, int,
108 struct symbol
*, struct block
*);
110 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
112 static const char *ada_op_name (enum exp_opcode
);
114 static int numeric_type_p (struct type
*);
116 static int integer_type_p (struct type
*);
118 static int scalar_type_p (struct type
*);
120 static int discrete_type_p (struct type
*);
122 static char *extended_canonical_line_spec (struct symtab_and_line
,
125 static struct value
*evaluate_subexp (struct type
*, struct expression
*,
128 static struct value
*evaluate_subexp_type (struct expression
*, int *);
130 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
132 static int is_dynamic_field (struct type
*, int);
134 static struct type
*to_fixed_variant_branch_type (struct type
*, char *,
135 CORE_ADDR
, struct value
*);
137 static struct type
*to_fixed_range_type (char *, struct value
*,
140 static struct type
*to_static_fixed_type (struct type
*);
142 static struct value
*unwrap_value (struct value
*);
144 static struct type
*packed_array_type (struct type
*, long *);
146 static struct type
*decode_packed_array_type (struct type
*);
148 static struct value
*decode_packed_array (struct value
*);
150 static struct value
*value_subscript_packed (struct value
*, int,
153 static struct value
*coerce_unspec_val_to_type (struct value
*, long,
156 static struct value
*get_var_value (char *, char *);
158 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
160 static int equiv_types (struct type
*, struct type
*);
162 static int is_name_suffix (const char *);
164 static int wild_match (const char *, int, const char *);
166 static struct symtabs_and_lines
find_sal_from_funcs_and_line (const char *,
171 static int find_line_in_linetable (struct linetable
*, int, struct symbol
**,
174 static int find_next_line_in_linetable (struct linetable
*, int, int, int);
176 static struct symtabs_and_lines
all_sals_for_line (const char *, int,
179 static void read_all_symtabs (const char *);
181 static int is_plausible_func_for_line (struct symbol
*, int);
183 static struct value
*ada_coerce_ref (struct value
*);
185 static struct value
*value_pos_atr (struct value
*);
187 static struct value
*value_val_atr (struct type
*, struct value
*);
189 static struct symbol
*standard_lookup (const char *, namespace_enum
);
191 extern void markTimeStart (int index
);
192 extern void markTimeStop (int index
);
196 /* Maximum-sized dynamic type. */
197 static unsigned int varsize_limit
;
199 static const char *ada_completer_word_break_characters
=
200 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
202 /* The name of the symbol to use to get the name of the main subprogram */
203 #define ADA_MAIN_PROGRAM_SYMBOL_NAME "__gnat_ada_main_program_name"
209 * read the string located at ADDR from the inferior and store the
213 extract_string (CORE_ADDR addr
, char *buf
)
217 /* Loop, reading one byte at a time, until we reach the '\000'
218 end-of-string marker */
221 target_read_memory (addr
+ char_index
* sizeof (char),
222 buf
+ char_index
* sizeof (char), sizeof (char));
225 while (buf
[char_index
- 1] != '\000');
228 /* Assuming *OLD_VECT points to an array of *SIZE objects of size
229 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
230 updating *OLD_VECT and *SIZE as necessary. */
233 grow_vect (void **old_vect
, size_t * size
, size_t min_size
, int element_size
)
235 if (*size
< min_size
)
238 if (*size
< min_size
)
240 *old_vect
= xrealloc (*old_vect
, *size
* element_size
);
244 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
245 suffix of FIELD_NAME beginning "___" */
248 field_name_match (const char *field_name
, const char *target
)
250 int len
= strlen (target
);
252 STREQN (field_name
, target
, len
)
253 && (field_name
[len
] == '\0'
254 || (STREQN (field_name
+ len
, "___", 3)
255 && !STREQ (field_name
+ strlen (field_name
) - 6, "___XVN")));
259 /* The length of the prefix of NAME prior to any "___" suffix. */
262 ada_name_prefix_len (const char *name
)
268 const char *p
= strstr (name
, "___");
270 return strlen (name
);
276 /* SUFFIX is a suffix of STR. False if STR is null. */
278 is_suffix (const char *str
, const char *suffix
)
284 len2
= strlen (suffix
);
285 return (len1
>= len2
&& STREQ (str
+ len1
- len2
, suffix
));
288 /* Create a value of type TYPE whose contents come from VALADDR, if it
289 * is non-null, and whose memory address (in the inferior) is
292 value_from_contents_and_address (struct type
*type
, char *valaddr
,
295 struct value
*v
= allocate_value (type
);
299 memcpy (VALUE_CONTENTS_RAW (v
), valaddr
, TYPE_LENGTH (type
));
300 VALUE_ADDRESS (v
) = address
;
302 VALUE_LVAL (v
) = lval_memory
;
306 /* The contents of value VAL, beginning at offset OFFSET, treated as a
307 value of type TYPE. The result is an lval in memory if VAL is. */
309 static struct value
*
310 coerce_unspec_val_to_type (struct value
*val
, long offset
, struct type
*type
)
312 CHECK_TYPEDEF (type
);
313 if (VALUE_LVAL (val
) == lval_memory
)
314 return value_at_lazy (type
,
315 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
) + offset
,
319 struct value
*result
= allocate_value (type
);
320 VALUE_LVAL (result
) = not_lval
;
321 if (VALUE_ADDRESS (val
) == 0)
322 memcpy (VALUE_CONTENTS_RAW (result
), VALUE_CONTENTS (val
) + offset
,
323 TYPE_LENGTH (type
) > TYPE_LENGTH (VALUE_TYPE (val
))
324 ? TYPE_LENGTH (VALUE_TYPE (val
)) : TYPE_LENGTH (type
));
327 VALUE_ADDRESS (result
) =
328 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
) + offset
;
329 VALUE_LAZY (result
) = 1;
336 cond_offset_host (char *valaddr
, long offset
)
341 return valaddr
+ offset
;
345 cond_offset_target (CORE_ADDR address
, long offset
)
350 return address
+ offset
;
353 /* Perform execute_command on the result of concatenating all
354 arguments up to NULL. */
356 do_command (const char *arg
, ...)
367 for (; s
!= NULL
; s
= va_arg (ap
, const char *))
371 cmd1
= alloca (len
+ 1);
377 execute_command (cmd
, 0);
381 /* Language Selection */
383 /* If the main program is in Ada, return language_ada, otherwise return LANG
384 (the main program is in Ada iif the adainit symbol is found).
386 MAIN_PST is not used. */
389 ada_update_initial_language (enum language lang
,
390 struct partial_symtab
*main_pst
)
392 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
393 (struct objfile
*) NULL
) != NULL
)
394 /* return language_ada; */
395 /* FIXME: language_ada should be defined in defs.h */
396 return language_unknown
;
404 /* Table of Ada operators and their GNAT-mangled names. Last entry is pair
407 const struct ada_opname_map ada_opname_table
[] = {
408 {"Oadd", "\"+\"", BINOP_ADD
},
409 {"Osubtract", "\"-\"", BINOP_SUB
},
410 {"Omultiply", "\"*\"", BINOP_MUL
},
411 {"Odivide", "\"/\"", BINOP_DIV
},
412 {"Omod", "\"mod\"", BINOP_MOD
},
413 {"Orem", "\"rem\"", BINOP_REM
},
414 {"Oexpon", "\"**\"", BINOP_EXP
},
415 {"Olt", "\"<\"", BINOP_LESS
},
416 {"Ole", "\"<=\"", BINOP_LEQ
},
417 {"Ogt", "\">\"", BINOP_GTR
},
418 {"Oge", "\">=\"", BINOP_GEQ
},
419 {"Oeq", "\"=\"", BINOP_EQUAL
},
420 {"One", "\"/=\"", BINOP_NOTEQUAL
},
421 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
422 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
423 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
424 {"Oconcat", "\"&\"", BINOP_CONCAT
},
425 {"Oabs", "\"abs\"", UNOP_ABS
},
426 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
427 {"Oadd", "\"+\"", UNOP_PLUS
},
428 {"Osubtract", "\"-\"", UNOP_NEG
},
432 /* True if STR should be suppressed in info listings. */
434 is_suppressed_name (const char *str
)
436 if (STREQN (str
, "_ada_", 5))
438 if (str
[0] == '_' || str
[0] == '\000')
443 const char *suffix
= strstr (str
, "___");
444 if (suffix
!= NULL
&& suffix
[3] != 'X')
447 suffix
= str
+ strlen (str
);
448 for (p
= suffix
- 1; p
!= str
; p
-= 1)
452 if (p
[0] == 'X' && p
[-1] != '_')
456 for (i
= 0; ada_opname_table
[i
].mangled
!= NULL
; i
+= 1)
457 if (STREQN (ada_opname_table
[i
].mangled
, p
,
458 strlen (ada_opname_table
[i
].mangled
)))
467 /* The "mangled" form of DEMANGLED, according to GNAT conventions.
468 * The result is valid until the next call to ada_mangle. */
470 ada_mangle (const char *demangled
)
472 static char *mangling_buffer
= NULL
;
473 static size_t mangling_buffer_size
= 0;
477 if (demangled
== NULL
)
480 GROW_VECT (mangling_buffer
, mangling_buffer_size
,
481 2 * strlen (demangled
) + 10);
484 for (p
= demangled
; *p
!= '\0'; p
+= 1)
488 mangling_buffer
[k
] = mangling_buffer
[k
+ 1] = '_';
493 const struct ada_opname_map
*mapping
;
495 for (mapping
= ada_opname_table
;
496 mapping
->mangled
!= NULL
&&
497 !STREQN (mapping
->demangled
, p
, strlen (mapping
->demangled
));
500 if (mapping
->mangled
== NULL
)
501 error ("invalid Ada operator name: %s", p
);
502 strcpy (mangling_buffer
+ k
, mapping
->mangled
);
503 k
+= strlen (mapping
->mangled
);
508 mangling_buffer
[k
] = *p
;
513 mangling_buffer
[k
] = '\0';
514 return mangling_buffer
;
517 /* Return NAME folded to lower case, or, if surrounded by single
518 * quotes, unfolded, but with the quotes stripped away. Result good
521 ada_fold_name (const char *name
)
523 static char *fold_buffer
= NULL
;
524 static size_t fold_buffer_size
= 0;
526 int len
= strlen (name
);
527 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
531 strncpy (fold_buffer
, name
+ 1, len
- 2);
532 fold_buffer
[len
- 2] = '\000';
537 for (i
= 0; i
<= len
; i
+= 1)
538 fold_buffer
[i
] = tolower (name
[i
]);
545 1. Discard final __{DIGIT}+ or ${DIGIT}+
546 2. Convert other instances of embedded "__" to `.'.
547 3. Discard leading _ada_.
548 4. Convert operator names to the appropriate quoted symbols.
549 5. Remove everything after first ___ if it is followed by
551 6. Replace TK__ with __, and a trailing B or TKB with nothing.
552 7. Put symbols that should be suppressed in <...> brackets.
553 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
554 The resulting string is valid until the next call of ada_demangle.
558 ada_demangle (const char *mangled
)
565 static char *demangling_buffer
= NULL
;
566 static size_t demangling_buffer_size
= 0;
568 if (STREQN (mangled
, "_ada_", 5))
571 if (mangled
[0] == '_' || mangled
[0] == '<')
574 p
= strstr (mangled
, "___");
576 len0
= strlen (mangled
);
584 if (len0
> 3 && STREQ (mangled
+ len0
- 3, "TKB"))
586 if (len0
> 1 && STREQ (mangled
+ len0
- 1, "B"))
589 /* Make demangled big enough for possible expansion by operator name. */
590 GROW_VECT (demangling_buffer
, demangling_buffer_size
, 2 * len0
+ 1);
591 demangled
= demangling_buffer
;
593 if (isdigit (mangled
[len0
- 1]))
595 for (i
= len0
- 2; i
>= 0 && isdigit (mangled
[i
]); i
-= 1)
597 if (i
> 1 && mangled
[i
] == '_' && mangled
[i
- 1] == '_')
599 else if (mangled
[i
] == '$')
603 for (i
= 0, j
= 0; i
< len0
&& !isalpha (mangled
[i
]); i
+= 1, j
+= 1)
604 demangled
[j
] = mangled
[i
];
609 if (at_start_name
&& mangled
[i
] == 'O')
612 for (k
= 0; ada_opname_table
[k
].mangled
!= NULL
; k
+= 1)
614 int op_len
= strlen (ada_opname_table
[k
].mangled
);
616 (ada_opname_table
[k
].mangled
+ 1, mangled
+ i
+ 1,
617 op_len
- 1) && !isalnum (mangled
[i
+ op_len
]))
619 strcpy (demangled
+ j
, ada_opname_table
[k
].demangled
);
622 j
+= strlen (ada_opname_table
[k
].demangled
);
626 if (ada_opname_table
[k
].mangled
!= NULL
)
631 if (i
< len0
- 4 && STREQN (mangled
+ i
, "TK__", 4))
633 if (mangled
[i
] == 'X' && i
!= 0 && isalnum (mangled
[i
- 1]))
637 while (i
< len0
&& (mangled
[i
] == 'b' || mangled
[i
] == 'n'));
641 else if (i
< len0
- 2 && mangled
[i
] == '_' && mangled
[i
+ 1] == '_')
650 demangled
[j
] = mangled
[i
];
655 demangled
[j
] = '\000';
657 for (i
= 0; demangled
[i
] != '\0'; i
+= 1)
658 if (isupper (demangled
[i
]) || demangled
[i
] == ' ')
664 GROW_VECT (demangling_buffer
, demangling_buffer_size
, strlen (mangled
) + 3);
665 demangled
= demangling_buffer
;
666 if (mangled
[0] == '<')
667 strcpy (demangled
, mangled
);
669 sprintf (demangled
, "<%s>", mangled
);
674 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
675 * suffixes that encode debugging information or leading _ada_ on
676 * SYM_NAME (see is_name_suffix commentary for the debugging
677 * information that is ignored). If WILD, then NAME need only match a
678 * suffix of SYM_NAME minus the same suffixes. Also returns 0 if
679 * either argument is NULL. */
682 ada_match_name (const char *sym_name
, const char *name
, int wild
)
684 if (sym_name
== NULL
|| name
== NULL
)
687 return wild_match (name
, strlen (name
), sym_name
);
690 int len_name
= strlen (name
);
691 return (STREQN (sym_name
, name
, len_name
)
692 && is_name_suffix (sym_name
+ len_name
))
693 || (STREQN (sym_name
, "_ada_", 5)
694 && STREQN (sym_name
+ 5, name
, len_name
)
695 && is_name_suffix (sym_name
+ len_name
+ 5));
699 /* True (non-zero) iff in Ada mode, the symbol SYM should be
700 suppressed in info listings. */
703 ada_suppress_symbol_printing (struct symbol
*sym
)
705 if (SYMBOL_NAMESPACE (sym
) == STRUCT_NAMESPACE
)
708 return is_suppressed_name (SYMBOL_NAME (sym
));
714 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of
715 array descriptors. */
717 static char *bound_name
[] = {
718 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
719 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
722 /* Maximum number of array dimensions we are prepared to handle. */
724 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char*)))
726 /* Like modify_field, but allows bitpos > wordlength. */
729 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
731 modify_field (addr
+ sizeof (LONGEST
) * bitpos
/ (8 * sizeof (LONGEST
)),
732 fieldval
, bitpos
% (8 * sizeof (LONGEST
)), bitsize
);
736 /* The desc_* routines return primitive portions of array descriptors
739 /* The descriptor or array type, if any, indicated by TYPE; removes
740 level of indirection, if needed. */
742 desc_base_type (struct type
*type
)
746 CHECK_TYPEDEF (type
);
747 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_PTR
)
748 return check_typedef (TYPE_TARGET_TYPE (type
));
753 /* True iff TYPE indicates a "thin" array pointer type. */
755 is_thin_pntr (struct type
*type
)
758 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
759 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
762 /* The descriptor type for thin pointer type TYPE. */
764 thin_descriptor_type (struct type
*type
)
766 struct type
*base_type
= desc_base_type (type
);
767 if (base_type
== NULL
)
769 if (is_suffix (ada_type_name (base_type
), "___XVE"))
773 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
774 if (alt_type
== NULL
)
781 /* A pointer to the array data for thin-pointer value VAL. */
782 static struct value
*
783 thin_data_pntr (struct value
*val
)
785 struct type
*type
= VALUE_TYPE (val
);
786 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
787 return value_cast (desc_data_type (thin_descriptor_type (type
)),
790 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
791 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
));
794 /* True iff TYPE indicates a "thick" array pointer type. */
796 is_thick_pntr (struct type
*type
)
798 type
= desc_base_type (type
);
799 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
800 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
803 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
804 pointer to one, the type of its bounds data; otherwise, NULL. */
806 desc_bounds_type (struct type
*type
)
810 type
= desc_base_type (type
);
814 else if (is_thin_pntr (type
))
816 type
= thin_descriptor_type (type
);
819 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
821 return check_typedef (r
);
823 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
825 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
827 return check_typedef (TYPE_TARGET_TYPE (check_typedef (r
)));
832 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
833 one, a pointer to its bounds data. Otherwise NULL. */
834 static struct value
*
835 desc_bounds (struct value
*arr
)
837 struct type
*type
= check_typedef (VALUE_TYPE (arr
));
838 if (is_thin_pntr (type
))
840 struct type
*bounds_type
=
841 desc_bounds_type (thin_descriptor_type (type
));
844 if (desc_bounds_type
== NULL
)
845 error ("Bad GNAT array descriptor");
847 /* NOTE: The following calculation is not really kosher, but
848 since desc_type is an XVE-encoded type (and shouldn't be),
849 the correct calculation is a real pain. FIXME (and fix GCC). */
850 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
851 addr
= value_as_long (arr
);
853 addr
= VALUE_ADDRESS (arr
) + VALUE_OFFSET (arr
);
856 value_from_longest (lookup_pointer_type (bounds_type
),
857 addr
- TYPE_LENGTH (bounds_type
));
860 else if (is_thick_pntr (type
))
861 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
862 "Bad GNAT array descriptor");
867 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
868 position of the field containing the address of the bounds data. */
870 fat_pntr_bounds_bitpos (struct type
*type
)
872 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
875 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
876 size of the field containing the address of the bounds data. */
878 fat_pntr_bounds_bitsize (struct type
*type
)
880 type
= desc_base_type (type
);
882 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
883 return TYPE_FIELD_BITSIZE (type
, 1);
885 return 8 * TYPE_LENGTH (check_typedef (TYPE_FIELD_TYPE (type
, 1)));
888 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
889 pointer to one, the type of its array data (a
890 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
891 ada_type_of_array to get an array type with bounds data. */
893 desc_data_type (struct type
*type
)
895 type
= desc_base_type (type
);
897 /* NOTE: The following is bogus; see comment in desc_bounds. */
898 if (is_thin_pntr (type
))
899 return lookup_pointer_type
900 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
901 else if (is_thick_pntr (type
))
902 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
907 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
909 static struct value
*
910 desc_data (struct value
*arr
)
912 struct type
*type
= VALUE_TYPE (arr
);
913 if (is_thin_pntr (type
))
914 return thin_data_pntr (arr
);
915 else if (is_thick_pntr (type
))
916 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
917 "Bad GNAT array descriptor");
923 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
924 position of the field containing the address of the data. */
926 fat_pntr_data_bitpos (struct type
*type
)
928 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
931 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
932 size of the field containing the address of the data. */
934 fat_pntr_data_bitsize (struct type
*type
)
936 type
= desc_base_type (type
);
938 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
939 return TYPE_FIELD_BITSIZE (type
, 0);
941 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
944 /* If BOUNDS is an array-bounds structure (or pointer to one), return
945 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
946 bound, if WHICH is 1. The first bound is I=1. */
947 static struct value
*
948 desc_one_bound (struct value
*bounds
, int i
, int which
)
950 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
951 "Bad GNAT array descriptor bounds");
954 /* If BOUNDS is an array-bounds structure type, return the bit position
955 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
956 bound, if WHICH is 1. The first bound is I=1. */
958 desc_bound_bitpos (struct type
*type
, int i
, int which
)
960 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
963 /* If BOUNDS is an array-bounds structure type, return the bit field size
964 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
965 bound, if WHICH is 1. The first bound is I=1. */
967 desc_bound_bitsize (struct type
*type
, int i
, int which
)
969 type
= desc_base_type (type
);
971 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
972 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
974 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
977 /* If TYPE is the type of an array-bounds structure, the type of its
978 Ith bound (numbering from 1). Otherwise, NULL. */
980 desc_index_type (struct type
*type
, int i
)
982 type
= desc_base_type (type
);
984 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
985 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
990 /* The number of index positions in the array-bounds type TYPE. 0
993 desc_arity (struct type
*type
)
995 type
= desc_base_type (type
);
998 return TYPE_NFIELDS (type
) / 2;
1003 /* Non-zero iff type is a simple array type (or pointer to one). */
1005 ada_is_simple_array (struct type
*type
)
1009 CHECK_TYPEDEF (type
);
1010 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1011 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1012 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1015 /* Non-zero iff type belongs to a GNAT array descriptor. */
1017 ada_is_array_descriptor (struct type
*type
)
1019 struct type
*data_type
= desc_data_type (type
);
1023 CHECK_TYPEDEF (type
);
1026 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1027 && TYPE_TARGET_TYPE (data_type
) != NULL
1028 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1030 TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1031 && desc_arity (desc_bounds_type (type
)) > 0;
1034 /* Non-zero iff type is a partially mal-formed GNAT array
1035 descriptor. (FIXME: This is to compensate for some problems with
1036 debugging output from GNAT. Re-examine periodically to see if it
1039 ada_is_bogus_array_descriptor (struct type
*type
)
1043 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1044 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1045 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1046 && !ada_is_array_descriptor (type
);
1050 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1051 (fat pointer) returns the type of the array data described---specifically,
1052 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1053 in from the descriptor; otherwise, they are left unspecified. If
1054 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1055 returns NULL. The result is simply the type of ARR if ARR is not
1058 ada_type_of_array (struct value
*arr
, int bounds
)
1060 if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1061 return decode_packed_array_type (VALUE_TYPE (arr
));
1063 if (!ada_is_array_descriptor (VALUE_TYPE (arr
)))
1064 return VALUE_TYPE (arr
);
1068 check_typedef (TYPE_TARGET_TYPE (desc_data_type (VALUE_TYPE (arr
))));
1071 struct type
*elt_type
;
1073 struct value
*descriptor
;
1074 struct objfile
*objf
= TYPE_OBJFILE (VALUE_TYPE (arr
));
1076 elt_type
= ada_array_element_type (VALUE_TYPE (arr
), -1);
1077 arity
= ada_array_arity (VALUE_TYPE (arr
));
1079 if (elt_type
== NULL
|| arity
== 0)
1080 return check_typedef (VALUE_TYPE (arr
));
1082 descriptor
= desc_bounds (arr
);
1083 if (value_as_long (descriptor
) == 0)
1087 struct type
*range_type
= alloc_type (objf
);
1088 struct type
*array_type
= alloc_type (objf
);
1089 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1090 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1093 create_range_type (range_type
, VALUE_TYPE (low
),
1094 (int) value_as_long (low
),
1095 (int) value_as_long (high
));
1096 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1099 return lookup_pointer_type (elt_type
);
1103 /* If ARR does not represent an array, returns ARR unchanged.
1104 Otherwise, returns either a standard GDB array with bounds set
1105 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1106 GDB array. Returns NULL if ARR is a null fat pointer. */
1108 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1110 if (ada_is_array_descriptor (VALUE_TYPE (arr
)))
1112 struct type
*arrType
= ada_type_of_array (arr
, 1);
1113 if (arrType
== NULL
)
1115 return value_cast (arrType
, value_copy (desc_data (arr
)));
1117 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1118 return decode_packed_array (arr
);
1123 /* If ARR does not represent an array, returns ARR unchanged.
1124 Otherwise, returns a standard GDB array describing ARR (which may
1125 be ARR itself if it already is in the proper form). */
1127 ada_coerce_to_simple_array (struct value
*arr
)
1129 if (ada_is_array_descriptor (VALUE_TYPE (arr
)))
1131 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1133 error ("Bounds unavailable for null array pointer.");
1134 return value_ind (arrVal
);
1136 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1137 return decode_packed_array (arr
);
1142 /* If TYPE represents a GNAT array type, return it translated to an
1143 ordinary GDB array type (possibly with BITSIZE fields indicating
1144 packing). For other types, is the identity. */
1146 ada_coerce_to_simple_array_type (struct type
*type
)
1148 struct value
*mark
= value_mark ();
1149 struct value
*dummy
= value_from_longest (builtin_type_long
, 0);
1150 struct type
*result
;
1151 VALUE_TYPE (dummy
) = type
;
1152 result
= ada_type_of_array (dummy
, 0);
1153 value_free_to_mark (dummy
);
1157 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1159 ada_is_packed_array_type (struct type
*type
)
1163 CHECK_TYPEDEF (type
);
1165 ada_type_name (type
) != NULL
1166 && strstr (ada_type_name (type
), "___XP") != NULL
;
1169 /* Given that TYPE is a standard GDB array type with all bounds filled
1170 in, and that the element size of its ultimate scalar constituents
1171 (that is, either its elements, or, if it is an array of arrays, its
1172 elements' elements, etc.) is *ELT_BITS, return an identical type,
1173 but with the bit sizes of its elements (and those of any
1174 constituent arrays) recorded in the BITSIZE components of its
1175 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1177 static struct type
*
1178 packed_array_type (struct type
*type
, long *elt_bits
)
1180 struct type
*new_elt_type
;
1181 struct type
*new_type
;
1182 LONGEST low_bound
, high_bound
;
1184 CHECK_TYPEDEF (type
);
1185 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1188 new_type
= alloc_type (TYPE_OBJFILE (type
));
1189 new_elt_type
= packed_array_type (check_typedef (TYPE_TARGET_TYPE (type
)),
1191 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1192 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1193 TYPE_NAME (new_type
) = ada_type_name (type
);
1195 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1196 &low_bound
, &high_bound
) < 0)
1197 low_bound
= high_bound
= 0;
1198 if (high_bound
< low_bound
)
1199 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1202 *elt_bits
*= (high_bound
- low_bound
+ 1);
1203 TYPE_LENGTH (new_type
) =
1204 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1207 /* TYPE_FLAGS (new_type) |= TYPE_FLAG_FIXED_INSTANCE; */
1208 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
1212 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE).
1214 static struct type
*
1215 decode_packed_array_type (struct type
*type
)
1217 struct symbol
**syms
;
1218 struct block
**blocks
;
1219 const char *raw_name
= ada_type_name (check_typedef (type
));
1220 char *name
= (char *) alloca (strlen (raw_name
) + 1);
1221 char *tail
= strstr (raw_name
, "___XP");
1222 struct type
*shadow_type
;
1226 memcpy (name
, raw_name
, tail
- raw_name
);
1227 name
[tail
- raw_name
] = '\000';
1229 /* NOTE: Use ada_lookup_symbol_list because of bug in some versions
1230 * of gcc (Solaris, e.g.). FIXME when compiler is fixed. */
1231 n
= ada_lookup_symbol_list (name
, get_selected_block (NULL
),
1232 VAR_NAMESPACE
, &syms
, &blocks
);
1233 for (i
= 0; i
< n
; i
+= 1)
1234 if (syms
[i
] != NULL
&& SYMBOL_CLASS (syms
[i
]) == LOC_TYPEDEF
1235 && STREQ (name
, ada_type_name (SYMBOL_TYPE (syms
[i
]))))
1239 warning ("could not find bounds information on packed array");
1242 shadow_type
= SYMBOL_TYPE (syms
[i
]);
1244 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1246 warning ("could not understand bounds information on packed array");
1250 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1252 warning ("could not understand bit size information on packed array");
1256 return packed_array_type (shadow_type
, &bits
);
1259 /* Given that ARR is a struct value* indicating a GNAT packed array,
1260 returns a simple array that denotes that array. Its type is a
1261 standard GDB array type except that the BITSIZEs of the array
1262 target types are set to the number of bits in each element, and the
1263 type length is set appropriately. */
1265 static struct value
*
1266 decode_packed_array (struct value
*arr
)
1268 struct type
*type
= decode_packed_array_type (VALUE_TYPE (arr
));
1272 error ("can't unpack array");
1276 return coerce_unspec_val_to_type (arr
, 0, type
);
1280 /* The value of the element of packed array ARR at the ARITY indices
1281 given in IND. ARR must be a simple array. */
1283 static struct value
*
1284 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1287 int bits
, elt_off
, bit_off
;
1288 long elt_total_bit_offset
;
1289 struct type
*elt_type
;
1293 elt_total_bit_offset
= 0;
1294 elt_type
= check_typedef (VALUE_TYPE (arr
));
1295 for (i
= 0; i
< arity
; i
+= 1)
1297 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1298 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1300 ("attempt to do packed indexing of something other than a packed array");
1303 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1304 LONGEST lowerbound
, upperbound
;
1307 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1309 warning ("don't know bounds of array");
1310 lowerbound
= upperbound
= 0;
1313 idx
= value_as_long (value_pos_atr (ind
[i
]));
1314 if (idx
< lowerbound
|| idx
> upperbound
)
1315 warning ("packed array index %ld out of bounds", (long) idx
);
1316 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1317 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1318 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
1321 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1322 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1324 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1326 if (VALUE_LVAL (arr
) == lval_internalvar
)
1327 VALUE_LVAL (v
) = lval_internalvar_component
;
1329 VALUE_LVAL (v
) = VALUE_LVAL (arr
);
1333 /* Non-zero iff TYPE includes negative integer values. */
1336 has_negatives (struct type
*type
)
1338 switch (TYPE_CODE (type
))
1343 return !TYPE_UNSIGNED (type
);
1344 case TYPE_CODE_RANGE
:
1345 return TYPE_LOW_BOUND (type
) < 0;
1350 /* Create a new value of type TYPE from the contents of OBJ starting
1351 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1352 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1353 assigning through the result will set the field fetched from. OBJ
1354 may also be NULL, in which case, VALADDR+OFFSET must address the
1355 start of storage containing the packed value. The value returned
1356 in this case is never an lval.
1357 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1360 ada_value_primitive_packed_val (struct value
*obj
, char *valaddr
, long offset
,
1361 int bit_offset
, int bit_size
,
1365 int src
, /* Index into the source area. */
1366 targ
, /* Index into the target area. */
1367 i
, srcBitsLeft
, /* Number of source bits left to move. */
1368 nsrc
, ntarg
, /* Number of source and target bytes. */
1369 unusedLS
, /* Number of bits in next significant
1370 * byte of source that are unused. */
1371 accumSize
; /* Number of meaningful bits in accum */
1372 unsigned char *bytes
; /* First byte containing data to unpack. */
1373 unsigned char *unpacked
;
1374 unsigned long accum
; /* Staging area for bits being transferred */
1376 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1377 /* Transmit bytes from least to most significant; delta is the
1378 * direction the indices move. */
1379 int delta
= BITS_BIG_ENDIAN
? -1 : 1;
1381 CHECK_TYPEDEF (type
);
1385 v
= allocate_value (type
);
1386 bytes
= (unsigned char *) (valaddr
+ offset
);
1388 else if (VALUE_LAZY (obj
))
1391 VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
, NULL
);
1392 bytes
= (unsigned char *) alloca (len
);
1393 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
1397 v
= allocate_value (type
);
1398 bytes
= (unsigned char *) VALUE_CONTENTS (obj
) + offset
;
1403 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
1404 if (VALUE_LVAL (obj
) == lval_internalvar
)
1405 VALUE_LVAL (v
) = lval_internalvar_component
;
1406 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
;
1407 VALUE_BITPOS (v
) = bit_offset
+ VALUE_BITPOS (obj
);
1408 VALUE_BITSIZE (v
) = bit_size
;
1409 if (VALUE_BITPOS (v
) >= HOST_CHAR_BIT
)
1411 VALUE_ADDRESS (v
) += 1;
1412 VALUE_BITPOS (v
) -= HOST_CHAR_BIT
;
1416 VALUE_BITSIZE (v
) = bit_size
;
1417 unpacked
= (unsigned char *) VALUE_CONTENTS (v
);
1419 srcBitsLeft
= bit_size
;
1421 ntarg
= TYPE_LENGTH (type
);
1425 memset (unpacked
, 0, TYPE_LENGTH (type
));
1428 else if (BITS_BIG_ENDIAN
)
1431 if (has_negatives (type
) &&
1432 ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
1436 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
1439 switch (TYPE_CODE (type
))
1441 case TYPE_CODE_ARRAY
:
1442 case TYPE_CODE_UNION
:
1443 case TYPE_CODE_STRUCT
:
1444 /* Non-scalar values must be aligned at a byte boundary. */
1446 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
1447 /* And are placed at the beginning (most-significant) bytes
1453 targ
= TYPE_LENGTH (type
) - 1;
1459 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
1462 unusedLS
= bit_offset
;
1465 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
1472 /* Mask for removing bits of the next source byte that are not
1473 * part of the value. */
1474 unsigned int unusedMSMask
=
1475 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
1477 /* Sign-extend bits for this byte. */
1478 unsigned int signMask
= sign
& ~unusedMSMask
;
1480 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
1481 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
1482 if (accumSize
>= HOST_CHAR_BIT
)
1484 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1485 accumSize
-= HOST_CHAR_BIT
;
1486 accum
>>= HOST_CHAR_BIT
;
1490 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
1497 accum
|= sign
<< accumSize
;
1498 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1499 accumSize
-= HOST_CHAR_BIT
;
1500 accum
>>= HOST_CHAR_BIT
;
1508 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1509 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
1512 move_bits (char *target
, int targ_offset
, char *source
, int src_offset
, int n
)
1514 unsigned int accum
, mask
;
1515 int accum_bits
, chunk_size
;
1517 target
+= targ_offset
/ HOST_CHAR_BIT
;
1518 targ_offset
%= HOST_CHAR_BIT
;
1519 source
+= src_offset
/ HOST_CHAR_BIT
;
1520 src_offset
%= HOST_CHAR_BIT
;
1521 if (BITS_BIG_ENDIAN
)
1523 accum
= (unsigned char) *source
;
1525 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1530 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
1531 accum_bits
+= HOST_CHAR_BIT
;
1533 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1536 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
1537 mask
= ((1 << chunk_size
) - 1) << unused_right
;
1540 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
1542 accum_bits
-= chunk_size
;
1549 accum
= (unsigned char) *source
>> src_offset
;
1551 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1555 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
1556 accum_bits
+= HOST_CHAR_BIT
;
1558 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1561 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
1562 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
1564 accum_bits
-= chunk_size
;
1565 accum
>>= chunk_size
;
1573 /* Store the contents of FROMVAL into the location of TOVAL.
1574 Return a new value with the location of TOVAL and contents of
1575 FROMVAL. Handles assignment into packed fields that have
1576 floating-point or non-scalar types. */
1578 static struct value
*
1579 ada_value_assign (struct value
*toval
, struct value
*fromval
)
1581 struct type
*type
= VALUE_TYPE (toval
);
1582 int bits
= VALUE_BITSIZE (toval
);
1584 if (!toval
->modifiable
)
1585 error ("Left operand of assignment is not a modifiable lvalue.");
1589 if (VALUE_LVAL (toval
) == lval_memory
1591 && (TYPE_CODE (type
) == TYPE_CODE_FLT
1592 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
1595 (VALUE_BITPOS (toval
) + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1596 char *buffer
= (char *) alloca (len
);
1599 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
1600 fromval
= value_cast (type
, fromval
);
1602 read_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
, len
);
1603 if (BITS_BIG_ENDIAN
)
1604 move_bits (buffer
, VALUE_BITPOS (toval
),
1605 VALUE_CONTENTS (fromval
),
1606 TYPE_LENGTH (VALUE_TYPE (fromval
)) * TARGET_CHAR_BIT
-
1609 move_bits (buffer
, VALUE_BITPOS (toval
), VALUE_CONTENTS (fromval
),
1611 write_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
,
1614 val
= value_copy (toval
);
1615 memcpy (VALUE_CONTENTS_RAW (val
), VALUE_CONTENTS (fromval
),
1616 TYPE_LENGTH (type
));
1617 VALUE_TYPE (val
) = type
;
1622 return value_assign (toval
, fromval
);
1626 /* The value of the element of array ARR at the ARITY indices given in IND.
1627 ARR may be either a simple array, GNAT array descriptor, or pointer
1631 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
1635 struct type
*elt_type
;
1637 elt
= ada_coerce_to_simple_array (arr
);
1639 elt_type
= check_typedef (VALUE_TYPE (elt
));
1640 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
1641 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
1642 return value_subscript_packed (elt
, arity
, ind
);
1644 for (k
= 0; k
< arity
; k
+= 1)
1646 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
1647 error ("too many subscripts (%d expected)", k
);
1648 elt
= value_subscript (elt
, value_pos_atr (ind
[k
]));
1653 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
1654 value of the element of *ARR at the ARITY indices given in
1655 IND. Does not read the entire array into memory. */
1658 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
1663 for (k
= 0; k
< arity
; k
+= 1)
1668 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1669 error ("too many subscripts (%d expected)", k
);
1670 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
1672 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
1676 idx
= value_sub (ind
[k
], value_from_longest (builtin_type_int
, lwb
));
1677 arr
= value_add (arr
, idx
);
1678 type
= TYPE_TARGET_TYPE (type
);
1681 return value_ind (arr
);
1684 /* If type is a record type in the form of a standard GNAT array
1685 descriptor, returns the number of dimensions for type. If arr is a
1686 simple array, returns the number of "array of"s that prefix its
1687 type designation. Otherwise, returns 0. */
1690 ada_array_arity (struct type
*type
)
1697 type
= desc_base_type (type
);
1700 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1701 return desc_arity (desc_bounds_type (type
));
1703 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
1706 type
= check_typedef (TYPE_TARGET_TYPE (type
));
1712 /* If TYPE is a record type in the form of a standard GNAT array
1713 descriptor or a simple array type, returns the element type for
1714 TYPE after indexing by NINDICES indices, or by all indices if
1715 NINDICES is -1. Otherwise, returns NULL. */
1718 ada_array_element_type (struct type
*type
, int nindices
)
1720 type
= desc_base_type (type
);
1722 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1725 struct type
*p_array_type
;
1727 p_array_type
= desc_data_type (type
);
1729 k
= ada_array_arity (type
);
1733 /* Initially p_array_type = elt_type(*)[]...(k times)...[] */
1734 if (nindices
>= 0 && k
> nindices
)
1736 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
1737 while (k
> 0 && p_array_type
!= NULL
)
1739 p_array_type
= check_typedef (TYPE_TARGET_TYPE (p_array_type
));
1742 return p_array_type
;
1744 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
1746 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
1748 type
= TYPE_TARGET_TYPE (type
);
1757 /* The type of nth index in arrays of given type (n numbering from 1). Does
1758 not examine memory. */
1761 ada_index_type (struct type
*type
, int n
)
1763 type
= desc_base_type (type
);
1765 if (n
> ada_array_arity (type
))
1768 if (ada_is_simple_array (type
))
1772 for (i
= 1; i
< n
; i
+= 1)
1773 type
= TYPE_TARGET_TYPE (type
);
1775 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
1778 return desc_index_type (desc_bounds_type (type
), n
);
1781 /* Given that arr is an array type, returns the lower bound of the
1782 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
1783 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1784 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
1785 bounds type. It works for other arrays with bounds supplied by
1786 run-time quantities other than discriminants. */
1789 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
1790 struct type
** typep
)
1793 struct type
*index_type_desc
;
1795 if (ada_is_packed_array_type (arr_type
))
1796 arr_type
= decode_packed_array_type (arr_type
);
1798 if (arr_type
== NULL
|| !ada_is_simple_array (arr_type
))
1801 *typep
= builtin_type_int
;
1802 return (LONGEST
) - which
;
1805 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
1806 type
= TYPE_TARGET_TYPE (arr_type
);
1810 index_type_desc
= ada_find_parallel_type (type
, "___XA");
1811 if (index_type_desc
== NULL
)
1813 struct type
*range_type
;
1814 struct type
*index_type
;
1818 type
= TYPE_TARGET_TYPE (type
);
1822 range_type
= TYPE_INDEX_TYPE (type
);
1823 index_type
= TYPE_TARGET_TYPE (range_type
);
1824 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
1825 index_type
= builtin_type_long
;
1827 *typep
= index_type
;
1829 (LONGEST
) (which
== 0
1830 ? TYPE_LOW_BOUND (range_type
)
1831 : TYPE_HIGH_BOUND (range_type
));
1835 struct type
*index_type
=
1836 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
1837 NULL
, TYPE_OBJFILE (arr_type
));
1839 *typep
= TYPE_TARGET_TYPE (index_type
);
1841 (LONGEST
) (which
== 0
1842 ? TYPE_LOW_BOUND (index_type
)
1843 : TYPE_HIGH_BOUND (index_type
));
1847 /* Given that arr is an array value, returns the lower bound of the
1848 nth index (numbering from 1) if which is 0, and the upper bound if
1849 which is 1. This routine will also work for arrays with bounds
1850 supplied by run-time quantities other than discriminants. */
1853 ada_array_bound (struct value
*arr
, int n
, int which
)
1855 struct type
*arr_type
= VALUE_TYPE (arr
);
1857 if (ada_is_packed_array_type (arr_type
))
1858 return ada_array_bound (decode_packed_array (arr
), n
, which
);
1859 else if (ada_is_simple_array (arr_type
))
1862 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
1863 return value_from_longest (type
, v
);
1866 return desc_one_bound (desc_bounds (arr
), n
, which
);
1869 /* Given that arr is an array value, returns the length of the
1870 nth index. This routine will also work for arrays with bounds
1871 supplied by run-time quantities other than discriminants. Does not
1872 work for arrays indexed by enumeration types with representation
1873 clauses at the moment. */
1876 ada_array_length (struct value
*arr
, int n
)
1878 struct type
*arr_type
= check_typedef (VALUE_TYPE (arr
));
1879 struct type
*index_type_desc
;
1881 if (ada_is_packed_array_type (arr_type
))
1882 return ada_array_length (decode_packed_array (arr
), n
);
1884 if (ada_is_simple_array (arr_type
))
1888 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
1889 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
1890 return value_from_longest (type
, v
);
1894 value_from_longest (builtin_type_ada_int
,
1895 value_as_long (desc_one_bound (desc_bounds (arr
),
1897 - value_as_long (desc_one_bound (desc_bounds (arr
),
1902 /* Name resolution */
1904 /* The "demangled" name for the user-definable Ada operator corresponding
1908 ada_op_name (enum exp_opcode op
)
1912 for (i
= 0; ada_opname_table
[i
].mangled
!= NULL
; i
+= 1)
1914 if (ada_opname_table
[i
].op
== op
)
1915 return ada_opname_table
[i
].demangled
;
1917 error ("Could not find operator name for opcode");
1921 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
1922 references (OP_UNRESOLVED_VALUES) and converts operators that are
1923 user-defined into appropriate function calls. If CONTEXT_TYPE is
1924 non-null, it provides a preferred result type [at the moment, only
1925 type void has any effect---causing procedures to be preferred over
1926 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
1927 return type is preferred. The variable unresolved_names contains a list
1928 of character strings referenced by expout that should be freed.
1929 May change (expand) *EXP. */
1932 ada_resolve (struct expression
**expp
, struct type
*context_type
)
1936 ada_resolve_subexp (expp
, &pc
, 1, context_type
);
1939 /* Resolve the operator of the subexpression beginning at
1940 position *POS of *EXPP. "Resolving" consists of replacing
1941 OP_UNRESOLVED_VALUE with an appropriate OP_VAR_VALUE, replacing
1942 built-in operators with function calls to user-defined operators,
1943 where appropriate, and (when DEPROCEDURE_P is non-zero), converting
1944 function-valued variables into parameterless calls. May expand
1945 EXP. The CONTEXT_TYPE functions as in ada_resolve, above. */
1947 static struct value
*
1948 ada_resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
1949 struct type
*context_type
)
1953 struct expression
*exp
; /* Convenience: == *expp */
1954 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
1955 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
1956 int nargs
; /* Number of operands */
1962 /* Pass one: resolve operands, saving their types and updating *pos. */
1966 /* case OP_UNRESOLVED_VALUE: */
1967 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
1972 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
1973 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
1974 /* if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
1978 argvec = (struct value* *) alloca (sizeof (struct value*) * (nargs + 1));
1979 for (i = 0; i < nargs-1; i += 1)
1980 argvec[i] = ada_resolve_subexp (expp, pos, 1, NULL);
1986 ada_resolve_subexp (expp, pos, 0, NULL);
1987 for (i = 1; i < nargs; i += 1)
1988 ada_resolve_subexp (expp, pos, 1, NULL);
1994 /* FIXME: UNOP_QUAL should be defined in expression.h */
1998 ada_resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
2002 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
2003 /* case OP_ATTRIBUTE:
2004 nargs = longest_to_int (exp->elts[pc + 1].longconst) + 1;
2006 for (i = 0; i < nargs; i += 1)
2007 ada_resolve_subexp (expp, pos, 1, NULL);
2014 ada_resolve_subexp (expp
, pos
, 0, NULL
);
2023 arg1
= ada_resolve_subexp (expp
, pos
, 0, NULL
);
2025 ada_resolve_subexp (expp
, pos
, 1, NULL
);
2027 ada_resolve_subexp (expp
, pos
, 1, VALUE_TYPE (arg1
));
2035 error ("Unexpected operator during name resolution");
2050 case BINOP_LOGICAL_AND
:
2051 case BINOP_LOGICAL_OR
:
2052 case BINOP_BITWISE_AND
:
2053 case BINOP_BITWISE_IOR
:
2054 case BINOP_BITWISE_XOR
:
2057 case BINOP_NOTEQUAL
:
2064 case BINOP_SUBSCRIPT
:
2072 case UNOP_LOGICAL_NOT
:
2089 case OP_INTERNALVAR
:
2098 case STRUCTOP_STRUCT
:
2101 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2106 nargs
= longest_to_int (exp
->elts
[pc
+ 2].longconst
) + 1;
2107 nargs
-= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2108 /* A null array contains one dummy element to give the type. */
2114 /* FIXME: TERNOP_MBR should be defined in expression.h */
2120 /* FIXME: BINOP_MBR should be defined in expression.h */
2128 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2129 for (i
= 0; i
< nargs
; i
+= 1)
2130 argvec
[i
] = ada_resolve_subexp (expp
, pos
, 1, NULL
);
2136 /* Pass two: perform any resolution on principal operator. */
2142 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2143 /* case OP_UNRESOLVED_VALUE:
2145 struct symbol** candidate_syms;
2146 struct block** candidate_blocks;
2149 n_candidates = ada_lookup_symbol_list (exp->elts[pc + 2].name,
2150 exp->elts[pc + 1].block,
2155 if (n_candidates > 1)
2157 /* Types tend to get re-introduced locally, so if there
2158 are any local symbols that are not types, first filter
2161 for (j = 0; j < n_candidates; j += 1)
2162 switch (SYMBOL_CLASS (candidate_syms[j]))
2168 case LOC_REGPARM_ADDR:
2172 case LOC_BASEREG_ARG:
2178 if (j < n_candidates)
2181 while (j < n_candidates)
2183 if (SYMBOL_CLASS (candidate_syms[j]) == LOC_TYPEDEF)
2185 candidate_syms[j] = candidate_syms[n_candidates-1];
2186 candidate_blocks[j] = candidate_blocks[n_candidates-1];
2195 if (n_candidates == 0)
2196 error ("No definition found for %s",
2197 ada_demangle (exp->elts[pc + 2].name));
2198 else if (n_candidates == 1)
2200 else if (deprocedure_p
2201 && ! is_nonfunction (candidate_syms, n_candidates))
2203 i = ada_resolve_function (candidate_syms, candidate_blocks,
2204 n_candidates, NULL, 0,
2205 exp->elts[pc + 2].name, context_type);
2207 error ("Could not find a match for %s",
2208 ada_demangle (exp->elts[pc + 2].name));
2212 printf_filtered ("Multiple matches for %s\n",
2213 ada_demangle (exp->elts[pc+2].name));
2214 user_select_syms (candidate_syms, candidate_blocks,
2219 exp->elts[pc].opcode = exp->elts[pc + 3].opcode = OP_VAR_VALUE;
2220 exp->elts[pc + 1].block = candidate_blocks[i];
2221 exp->elts[pc + 2].symbol = candidate_syms[i];
2222 if (innermost_block == NULL ||
2223 contained_in (candidate_blocks[i], innermost_block))
2224 innermost_block = candidate_blocks[i];
2229 if (deprocedure_p
&&
2230 TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
)) ==
2233 replace_operator_with_call (expp
, pc
, 0, 0,
2234 exp
->elts
[pc
+ 2].symbol
,
2235 exp
->elts
[pc
+ 1].block
);
2242 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2243 /* if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
2245 struct symbol** candidate_syms;
2246 struct block** candidate_blocks;
2249 n_candidates = ada_lookup_symbol_list (exp->elts[pc + 5].name,
2250 exp->elts[pc + 4].block,
2254 if (n_candidates == 1)
2258 i = ada_resolve_function (candidate_syms, candidate_blocks,
2259 n_candidates, argvec, nargs-1,
2260 exp->elts[pc + 5].name, context_type);
2262 error ("Could not find a match for %s",
2263 ada_demangle (exp->elts[pc + 5].name));
2266 exp->elts[pc + 3].opcode = exp->elts[pc + 6].opcode = OP_VAR_VALUE;
2267 exp->elts[pc + 4].block = candidate_blocks[i];
2268 exp->elts[pc + 5].symbol = candidate_syms[i];
2269 if (innermost_block == NULL ||
2270 contained_in (candidate_blocks[i], innermost_block))
2271 innermost_block = candidate_blocks[i];
2283 case BINOP_BITWISE_AND
:
2284 case BINOP_BITWISE_IOR
:
2285 case BINOP_BITWISE_XOR
:
2287 case BINOP_NOTEQUAL
:
2295 case UNOP_LOGICAL_NOT
:
2297 if (possible_user_operator_p (op
, argvec
))
2299 struct symbol
**candidate_syms
;
2300 struct block
**candidate_blocks
;
2304 ada_lookup_symbol_list (ada_mangle (ada_op_name (op
)),
2305 (struct block
*) NULL
, VAR_NAMESPACE
,
2306 &candidate_syms
, &candidate_blocks
);
2308 ada_resolve_function (candidate_syms
, candidate_blocks
,
2309 n_candidates
, argvec
, nargs
,
2310 ada_op_name (op
), NULL
);
2314 replace_operator_with_call (expp
, pc
, nargs
, 1,
2315 candidate_syms
[i
], candidate_blocks
[i
]);
2322 return evaluate_subexp_type (exp
, pos
);
2325 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2326 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2328 /* The term "match" here is rather loose. The match is heuristic and
2329 liberal. FIXME: TOO liberal, in fact. */
2332 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
2334 CHECK_TYPEDEF (ftype
);
2335 CHECK_TYPEDEF (atype
);
2337 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2338 ftype
= TYPE_TARGET_TYPE (ftype
);
2339 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2340 atype
= TYPE_TARGET_TYPE (atype
);
2342 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2343 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2346 switch (TYPE_CODE (ftype
))
2351 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2352 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2353 TYPE_TARGET_TYPE (atype
), 0);
2355 return (may_deref
&&
2356 ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2358 case TYPE_CODE_ENUM
:
2359 case TYPE_CODE_RANGE
:
2360 switch (TYPE_CODE (atype
))
2363 case TYPE_CODE_ENUM
:
2364 case TYPE_CODE_RANGE
:
2370 case TYPE_CODE_ARRAY
:
2371 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2372 || ada_is_array_descriptor (atype
));
2374 case TYPE_CODE_STRUCT
:
2375 if (ada_is_array_descriptor (ftype
))
2376 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2377 || ada_is_array_descriptor (atype
));
2379 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2380 && !ada_is_array_descriptor (atype
));
2382 case TYPE_CODE_UNION
:
2384 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2388 /* Return non-zero if the formals of FUNC "sufficiently match" the
2389 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2390 may also be an enumeral, in which case it is treated as a 0-
2391 argument function. */
2394 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
2397 struct type
*func_type
= SYMBOL_TYPE (func
);
2399 if (SYMBOL_CLASS (func
) == LOC_CONST
&&
2400 TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2401 return (n_actuals
== 0);
2402 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2405 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2408 for (i
= 0; i
< n_actuals
; i
+= 1)
2410 struct type
*ftype
= check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2411 struct type
*atype
= check_typedef (VALUE_TYPE (actuals
[i
]));
2413 if (!ada_type_match (TYPE_FIELD_TYPE (func_type
, i
),
2414 VALUE_TYPE (actuals
[i
]), 1))
2420 /* False iff function type FUNC_TYPE definitely does not produce a value
2421 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2422 FUNC_TYPE is not a valid function type with a non-null return type
2423 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2426 return_match (struct type
*func_type
, struct type
*context_type
)
2428 struct type
*return_type
;
2430 if (func_type
== NULL
)
2433 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2434 /* if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
2435 return_type = base_type (TYPE_TARGET_TYPE (func_type));
2437 return_type = base_type (func_type); */
2438 if (return_type
== NULL
)
2441 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2442 /* context_type = base_type (context_type); */
2444 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2445 return context_type
== NULL
|| return_type
== context_type
;
2446 else if (context_type
== NULL
)
2447 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2449 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
2453 /* Return the index in SYMS[0..NSYMS-1] of symbol for the
2454 function (if any) that matches the types of the NARGS arguments in
2455 ARGS. If CONTEXT_TYPE is non-null, and there is at least one match
2456 that returns type CONTEXT_TYPE, then eliminate other matches. If
2457 CONTEXT_TYPE is null, prefer a non-void-returning function.
2458 Asks the user if there is more than one match remaining. Returns -1
2459 if there is no such symbol or none is selected. NAME is used
2460 solely for messages. May re-arrange and modify SYMS in
2461 the process; the index returned is for the modified vector. BLOCKS
2462 is modified in parallel to SYMS. */
2465 ada_resolve_function (struct symbol
*syms
[], struct block
*blocks
[],
2466 int nsyms
, struct value
**args
, int nargs
,
2467 const char *name
, struct type
*context_type
)
2470 int m
; /* Number of hits */
2471 struct type
*fallback
;
2472 struct type
*return_type
;
2474 return_type
= context_type
;
2475 if (context_type
== NULL
)
2476 fallback
= builtin_type_void
;
2483 for (k
= 0; k
< nsyms
; k
+= 1)
2485 struct type
*type
= check_typedef (SYMBOL_TYPE (syms
[k
]));
2487 if (ada_args_match (syms
[k
], args
, nargs
)
2488 && return_match (SYMBOL_TYPE (syms
[k
]), return_type
))
2492 blocks
[m
] = blocks
[k
];
2496 if (m
> 0 || return_type
== fallback
)
2499 return_type
= fallback
;
2506 printf_filtered ("Multiple matches for %s\n", name
);
2507 user_select_syms (syms
, blocks
, m
, 1);
2513 /* Returns true (non-zero) iff demangled name N0 should appear before N1 */
2514 /* in a listing of choices during disambiguation (see sort_choices, below). */
2515 /* The idea is that overloadings of a subprogram name from the */
2516 /* same package should sort in their source order. We settle for ordering */
2517 /* such symbols by their trailing number (__N or $N). */
2519 mangled_ordered_before (char *N0
, char *N1
)
2523 else if (N0
== NULL
)
2528 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
2530 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
2532 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
2533 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
2537 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
2540 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
2542 if (n0
== n1
&& STREQN (N0
, N1
, n0
))
2543 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
2545 return (strcmp (N0
, N1
) < 0);
2549 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by their */
2550 /* mangled names, rearranging BLOCKS[0..NSYMS-1] according to the same */
2553 sort_choices (struct symbol
*syms
[], struct block
*blocks
[], int nsyms
)
2556 for (i
= 1; i
< nsyms
; i
+= 1)
2558 struct symbol
*sym
= syms
[i
];
2559 struct block
*block
= blocks
[i
];
2562 for (j
= i
- 1; j
>= 0; j
-= 1)
2564 if (mangled_ordered_before (SYMBOL_NAME (syms
[j
]),
2567 syms
[j
+ 1] = syms
[j
];
2568 blocks
[j
+ 1] = blocks
[j
];
2571 blocks
[j
+ 1] = block
;
2575 /* Given a list of NSYMS symbols in SYMS and corresponding blocks in */
2576 /* BLOCKS, select up to MAX_RESULTS>0 by asking the user (if */
2577 /* necessary), returning the number selected, and setting the first */
2578 /* elements of SYMS and BLOCKS to the selected symbols and */
2579 /* corresponding blocks. Error if no symbols selected. BLOCKS may */
2580 /* be NULL, in which case it is ignored. */
2582 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
2583 to be re-integrated one of these days. */
2586 user_select_syms (struct symbol
*syms
[], struct block
*blocks
[], int nsyms
,
2590 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
2592 int first_choice
= (max_results
== 1) ? 1 : 2;
2594 if (max_results
< 1)
2595 error ("Request to select 0 symbols!");
2599 printf_unfiltered ("[0] cancel\n");
2600 if (max_results
> 1)
2601 printf_unfiltered ("[1] all\n");
2603 sort_choices (syms
, blocks
, nsyms
);
2605 for (i
= 0; i
< nsyms
; i
+= 1)
2607 if (syms
[i
] == NULL
)
2610 if (SYMBOL_CLASS (syms
[i
]) == LOC_BLOCK
)
2612 struct symtab_and_line sal
= find_function_start_sal (syms
[i
], 1);
2613 printf_unfiltered ("[%d] %s at %s:%d\n",
2615 SYMBOL_SOURCE_NAME (syms
[i
]),
2617 ? "<no source file available>"
2618 : sal
.symtab
->filename
, sal
.line
);
2624 (SYMBOL_CLASS (syms
[i
]) == LOC_CONST
2625 && SYMBOL_TYPE (syms
[i
]) != NULL
2626 && TYPE_CODE (SYMBOL_TYPE (syms
[i
])) == TYPE_CODE_ENUM
);
2627 struct symtab
*symtab
= symtab_for_sym (syms
[i
]);
2629 if (SYMBOL_LINE (syms
[i
]) != 0 && symtab
!= NULL
)
2630 printf_unfiltered ("[%d] %s at %s:%d\n",
2632 SYMBOL_SOURCE_NAME (syms
[i
]),
2633 symtab
->filename
, SYMBOL_LINE (syms
[i
]));
2634 else if (is_enumeral
&& TYPE_NAME (SYMBOL_TYPE (syms
[i
])) != NULL
)
2636 printf_unfiltered ("[%d] ", i
+ first_choice
);
2637 ada_print_type (SYMBOL_TYPE (syms
[i
]), NULL
, gdb_stdout
, -1, 0);
2638 printf_unfiltered ("'(%s) (enumeral)\n",
2639 SYMBOL_SOURCE_NAME (syms
[i
]));
2641 else if (symtab
!= NULL
)
2642 printf_unfiltered (is_enumeral
2643 ? "[%d] %s in %s (enumeral)\n"
2644 : "[%d] %s at %s:?\n",
2646 SYMBOL_SOURCE_NAME (syms
[i
]),
2649 printf_unfiltered (is_enumeral
2650 ? "[%d] %s (enumeral)\n"
2653 SYMBOL_SOURCE_NAME (syms
[i
]));
2657 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
2660 for (i
= 0; i
< n_chosen
; i
+= 1)
2662 syms
[i
] = syms
[chosen
[i
]];
2664 blocks
[i
] = blocks
[chosen
[i
]];
2670 /* Read and validate a set of numeric choices from the user in the
2671 range 0 .. N_CHOICES-1. Place the results in increasing
2672 order in CHOICES[0 .. N-1], and return N.
2674 The user types choices as a sequence of numbers on one line
2675 separated by blanks, encoding them as follows:
2677 + A choice of 0 means to cancel the selection, throwing an error.
2678 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
2679 + The user chooses k by typing k+IS_ALL_CHOICE+1.
2681 The user is not allowed to choose more than MAX_RESULTS values.
2683 ANNOTATION_SUFFIX, if present, is used to annotate the input
2684 prompts (for use with the -f switch). */
2687 get_selections (int *choices
, int n_choices
, int max_results
,
2688 int is_all_choice
, char *annotation_suffix
)
2694 int first_choice
= is_all_choice
? 2 : 1;
2696 prompt
= getenv ("PS2");
2700 printf_unfiltered ("%s ", prompt
);
2701 gdb_flush (gdb_stdout
);
2703 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
2706 error_no_arg ("one or more choice numbers");
2710 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
2711 order, as given in args. Choices are validated. */
2717 while (isspace (*args
))
2719 if (*args
== '\0' && n_chosen
== 0)
2720 error_no_arg ("one or more choice numbers");
2721 else if (*args
== '\0')
2724 choice
= strtol (args
, &args2
, 10);
2725 if (args
== args2
|| choice
< 0
2726 || choice
> n_choices
+ first_choice
- 1)
2727 error ("Argument must be choice number");
2731 error ("cancelled");
2733 if (choice
< first_choice
)
2735 n_chosen
= n_choices
;
2736 for (j
= 0; j
< n_choices
; j
+= 1)
2740 choice
-= first_choice
;
2742 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
2746 if (j
< 0 || choice
!= choices
[j
])
2749 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
2750 choices
[k
+ 1] = choices
[k
];
2751 choices
[j
+ 1] = choice
;
2756 if (n_chosen
> max_results
)
2757 error ("Select no more than %d of the above", max_results
);
2762 /* Replace the operator of length OPLEN at position PC in *EXPP with a call */
2763 /* on the function identified by SYM and BLOCK, and taking NARGS */
2764 /* arguments. Update *EXPP as needed to hold more space. */
2767 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
2768 int oplen
, struct symbol
*sym
,
2769 struct block
*block
)
2771 /* A new expression, with 6 more elements (3 for funcall, 4 for function
2772 symbol, -oplen for operator being replaced). */
2773 struct expression
*newexp
= (struct expression
*)
2774 xmalloc (sizeof (struct expression
)
2775 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
2776 struct expression
*exp
= *expp
;
2778 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
2779 newexp
->language_defn
= exp
->language_defn
;
2780 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
2781 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
2782 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
2784 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
2785 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
2787 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
2788 newexp
->elts
[pc
+ 4].block
= block
;
2789 newexp
->elts
[pc
+ 5].symbol
= sym
;
2795 /* Type-class predicates */
2797 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type), or */
2801 numeric_type_p (struct type
*type
)
2807 switch (TYPE_CODE (type
))
2812 case TYPE_CODE_RANGE
:
2813 return (type
== TYPE_TARGET_TYPE (type
)
2814 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
2821 /* True iff TYPE is integral (an INT or RANGE of INTs). */
2824 integer_type_p (struct type
*type
)
2830 switch (TYPE_CODE (type
))
2834 case TYPE_CODE_RANGE
:
2835 return (type
== TYPE_TARGET_TYPE (type
)
2836 || integer_type_p (TYPE_TARGET_TYPE (type
)));
2843 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
2846 scalar_type_p (struct type
*type
)
2852 switch (TYPE_CODE (type
))
2855 case TYPE_CODE_RANGE
:
2856 case TYPE_CODE_ENUM
:
2865 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
2868 discrete_type_p (struct type
*type
)
2874 switch (TYPE_CODE (type
))
2877 case TYPE_CODE_RANGE
:
2878 case TYPE_CODE_ENUM
:
2886 /* Returns non-zero if OP with operatands in the vector ARGS could be
2887 a user-defined function. Errs on the side of pre-defined operators
2888 (i.e., result 0). */
2891 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
2893 struct type
*type0
= check_typedef (VALUE_TYPE (args
[0]));
2894 struct type
*type1
=
2895 (args
[1] == NULL
) ? NULL
: check_typedef (VALUE_TYPE (args
[1]));
2906 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
2910 case BINOP_BITWISE_AND
:
2911 case BINOP_BITWISE_IOR
:
2912 case BINOP_BITWISE_XOR
:
2913 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
2916 case BINOP_NOTEQUAL
:
2921 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
2924 return ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
&&
2925 (TYPE_CODE (type0
) != TYPE_CODE_PTR
||
2926 TYPE_CODE (TYPE_TARGET_TYPE (type0
))
2927 != TYPE_CODE_ARRAY
))
2928 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
&&
2929 (TYPE_CODE (type1
) != TYPE_CODE_PTR
||
2930 TYPE_CODE (TYPE_TARGET_TYPE (type1
)) != TYPE_CODE_ARRAY
)));
2933 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
2937 case UNOP_LOGICAL_NOT
:
2939 return (!numeric_type_p (type0
));
2946 /** NOTE: In the following, we assume that a renaming type's name may
2947 * have an ___XD suffix. It would be nice if this went away at some
2950 /* If TYPE encodes a renaming, returns the renaming suffix, which
2951 * is XR for an object renaming, XRP for a procedure renaming, XRE for
2952 * an exception renaming, and XRS for a subprogram renaming. Returns
2953 * NULL if NAME encodes none of these. */
2955 ada_renaming_type (struct type
*type
)
2957 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
2959 const char *name
= type_name_no_tag (type
);
2960 const char *suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
2962 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
2971 /* Return non-zero iff SYM encodes an object renaming. */
2973 ada_is_object_renaming (struct symbol
*sym
)
2975 const char *renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
2976 return renaming_type
!= NULL
2977 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
2980 /* Assuming that SYM encodes a non-object renaming, returns the original
2981 * name of the renamed entity. The name is good until the end of
2984 ada_simple_renamed_entity (struct symbol
*sym
)
2987 const char *raw_name
;
2991 type
= SYMBOL_TYPE (sym
);
2992 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
2993 error ("Improperly encoded renaming.");
2995 raw_name
= TYPE_FIELD_NAME (type
, 0);
2996 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
2998 error ("Improperly encoded renaming.");
3000 result
= xmalloc (len
+ 1);
3001 /* FIXME: add_name_string_cleanup should be defined in parse.c */
3002 /* add_name_string_cleanup (result); */
3003 strncpy (result
, raw_name
, len
);
3004 result
[len
] = '\000';
3009 /* Evaluation: Function Calls */
3011 /* Copy VAL onto the stack, using and updating *SP as the stack
3012 pointer. Return VAL as an lvalue. */
3014 static struct value
*
3015 place_on_stack (struct value
*val
, CORE_ADDR
*sp
)
3017 CORE_ADDR old_sp
= *sp
;
3020 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3021 STACK_ALIGN (TYPE_LENGTH
3022 (check_typedef (VALUE_TYPE (val
)))));
3024 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3025 TYPE_LENGTH (check_typedef (VALUE_TYPE (val
))));
3028 VALUE_LVAL (val
) = lval_memory
;
3029 if (INNER_THAN (1, 2))
3030 VALUE_ADDRESS (val
) = *sp
;
3032 VALUE_ADDRESS (val
) = old_sp
;
3037 /* Return the value ACTUAL, converted to be an appropriate value for a
3038 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3039 allocating any necessary descriptors (fat pointers), or copies of
3040 values not residing in memory, updating it as needed. */
3042 static struct value
*
3043 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3046 struct type
*actual_type
= check_typedef (VALUE_TYPE (actual
));
3047 struct type
*formal_type
= check_typedef (formal_type0
);
3048 struct type
*formal_target
=
3049 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3050 ? check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3051 struct type
*actual_target
=
3052 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3053 ? check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3055 if (ada_is_array_descriptor (formal_target
)
3056 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3057 return make_array_descriptor (formal_type
, actual
, sp
);
3058 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3060 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3061 && ada_is_array_descriptor (actual_target
))
3062 return desc_data (actual
);
3063 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3065 if (VALUE_LVAL (actual
) != lval_memory
)
3068 actual_type
= check_typedef (VALUE_TYPE (actual
));
3069 val
= allocate_value (actual_type
);
3070 memcpy ((char *) VALUE_CONTENTS_RAW (val
),
3071 (char *) VALUE_CONTENTS (actual
),
3072 TYPE_LENGTH (actual_type
));
3073 actual
= place_on_stack (val
, sp
);
3075 return value_addr (actual
);
3078 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3079 return ada_value_ind (actual
);
3085 /* Push a descriptor of type TYPE for array value ARR on the stack at
3086 *SP, updating *SP to reflect the new descriptor. Return either
3087 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3088 to-descriptor type rather than a descriptor type), a struct value*
3089 representing a pointer to this descriptor. */
3091 static struct value
*
3092 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3094 struct type
*bounds_type
= desc_bounds_type (type
);
3095 struct type
*desc_type
= desc_base_type (type
);
3096 struct value
*descriptor
= allocate_value (desc_type
);
3097 struct value
*bounds
= allocate_value (bounds_type
);
3098 CORE_ADDR bounds_addr
;
3101 for (i
= ada_array_arity (check_typedef (VALUE_TYPE (arr
))); i
> 0; i
-= 1)
3103 modify_general_field (VALUE_CONTENTS (bounds
),
3104 value_as_long (ada_array_bound (arr
, i
, 0)),
3105 desc_bound_bitpos (bounds_type
, i
, 0),
3106 desc_bound_bitsize (bounds_type
, i
, 0));
3107 modify_general_field (VALUE_CONTENTS (bounds
),
3108 value_as_long (ada_array_bound (arr
, i
, 1)),
3109 desc_bound_bitpos (bounds_type
, i
, 1),
3110 desc_bound_bitsize (bounds_type
, i
, 1));
3113 bounds
= place_on_stack (bounds
, sp
);
3115 modify_general_field (VALUE_CONTENTS (descriptor
),
3117 fat_pntr_data_bitpos (desc_type
),
3118 fat_pntr_data_bitsize (desc_type
));
3119 modify_general_field (VALUE_CONTENTS (descriptor
),
3120 VALUE_ADDRESS (bounds
),
3121 fat_pntr_bounds_bitpos (desc_type
),
3122 fat_pntr_bounds_bitsize (desc_type
));
3124 descriptor
= place_on_stack (descriptor
, sp
);
3126 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3127 return value_addr (descriptor
);
3133 /* Assuming a dummy frame has been established on the target, perform any
3134 conversions needed for calling function FUNC on the NARGS actual
3135 parameters in ARGS, other than standard C conversions. Does
3136 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3137 does not match the number of arguments expected. Use *SP as a
3138 stack pointer for additional data that must be pushed, updating its
3142 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3147 if (TYPE_NFIELDS (VALUE_TYPE (func
)) == 0
3148 || nargs
!= TYPE_NFIELDS (VALUE_TYPE (func
)))
3151 for (i
= 0; i
< nargs
; i
+= 1)
3153 convert_actual (args
[i
], TYPE_FIELD_TYPE (VALUE_TYPE (func
), i
), sp
);
3160 /* The vectors of symbols and blocks ultimately returned from */
3161 /* ada_lookup_symbol_list. */
3163 /* Current size of defn_symbols and defn_blocks */
3164 static size_t defn_vector_size
= 0;
3166 /* Current number of symbols found. */
3167 static int ndefns
= 0;
3169 static struct symbol
**defn_symbols
= NULL
;
3170 static struct block
**defn_blocks
= NULL
;
3172 /* Return the result of a standard (literal, C-like) lookup of NAME in
3173 * given NAMESPACE. */
3175 static struct symbol
*
3176 standard_lookup (const char *name
, namespace_enum
namespace)
3179 struct symtab
*symtab
;
3180 sym
= lookup_symbol (name
, (struct block
*) NULL
, namespace, 0, &symtab
);
3185 /* Non-zero iff there is at least one non-function/non-enumeral symbol */
3186 /* in SYMS[0..N-1]. We treat enumerals as functions, since they */
3187 /* contend in overloading in the same way. */
3189 is_nonfunction (struct symbol
*syms
[], int n
)
3193 for (i
= 0; i
< n
; i
+= 1)
3194 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
])) != TYPE_CODE_FUNC
3195 && TYPE_CODE (SYMBOL_TYPE (syms
[i
])) != TYPE_CODE_ENUM
)
3201 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3202 struct types. Otherwise, they may not. */
3205 equiv_types (struct type
*type0
, struct type
*type1
)
3209 if (type0
== NULL
|| type1
== NULL
3210 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3212 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3213 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3214 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3215 && STREQ (ada_type_name (type0
), ada_type_name (type1
)))
3221 /* True iff SYM0 represents the same entity as SYM1, or one that is
3222 no more defined than that of SYM1. */
3225 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3229 if (SYMBOL_NAMESPACE (sym0
) != SYMBOL_NAMESPACE (sym1
)
3230 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3233 switch (SYMBOL_CLASS (sym0
))
3239 struct type
*type0
= SYMBOL_TYPE (sym0
);
3240 struct type
*type1
= SYMBOL_TYPE (sym1
);
3241 char *name0
= SYMBOL_NAME (sym0
);
3242 char *name1
= SYMBOL_NAME (sym1
);
3243 int len0
= strlen (name0
);
3245 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3246 && (equiv_types (type0
, type1
)
3247 || (len0
< strlen (name1
) && STREQN (name0
, name1
, len0
)
3248 && STREQN (name1
+ len0
, "___XV", 5)));
3251 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3252 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3258 /* Append SYM to the end of defn_symbols, and BLOCK to the end of
3259 defn_blocks, updating ndefns, and expanding defn_symbols and
3260 defn_blocks as needed. Do not include SYM if it is a duplicate. */
3263 add_defn_to_vec (struct symbol
*sym
, struct block
*block
)
3268 if (SYMBOL_TYPE (sym
) != NULL
)
3269 CHECK_TYPEDEF (SYMBOL_TYPE (sym
));
3270 for (i
= 0; i
< ndefns
; i
+= 1)
3272 if (lesseq_defined_than (sym
, defn_symbols
[i
]))
3274 else if (lesseq_defined_than (defn_symbols
[i
], sym
))
3276 defn_symbols
[i
] = sym
;
3277 defn_blocks
[i
] = block
;
3282 tmp
= defn_vector_size
;
3283 GROW_VECT (defn_symbols
, tmp
, ndefns
+ 2);
3284 GROW_VECT (defn_blocks
, defn_vector_size
, ndefns
+ 2);
3286 defn_symbols
[ndefns
] = sym
;
3287 defn_blocks
[ndefns
] = block
;
3291 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3292 Check the global symbols if GLOBAL, the static symbols if not. Do
3293 wild-card match if WILD. */
3295 static struct partial_symbol
*
3296 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
3297 int global
, namespace_enum
namespace, int wild
)
3299 struct partial_symbol
**start
;
3300 int name_len
= strlen (name
);
3301 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
3310 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
3311 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
3315 for (i
= 0; i
< length
; i
+= 1)
3317 struct partial_symbol
*psym
= start
[i
];
3319 if (SYMBOL_NAMESPACE (psym
) == namespace &&
3320 wild_match (name
, name_len
, SYMBOL_NAME (psym
)))
3334 int M
= (U
+ i
) >> 1;
3335 struct partial_symbol
*psym
= start
[M
];
3336 if (SYMBOL_NAME (psym
)[0] < name
[0])
3338 else if (SYMBOL_NAME (psym
)[0] > name
[0])
3340 else if (strcmp (SYMBOL_NAME (psym
), name
) < 0)
3351 struct partial_symbol
*psym
= start
[i
];
3353 if (SYMBOL_NAMESPACE (psym
) == namespace)
3355 int cmp
= strncmp (name
, SYMBOL_NAME (psym
), name_len
);
3363 && is_name_suffix (SYMBOL_NAME (psym
) + name_len
))
3376 int M
= (U
+ i
) >> 1;
3377 struct partial_symbol
*psym
= start
[M
];
3378 if (SYMBOL_NAME (psym
)[0] < '_')
3380 else if (SYMBOL_NAME (psym
)[0] > '_')
3382 else if (strcmp (SYMBOL_NAME (psym
), "_ada_") < 0)
3393 struct partial_symbol
*psym
= start
[i
];
3395 if (SYMBOL_NAMESPACE (psym
) == namespace)
3399 cmp
= (int) '_' - (int) SYMBOL_NAME (psym
)[0];
3402 cmp
= strncmp ("_ada_", SYMBOL_NAME (psym
), 5);
3404 cmp
= strncmp (name
, SYMBOL_NAME (psym
) + 5, name_len
);
3413 && is_name_suffix (SYMBOL_NAME (psym
) + name_len
+ 5))
3424 /* Find a symbol table containing symbol SYM or NULL if none. */
3425 static struct symtab
*
3426 symtab_for_sym (struct symbol
*sym
)
3429 struct objfile
*objfile
;
3431 struct symbol
*tmp_sym
;
3434 ALL_SYMTABS (objfile
, s
)
3436 switch (SYMBOL_CLASS (sym
))
3444 case LOC_CONST_BYTES
:
3445 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
3446 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
) if (sym
== tmp_sym
)
3448 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
3449 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
) if (sym
== tmp_sym
)
3455 switch (SYMBOL_CLASS (sym
))
3461 case LOC_REGPARM_ADDR
:
3466 case LOC_BASEREG_ARG
:
3467 for (j
= FIRST_LOCAL_BLOCK
;
3468 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
3470 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
3471 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
) if (sym
== tmp_sym
)
3482 /* Return a minimal symbol matching NAME according to Ada demangling
3483 rules. Returns NULL if there is no such minimal symbol. */
3485 struct minimal_symbol
*
3486 ada_lookup_minimal_symbol (const char *name
)
3488 struct objfile
*objfile
;
3489 struct minimal_symbol
*msymbol
;
3490 int wild_match
= (strstr (name
, "__") == NULL
);
3492 ALL_MSYMBOLS (objfile
, msymbol
)
3494 if (ada_match_name (SYMBOL_NAME (msymbol
), name
, wild_match
)
3495 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
3502 /* For all subprograms that statically enclose the subprogram of the
3503 * selected frame, add symbols matching identifier NAME in NAMESPACE
3504 * and their blocks to vectors *defn_symbols and *defn_blocks, as for
3505 * ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
3506 * wildcard prefix. At the moment, this function uses a heuristic to
3507 * find the frames of enclosing subprograms: it treats the
3508 * pointer-sized value at location 0 from the local-variable base of a
3509 * frame as a static link, and then searches up the call stack for a
3510 * frame with that same local-variable base. */
3512 add_symbols_from_enclosing_procs (const char *name
, namespace_enum
namespace,
3516 static struct symbol static_link_sym
;
3517 static struct symbol
*static_link
;
3519 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
3520 struct frame_info
*frame
;
3521 struct frame_info
*target_frame
;
3523 if (static_link
== NULL
)
3525 /* Initialize the local variable symbol that stands for the
3526 * static link (when it exists). */
3527 static_link
= &static_link_sym
;
3528 SYMBOL_NAME (static_link
) = "";
3529 SYMBOL_LANGUAGE (static_link
) = language_unknown
;
3530 SYMBOL_CLASS (static_link
) = LOC_LOCAL
;
3531 SYMBOL_NAMESPACE (static_link
) = VAR_NAMESPACE
;
3532 SYMBOL_TYPE (static_link
) = lookup_pointer_type (builtin_type_void
);
3533 SYMBOL_VALUE (static_link
) =
3534 -(long) TYPE_LENGTH (SYMBOL_TYPE (static_link
));
3537 frame
= deprecated_selected_frame
;
3538 while (frame
!= NULL
&& ndefns
== 0)
3540 struct block
*block
;
3541 struct value
*target_link_val
= read_var_value (static_link
, frame
);
3542 CORE_ADDR target_link
;
3544 if (target_link_val
== NULL
)
3548 target_link
= target_link_val
;
3552 frame
= get_prev_frame (frame
);
3554 while (frame
!= NULL
&& FRAME_LOCALS_ADDRESS (frame
) != target_link
);
3559 block
= get_frame_block (frame
, 0);
3560 while (block
!= NULL
&& block_function (block
) != NULL
&& ndefns
== 0)
3562 ada_add_block_symbols (block
, name
, namespace, NULL
, wild_match
);
3564 block
= BLOCK_SUPERBLOCK (block
);
3568 do_cleanups (old_chain
);
3572 /* True if TYPE is definitely an artificial type supplied to a symbol
3573 * for which no debugging information was given in the symbol file. */
3575 is_nondebugging_type (struct type
*type
)
3577 char *name
= ada_type_name (type
);
3578 return (name
!= NULL
&& STREQ (name
, "<variable, no debug info>"));
3581 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
3582 * duplicate other symbols in the list. (The only case I know of where
3583 * this happens is when object files containing stabs-in-ecoff are
3584 * linked with files containing ordinary ecoff debugging symbols (or no
3585 * debugging symbols)). Modifies SYMS to squeeze out deleted symbols,
3586 * and applies the same modification to BLOCKS to maintain the
3587 * correspondence between SYMS[i] and BLOCKS[i]. Returns the number
3588 * of symbols in the modified list. */
3590 remove_extra_symbols (struct symbol
**syms
, struct block
**blocks
, int nsyms
)
3597 if (SYMBOL_NAME (syms
[i
]) != NULL
3598 && SYMBOL_CLASS (syms
[i
]) == LOC_STATIC
3599 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
])))
3601 for (j
= 0; j
< nsyms
; j
+= 1)
3604 && SYMBOL_NAME (syms
[j
]) != NULL
3605 && STREQ (SYMBOL_NAME (syms
[i
]), SYMBOL_NAME (syms
[j
]))
3606 && SYMBOL_CLASS (syms
[i
]) == SYMBOL_CLASS (syms
[j
])
3607 && SYMBOL_VALUE_ADDRESS (syms
[i
])
3608 == SYMBOL_VALUE_ADDRESS (syms
[j
]))
3611 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
3613 syms
[k
- 1] = syms
[k
];
3614 blocks
[k
- 1] = blocks
[k
];
3628 /* Find symbols in NAMESPACE matching NAME, in BLOCK0 and enclosing
3629 scope and in global scopes, returning the number of matches. Sets
3630 *SYMS to point to a vector of matching symbols, with *BLOCKS
3631 pointing to the vector of corresponding blocks in which those
3632 symbols reside. These two vectors are transient---good only to the
3633 next call of ada_lookup_symbol_list. Any non-function/non-enumeral symbol
3634 match within the nest of blocks whose innermost member is BLOCK0,
3635 is the outermost match returned (no other matches in that or
3636 enclosing blocks is returned). If there are any matches in or
3637 surrounding BLOCK0, then these alone are returned. */
3640 ada_lookup_symbol_list (const char *name
, struct block
*block0
,
3641 namespace_enum
namespace, struct symbol
***syms
,
3642 struct block
***blocks
)
3646 struct partial_symtab
*ps
;
3647 struct blockvector
*bv
;
3648 struct objfile
*objfile
;
3650 struct block
*block
;
3651 struct minimal_symbol
*msymbol
;
3652 int wild_match
= (strstr (name
, "__") == NULL
);
3662 /* Search specified block and its superiors. */
3665 while (block
!= NULL
)
3667 ada_add_block_symbols (block
, name
, namespace, NULL
, wild_match
);
3669 /* If we found a non-function match, assume that's the one. */
3670 if (is_nonfunction (defn_symbols
, ndefns
))
3673 block
= BLOCK_SUPERBLOCK (block
);
3676 /* If we found ANY matches in the specified BLOCK, we're done. */
3683 /* Now add symbols from all global blocks: symbol tables, minimal symbol
3684 tables, and psymtab's */
3686 ALL_SYMTABS (objfile
, s
)
3691 bv
= BLOCKVECTOR (s
);
3692 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3693 ada_add_block_symbols (block
, name
, namespace, objfile
, wild_match
);
3696 if (namespace == VAR_NAMESPACE
)
3698 ALL_MSYMBOLS (objfile
, msymbol
)
3700 if (ada_match_name (SYMBOL_NAME (msymbol
), name
, wild_match
))
3702 switch (MSYMBOL_TYPE (msymbol
))
3704 case mst_solib_trampoline
:
3707 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
3710 int old_ndefns
= ndefns
;
3712 bv
= BLOCKVECTOR (s
);
3713 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3714 ada_add_block_symbols (block
,
3715 SYMBOL_NAME (msymbol
),
3716 namespace, objfile
, wild_match
);
3717 if (ndefns
== old_ndefns
)
3719 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3720 ada_add_block_symbols (block
,
3721 SYMBOL_NAME (msymbol
),
3731 ALL_PSYMTABS (objfile
, ps
)
3735 && ada_lookup_partial_symbol (ps
, name
, 1, namespace, wild_match
))
3737 s
= PSYMTAB_TO_SYMTAB (ps
);
3740 bv
= BLOCKVECTOR (s
);
3741 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3742 ada_add_block_symbols (block
, name
, namespace, objfile
, wild_match
);
3746 /* Now add symbols from all per-file blocks if we've gotten no hits.
3747 (Not strictly correct, but perhaps better than an error).
3748 Do the symtabs first, then check the psymtabs */
3753 ALL_SYMTABS (objfile
, s
)
3758 bv
= BLOCKVECTOR (s
);
3759 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3760 ada_add_block_symbols (block
, name
, namespace, objfile
, wild_match
);
3763 ALL_PSYMTABS (objfile
, ps
)
3767 && ada_lookup_partial_symbol (ps
, name
, 0, namespace, wild_match
))
3769 s
= PSYMTAB_TO_SYMTAB (ps
);
3770 bv
= BLOCKVECTOR (s
);
3773 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3774 ada_add_block_symbols (block
, name
, namespace,
3775 objfile
, wild_match
);
3780 /* Finally, we try to find NAME as a local symbol in some lexically
3781 enclosing block. We do this last, expecting this case to be
3785 add_symbols_from_enclosing_procs (name
, namespace, wild_match
);
3791 ndefns
= remove_extra_symbols (defn_symbols
, defn_blocks
, ndefns
);
3794 *syms
= defn_symbols
;
3795 *blocks
= defn_blocks
;
3802 /* Return a symbol in NAMESPACE matching NAME, in BLOCK0 and enclosing
3803 * scope and in global scopes, or NULL if none. NAME is folded to
3804 * lower case first, unless it is surrounded in single quotes.
3805 * Otherwise, the result is as for ada_lookup_symbol_list, but is
3806 * disambiguated by user query if needed. */
3809 ada_lookup_symbol (const char *name
, struct block
*block0
,
3810 namespace_enum
namespace)
3812 struct symbol
**candidate_syms
;
3813 struct block
**candidate_blocks
;
3816 n_candidates
= ada_lookup_symbol_list (name
,
3818 &candidate_syms
, &candidate_blocks
);
3820 if (n_candidates
== 0)
3822 else if (n_candidates
!= 1)
3823 user_select_syms (candidate_syms
, candidate_blocks
, n_candidates
, 1);
3825 return candidate_syms
[0];
3829 /* True iff STR is a possible encoded suffix of a normal Ada name
3830 * that is to be ignored for matching purposes. Suffixes of parallel
3831 * names (e.g., XVE) are not included here. Currently, the possible suffixes
3832 * are given by the regular expression:
3833 * (X[nb]*)?(__[0-9]+|\$[0-9]+|___(LJM|X([FDBUP].*|R[^T]?)))?$
3837 is_name_suffix (const char *str
)
3843 while (str
[0] != '_' && str
[0] != '\0')
3845 if (str
[0] != 'n' && str
[0] != 'b')
3850 if (str
[0] == '\000')
3854 if (str
[1] != '_' || str
[2] == '\000')
3858 if (STREQ (str
+ 3, "LJM"))
3862 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B' ||
3863 str
[4] == 'U' || str
[4] == 'P')
3865 if (str
[4] == 'R' && str
[5] != 'T')
3869 for (k
= 2; str
[k
] != '\0'; k
+= 1)
3870 if (!isdigit (str
[k
]))
3874 if (str
[0] == '$' && str
[1] != '\000')
3876 for (k
= 1; str
[k
] != '\0'; k
+= 1)
3877 if (!isdigit (str
[k
]))
3884 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
3885 * PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
3886 * informational suffixes of NAME (i.e., for which is_name_suffix is
3889 wild_match (const char *patn
, int patn_len
, const char *name
)
3894 name_len
= strlen (name
);
3895 if (name_len
>= patn_len
+ 5 && STREQN (name
, "_ada_", 5)
3896 && STREQN (patn
, name
+ 5, patn_len
)
3897 && is_name_suffix (name
+ patn_len
+ 5))
3900 while (name_len
>= patn_len
)
3902 if (STREQN (patn
, name
, patn_len
) && is_name_suffix (name
+ patn_len
))
3910 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
3915 if (!islower (name
[2]))
3922 if (!islower (name
[1]))
3933 /* Add symbols from BLOCK matching identifier NAME in NAMESPACE to
3934 vector *defn_symbols, updating *defn_symbols (if necessary), *SZ (the size of
3935 the vector *defn_symbols), and *ndefns (the number of symbols
3936 currently stored in *defn_symbols). If WILD, treat as NAME with a
3937 wildcard prefix. OBJFILE is the section containing BLOCK. */
3940 ada_add_block_symbols (struct block
*block
, const char *name
,
3941 namespace_enum
namespace, struct objfile
*objfile
,
3945 int name_len
= strlen (name
);
3946 /* A matching argument symbol, if any. */
3947 struct symbol
*arg_sym
;
3948 /* Set true when we find a matching non-argument symbol */
3950 int is_sorted
= BLOCK_SHOULD_SORT (block
);
3958 ALL_BLOCK_SYMBOLS (block
, i
, sym
)
3960 if (SYMBOL_NAMESPACE (sym
) == namespace &&
3961 wild_match (name
, name_len
, SYMBOL_NAME (sym
)))
3963 switch (SYMBOL_CLASS (sym
))
3969 case LOC_REGPARM_ADDR
:
3970 case LOC_BASEREG_ARG
:
3973 case LOC_UNRESOLVED
:
3977 fill_in_ada_prototype (sym
);
3978 add_defn_to_vec (fixup_symbol_section (sym
, objfile
), block
);
3990 U
= BLOCK_NSYMS (block
) - 1;
3993 int M
= (U
+ i
) >> 1;
3994 struct symbol
*sym
= BLOCK_SYM (block
, M
);
3995 if (SYMBOL_NAME (sym
)[0] < name
[0])
3997 else if (SYMBOL_NAME (sym
)[0] > name
[0])
3999 else if (strcmp (SYMBOL_NAME (sym
), name
) < 0)
4008 for (; i
< BLOCK_BUCKETS (block
); i
+= 1)
4009 for (sym
= BLOCK_BUCKET (block
, i
); sym
!= NULL
; sym
= sym
->hash_next
)
4011 if (SYMBOL_NAMESPACE (sym
) == namespace)
4013 int cmp
= strncmp (name
, SYMBOL_NAME (sym
), name_len
);
4019 i
= BLOCK_BUCKETS (block
);
4024 && is_name_suffix (SYMBOL_NAME (sym
) + name_len
))
4026 switch (SYMBOL_CLASS (sym
))
4032 case LOC_REGPARM_ADDR
:
4033 case LOC_BASEREG_ARG
:
4036 case LOC_UNRESOLVED
:
4040 fill_in_ada_prototype (sym
);
4041 add_defn_to_vec (fixup_symbol_section (sym
, objfile
),
4050 if (!found_sym
&& arg_sym
!= NULL
)
4052 fill_in_ada_prototype (arg_sym
);
4053 add_defn_to_vec (fixup_symbol_section (arg_sym
, objfile
), block
);
4064 U
= BLOCK_NSYMS (block
) - 1;
4067 int M
= (U
+ i
) >> 1;
4068 struct symbol
*sym
= BLOCK_SYM (block
, M
);
4069 if (SYMBOL_NAME (sym
)[0] < '_')
4071 else if (SYMBOL_NAME (sym
)[0] > '_')
4073 else if (strcmp (SYMBOL_NAME (sym
), "_ada_") < 0)
4082 for (; i
< BLOCK_BUCKETS (block
); i
+= 1)
4083 for (sym
= BLOCK_BUCKET (block
, i
); sym
!= NULL
; sym
= sym
->hash_next
)
4085 struct symbol
*sym
= BLOCK_SYM (block
, i
);
4087 if (SYMBOL_NAMESPACE (sym
) == namespace)
4091 cmp
= (int) '_' - (int) SYMBOL_NAME (sym
)[0];
4094 cmp
= strncmp ("_ada_", SYMBOL_NAME (sym
), 5);
4096 cmp
= strncmp (name
, SYMBOL_NAME (sym
) + 5, name_len
);
4103 i
= BLOCK_BUCKETS (block
);
4108 && is_name_suffix (SYMBOL_NAME (sym
) + name_len
+ 5))
4110 switch (SYMBOL_CLASS (sym
))
4116 case LOC_REGPARM_ADDR
:
4117 case LOC_BASEREG_ARG
:
4120 case LOC_UNRESOLVED
:
4124 fill_in_ada_prototype (sym
);
4125 add_defn_to_vec (fixup_symbol_section (sym
, objfile
),
4133 /* NOTE: This really shouldn't be needed for _ada_ symbols.
4134 They aren't parameters, right? */
4135 if (!found_sym
&& arg_sym
!= NULL
)
4137 fill_in_ada_prototype (arg_sym
);
4138 add_defn_to_vec (fixup_symbol_section (arg_sym
, objfile
), block
);
4144 /* Function Types */
4146 /* Assuming that SYM is the symbol for a function, fill in its type
4147 with prototype information, if it is not already there. */
4150 fill_in_ada_prototype (struct symbol
*func
)
4161 || TYPE_CODE (SYMBOL_TYPE (func
)) != TYPE_CODE_FUNC
4162 || TYPE_FIELDS (SYMBOL_TYPE (func
)) != NULL
)
4165 /* We make each function type unique, so that each may have its own */
4166 /* parameter types. This particular way of doing so wastes space: */
4167 /* it would be nicer to build the argument types while the original */
4168 /* function type is being built (FIXME). */
4169 rtype
= check_typedef (TYPE_TARGET_TYPE (SYMBOL_TYPE (func
)));
4170 ftype
= alloc_type (TYPE_OBJFILE (SYMBOL_TYPE (func
)));
4171 make_function_type (rtype
, &ftype
);
4172 SYMBOL_TYPE (func
) = ftype
;
4174 b
= SYMBOL_BLOCK_VALUE (func
);
4178 TYPE_FIELDS (ftype
) =
4179 (struct field
*) xmalloc (sizeof (struct field
) * max_fields
);
4180 ALL_BLOCK_SYMBOLS (b
, i
, sym
)
4182 GROW_VECT (TYPE_FIELDS (ftype
), max_fields
, nargs
+ 1);
4184 switch (SYMBOL_CLASS (sym
))
4187 case LOC_REGPARM_ADDR
:
4188 TYPE_FIELD_BITPOS (ftype
, nargs
) = nargs
;
4189 TYPE_FIELD_BITSIZE (ftype
, nargs
) = 0;
4190 TYPE_FIELD_STATIC_KIND (ftype
, nargs
) = 0;
4191 TYPE_FIELD_TYPE (ftype
, nargs
) =
4192 lookup_pointer_type (check_typedef (SYMBOL_TYPE (sym
)));
4193 TYPE_FIELD_NAME (ftype
, nargs
) = SYMBOL_NAME (sym
);
4201 case LOC_BASEREG_ARG
:
4202 TYPE_FIELD_BITPOS (ftype
, nargs
) = nargs
;
4203 TYPE_FIELD_BITSIZE (ftype
, nargs
) = 0;
4204 TYPE_FIELD_STATIC_KIND (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 find_frame_sal (fi
, &sal
);
5034 if (sal
.symtab
&& !is_ada_runtime_file (sal
.symtab
->filename
))
5036 #if defined(__alpha__) && defined(__osf__) && !defined(VXWORKS_TARGET)
5037 /* libpthread.so contains some debugging information that prevents us
5038 from finding the right frame */
5040 if (sal
.symtab
->objfile
&&
5041 STREQ (sal
.symtab
->objfile
->name
, "/usr/shlib/libpthread.so"))
5044 deprecated_selected_frame
= fi
;
5053 ada_report_exception_break (struct breakpoint
*b
)
5055 /* FIXME: break_on_exception should be defined in breakpoint.h */
5056 /* if (b->break_on_exception == 1)
5058 /* Assume that cond has 16 elements, the 15th
5059 being the exception *//*
5060 if (b->cond && b->cond->nelts == 16)
5062 ui_out_text (uiout, "on ");
5063 ui_out_field_string (uiout, "exception",
5064 SYMBOL_NAME (b->cond->elts[14].symbol));
5067 ui_out_text (uiout, "on all exceptions");
5069 else if (b->break_on_exception == 2)
5070 ui_out_text (uiout, "on unhandled exception");
5071 else if (b->break_on_exception == 3)
5072 ui_out_text (uiout, "on assert failure");
5074 if (b->break_on_exception == 1)
5076 /* Assume that cond has 16 elements, the 15th
5077 being the exception *//*
5078 if (b->cond && b->cond->nelts == 16)
5080 fputs_filtered ("on ", gdb_stdout);
5081 fputs_filtered (SYMBOL_NAME
5082 (b->cond->elts[14].symbol), gdb_stdout);
5085 fputs_filtered ("on all exceptions", gdb_stdout);
5087 else if (b->break_on_exception == 2)
5088 fputs_filtered ("on unhandled exception", gdb_stdout);
5089 else if (b->break_on_exception == 3)
5090 fputs_filtered ("on assert failure", gdb_stdout);
5095 ada_is_exception_sym (struct symbol
*sym
)
5097 char *type_name
= type_name_no_tag (SYMBOL_TYPE (sym
));
5099 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5100 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5101 && SYMBOL_CLASS (sym
) != LOC_CONST
5102 && type_name
!= NULL
&& STREQ (type_name
, "exception"));
5106 ada_maybe_exception_partial_symbol (struct partial_symbol
*sym
)
5108 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5109 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5110 && SYMBOL_CLASS (sym
) != LOC_CONST
);
5113 /* If ARG points to an Ada exception or assert breakpoint, rewrite
5114 into equivalent form. Return resulting argument string. Set
5115 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
5116 break on unhandled, 3 for assert, 0 otherwise. */
5118 ada_breakpoint_rewrite (char *arg
, int *break_on_exceptionp
)
5122 *break_on_exceptionp
= 0;
5123 /* FIXME: language_ada should be defined in defs.h */
5124 /* if (current_language->la_language == language_ada
5125 && STREQN (arg, "exception", 9) &&
5126 (arg[9] == ' ' || arg[9] == '\t' || arg[9] == '\0'))
5128 char *tok, *end_tok;
5131 *break_on_exceptionp = 1;
5134 while (*tok == ' ' || *tok == '\t')
5139 while (*end_tok != ' ' && *end_tok != '\t' && *end_tok != '\000')
5142 toklen = end_tok - tok;
5144 arg = (char*) xmalloc (sizeof ("__gnat_raise_nodefer_with_msg if "
5145 "long_integer(e) = long_integer(&)")
5147 make_cleanup (xfree, arg);
5149 strcpy (arg, "__gnat_raise_nodefer_with_msg");
5150 else if (STREQN (tok, "unhandled", toklen))
5152 *break_on_exceptionp = 2;
5153 strcpy (arg, "__gnat_unhandled_exception");
5157 sprintf (arg, "__gnat_raise_nodefer_with_msg if "
5158 "long_integer(e) = long_integer(&%.*s)",
5162 else if (current_language->la_language == language_ada
5163 && STREQN (arg, "assert", 6) &&
5164 (arg[6] == ' ' || arg[6] == '\t' || arg[6] == '\0'))
5166 char *tok = arg + 6;
5168 *break_on_exceptionp = 3;
5171 xmalloc (sizeof ("system__assertions__raise_assert_failure")
5172 + strlen (tok) + 1);
5173 make_cleanup (xfree, arg);
5174 sprintf (arg, "system__assertions__raise_assert_failure%s", tok);
5183 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5184 to be invisible to users. */
5187 ada_is_ignored_field (struct type
*type
, int field_num
)
5189 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5193 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5194 return (name
== NULL
5195 || (name
[0] == '_' && !STREQN (name
, "_parent", 7)));
5199 /* True iff structure type TYPE has a tag field. */
5202 ada_is_tagged_type (struct type
*type
)
5204 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5207 return (ada_lookup_struct_elt_type (type
, "_tag", 1, NULL
) != NULL
);
5210 /* The type of the tag on VAL. */
5213 ada_tag_type (struct value
*val
)
5215 return ada_lookup_struct_elt_type (VALUE_TYPE (val
), "_tag", 0, NULL
);
5218 /* The value of the tag on VAL. */
5221 ada_value_tag (struct value
*val
)
5223 return ada_value_struct_elt (val
, "_tag", "record");
5226 /* The parent type of TYPE, or NULL if none. */
5229 ada_parent_type (struct type
*type
)
5233 CHECK_TYPEDEF (type
);
5235 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5238 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5239 if (ada_is_parent_field (type
, i
))
5240 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5245 /* True iff field number FIELD_NUM of structure type TYPE contains the
5246 parent-type (inherited) fields of a derived type. Assumes TYPE is
5247 a structure type with at least FIELD_NUM+1 fields. */
5250 ada_is_parent_field (struct type
*type
, int field_num
)
5252 const char *name
= TYPE_FIELD_NAME (check_typedef (type
), field_num
);
5253 return (name
!= NULL
&&
5254 (STREQN (name
, "PARENT", 6) || STREQN (name
, "_parent", 7)));
5257 /* True iff field number FIELD_NUM of structure type TYPE is a
5258 transparent wrapper field (which should be silently traversed when doing
5259 field selection and flattened when printing). Assumes TYPE is a
5260 structure type with at least FIELD_NUM+1 fields. Such fields are always
5264 ada_is_wrapper_field (struct type
*type
, int field_num
)
5266 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5267 return (name
!= NULL
5268 && (STREQN (name
, "PARENT", 6) || STREQ (name
, "REP")
5269 || STREQN (name
, "_parent", 7)
5270 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5273 /* True iff field number FIELD_NUM of structure or union type TYPE
5274 is a variant wrapper. Assumes TYPE is a structure type with at least
5275 FIELD_NUM+1 fields. */
5278 ada_is_variant_part (struct type
*type
, int field_num
)
5280 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5281 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5282 || (is_dynamic_field (type
, field_num
)
5283 && TYPE_CODE (TYPE_TARGET_TYPE (field_type
)) ==
5287 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5288 whose discriminants are contained in the record type OUTER_TYPE,
5289 returns the type of the controlling discriminant for the variant. */
5292 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5294 char *name
= ada_variant_discrim_name (var_type
);
5295 struct type
*type
= ada_lookup_struct_elt_type (outer_type
, name
, 1, NULL
);
5297 return builtin_type_int
;
5302 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5303 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5304 represents a 'when others' clause; otherwise 0. */
5307 ada_is_others_clause (struct type
*type
, int field_num
)
5309 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5310 return (name
!= NULL
&& name
[0] == 'O');
5313 /* Assuming that TYPE0 is the type of the variant part of a record,
5314 returns the name of the discriminant controlling the variant. The
5315 value is valid until the next call to ada_variant_discrim_name. */
5318 ada_variant_discrim_name (struct type
*type0
)
5320 static char *result
= NULL
;
5321 static size_t result_len
= 0;
5324 const char *discrim_end
;
5325 const char *discrim_start
;
5327 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5328 type
= TYPE_TARGET_TYPE (type0
);
5332 name
= ada_type_name (type
);
5334 if (name
== NULL
|| name
[0] == '\000')
5337 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5340 if (STREQN (discrim_end
, "___XVN", 6))
5343 if (discrim_end
== name
)
5346 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5349 if (discrim_start
== name
+ 1)
5351 if ((discrim_start
> name
+ 3 && STREQN (discrim_start
- 3, "___", 3))
5352 || discrim_start
[-1] == '.')
5356 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5357 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5358 result
[discrim_end
- discrim_start
] = '\0';
5362 /* Scan STR for a subtype-encoded number, beginning at position K. Put the
5363 position of the character just past the number scanned in *NEW_K,
5364 if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL. Return 1
5365 if there was a valid number at the given position, and 0 otherwise. A
5366 "subtype-encoded" number consists of the absolute value in decimal,
5367 followed by the letter 'm' to indicate a negative number. Assumes 0m
5371 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5375 if (!isdigit (str
[k
]))
5378 /* Do it the hard way so as not to make any assumption about
5379 the relationship of unsigned long (%lu scan format code) and
5382 while (isdigit (str
[k
]))
5384 RU
= RU
* 10 + (str
[k
] - '0');
5391 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5397 /* NOTE on the above: Technically, C does not say what the results of
5398 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5399 number representable as a LONGEST (although either would probably work
5400 in most implementations). When RU>0, the locution in the then branch
5401 above is always equivalent to the negative of RU. */
5408 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5409 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5410 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5413 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5415 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5428 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5437 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5438 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5440 if (val
>= L
&& val
<= U
)
5452 /* Given a value ARG1 (offset by OFFSET bytes)
5453 of a struct or union type ARG_TYPE,
5454 extract and return the value of one of its (non-static) fields.
5455 FIELDNO says which field. Differs from value_primitive_field only
5456 in that it can handle packed values of arbitrary type. */
5459 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5460 struct type
*arg_type
)
5465 CHECK_TYPEDEF (arg_type
);
5466 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5468 /* Handle packed fields */
5470 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5472 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5473 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5475 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
5476 offset
+ bit_pos
/ 8,
5477 bit_pos
% 8, bit_size
, type
);
5480 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5484 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5485 and search in it assuming it has (class) type TYPE.
5486 If found, return value, else return NULL.
5488 Searches recursively through wrapper fields (e.g., '_parent'). */
5491 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5495 CHECK_TYPEDEF (type
);
5497 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5499 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5501 if (t_field_name
== NULL
)
5504 else if (field_name_match (t_field_name
, name
))
5505 return ada_value_primitive_field (arg
, offset
, i
, type
);
5507 else if (ada_is_wrapper_field (type
, i
))
5509 struct value
*v
= ada_search_struct_field (name
, arg
,
5511 TYPE_FIELD_BITPOS (type
,
5514 TYPE_FIELD_TYPE (type
,
5520 else if (ada_is_variant_part (type
, i
))
5523 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5524 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5526 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5528 struct value
*v
= ada_search_struct_field (name
, arg
,
5532 (field_type
, j
) / 8,
5543 /* Given ARG, a value of type (pointer to a)* structure/union,
5544 extract the component named NAME from the ultimate target structure/union
5545 and return it as a value with its appropriate type.
5547 The routine searches for NAME among all members of the structure itself
5548 and (recursively) among all members of any wrapper members
5551 ERR is a name (for use in error messages) that identifies the class
5552 of entity that ARG is supposed to be. */
5555 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5560 arg
= ada_coerce_ref (arg
);
5561 t
= check_typedef (VALUE_TYPE (arg
));
5563 /* Follow pointers until we get to a non-pointer. */
5565 while (TYPE_CODE (t
) == TYPE_CODE_PTR
|| TYPE_CODE (t
) == TYPE_CODE_REF
)
5567 arg
= ada_value_ind (arg
);
5568 t
= check_typedef (VALUE_TYPE (arg
));
5571 if (TYPE_CODE (t
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t
) != TYPE_CODE_UNION
)
5572 error ("Attempt to extract a component of a value that is not a %s.",
5575 v
= ada_search_struct_field (name
, arg
, 0, t
);
5577 error ("There is no member named %s.", name
);
5582 /* Given a type TYPE, look up the type of the component of type named NAME.
5583 If DISPP is non-null, add its byte displacement from the beginning of a
5584 structure (pointed to by a value) of type TYPE to *DISPP (does not
5585 work for packed fields).
5587 Matches any field whose name has NAME as a prefix, possibly
5590 TYPE can be either a struct or union, or a pointer or reference to
5591 a struct or union. If it is a pointer or reference, its target
5592 type is automatically used.
5594 Looks recursively into variant clauses and parent types.
5596 If NOERR is nonzero, return NULL if NAME is not suitably defined. */
5599 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int noerr
,
5609 CHECK_TYPEDEF (type
);
5610 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5611 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5613 type
= TYPE_TARGET_TYPE (type
);
5616 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
&&
5617 TYPE_CODE (type
) != TYPE_CODE_UNION
)
5619 target_terminal_ours ();
5620 gdb_flush (gdb_stdout
);
5621 fprintf_unfiltered (gdb_stderr
, "Type ");
5622 type_print (type
, "", gdb_stderr
, -1);
5623 error (" is not a structure or union type");
5626 type
= to_static_fixed_type (type
);
5628 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5630 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5634 if (t_field_name
== NULL
)
5637 else if (field_name_match (t_field_name
, name
))
5640 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5641 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5644 else if (ada_is_wrapper_field (type
, i
))
5647 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5652 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5657 else if (ada_is_variant_part (type
, i
))
5660 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5662 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5665 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5670 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5681 target_terminal_ours ();
5682 gdb_flush (gdb_stdout
);
5683 fprintf_unfiltered (gdb_stderr
, "Type ");
5684 type_print (type
, "", gdb_stderr
, -1);
5685 fprintf_unfiltered (gdb_stderr
, " has no component named ");
5686 error ("%s", name
== NULL
? "<null>" : name
);
5692 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5693 within a value of type OUTER_TYPE that is stored in GDB at
5694 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5695 numbering from 0) is applicable. Returns -1 if none are. */
5698 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5699 char *outer_valaddr
)
5704 struct type
*discrim_type
;
5705 char *discrim_name
= ada_variant_discrim_name (var_type
);
5706 LONGEST discrim_val
;
5710 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, &disp
);
5711 if (discrim_type
== NULL
)
5713 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5716 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5718 if (ada_is_others_clause (var_type
, i
))
5720 else if (ada_in_variant (discrim_val
, var_type
, i
))
5724 return others_clause
;
5729 /* Dynamic-Sized Records */
5731 /* Strategy: The type ostensibly attached to a value with dynamic size
5732 (i.e., a size that is not statically recorded in the debugging
5733 data) does not accurately reflect the size or layout of the value.
5734 Our strategy is to convert these values to values with accurate,
5735 conventional types that are constructed on the fly. */
5737 /* There is a subtle and tricky problem here. In general, we cannot
5738 determine the size of dynamic records without its data. However,
5739 the 'struct value' data structure, which GDB uses to represent
5740 quantities in the inferior process (the target), requires the size
5741 of the type at the time of its allocation in order to reserve space
5742 for GDB's internal copy of the data. That's why the
5743 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5744 rather than struct value*s.
5746 However, GDB's internal history variables ($1, $2, etc.) are
5747 struct value*s containing internal copies of the data that are not, in
5748 general, the same as the data at their corresponding addresses in
5749 the target. Fortunately, the types we give to these values are all
5750 conventional, fixed-size types (as per the strategy described
5751 above), so that we don't usually have to perform the
5752 'to_fixed_xxx_type' conversions to look at their values.
5753 Unfortunately, there is one exception: if one of the internal
5754 history variables is an array whose elements are unconstrained
5755 records, then we will need to create distinct fixed types for each
5756 element selected. */
5758 /* The upshot of all of this is that many routines take a (type, host
5759 address, target address) triple as arguments to represent a value.
5760 The host address, if non-null, is supposed to contain an internal
5761 copy of the relevant data; otherwise, the program is to consult the
5762 target at the target address. */
5764 /* Assuming that VAL0 represents a pointer value, the result of
5765 dereferencing it. Differs from value_ind in its treatment of
5766 dynamic-sized types. */
5769 ada_value_ind (struct value
*val0
)
5771 struct value
*val
= unwrap_value (value_ind (val0
));
5772 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5773 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
), val
);
5776 /* The value resulting from dereferencing any "reference to"
5777 * qualifiers on VAL0. */
5778 static struct value
*
5779 ada_coerce_ref (struct value
*val0
)
5781 if (TYPE_CODE (VALUE_TYPE (val0
)) == TYPE_CODE_REF
)
5783 struct value
*val
= val0
;
5785 val
= unwrap_value (val
);
5786 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5787 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
5794 /* Return OFF rounded upward if necessary to a multiple of
5795 ALIGNMENT (a power of 2). */
5798 align_value (unsigned int off
, unsigned int alignment
)
5800 return (off
+ alignment
- 1) & ~(alignment
- 1);
5803 /* Return the additional bit offset required by field F of template
5807 field_offset (struct type
*type
, int f
)
5809 int n
= TYPE_FIELD_BITPOS (type
, f
);
5810 /* Kludge (temporary?) to fix problem with dwarf output. */
5812 return (unsigned int) n
& 0xffff;
5818 /* Return the bit alignment required for field #F of template type TYPE. */
5821 field_alignment (struct type
*type
, int f
)
5823 const char *name
= TYPE_FIELD_NAME (type
, f
);
5824 int len
= (name
== NULL
) ? 0 : strlen (name
);
5827 if (len
< 8 || !isdigit (name
[len
- 1]))
5828 return TARGET_CHAR_BIT
;
5830 if (isdigit (name
[len
- 2]))
5831 align_offset
= len
- 2;
5833 align_offset
= len
- 1;
5835 if (align_offset
< 7 || !STREQN ("___XV", name
+ align_offset
- 6, 5))
5836 return TARGET_CHAR_BIT
;
5838 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
5841 /* Find a type named NAME. Ignores ambiguity. */
5843 ada_find_any_type (const char *name
)
5847 sym
= standard_lookup (name
, VAR_NAMESPACE
);
5848 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5849 return SYMBOL_TYPE (sym
);
5851 sym
= standard_lookup (name
, STRUCT_NAMESPACE
);
5853 return SYMBOL_TYPE (sym
);
5858 /* Because of GNAT encoding conventions, several GDB symbols may match a
5859 given type name. If the type denoted by TYPE0 is to be preferred to
5860 that of TYPE1 for purposes of type printing, return non-zero;
5861 otherwise return 0. */
5863 ada_prefer_type (struct type
*type0
, struct type
*type1
)
5867 else if (type0
== NULL
)
5869 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
5871 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
5873 else if (ada_is_packed_array_type (type0
))
5875 else if (ada_is_array_descriptor (type0
)
5876 && !ada_is_array_descriptor (type1
))
5878 else if (ada_renaming_type (type0
) != NULL
5879 && ada_renaming_type (type1
) == NULL
)
5884 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5885 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5887 ada_type_name (struct type
*type
)
5891 else if (TYPE_NAME (type
) != NULL
)
5892 return TYPE_NAME (type
);
5894 return TYPE_TAG_NAME (type
);
5897 /* Find a parallel type to TYPE whose name is formed by appending
5898 SUFFIX to the name of TYPE. */
5901 ada_find_parallel_type (struct type
*type
, const char *suffix
)
5904 static size_t name_len
= 0;
5905 struct symbol
**syms
;
5906 struct block
**blocks
;
5909 char *typename
= ada_type_name (type
);
5911 if (typename
== NULL
)
5914 len
= strlen (typename
);
5916 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
5918 strcpy (name
, typename
);
5919 strcpy (name
+ len
, suffix
);
5921 return ada_find_any_type (name
);
5925 /* If TYPE is a variable-size record type, return the corresponding template
5926 type describing its fields. Otherwise, return NULL. */
5928 static struct type
*
5929 dynamic_template_type (struct type
*type
)
5931 CHECK_TYPEDEF (type
);
5933 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5934 || ada_type_name (type
) == NULL
)
5938 int len
= strlen (ada_type_name (type
));
5939 if (len
> 6 && STREQ (ada_type_name (type
) + len
- 6, "___XVE"))
5942 return ada_find_parallel_type (type
, "___XVE");
5946 /* Assuming that TEMPL_TYPE is a union or struct type, returns
5947 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
5950 is_dynamic_field (struct type
*templ_type
, int field_num
)
5952 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
5954 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
5955 && strstr (name
, "___XVL") != NULL
;
5958 /* Assuming that TYPE is a struct type, returns non-zero iff TYPE
5959 contains a variant part. */
5962 contains_variant_part (struct type
*type
)
5966 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5967 || TYPE_NFIELDS (type
) <= 0)
5969 return ada_is_variant_part (type
, TYPE_NFIELDS (type
) - 1);
5972 /* A record type with no fields, . */
5973 static struct type
*
5974 empty_record (struct objfile
*objfile
)
5976 struct type
*type
= alloc_type (objfile
);
5977 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
5978 TYPE_NFIELDS (type
) = 0;
5979 TYPE_FIELDS (type
) = NULL
;
5980 TYPE_NAME (type
) = "<empty>";
5981 TYPE_TAG_NAME (type
) = NULL
;
5982 TYPE_FLAGS (type
) = 0;
5983 TYPE_LENGTH (type
) = 0;
5987 /* An ordinary record type (with fixed-length fields) that describes
5988 the value of type TYPE at VALADDR or ADDRESS (see comments at
5989 the beginning of this section) VAL according to GNAT conventions.
5990 DVAL0 should describe the (portion of a) record that contains any
5991 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
5992 an outer-level type (i.e., as opposed to a branch of a variant.) A
5993 variant field (unless unchecked) is replaced by a particular branch
5995 /* NOTE: Limitations: For now, we assume that dynamic fields and
5996 * variants occupy whole numbers of bytes. However, they need not be
5999 static struct type
*
6000 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
6001 CORE_ADDR address
, struct value
*dval0
)
6003 struct value
*mark
= value_mark ();
6006 int nfields
, bit_len
;
6010 nfields
= TYPE_NFIELDS (type
);
6011 rtype
= alloc_type (TYPE_OBJFILE (type
));
6012 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6013 INIT_CPLUS_SPECIFIC (rtype
);
6014 TYPE_NFIELDS (rtype
) = nfields
;
6015 TYPE_FIELDS (rtype
) = (struct field
*)
6016 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6017 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6018 TYPE_NAME (rtype
) = ada_type_name (type
);
6019 TYPE_TAG_NAME (rtype
) = NULL
;
6020 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in
6022 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6026 for (f
= 0; f
< nfields
; f
+= 1)
6028 int fld_bit_len
, bit_incr
;
6031 field_alignment (type
, f
)) + TYPE_FIELD_BITPOS (type
, f
);
6032 /* NOTE: used to use field_offset above, but that causes
6033 * problems with really negative bit positions. So, let's
6034 * rediscover why we needed field_offset and fix it properly. */
6035 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6036 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6037 TYPE_FIELD_STATIC_KIND (rtype
, f
) = 0;
6039 if (ada_is_variant_part (type
, f
))
6041 struct type
*branch_type
;
6044 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6049 to_fixed_variant_branch_type
6050 (TYPE_FIELD_TYPE (type
, f
),
6051 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6052 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6053 if (branch_type
== NULL
)
6054 TYPE_NFIELDS (rtype
) -= 1;
6057 TYPE_FIELD_TYPE (rtype
, f
) = branch_type
;
6058 TYPE_FIELD_NAME (rtype
, f
) = "S";
6062 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6064 else if (is_dynamic_field (type
, f
))
6067 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6071 TYPE_FIELD_TYPE (rtype
, f
) =
6074 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6075 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6076 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6077 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6078 bit_incr
= fld_bit_len
=
6079 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6083 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6084 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6085 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6086 bit_incr
= fld_bit_len
=
6087 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6089 bit_incr
= fld_bit_len
=
6090 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6092 if (off
+ fld_bit_len
> bit_len
)
6093 bit_len
= off
+ fld_bit_len
;
6095 TYPE_LENGTH (rtype
) = bit_len
/ TARGET_CHAR_BIT
;
6097 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
), TYPE_LENGTH (type
));
6099 value_free_to_mark (mark
);
6100 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6101 error ("record type with dynamic size is larger than varsize-limit");
6105 /* As for template_to_fixed_record_type, but uses no run-time values.
6106 As a result, this type can only be approximate, but that's OK,
6107 since it is used only for type determinations. Works on both
6109 Representation note: to save space, we memoize the result of this
6110 function in the TYPE_TARGET_TYPE of the template type. */
6112 static struct type
*
6113 template_to_static_fixed_type (struct type
*templ_type
)
6119 if (TYPE_TARGET_TYPE (templ_type
) != NULL
)
6120 return TYPE_TARGET_TYPE (templ_type
);
6122 nfields
= TYPE_NFIELDS (templ_type
);
6123 TYPE_TARGET_TYPE (templ_type
) = type
=
6124 alloc_type (TYPE_OBJFILE (templ_type
));
6125 TYPE_CODE (type
) = TYPE_CODE (templ_type
);
6126 INIT_CPLUS_SPECIFIC (type
);
6127 TYPE_NFIELDS (type
) = nfields
;
6128 TYPE_FIELDS (type
) = (struct field
*)
6129 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6130 memset (TYPE_FIELDS (type
), 0, sizeof (struct field
) * nfields
);
6131 TYPE_NAME (type
) = ada_type_name (templ_type
);
6132 TYPE_TAG_NAME (type
) = NULL
;
6133 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6134 /* TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE; */
6135 TYPE_LENGTH (type
) = 0;
6137 for (f
= 0; f
< nfields
; f
+= 1)
6139 TYPE_FIELD_BITPOS (type
, f
) = 0;
6140 TYPE_FIELD_BITSIZE (type
, f
) = 0;
6141 TYPE_FIELD_STATIC_KIND (type
, f
) = 0;
6143 if (is_dynamic_field (templ_type
, f
))
6145 TYPE_FIELD_TYPE (type
, f
) =
6146 to_static_fixed_type (TYPE_TARGET_TYPE
6147 (TYPE_FIELD_TYPE (templ_type
, f
)));
6148 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6152 TYPE_FIELD_TYPE (type
, f
) =
6153 check_typedef (TYPE_FIELD_TYPE (templ_type
, f
));
6154 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6161 /* A revision of TYPE0 -- a non-dynamic-sized record with a variant
6162 part -- in which the variant part is replaced with the appropriate
6164 static struct type
*
6165 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
6166 CORE_ADDR address
, struct value
*dval
)
6168 struct value
*mark
= value_mark ();
6170 struct type
*branch_type
;
6171 int nfields
= TYPE_NFIELDS (type
);
6176 rtype
= alloc_type (TYPE_OBJFILE (type
));
6177 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6178 INIT_CPLUS_SPECIFIC (type
);
6179 TYPE_NFIELDS (rtype
) = TYPE_NFIELDS (type
);
6180 TYPE_FIELDS (rtype
) =
6181 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6182 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6183 sizeof (struct field
) * nfields
);
6184 TYPE_NAME (rtype
) = ada_type_name (type
);
6185 TYPE_TAG_NAME (rtype
) = NULL
;
6186 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6187 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6188 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6191 to_fixed_variant_branch_type
6192 (TYPE_FIELD_TYPE (type
, nfields
- 1),
6193 cond_offset_host (valaddr
,
6194 TYPE_FIELD_BITPOS (type
,
6195 nfields
- 1) / TARGET_CHAR_BIT
),
6196 cond_offset_target (address
,
6197 TYPE_FIELD_BITPOS (type
,
6198 nfields
- 1) / TARGET_CHAR_BIT
),
6200 if (branch_type
== NULL
)
6202 TYPE_NFIELDS (rtype
) -= 1;
6203 TYPE_LENGTH (rtype
) -=
6204 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6208 TYPE_FIELD_TYPE (rtype
, nfields
- 1) = branch_type
;
6209 TYPE_FIELD_NAME (rtype
, nfields
- 1) = "S";
6210 TYPE_FIELD_BITSIZE (rtype
, nfields
- 1) = 0;
6211 TYPE_FIELD_STATIC_KIND (rtype
, nfields
- 1) = 0;
6212 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6213 -TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6219 /* An ordinary record type (with fixed-length fields) that describes
6220 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6221 beginning of this section]. Any necessary discriminants' values
6222 should be in DVAL, a record value; it should be NULL if the object
6223 at ADDR itself contains any necessary discriminant values. A
6224 variant field (unless unchecked) is replaced by a particular branch
6227 static struct type
*
6228 to_fixed_record_type (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6231 struct type
*templ_type
;
6233 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6234 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6237 templ_type
= dynamic_template_type (type0
);
6239 if (templ_type
!= NULL
)
6240 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6241 else if (contains_variant_part (type0
))
6242 return to_record_with_fixed_variant_part (type0
, valaddr
, address
, dval
);
6245 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6246 /* TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE; */
6252 /* An ordinary record type (with fixed-length fields) that describes
6253 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6254 union type. Any necessary discriminants' values should be in DVAL,
6255 a record value. That is, this routine selects the appropriate
6256 branch of the union at ADDR according to the discriminant value
6257 indicated in the union's type name. */
6259 static struct type
*
6260 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
6261 CORE_ADDR address
, struct value
*dval
)
6264 struct type
*templ_type
;
6265 struct type
*var_type
;
6267 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6268 var_type
= TYPE_TARGET_TYPE (var_type0
);
6270 var_type
= var_type0
;
6272 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6274 if (templ_type
!= NULL
)
6275 var_type
= templ_type
;
6278 ada_which_variant_applies (var_type
,
6279 VALUE_TYPE (dval
), VALUE_CONTENTS (dval
));
6282 return empty_record (TYPE_OBJFILE (var_type
));
6283 else if (is_dynamic_field (var_type
, which
))
6285 to_fixed_record_type
6286 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6287 valaddr
, address
, dval
);
6288 else if (contains_variant_part (TYPE_FIELD_TYPE (var_type
, which
)))
6290 to_fixed_record_type
6291 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6293 return TYPE_FIELD_TYPE (var_type
, which
);
6296 /* Assuming that TYPE0 is an array type describing the type of a value
6297 at ADDR, and that DVAL describes a record containing any
6298 discriminants used in TYPE0, returns a type for the value that
6299 contains no dynamic components (that is, no components whose sizes
6300 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6301 true, gives an error message if the resulting type's size is over
6305 static struct type
*
6306 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6309 struct type
*index_type_desc
;
6310 struct type
*result
;
6312 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6313 /* if (ada_is_packed_array_type (type0) /* revisit? *//*
6314 || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
6317 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6318 if (index_type_desc
== NULL
)
6320 struct type
*elt_type0
= check_typedef (TYPE_TARGET_TYPE (type0
));
6321 /* NOTE: elt_type---the fixed version of elt_type0---should never
6322 * depend on the contents of the array in properly constructed
6323 * debugging data. */
6324 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6326 if (elt_type0
== elt_type
)
6329 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6330 elt_type
, TYPE_INDEX_TYPE (type0
));
6335 struct type
*elt_type0
;
6338 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6339 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6341 /* NOTE: result---the fixed version of elt_type0---should never
6342 * depend on the contents of the array in properly constructed
6343 * debugging data. */
6344 result
= ada_to_fixed_type (check_typedef (elt_type0
), 0, 0, dval
);
6345 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6347 struct type
*range_type
=
6348 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6349 dval
, TYPE_OBJFILE (type0
));
6350 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6351 result
, range_type
);
6353 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6354 error ("array type with dynamic size is larger than varsize-limit");
6357 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6358 /* TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE; */
6363 /* A standard type (containing no dynamically sized components)
6364 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6365 DVAL describes a record containing any discriminants used in TYPE0,
6366 and may be NULL if there are none. */
6369 ada_to_fixed_type (struct type
*type
, char *valaddr
, CORE_ADDR address
,
6372 CHECK_TYPEDEF (type
);
6373 switch (TYPE_CODE (type
))
6377 case TYPE_CODE_STRUCT
:
6378 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6379 case TYPE_CODE_ARRAY
:
6380 return to_fixed_array_type (type
, dval
, 0);
6381 case TYPE_CODE_UNION
:
6385 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6389 /* A standard (static-sized) type corresponding as well as possible to
6390 TYPE0, but based on no runtime data. */
6392 static struct type
*
6393 to_static_fixed_type (struct type
*type0
)
6400 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6401 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6404 CHECK_TYPEDEF (type0
);
6406 switch (TYPE_CODE (type0
))
6410 case TYPE_CODE_STRUCT
:
6411 type
= dynamic_template_type (type0
);
6413 return template_to_static_fixed_type (type
);
6415 case TYPE_CODE_UNION
:
6416 type
= ada_find_parallel_type (type0
, "___XVU");
6418 return template_to_static_fixed_type (type
);
6423 /* A static approximation of TYPE with all type wrappers removed. */
6424 static struct type
*
6425 static_unwrap_type (struct type
*type
)
6427 if (ada_is_aligner_type (type
))
6429 struct type
*type1
= TYPE_FIELD_TYPE (check_typedef (type
), 0);
6430 if (ada_type_name (type1
) == NULL
)
6431 TYPE_NAME (type1
) = ada_type_name (type
);
6433 return static_unwrap_type (type1
);
6437 struct type
*raw_real_type
= ada_get_base_type (type
);
6438 if (raw_real_type
== type
)
6441 return to_static_fixed_type (raw_real_type
);
6445 /* In some cases, incomplete and private types require
6446 cross-references that are not resolved as records (for example,
6448 type FooP is access Foo;
6450 type Foo is array ...;
6451 ). In these cases, since there is no mechanism for producing
6452 cross-references to such types, we instead substitute for FooP a
6453 stub enumeration type that is nowhere resolved, and whose tag is
6454 the name of the actual type. Call these types "non-record stubs". */
6456 /* A type equivalent to TYPE that is not a non-record stub, if one
6457 exists, otherwise TYPE. */
6459 ada_completed_type (struct type
*type
)
6461 CHECK_TYPEDEF (type
);
6462 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6463 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
6464 || TYPE_TAG_NAME (type
) == NULL
)
6468 char *name
= TYPE_TAG_NAME (type
);
6469 struct type
*type1
= ada_find_any_type (name
);
6470 return (type1
== NULL
) ? type
: type1
;
6474 /* A value representing the data at VALADDR/ADDRESS as described by
6475 type TYPE0, but with a standard (static-sized) type that correctly
6476 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6477 type, then return VAL0 [this feature is simply to avoid redundant
6478 creation of struct values]. */
6481 ada_to_fixed_value (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6484 struct type
*type
= ada_to_fixed_type (type0
, valaddr
, address
, NULL
);
6485 if (type
== type0
&& val0
!= NULL
)
6488 return value_from_contents_and_address (type
, valaddr
, address
);
6491 /* A value representing VAL, but with a standard (static-sized) type
6492 chosen to approximate the real type of VAL as well as possible, but
6493 without consulting any runtime values. For Ada dynamic-sized
6494 types, therefore, the type of the result is likely to be inaccurate. */
6497 ada_to_static_fixed_value (struct value
*val
)
6500 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val
)));
6501 if (type
== VALUE_TYPE (val
))
6504 return coerce_unspec_val_to_type (val
, 0, type
);
6513 /* Table mapping attribute numbers to names */
6514 /* NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h */
6516 static const char *attribute_names
[] = {
6533 ada_attribute_name (int n
)
6535 if (n
> 0 && n
< (int) ATR_END
)
6536 return attribute_names
[n
];
6538 return attribute_names
[0];
6541 /* Evaluate the 'POS attribute applied to ARG. */
6543 static struct value
*
6544 value_pos_atr (struct value
*arg
)
6546 struct type
*type
= VALUE_TYPE (arg
);
6548 if (!discrete_type_p (type
))
6549 error ("'POS only defined on discrete types");
6551 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6554 LONGEST v
= value_as_long (arg
);
6556 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6558 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6559 return value_from_longest (builtin_type_ada_int
, i
);
6561 error ("enumeration value is invalid: can't find 'POS");
6564 return value_from_longest (builtin_type_ada_int
, value_as_long (arg
));
6567 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6569 static struct value
*
6570 value_val_atr (struct type
*type
, struct value
*arg
)
6572 if (!discrete_type_p (type
))
6573 error ("'VAL only defined on discrete types");
6574 if (!integer_type_p (VALUE_TYPE (arg
)))
6575 error ("'VAL requires integral argument");
6577 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6579 long pos
= value_as_long (arg
);
6580 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6581 error ("argument to 'VAL out of range");
6582 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6585 return value_from_longest (type
, value_as_long (arg
));
6591 /* True if TYPE appears to be an Ada character type.
6592 * [At the moment, this is true only for Character and Wide_Character;
6593 * It is a heuristic test that could stand improvement]. */
6596 ada_is_character_type (struct type
*type
)
6598 const char *name
= ada_type_name (type
);
6601 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6602 || TYPE_CODE (type
) == TYPE_CODE_INT
6603 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6604 && (STREQ (name
, "character") || STREQ (name
, "wide_character")
6605 || STREQ (name
, "unsigned char"));
6608 /* True if TYPE appears to be an Ada string type. */
6611 ada_is_string_type (struct type
*type
)
6613 CHECK_TYPEDEF (type
);
6615 && TYPE_CODE (type
) != TYPE_CODE_PTR
6616 && (ada_is_simple_array (type
) || ada_is_array_descriptor (type
))
6617 && ada_array_arity (type
) == 1)
6619 struct type
*elttype
= ada_array_element_type (type
, 1);
6621 return ada_is_character_type (elttype
);
6628 /* True if TYPE is a struct type introduced by the compiler to force the
6629 alignment of a value. Such types have a single field with a
6630 distinctive name. */
6633 ada_is_aligner_type (struct type
*type
)
6635 CHECK_TYPEDEF (type
);
6636 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
6637 && TYPE_NFIELDS (type
) == 1
6638 && STREQ (TYPE_FIELD_NAME (type
, 0), "F"));
6641 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6642 the parallel type. */
6645 ada_get_base_type (struct type
*raw_type
)
6647 struct type
*real_type_namer
;
6648 struct type
*raw_real_type
;
6649 struct type
*real_type
;
6651 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
6654 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
6655 if (real_type_namer
== NULL
6656 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
6657 || TYPE_NFIELDS (real_type_namer
) != 1)
6660 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
6661 if (raw_real_type
== NULL
)
6664 return raw_real_type
;
6667 /* The type of value designated by TYPE, with all aligners removed. */
6670 ada_aligned_type (struct type
*type
)
6672 if (ada_is_aligner_type (type
))
6673 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
6675 return ada_get_base_type (type
);
6679 /* The address of the aligned value in an object at address VALADDR
6680 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6683 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
6685 if (ada_is_aligner_type (type
))
6686 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
6688 TYPE_FIELD_BITPOS (type
,
6689 0) / TARGET_CHAR_BIT
);
6694 /* The printed representation of an enumeration literal with encoded
6695 name NAME. The value is good to the next call of ada_enum_name. */
6697 ada_enum_name (const char *name
)
6703 if ((tmp
= strstr (name
, "__")) != NULL
)
6705 else if ((tmp
= strchr (name
, '.')) != NULL
)
6713 static char result
[16];
6715 if (name
[1] == 'U' || name
[1] == 'W')
6717 if (sscanf (name
+ 2, "%x", &v
) != 1)
6723 if (isascii (v
) && isprint (v
))
6724 sprintf (result
, "'%c'", v
);
6725 else if (name
[1] == 'U')
6726 sprintf (result
, "[\"%02x\"]", v
);
6728 sprintf (result
, "[\"%04x\"]", v
);
6736 static struct value
*
6737 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
6740 return (*exp
->language_defn
->evaluate_exp
) (expect_type
, exp
, pos
, noside
);
6743 /* Evaluate the subexpression of EXP starting at *POS as for
6744 evaluate_type, updating *POS to point just past the evaluated
6747 static struct value
*
6748 evaluate_subexp_type (struct expression
*exp
, int *pos
)
6750 return (*exp
->language_defn
->evaluate_exp
)
6751 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
6754 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6757 static struct value
*
6758 unwrap_value (struct value
*val
)
6760 struct type
*type
= check_typedef (VALUE_TYPE (val
));
6761 if (ada_is_aligner_type (type
))
6763 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
6764 NULL
, "internal structure");
6765 struct type
*val_type
= check_typedef (VALUE_TYPE (v
));
6766 if (ada_type_name (val_type
) == NULL
)
6767 TYPE_NAME (val_type
) = ada_type_name (type
);
6769 return unwrap_value (v
);
6773 struct type
*raw_real_type
=
6774 ada_completed_type (ada_get_base_type (type
));
6776 if (type
== raw_real_type
)
6780 coerce_unspec_val_to_type
6781 (val
, 0, ada_to_fixed_type (raw_real_type
, 0,
6782 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
6787 static struct value
*
6788 cast_to_fixed (struct type
*type
, struct value
*arg
)
6792 if (type
== VALUE_TYPE (arg
))
6794 else if (ada_is_fixed_point_type (VALUE_TYPE (arg
)))
6795 val
= ada_float_to_fixed (type
,
6796 ada_fixed_to_float (VALUE_TYPE (arg
),
6797 value_as_long (arg
)));
6801 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
6802 val
= ada_float_to_fixed (type
, argd
);
6805 return value_from_longest (type
, val
);
6808 static struct value
*
6809 cast_from_fixed_to_double (struct value
*arg
)
6811 DOUBLEST val
= ada_fixed_to_float (VALUE_TYPE (arg
),
6812 value_as_long (arg
));
6813 return value_from_double (builtin_type_double
, val
);
6816 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
6817 * return the converted value. */
6818 static struct value
*
6819 coerce_for_assign (struct type
*type
, struct value
*val
)
6821 struct type
*type2
= VALUE_TYPE (val
);
6825 CHECK_TYPEDEF (type2
);
6826 CHECK_TYPEDEF (type
);
6828 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
6829 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6831 val
= ada_value_ind (val
);
6832 type2
= VALUE_TYPE (val
);
6835 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
6836 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6838 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
6839 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
6840 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
6841 error ("Incompatible types in assignment");
6842 VALUE_TYPE (val
) = type
;
6848 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
6849 int *pos
, enum noside noside
)
6852 enum ada_attribute atr
;
6853 int tem
, tem2
, tem3
;
6855 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
6858 struct value
**argvec
;
6862 op
= exp
->elts
[pc
].opcode
;
6869 unwrap_value (evaluate_subexp_standard
6870 (expect_type
, exp
, pos
, noside
));
6874 type
= exp
->elts
[pc
+ 1].type
;
6875 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
6876 if (noside
== EVAL_SKIP
)
6878 if (type
!= check_typedef (VALUE_TYPE (arg1
)))
6880 if (ada_is_fixed_point_type (type
))
6881 arg1
= cast_to_fixed (type
, arg1
);
6882 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6883 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
6884 else if (VALUE_LVAL (arg1
) == lval_memory
)
6886 /* This is in case of the really obscure (and undocumented,
6887 but apparently expected) case of (Foo) Bar.all, where Bar
6888 is an integer constant and Foo is a dynamic-sized type.
6889 If we don't do this, ARG1 will simply be relabeled with
6891 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
6892 return value_zero (to_static_fixed_type (type
), not_lval
);
6895 (type
, 0, VALUE_ADDRESS (arg1
) + VALUE_OFFSET (arg1
), 0);
6898 arg1
= value_cast (type
, arg1
);
6902 /* FIXME: UNOP_QUAL should be defined in expression.h */
6905 type = exp->elts[pc + 1].type;
6906 return ada_evaluate_subexp (type, exp, pos, noside);
6909 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6910 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
6911 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
6913 if (binop_user_defined_p (op
, arg1
, arg2
))
6914 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6917 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6918 arg2
= cast_to_fixed (VALUE_TYPE (arg1
), arg2
);
6919 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6921 ("Fixed-point values must be assigned to fixed-point variables");
6923 arg2
= coerce_for_assign (VALUE_TYPE (arg1
), arg2
);
6924 return ada_value_assign (arg1
, arg2
);
6928 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6929 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6930 if (noside
== EVAL_SKIP
)
6932 if (binop_user_defined_p (op
, arg1
, arg2
))
6933 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6936 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6937 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6938 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6940 ("Operands of fixed-point addition must have the same type");
6941 return value_cast (VALUE_TYPE (arg1
), value_add (arg1
, arg2
));
6945 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6946 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6947 if (noside
== EVAL_SKIP
)
6949 if (binop_user_defined_p (op
, arg1
, arg2
))
6950 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6953 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6954 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6955 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6957 ("Operands of fixed-point subtraction must have the same type");
6958 return value_cast (VALUE_TYPE (arg1
), value_sub (arg1
, arg2
));
6963 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6964 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6965 if (noside
== EVAL_SKIP
)
6967 if (binop_user_defined_p (op
, arg1
, arg2
))
6968 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6970 if (noside
== EVAL_AVOID_SIDE_EFFECTS
6971 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
6972 return value_zero (VALUE_TYPE (arg1
), not_lval
);
6975 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6976 arg1
= cast_from_fixed_to_double (arg1
);
6977 if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6978 arg2
= cast_from_fixed_to_double (arg2
);
6979 return value_binop (arg1
, arg2
, op
);
6983 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6984 if (noside
== EVAL_SKIP
)
6986 if (unop_user_defined_p (op
, arg1
))
6987 return value_x_unop (arg1
, op
, EVAL_NORMAL
);
6988 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6989 return value_cast (VALUE_TYPE (arg1
), value_neg (arg1
));
6991 return value_neg (arg1
);
6993 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
6994 /* case OP_UNRESOLVED_VALUE:
6995 /* Only encountered when an unresolved symbol occurs in a
6996 context other than a function call, in which case, it is
6999 if (noside == EVAL_SKIP)
7002 error ("Unexpected unresolved symbol, %s, during evaluation",
7003 ada_demangle (exp->elts[pc + 2].name));
7007 if (noside
== EVAL_SKIP
)
7012 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7016 (to_static_fixed_type
7017 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
7023 unwrap_value (evaluate_subexp_standard
7024 (expect_type
, exp
, pos
, noside
));
7025 return ada_to_fixed_value (VALUE_TYPE (arg1
), 0,
7026 VALUE_ADDRESS (arg1
) +
7027 VALUE_OFFSET (arg1
), arg1
);
7032 tem2
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7033 tem3
= longest_to_int (exp
->elts
[pc
+ 2].longconst
);
7034 nargs
= tem3
- tem2
+ 1;
7035 type
= expect_type
? check_typedef (expect_type
) : NULL_TYPE
;
7038 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
7039 for (tem
= 0; tem
== 0 || tem
< nargs
; tem
+= 1)
7040 /* At least one element gets inserted for the type */
7042 /* Ensure that array expressions are coerced into pointer objects. */
7043 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
7045 if (noside
== EVAL_SKIP
)
7047 return value_array (tem2
, tem3
, argvec
);
7052 /* Allocate arg vector, including space for the function to be
7053 called in argvec[0] and a terminating NULL */
7054 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7056 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 2));
7058 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7059 /* FIXME: name should be defined in expresion.h */
7060 /* if (exp->elts[*pos].opcode == OP_UNRESOLVED_VALUE)
7061 error ("Unexpected unresolved symbol, %s, during evaluation",
7062 ada_demangle (exp->elts[pc + 5].name));
7066 error ("unexpected code path, FIXME");
7070 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7071 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7074 if (noside
== EVAL_SKIP
)
7078 if (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_REF
)
7079 argvec
[0] = value_addr (argvec
[0]);
7081 if (ada_is_packed_array_type (VALUE_TYPE (argvec
[0])))
7082 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7084 type
= check_typedef (VALUE_TYPE (argvec
[0]));
7085 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7087 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type
))))
7089 case TYPE_CODE_FUNC
:
7090 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7092 case TYPE_CODE_ARRAY
:
7094 case TYPE_CODE_STRUCT
:
7095 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7096 argvec
[0] = ada_value_ind (argvec
[0]);
7097 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7100 error ("cannot subscript or call something of type `%s'",
7101 ada_type_name (VALUE_TYPE (argvec
[0])));
7106 switch (TYPE_CODE (type
))
7108 case TYPE_CODE_FUNC
:
7109 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7110 return allocate_value (TYPE_TARGET_TYPE (type
));
7111 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7112 case TYPE_CODE_STRUCT
:
7114 int arity
= ada_array_arity (type
);
7115 type
= ada_array_element_type (type
, nargs
);
7117 error ("cannot subscript or call a record");
7119 error ("wrong number of subscripts; expecting %d", arity
);
7120 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7121 return allocate_value (ada_aligned_type (type
));
7123 unwrap_value (ada_value_subscript
7124 (argvec
[0], nargs
, argvec
+ 1));
7126 case TYPE_CODE_ARRAY
:
7127 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7129 type
= ada_array_element_type (type
, nargs
);
7131 error ("element type of array unknown");
7133 return allocate_value (ada_aligned_type (type
));
7136 unwrap_value (ada_value_subscript
7137 (ada_coerce_to_simple_array (argvec
[0]),
7138 nargs
, argvec
+ 1));
7139 case TYPE_CODE_PTR
: /* Pointer to array */
7140 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7141 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7143 type
= ada_array_element_type (type
, nargs
);
7145 error ("element type of array unknown");
7147 return allocate_value (ada_aligned_type (type
));
7150 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7151 nargs
, argvec
+ 1));
7154 error ("Internal error in evaluate_subexp");
7159 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7161 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7163 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7164 if (noside
== EVAL_SKIP
)
7167 /* If this is a reference to an array, then dereference it */
7168 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
7169 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7170 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7172 && !ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7174 array
= ada_coerce_ref (array
);
7177 if (noside
== EVAL_AVOID_SIDE_EFFECTS
&&
7178 ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7180 /* Try to dereference the array, in case it is an access to array */
7181 struct type
*arrType
= ada_type_of_array (array
, 0);
7182 if (arrType
!= NULL
)
7183 array
= value_at_lazy (arrType
, 0, NULL
);
7185 if (ada_is_array_descriptor (VALUE_TYPE (array
)))
7186 array
= ada_coerce_to_simple_array (array
);
7188 /* If at this point we have a pointer to an array, it means that
7189 it is a pointer to a simple (non-ada) array. We just then
7191 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
7192 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7193 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7196 array
= ada_value_ind (array
);
7199 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7200 /* The following will get the bounds wrong, but only in contexts
7201 where the value is not being requested (FIXME?). */
7204 return value_slice (array
, lowbound
, upper
- lowbound
+ 1);
7207 /* FIXME: UNOP_MBR should be defined in expression.h */
7210 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7211 type = exp->elts[pc + 1].type;
7213 if (noside == EVAL_SKIP)
7216 switch (TYPE_CODE (type))
7219 warning ("Membership test incompletely implemented; always returns true");
7220 return value_from_longest (builtin_type_int, (LONGEST) 1);
7222 case TYPE_CODE_RANGE:
7223 arg2 = value_from_longest (builtin_type_int,
7224 (LONGEST) TYPE_LOW_BOUND (type));
7225 arg3 = value_from_longest (builtin_type_int,
7226 (LONGEST) TYPE_HIGH_BOUND (type));
7228 value_from_longest (builtin_type_int,
7229 (value_less (arg1,arg3)
7230 || value_equal (arg1,arg3))
7231 && (value_less (arg2,arg1)
7232 || value_equal (arg2,arg1)));
7235 /* FIXME: BINOP_MBR should be defined in expression.h */
7238 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7239 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7241 if (noside == EVAL_SKIP)
7244 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7245 return value_zero (builtin_type_int, not_lval);
7247 tem = longest_to_int (exp->elts[pc + 1].longconst);
7249 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
7250 error ("invalid dimension number to '%s", "range");
7252 arg3 = ada_array_bound (arg2, tem, 1);
7253 arg2 = ada_array_bound (arg2, tem, 0);
7256 value_from_longest (builtin_type_int,
7257 (value_less (arg1,arg3)
7258 || value_equal (arg1,arg3))
7259 && (value_less (arg2,arg1)
7260 || value_equal (arg2,arg1)));
7262 /* FIXME: TERNOP_MBR should be defined in expression.h */
7264 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7265 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7266 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7268 if (noside == EVAL_SKIP)
7272 value_from_longest (builtin_type_int,
7273 (value_less (arg1,arg3)
7274 || value_equal (arg1,arg3))
7275 && (value_less (arg2,arg1)
7276 || value_equal (arg2,arg1)));
7278 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
7279 /* case OP_ATTRIBUTE:
7281 atr = (enum ada_attribute) longest_to_int (exp->elts[pc + 2].longconst);
7285 error ("unexpected attribute encountered");
7291 struct type* type_arg;
7292 if (exp->elts[*pos].opcode == OP_TYPE)
7294 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7296 type_arg = exp->elts[pc + 5].type;
7300 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7304 if (exp->elts[*pos].opcode != OP_LONG)
7305 error ("illegal operand to '%s", ada_attribute_name (atr));
7306 tem = longest_to_int (exp->elts[*pos+2].longconst);
7309 if (noside == EVAL_SKIP)
7312 if (type_arg == NULL)
7314 arg1 = ada_coerce_ref (arg1);
7316 if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
7317 arg1 = ada_coerce_to_simple_array (arg1);
7319 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
7320 error ("invalid dimension number to '%s",
7321 ada_attribute_name (atr));
7323 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7325 type = ada_index_type (VALUE_TYPE (arg1), tem);
7327 error ("attempt to take bound of something that is not an array");
7328 return allocate_value (type);
7334 error ("unexpected attribute encountered");
7336 return ada_array_bound (arg1, tem, 0);
7338 return ada_array_bound (arg1, tem, 1);
7340 return ada_array_length (arg1, tem);
7343 else if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE
7344 || TYPE_CODE (type_arg) == TYPE_CODE_INT)
7346 struct type* range_type;
7347 char* name = ada_type_name (type_arg);
7350 if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE)
7351 range_type = type_arg;
7353 error ("unimplemented type attribute");
7357 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
7361 error ("unexpected attribute encountered");
7363 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7364 TYPE_LOW_BOUND (range_type));
7366 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7367 TYPE_HIGH_BOUND (range_type));
7370 else if (TYPE_CODE (type_arg) == TYPE_CODE_ENUM)
7375 error ("unexpected attribute encountered");
7377 return value_from_longest
7378 (type_arg, TYPE_FIELD_BITPOS (type_arg, 0));
7380 return value_from_longest
7382 TYPE_FIELD_BITPOS (type_arg,
7383 TYPE_NFIELDS (type_arg) - 1));
7386 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
7387 error ("unimplemented type attribute");
7392 if (ada_is_packed_array_type (type_arg))
7393 type_arg = decode_packed_array_type (type_arg);
7395 if (tem < 1 || tem > ada_array_arity (type_arg))
7396 error ("invalid dimension number to '%s",
7397 ada_attribute_name (atr));
7399 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7401 type = ada_index_type (type_arg, tem);
7403 error ("attempt to take bound of something that is not an array");
7404 return allocate_value (type);
7410 error ("unexpected attribute encountered");
7412 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7413 return value_from_longest (type, low);
7415 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
7416 return value_from_longest (type, high);
7418 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7419 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
7420 return value_from_longest (type, high-low+1);
7426 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7427 if (noside == EVAL_SKIP)
7430 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7432 value_zero (ada_tag_type (arg1), not_lval);
7434 return ada_value_tag (arg1);
7438 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7439 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7440 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7441 if (noside == EVAL_SKIP)
7443 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7444 return value_zero (VALUE_TYPE (arg1), not_lval);
7446 return value_binop (arg1, arg2,
7447 atr == ATR_MIN ? BINOP_MIN : BINOP_MAX);
7451 struct type* type_arg = exp->elts[pc + 5].type;
7452 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7455 if (noside == EVAL_SKIP)
7458 if (! ada_is_modular_type (type_arg))
7459 error ("'modulus must be applied to modular type");
7461 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
7462 ada_modulus (type_arg));
7467 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7468 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7469 if (noside == EVAL_SKIP)
7471 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7472 return value_zero (builtin_type_ada_int, not_lval);
7474 return value_pos_atr (arg1);
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_from_longest (builtin_type_ada_int,
7485 * TYPE_LENGTH (VALUE_TYPE (arg1)));
7488 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7489 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7490 type = exp->elts[pc + 5].type;
7491 if (noside == EVAL_SKIP)
7493 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7494 return value_zero (type, not_lval);
7496 return value_val_atr (type, arg1);
7499 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7500 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7501 if (noside
== EVAL_SKIP
)
7503 if (binop_user_defined_p (op
, arg1
, arg2
))
7504 return unwrap_value (value_x_binop (arg1
, arg2
, op
, OP_NULL
,
7506 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7507 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7509 return value_binop (arg1
, arg2
, op
);
7512 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7513 if (noside
== EVAL_SKIP
)
7515 if (unop_user_defined_p (op
, arg1
))
7516 return unwrap_value (value_x_unop (arg1
, op
, EVAL_NORMAL
));
7521 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7522 if (noside
== EVAL_SKIP
)
7524 if (value_less (arg1
, value_zero (VALUE_TYPE (arg1
), not_lval
)))
7525 return value_neg (arg1
);
7530 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
7531 expect_type
= TYPE_TARGET_TYPE (check_typedef (expect_type
));
7532 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
7533 if (noside
== EVAL_SKIP
)
7535 type
= check_typedef (VALUE_TYPE (arg1
));
7536 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7538 if (ada_is_array_descriptor (type
))
7539 /* GDB allows dereferencing GNAT array descriptors. */
7541 struct type
*arrType
= ada_type_of_array (arg1
, 0);
7542 if (arrType
== NULL
)
7543 error ("Attempt to dereference null array pointer.");
7544 return value_at_lazy (arrType
, 0, NULL
);
7546 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
7547 || TYPE_CODE (type
) == TYPE_CODE_REF
7548 /* In C you can dereference an array to get the 1st elt. */
7549 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7552 (to_static_fixed_type
7553 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type
)))),
7555 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
7556 /* GDB allows dereferencing an int. */
7557 return value_zero (builtin_type_int
, lval_memory
);
7559 error ("Attempt to take contents of a non-pointer value.");
7561 arg1
= ada_coerce_ref (arg1
);
7562 type
= check_typedef (VALUE_TYPE (arg1
));
7564 if (ada_is_array_descriptor (type
))
7565 /* GDB allows dereferencing GNAT array descriptors. */
7566 return ada_coerce_to_simple_array (arg1
);
7568 return ada_value_ind (arg1
);
7570 case STRUCTOP_STRUCT
:
7571 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7572 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7573 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7574 if (noside
== EVAL_SKIP
)
7576 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7577 return value_zero (ada_aligned_type
7578 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7584 return unwrap_value (ada_value_struct_elt (arg1
,
7585 &exp
->elts
[pc
+ 2].string
,
7588 /* The value is not supposed to be used. This is here to make it
7589 easier to accommodate expressions that contain types. */
7591 if (noside
== EVAL_SKIP
)
7593 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7594 return allocate_value (builtin_type_void
);
7596 error ("Attempt to use a type name as an expression");
7599 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7600 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7601 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7602 if (noside
== EVAL_SKIP
)
7604 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7605 return value_zero (ada_aligned_type
7606 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7612 return unwrap_value (ada_value_struct_elt (arg1
,
7613 &exp
->elts
[pc
+ 2].string
,
7618 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
7624 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7625 type name that encodes the 'small and 'delta information.
7626 Otherwise, return NULL. */
7629 fixed_type_info (struct type
*type
)
7631 const char *name
= ada_type_name (type
);
7632 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
7634 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
7636 const char *tail
= strstr (name
, "___XF_");
7642 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
7643 return fixed_type_info (TYPE_TARGET_TYPE (type
));
7648 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7651 ada_is_fixed_point_type (struct type
*type
)
7653 return fixed_type_info (type
) != NULL
;
7656 /* Assuming that TYPE is the representation of an Ada fixed-point
7657 type, return its delta, or -1 if the type is malformed and the
7658 delta cannot be determined. */
7661 ada_delta (struct type
*type
)
7663 const char *encoding
= fixed_type_info (type
);
7666 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
7669 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
7672 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7673 factor ('SMALL value) associated with the type. */
7676 scaling_factor (struct type
*type
)
7678 const char *encoding
= fixed_type_info (type
);
7679 unsigned long num0
, den0
, num1
, den1
;
7682 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
7687 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
7689 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
7693 /* Assuming that X is the representation of a value of fixed-point
7694 type TYPE, return its floating-point equivalent. */
7697 ada_fixed_to_float (struct type
*type
, LONGEST x
)
7699 return (DOUBLEST
) x
*scaling_factor (type
);
7702 /* The representation of a fixed-point value of type TYPE
7703 corresponding to the value X. */
7706 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
7708 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
7712 /* VAX floating formats */
7714 /* Non-zero iff TYPE represents one of the special VAX floating-point
7717 ada_is_vax_floating_type (struct type
*type
)
7720 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
7723 && (TYPE_CODE (type
) == TYPE_CODE_INT
7724 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7725 && STREQN (ada_type_name (type
) + name_len
- 6, "___XF", 5);
7728 /* The type of special VAX floating-point type this is, assuming
7729 ada_is_vax_floating_point */
7731 ada_vax_float_type_suffix (struct type
*type
)
7733 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
7736 /* A value representing the special debugging function that outputs
7737 VAX floating-point values of the type represented by TYPE. Assumes
7738 ada_is_vax_floating_type (TYPE). */
7740 ada_vax_float_print_function (struct type
*type
)
7742 switch (ada_vax_float_type_suffix (type
))
7745 return get_var_value ("DEBUG_STRING_F", 0);
7747 return get_var_value ("DEBUG_STRING_D", 0);
7749 return get_var_value ("DEBUG_STRING_G", 0);
7751 error ("invalid VAX floating-point type");
7758 /* Scan STR beginning at position K for a discriminant name, and
7759 return the value of that discriminant field of DVAL in *PX. If
7760 PNEW_K is not null, put the position of the character beyond the
7761 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
7762 not alter *PX and *PNEW_K if unsuccessful. */
7765 scan_discrim_bound (char *, int k
, struct value
*dval
, LONGEST
* px
,
7768 static char *bound_buffer
= NULL
;
7769 static size_t bound_buffer_len
= 0;
7772 struct value
*bound_val
;
7774 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
7777 pend
= strstr (str
+ k
, "__");
7781 k
+= strlen (bound
);
7785 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
7786 bound
= bound_buffer
;
7787 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
7788 bound
[pend
- (str
+ k
)] = '\0';
7792 bound_val
= ada_search_struct_field (bound
, dval
, 0, VALUE_TYPE (dval
));
7793 if (bound_val
== NULL
)
7796 *px
= value_as_long (bound_val
);
7802 /* Value of variable named NAME in the current environment. If
7803 no such variable found, then if ERR_MSG is null, returns 0, and
7804 otherwise causes an error with message ERR_MSG. */
7805 static struct value
*
7806 get_var_value (char *name
, char *err_msg
)
7808 struct symbol
**syms
;
7809 struct block
**blocks
;
7813 ada_lookup_symbol_list (name
, get_selected_block (NULL
), VAR_NAMESPACE
,
7818 if (err_msg
== NULL
)
7821 error ("%s", err_msg
);
7824 return value_of_variable (syms
[0], blocks
[0]);
7827 /* Value of integer variable named NAME in the current environment. If
7828 no such variable found, then if ERR_MSG is null, returns 0, and sets
7829 *FLAG to 0. If successful, sets *FLAG to 1. */
7831 get_int_var_value (char *name
, char *err_msg
, int *flag
)
7833 struct value
*var_val
= get_var_value (name
, err_msg
);
7845 return value_as_long (var_val
);
7850 /* Return a range type whose base type is that of the range type named
7851 NAME in the current environment, and whose bounds are calculated
7852 from NAME according to the GNAT range encoding conventions.
7853 Extract discriminant values, if needed, from DVAL. If a new type
7854 must be created, allocate in OBJFILE's space. The bounds
7855 information, in general, is encoded in NAME, the base type given in
7856 the named range type. */
7858 static struct type
*
7859 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
7861 struct type
*raw_type
= ada_find_any_type (name
);
7862 struct type
*base_type
;
7866 if (raw_type
== NULL
)
7867 base_type
= builtin_type_int
;
7868 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
7869 base_type
= TYPE_TARGET_TYPE (raw_type
);
7871 base_type
= raw_type
;
7873 subtype_info
= strstr (name
, "___XD");
7874 if (subtype_info
== NULL
)
7878 static char *name_buf
= NULL
;
7879 static size_t name_len
= 0;
7880 int prefix_len
= subtype_info
- name
;
7886 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
7887 strncpy (name_buf
, name
, prefix_len
);
7888 name_buf
[prefix_len
] = '\0';
7891 bounds_str
= strchr (subtype_info
, '_');
7894 if (*subtype_info
== 'L')
7896 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
7897 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
7899 if (bounds_str
[n
] == '_')
7901 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
7907 strcpy (name_buf
+ prefix_len
, "___L");
7908 L
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7911 if (*subtype_info
== 'U')
7913 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
7914 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
7919 strcpy (name_buf
+ prefix_len
, "___U");
7920 U
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7923 if (objfile
== NULL
)
7924 objfile
= TYPE_OBJFILE (base_type
);
7925 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
7926 TYPE_NAME (type
) = name
;
7931 /* True iff NAME is the name of a range type. */
7933 ada_is_range_type_name (const char *name
)
7935 return (name
!= NULL
&& strstr (name
, "___XD"));
7941 /* True iff TYPE is an Ada modular type. */
7943 ada_is_modular_type (struct type
*type
)
7945 /* FIXME: base_type should be declared in gdbtypes.h, implemented in
7947 struct type
*subranged_type
; /* = base_type (type); */
7949 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
7950 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
7951 && TYPE_UNSIGNED (subranged_type
));
7954 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
7956 ada_modulus (struct type
* type
)
7958 return TYPE_HIGH_BOUND (type
) + 1;
7965 /* Table mapping opcodes into strings for printing operators
7966 and precedences of the operators. */
7968 static const struct op_print ada_op_print_tab
[] = {
7969 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
7970 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
7971 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
7972 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
7973 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
7974 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
7975 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
7976 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
7977 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
7978 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
7979 {">", BINOP_GTR
, PREC_ORDER
, 0},
7980 {"<", BINOP_LESS
, PREC_ORDER
, 0},
7981 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
7982 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
7983 {"+", BINOP_ADD
, PREC_ADD
, 0},
7984 {"-", BINOP_SUB
, PREC_ADD
, 0},
7985 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
7986 {"*", BINOP_MUL
, PREC_MUL
, 0},
7987 {"/", BINOP_DIV
, PREC_MUL
, 0},
7988 {"rem", BINOP_REM
, PREC_MUL
, 0},
7989 {"mod", BINOP_MOD
, PREC_MUL
, 0},
7990 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
7991 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
7992 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
7993 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
7994 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
7995 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
7996 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
7997 {".all", UNOP_IND
, PREC_SUFFIX
, 1}, /* FIXME: postfix .ALL */
7998 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1}, /* FIXME: postfix 'ACCESS */
8002 /* Assorted Types and Interfaces */
8004 struct type
*builtin_type_ada_int
;
8005 struct type
*builtin_type_ada_short
;
8006 struct type
*builtin_type_ada_long
;
8007 struct type
*builtin_type_ada_long_long
;
8008 struct type
*builtin_type_ada_char
;
8009 struct type
*builtin_type_ada_float
;
8010 struct type
*builtin_type_ada_double
;
8011 struct type
*builtin_type_ada_long_double
;
8012 struct type
*builtin_type_ada_natural
;
8013 struct type
*builtin_type_ada_positive
;
8014 struct type
*builtin_type_ada_system_address
;
8016 struct type
**const (ada_builtin_types
[]) =
8019 &builtin_type_ada_int
,
8020 &builtin_type_ada_long
,
8021 &builtin_type_ada_short
,
8022 &builtin_type_ada_char
,
8023 &builtin_type_ada_float
,
8024 &builtin_type_ada_double
,
8025 &builtin_type_ada_long_long
,
8026 &builtin_type_ada_long_double
,
8027 &builtin_type_ada_natural
, &builtin_type_ada_positive
,
8028 /* The following types are carried over from C for convenience. */
8031 &builtin_type_short
,
8033 &builtin_type_float
,
8034 &builtin_type_double
,
8035 &builtin_type_long_long
,
8037 &builtin_type_signed_char
,
8038 &builtin_type_unsigned_char
,
8039 &builtin_type_unsigned_short
,
8040 &builtin_type_unsigned_int
,
8041 &builtin_type_unsigned_long
,
8042 &builtin_type_unsigned_long_long
,
8043 &builtin_type_long_double
,
8044 &builtin_type_complex
, &builtin_type_double_complex
, 0};
8046 /* Not really used, but needed in the ada_language_defn. */
8048 emit_char (int c
, struct ui_file
*stream
, int quoter
)
8050 ada_emit_char (c
, stream
, quoter
, 1);
8053 const struct language_defn ada_language_defn
= {
8054 "ada", /* Language name */
8057 /* FIXME: language_ada should be defined in defs.h */
8061 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8062 * that's not quite what this means. */
8065 ada_evaluate_subexp
,
8066 ada_printchar
, /* Print a character constant */
8067 ada_printstr
, /* Function to print string constant */
8068 emit_char
, /* Function to print single char (not used) */
8069 ada_create_fundamental_type
, /* Create fundamental type in this language */
8070 ada_print_type
, /* Print a type using appropriate syntax */
8071 ada_val_print
, /* Print a value using appropriate syntax */
8072 ada_value_print
, /* Print a top-level value */
8073 {"", "", "", ""}, /* Binary format info */
8075 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
8076 {"%ld", "", "d", ""}, /* Decimal format info */
8077 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
8079 /* Copied from c-lang.c. */
8080 {"0%lo", "0", "o", ""}, /* Octal format info */
8081 {"%ld", "", "d", ""}, /* Decimal format info */
8082 {"0x%lx", "0x", "x", ""}, /* Hex format info */
8084 ada_op_print_tab
, /* expression operators for printing */
8085 1, /* c-style arrays (FIXME?) */
8086 0, /* String lower bound (FIXME?) */
8087 &builtin_type_ada_char
,
8092 _initialize_ada_language (void)
8094 builtin_type_ada_int
=
8095 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8096 0, "integer", (struct objfile
*) NULL
);
8097 builtin_type_ada_long
=
8098 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8099 0, "long_integer", (struct objfile
*) NULL
);
8100 builtin_type_ada_short
=
8101 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8102 0, "short_integer", (struct objfile
*) NULL
);
8103 builtin_type_ada_char
=
8104 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8105 0, "character", (struct objfile
*) NULL
);
8106 builtin_type_ada_float
=
8107 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8108 0, "float", (struct objfile
*) NULL
);
8109 builtin_type_ada_double
=
8110 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8111 0, "long_float", (struct objfile
*) NULL
);
8112 builtin_type_ada_long_long
=
8113 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8114 0, "long_long_integer", (struct objfile
*) NULL
);
8115 builtin_type_ada_long_double
=
8116 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8117 0, "long_long_float", (struct objfile
*) NULL
);
8118 builtin_type_ada_natural
=
8119 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8120 0, "natural", (struct objfile
*) NULL
);
8121 builtin_type_ada_positive
=
8122 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8123 0, "positive", (struct objfile
*) NULL
);
8126 builtin_type_ada_system_address
=
8127 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8128 (struct objfile
*) NULL
));
8129 TYPE_NAME (builtin_type_ada_system_address
) = "system__address";
8131 add_language (&ada_language_defn
);
8134 (add_set_cmd ("varsize-limit", class_support
, var_uinteger
,
8135 (char *) &varsize_limit
,
8136 "Set maximum bytes in dynamic-sized object.",
8137 &setlist
), &showlist
);
8138 varsize_limit
= 65536;
8140 add_com ("begin", class_breakpoint
, begin_command
,
8141 "Start the debugged program, stopping at the beginning of the\n\
8142 main program. You may specify command-line arguments to give it, as for\n\
8143 the \"run\" command (q.v.).");
8147 /* Create a fundamental Ada type using default reasonable for the current
8150 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8151 define fundamental types such as "int" or "double". Others (stabs or
8152 DWARF version 2, etc) do define fundamental types. For the formats which
8153 don't provide fundamental types, gdb can create such types using this
8156 FIXME: Some compilers distinguish explicitly signed integral types
8157 (signed short, signed int, signed long) from "regular" integral types
8158 (short, int, long) in the debugging information. There is some dis-
8159 agreement as to how useful this feature is. In particular, gcc does
8160 not support this. Also, only some debugging formats allow the
8161 distinction to be passed on to a debugger. For now, we always just
8162 use "short", "int", or "long" as the type name, for both the implicit
8163 and explicitly signed types. This also makes life easier for the
8164 gdb test suite since we don't have to account for the differences
8165 in output depending upon what the compiler and debugging format
8166 support. We will probably have to re-examine the issue when gdb
8167 starts taking it's fundamental type information directly from the
8168 debugging information supplied by the compiler. fnf@cygnus.com */
8170 static struct type
*
8171 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8173 struct type
*type
= NULL
;
8178 /* FIXME: For now, if we are asked to produce a type not in this
8179 language, create the equivalent of a C integer type with the
8180 name "<?type?>". When all the dust settles from the type
8181 reconstruction work, this should probably become an error. */
8182 type
= init_type (TYPE_CODE_INT
,
8183 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8184 0, "<?type?>", objfile
);
8185 warning ("internal error: no Ada fundamental type %d", typeid);
8188 type
= init_type (TYPE_CODE_VOID
,
8189 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8190 0, "void", objfile
);
8193 type
= init_type (TYPE_CODE_INT
,
8194 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8195 0, "character", objfile
);
8197 case FT_SIGNED_CHAR
:
8198 type
= init_type (TYPE_CODE_INT
,
8199 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8200 0, "signed char", objfile
);
8202 case FT_UNSIGNED_CHAR
:
8203 type
= init_type (TYPE_CODE_INT
,
8204 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8205 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8208 type
= init_type (TYPE_CODE_INT
,
8209 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8210 0, "short_integer", objfile
);
8212 case FT_SIGNED_SHORT
:
8213 type
= init_type (TYPE_CODE_INT
,
8214 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8215 0, "short_integer", objfile
);
8217 case FT_UNSIGNED_SHORT
:
8218 type
= init_type (TYPE_CODE_INT
,
8219 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8220 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8223 type
= init_type (TYPE_CODE_INT
,
8224 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8225 0, "integer", objfile
);
8227 case FT_SIGNED_INTEGER
:
8228 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
, 0, "integer", objfile
); /* FIXME -fnf */
8230 case FT_UNSIGNED_INTEGER
:
8231 type
= init_type (TYPE_CODE_INT
,
8232 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8233 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8236 type
= init_type (TYPE_CODE_INT
,
8237 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8238 0, "long_integer", objfile
);
8240 case FT_SIGNED_LONG
:
8241 type
= init_type (TYPE_CODE_INT
,
8242 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8243 0, "long_integer", objfile
);
8245 case FT_UNSIGNED_LONG
:
8246 type
= init_type (TYPE_CODE_INT
,
8247 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8248 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8251 type
= init_type (TYPE_CODE_INT
,
8252 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8253 0, "long_long_integer", objfile
);
8255 case FT_SIGNED_LONG_LONG
:
8256 type
= init_type (TYPE_CODE_INT
,
8257 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8258 0, "long_long_integer", objfile
);
8260 case FT_UNSIGNED_LONG_LONG
:
8261 type
= init_type (TYPE_CODE_INT
,
8262 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8263 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8266 type
= init_type (TYPE_CODE_FLT
,
8267 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8268 0, "float", objfile
);
8270 case FT_DBL_PREC_FLOAT
:
8271 type
= init_type (TYPE_CODE_FLT
,
8272 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8273 0, "long_float", objfile
);
8275 case FT_EXT_PREC_FLOAT
:
8276 type
= init_type (TYPE_CODE_FLT
,
8277 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8278 0, "long_long_float", objfile
);
8285 ada_dump_symtab (struct symtab
*s
)
8288 fprintf (stderr
, "New symtab: [\n");
8289 fprintf (stderr
, " Name: %s/%s;\n",
8290 s
->dirname
? s
->dirname
: "?", s
->filename
? s
->filename
: "?");
8291 fprintf (stderr
, " Format: %s;\n", s
->debugformat
);
8292 if (s
->linetable
!= NULL
)
8294 fprintf (stderr
, " Line table (section %d):\n", s
->block_line_section
);
8295 for (i
= 0; i
< s
->linetable
->nitems
; i
+= 1)
8297 struct linetable_entry
*e
= s
->linetable
->item
+ i
;
8298 fprintf (stderr
, " %4ld: %8lx\n", (long) e
->line
, (long) e
->pc
);
8301 fprintf (stderr
, "]\n");