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. */
29 #include "expression.h"
30 #include "parser-defs.h"
36 #include "breakpoint.h"
43 struct cleanup
* unresolved_names
;
45 void extract_string (CORE_ADDR addr
, char *buf
);
47 static struct type
* ada_create_fundamental_type (struct objfile
*, int);
49 static void modify_general_field (char *, LONGEST
, int, int);
51 static struct type
* desc_base_type (struct type
*);
53 static struct type
* desc_bounds_type (struct type
*);
55 static struct value
* desc_bounds (struct value
*);
57 static int fat_pntr_bounds_bitpos (struct type
*);
59 static int fat_pntr_bounds_bitsize (struct type
*);
61 static struct type
* desc_data_type (struct type
*);
63 static struct value
* desc_data (struct value
*);
65 static int fat_pntr_data_bitpos (struct type
*);
67 static int fat_pntr_data_bitsize (struct type
*);
69 static struct value
* desc_one_bound (struct value
*, int, int);
71 static int desc_bound_bitpos (struct type
*, int, int);
73 static int desc_bound_bitsize (struct type
*, int, int);
75 static struct type
* desc_index_type (struct type
*, int);
77 static int desc_arity (struct type
*);
79 static int ada_type_match (struct type
*, struct type
*, int);
81 static int ada_args_match (struct symbol
*, struct value
**, int);
83 static struct value
* place_on_stack (struct value
*, CORE_ADDR
*);
85 static struct value
* convert_actual (struct value
*, struct type
*, CORE_ADDR
*);
87 static struct value
* make_array_descriptor (struct type
*, struct value
*, CORE_ADDR
*);
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
*
99 ada_lookup_partial_symbol (struct partial_symtab
*, const char*,
100 int, namespace_enum
, int);
102 static struct symtab
* symtab_for_sym (struct symbol
*);
104 static struct value
* ada_resolve_subexp (struct expression
**, int*, int, struct type
*);
106 static void replace_operator_with_call (struct expression
**, int, int, int,
107 struct symbol
*, struct block
*);
109 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
111 static const char* ada_op_name (enum exp_opcode
);
113 static int numeric_type_p (struct type
*);
115 static int integer_type_p (struct type
*);
117 static int scalar_type_p (struct type
*);
119 static int discrete_type_p (struct type
*);
121 static char* extended_canonical_line_spec (struct symtab_and_line
, const char*);
123 static struct value
* evaluate_subexp (struct type
*, struct expression
*, int*, enum noside
);
125 static struct value
* evaluate_subexp_type (struct expression
*, int*);
127 static struct type
* ada_create_fundamental_type (struct objfile
*, int);
129 static int is_dynamic_field (struct type
*, int);
132 to_fixed_variant_branch_type (struct type
*, char*, CORE_ADDR
, struct value
*);
134 static struct type
* to_fixed_range_type (char*, struct value
*, struct objfile
*);
136 static struct type
* to_static_fixed_type (struct type
*);
138 static struct value
* unwrap_value (struct value
*);
140 static struct type
* packed_array_type (struct type
*, long*);
142 static struct type
* decode_packed_array_type (struct type
*);
144 static struct value
* decode_packed_array (struct value
*);
146 static struct value
* value_subscript_packed (struct value
*, int, struct value
**);
148 static struct value
* coerce_unspec_val_to_type (struct value
*, long, struct type
*);
150 static struct value
* get_var_value (char*, char*);
152 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
154 static int equiv_types (struct type
*, struct type
*);
156 static int is_name_suffix (const char*);
158 static int wild_match (const char*, int, const char*);
160 static struct symtabs_and_lines
find_sal_from_funcs_and_line (const char*, int, struct symbol
**, int);
163 find_line_in_linetable (struct linetable
*, int, struct symbol
**, int, int*);
165 static int find_next_line_in_linetable (struct linetable
*, int, int, int);
167 static struct symtabs_and_lines
all_sals_for_line (const char*, int, char***);
169 static void read_all_symtabs (const char*);
171 static int is_plausible_func_for_line (struct symbol
*, int);
173 static struct value
* ada_coerce_ref (struct value
*);
175 static struct value
* value_pos_atr (struct value
*);
177 static struct value
* value_val_atr (struct type
*, struct value
*);
179 static struct symbol
* standard_lookup (const char*, namespace_enum
);
181 extern void markTimeStart (int index
);
182 extern void markTimeStop (int index
);
186 /* Maximum-sized dynamic type. */
187 static unsigned int varsize_limit
;
189 static const char* ada_completer_word_break_characters
=
190 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
192 /* The name of the symbol to use to get the name of the main subprogram */
193 #define ADA_MAIN_PROGRAM_SYMBOL_NAME "__gnat_ada_main_program_name"
199 * read the string located at ADDR from the inferior and store the
203 extract_string (CORE_ADDR addr
, char *buf
)
207 /* Loop, reading one byte at a time, until we reach the '\000'
208 end-of-string marker */
211 target_read_memory (addr
+ char_index
* sizeof (char),
212 buf
+ char_index
* sizeof (char),
216 while (buf
[char_index
- 1] != '\000');
219 /* Assuming *OLD_VECT points to an array of *SIZE objects of size
220 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
221 updating *OLD_VECT and *SIZE as necessary. */
224 grow_vect (void** old_vect
, size_t* size
, size_t min_size
, int element_size
)
226 if (*size
< min_size
) {
228 if (*size
< min_size
)
230 *old_vect
= xrealloc (*old_vect
, *size
* element_size
);
234 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
235 suffix of FIELD_NAME beginning "___" */
238 field_name_match (const char *field_name
, const char *target
)
240 int len
= strlen (target
);
242 STREQN (field_name
, target
, len
)
243 && (field_name
[len
] == '\0'
244 || (STREQN (field_name
+ len
, "___", 3)
245 && ! STREQ (field_name
+ strlen (field_name
) - 6, "___XVN")));
249 /* The length of the prefix of NAME prior to any "___" suffix. */
252 ada_name_prefix_len (const char* name
)
258 const char* p
= strstr (name
, "___");
260 return strlen (name
);
266 /* SUFFIX is a suffix of STR. False if STR is null. */
268 is_suffix (const char* str
, const char* suffix
)
274 len2
= strlen (suffix
);
275 return (len1
>= len2
&& STREQ (str
+ len1
- len2
, suffix
));
278 /* Create a value of type TYPE whose contents come from VALADDR, if it
279 * is non-null, and whose memory address (in the inferior) is
282 value_from_contents_and_address (struct type
* type
, char* valaddr
, CORE_ADDR address
)
284 struct value
* v
= allocate_value (type
);
288 memcpy (VALUE_CONTENTS_RAW (v
), valaddr
, TYPE_LENGTH (type
));
289 VALUE_ADDRESS (v
) = address
;
291 VALUE_LVAL (v
) = lval_memory
;
295 /* The contents of value VAL, beginning at offset OFFSET, treated as a
296 value of type TYPE. The result is an lval in memory if VAL is. */
299 coerce_unspec_val_to_type (struct value
* val
, long offset
, struct type
*type
)
301 CHECK_TYPEDEF (type
);
302 if (VALUE_LVAL (val
) == lval_memory
)
303 return value_at_lazy (type
,
304 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
) + offset
, NULL
);
307 struct value
* result
= allocate_value (type
);
308 VALUE_LVAL (result
) = not_lval
;
309 if (VALUE_ADDRESS (val
) == 0)
310 memcpy (VALUE_CONTENTS_RAW (result
), VALUE_CONTENTS (val
) + offset
,
311 TYPE_LENGTH (type
) > TYPE_LENGTH (VALUE_TYPE (val
))
312 ? TYPE_LENGTH (VALUE_TYPE (val
)) : TYPE_LENGTH (type
));
315 VALUE_ADDRESS (result
) =
316 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
) + offset
;
317 VALUE_LAZY (result
) = 1;
324 cond_offset_host (char* valaddr
, long offset
)
329 return valaddr
+ offset
;
333 cond_offset_target (CORE_ADDR address
, long offset
)
338 return address
+ offset
;
341 /* Perform execute_command on the result of concatenating all
342 arguments up to NULL. */
344 do_command (const char* arg
, ...)
355 for (; s
!= NULL
; s
= va_arg (ap
, const char*))
359 cmd1
= alloca (len
+1);
365 execute_command (cmd
, 0);
369 /* Language Selection */
371 /* If the main program is in Ada, return language_ada, otherwise return LANG
372 (the main program is in Ada iif the adainit symbol is found).
374 MAIN_PST is not used. */
377 ada_update_initial_language (enum language lang
, struct partial_symtab
* main_pst
)
379 if (lookup_minimal_symbol ("adainit", (const char*) NULL
,
380 (struct objfile
*) NULL
) != NULL
)
381 /* return language_ada; */
382 /* FIXME: language_ada should be defined in defs.h */
383 return language_unknown
;
391 /* Table of Ada operators and their GNAT-mangled names. Last entry is pair
394 const struct ada_opname_map ada_opname_table
[] =
396 { "Oadd", "\"+\"", BINOP_ADD
},
397 { "Osubtract", "\"-\"", BINOP_SUB
},
398 { "Omultiply", "\"*\"", BINOP_MUL
},
399 { "Odivide", "\"/\"", BINOP_DIV
},
400 { "Omod", "\"mod\"", BINOP_MOD
},
401 { "Orem", "\"rem\"", BINOP_REM
},
402 { "Oexpon", "\"**\"", BINOP_EXP
},
403 { "Olt", "\"<\"", BINOP_LESS
},
404 { "Ole", "\"<=\"", BINOP_LEQ
},
405 { "Ogt", "\">\"", BINOP_GTR
},
406 { "Oge", "\">=\"", BINOP_GEQ
},
407 { "Oeq", "\"=\"", BINOP_EQUAL
},
408 { "One", "\"/=\"", BINOP_NOTEQUAL
},
409 { "Oand", "\"and\"", BINOP_BITWISE_AND
},
410 { "Oor", "\"or\"", BINOP_BITWISE_IOR
},
411 { "Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
412 { "Oconcat", "\"&\"", BINOP_CONCAT
},
413 { "Oabs", "\"abs\"", UNOP_ABS
},
414 { "Onot", "\"not\"", UNOP_LOGICAL_NOT
},
415 { "Oadd", "\"+\"", UNOP_PLUS
},
416 { "Osubtract", "\"-\"", UNOP_NEG
},
420 /* True if STR should be suppressed in info listings. */
422 is_suppressed_name (const char* str
)
424 if (STREQN (str
, "_ada_", 5))
426 if (str
[0] == '_' || str
[0] == '\000')
431 const char* suffix
= strstr (str
, "___");
432 if (suffix
!= NULL
&& suffix
[3] != 'X')
435 suffix
= str
+ strlen (str
);
436 for (p
= suffix
-1; p
!= str
; p
-= 1)
440 if (p
[0] == 'X' && p
[-1] != '_')
444 for (i
= 0; ada_opname_table
[i
].mangled
!= NULL
; i
+= 1)
445 if (STREQN (ada_opname_table
[i
].mangled
, p
,
446 strlen (ada_opname_table
[i
].mangled
)))
455 /* The "mangled" form of DEMANGLED, according to GNAT conventions.
456 * The result is valid until the next call to ada_mangle. */
458 ada_mangle (const char* demangled
)
460 static char* mangling_buffer
= NULL
;
461 static size_t mangling_buffer_size
= 0;
465 if (demangled
== NULL
)
468 GROW_VECT (mangling_buffer
, mangling_buffer_size
, 2*strlen (demangled
) + 10);
471 for (p
= demangled
; *p
!= '\0'; p
+= 1)
475 mangling_buffer
[k
] = mangling_buffer
[k
+1] = '_';
480 const struct ada_opname_map
* mapping
;
482 for (mapping
= ada_opname_table
;
483 mapping
->mangled
!= NULL
&&
484 ! STREQN (mapping
->demangled
, p
, strlen (mapping
->demangled
));
487 if (mapping
->mangled
== NULL
)
488 error ("invalid Ada operator name: %s", p
);
489 strcpy (mangling_buffer
+k
, mapping
->mangled
);
490 k
+= strlen (mapping
->mangled
);
495 mangling_buffer
[k
] = *p
;
500 mangling_buffer
[k
] = '\0';
501 return mangling_buffer
;
504 /* Return NAME folded to lower case, or, if surrounded by single
505 * quotes, unfolded, but with the quotes stripped away. Result good
508 ada_fold_name (const char* name
)
510 static char* fold_buffer
= NULL
;
511 static size_t fold_buffer_size
= 0;
513 int len
= strlen (name
);
514 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+1);
518 strncpy (fold_buffer
, name
+1, len
-2);
519 fold_buffer
[len
-2] = '\000';
524 for (i
= 0; i
<= len
; i
+= 1)
525 fold_buffer
[i
] = tolower (name
[i
]);
532 1. Discard final __{DIGIT}+ or ${DIGIT}+
533 2. Convert other instances of embedded "__" to `.'.
534 3. Discard leading _ada_.
535 4. Convert operator names to the appropriate quoted symbols.
536 5. Remove everything after first ___ if it is followed by
538 6. Replace TK__ with __, and a trailing B or TKB with nothing.
539 7. Put symbols that should be suppressed in <...> brackets.
540 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
541 The resulting string is valid until the next call of ada_demangle.
545 ada_demangle (const char* mangled
)
552 static char* demangling_buffer
= NULL
;
553 static size_t demangling_buffer_size
= 0;
555 if (STREQN (mangled
, "_ada_", 5))
558 if (mangled
[0] == '_' || mangled
[0] == '<')
561 p
= strstr (mangled
, "___");
563 len0
= strlen (mangled
);
571 if (len0
> 3 && STREQ (mangled
+ len0
- 3, "TKB"))
573 if (len0
> 1 && STREQ (mangled
+ len0
- 1, "B"))
576 /* Make demangled big enough for possible expansion by operator name. */
577 GROW_VECT (demangling_buffer
, demangling_buffer_size
, 2*len0
+1);
578 demangled
= demangling_buffer
;
580 if (isdigit (mangled
[len0
- 1])) {
581 for (i
= len0
-2; i
>= 0 && isdigit (mangled
[i
]); i
-= 1)
583 if (i
> 1 && mangled
[i
] == '_' && mangled
[i
-1] == '_')
585 else if (mangled
[i
] == '$')
589 for (i
= 0, j
= 0; i
< len0
&& ! isalpha (mangled
[i
]); i
+= 1, j
+= 1)
590 demangled
[j
] = mangled
[i
];
595 if (at_start_name
&& mangled
[i
] == 'O')
598 for (k
= 0; ada_opname_table
[k
].mangled
!= NULL
; k
+= 1)
600 int op_len
= strlen (ada_opname_table
[k
].mangled
);
601 if (STREQN (ada_opname_table
[k
].mangled
+1, mangled
+i
+1, op_len
-1)
602 && ! isalnum (mangled
[i
+ op_len
]))
604 strcpy (demangled
+ j
, ada_opname_table
[k
].demangled
);
607 j
+= strlen (ada_opname_table
[k
].demangled
);
611 if (ada_opname_table
[k
].mangled
!= NULL
)
616 if (i
< len0
-4 && STREQN (mangled
+i
, "TK__", 4))
618 if (mangled
[i
] == 'X' && i
!= 0 && isalnum (mangled
[i
-1]))
622 while (i
< len0
&& (mangled
[i
] == 'b' || mangled
[i
] == 'n'));
626 else if (i
< len0
-2 && mangled
[i
] == '_' && mangled
[i
+1] == '_')
634 demangled
[j
] = mangled
[i
];
638 demangled
[j
] = '\000';
640 for (i
= 0; demangled
[i
] != '\0'; i
+= 1)
641 if (isupper (demangled
[i
]) || demangled
[i
] == ' ')
647 GROW_VECT (demangling_buffer
, demangling_buffer_size
,
648 strlen (mangled
) + 3);
649 demangled
= demangling_buffer
;
650 if (mangled
[0] == '<')
651 strcpy (demangled
, mangled
);
653 sprintf (demangled
, "<%s>", mangled
);
658 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
659 * suffixes that encode debugging information or leading _ada_ on
660 * SYM_NAME (see is_name_suffix commentary for the debugging
661 * information that is ignored). If WILD, then NAME need only match a
662 * suffix of SYM_NAME minus the same suffixes. Also returns 0 if
663 * either argument is NULL. */
666 ada_match_name (const char* sym_name
, const char* name
, int wild
)
668 if (sym_name
== NULL
|| name
== NULL
)
671 return wild_match (name
, strlen (name
), sym_name
);
673 int len_name
= strlen (name
);
674 return (STREQN (sym_name
, name
, len_name
)
675 && is_name_suffix (sym_name
+len_name
))
676 || (STREQN (sym_name
, "_ada_", 5)
677 && STREQN (sym_name
+5, name
, len_name
)
678 && is_name_suffix (sym_name
+len_name
+5));
682 /* True (non-zero) iff in Ada mode, the symbol SYM should be
683 suppressed in info listings. */
686 ada_suppress_symbol_printing (struct symbol
*sym
)
688 if (SYMBOL_NAMESPACE (sym
) == STRUCT_NAMESPACE
)
691 return is_suppressed_name (SYMBOL_NAME (sym
));
697 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of
698 array descriptors. */
700 static char* bound_name
[] = {
701 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
702 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
705 /* Maximum number of array dimensions we are prepared to handle. */
707 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char*)))
709 /* Like modify_field, but allows bitpos > wordlength. */
712 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
714 modify_field (addr
+ sizeof (LONGEST
) * bitpos
/ (8 * sizeof (LONGEST
)),
715 fieldval
, bitpos
% (8 * sizeof (LONGEST
)),
720 /* The desc_* routines return primitive portions of array descriptors
723 /* The descriptor or array type, if any, indicated by TYPE; removes
724 level of indirection, if needed. */
726 desc_base_type (struct type
* type
)
730 CHECK_TYPEDEF (type
);
731 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_PTR
)
732 return check_typedef (TYPE_TARGET_TYPE (type
));
737 /* True iff TYPE indicates a "thin" array pointer type. */
739 is_thin_pntr (struct type
* type
)
742 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
743 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
746 /* The descriptor type for thin pointer type TYPE. */
748 thin_descriptor_type (struct type
* type
)
750 struct type
* base_type
= desc_base_type (type
);
751 if (base_type
== NULL
)
753 if (is_suffix (ada_type_name (base_type
), "___XVE"))
757 struct type
* alt_type
=
758 ada_find_parallel_type (base_type
, "___XVE");
759 if (alt_type
== NULL
)
766 /* A pointer to the array data for thin-pointer value VAL. */
768 thin_data_pntr (struct value
* val
)
770 struct type
* type
= VALUE_TYPE (val
);
771 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
772 return value_cast (desc_data_type (thin_descriptor_type (type
)),
775 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
776 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
));
779 /* True iff TYPE indicates a "thick" array pointer type. */
781 is_thick_pntr (struct type
* type
)
783 type
= desc_base_type (type
);
784 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
785 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
788 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
789 pointer to one, the type of its bounds data; otherwise, NULL. */
791 desc_bounds_type (struct type
* type
)
795 type
= desc_base_type (type
);
799 else if (is_thin_pntr (type
))
801 type
= thin_descriptor_type (type
);
804 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
806 return check_typedef (r
);
808 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
810 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
812 return check_typedef (TYPE_TARGET_TYPE (check_typedef (r
)));
817 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
818 one, a pointer to its bounds data. Otherwise NULL. */
820 desc_bounds (struct value
* arr
)
822 struct type
* type
= check_typedef (VALUE_TYPE (arr
));
823 if (is_thin_pntr (type
))
825 struct type
* bounds_type
= desc_bounds_type (thin_descriptor_type (type
));
828 if (desc_bounds_type
== NULL
)
829 error ("Bad GNAT array descriptor");
831 /* NOTE: The following calculation is not really kosher, but
832 since desc_type is an XVE-encoded type (and shouldn't be),
833 the correct calculation is a real pain. FIXME (and fix GCC). */
834 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
835 addr
= value_as_long (arr
);
837 addr
= VALUE_ADDRESS (arr
) + VALUE_OFFSET (arr
);
840 value_from_longest (lookup_pointer_type (bounds_type
),
841 addr
- TYPE_LENGTH (bounds_type
));
844 else if (is_thick_pntr (type
))
845 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
846 "Bad GNAT array descriptor");
851 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
852 position of the field containing the address of the bounds data. */
854 fat_pntr_bounds_bitpos (struct type
* type
)
856 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
859 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
860 size of the field containing the address of the bounds data. */
862 fat_pntr_bounds_bitsize (struct type
* type
)
864 type
= desc_base_type (type
);
866 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
867 return TYPE_FIELD_BITSIZE (type
, 1);
869 return 8 * TYPE_LENGTH (check_typedef (TYPE_FIELD_TYPE (type
, 1)));
872 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
873 pointer to one, the type of its array data (a
874 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
875 ada_type_of_array to get an array type with bounds data. */
877 desc_data_type (struct type
* type
)
879 type
= desc_base_type (type
);
881 /* NOTE: The following is bogus; see comment in desc_bounds. */
882 if (is_thin_pntr (type
))
883 return lookup_pointer_type
884 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
),1)));
885 else if (is_thick_pntr (type
))
886 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
891 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
894 desc_data (struct value
* arr
)
896 struct type
* type
= VALUE_TYPE (arr
);
897 if (is_thin_pntr (type
))
898 return thin_data_pntr (arr
);
899 else if (is_thick_pntr (type
))
900 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
901 "Bad GNAT array descriptor");
907 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
908 position of the field containing the address of the data. */
910 fat_pntr_data_bitpos (struct type
* type
)
912 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
915 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
916 size of the field containing the address of the data. */
918 fat_pntr_data_bitsize (struct type
* type
)
920 type
= desc_base_type (type
);
922 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
923 return TYPE_FIELD_BITSIZE (type
, 0);
925 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
928 /* If BOUNDS is an array-bounds structure (or pointer to one), return
929 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
930 bound, if WHICH is 1. The first bound is I=1. */
932 desc_one_bound (struct value
* bounds
, int i
, int which
)
934 return value_struct_elt (&bounds
, NULL
, bound_name
[2*i
+which
-2], NULL
,
935 "Bad GNAT array descriptor bounds");
938 /* If BOUNDS is an array-bounds structure type, return the bit position
939 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
940 bound, if WHICH is 1. The first bound is I=1. */
942 desc_bound_bitpos (struct type
* type
, int i
, int which
)
944 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2*i
+which
-2);
947 /* If BOUNDS is an array-bounds structure type, return the bit field size
948 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
949 bound, if WHICH is 1. The first bound is I=1. */
951 desc_bound_bitsize (struct type
* type
, int i
, int which
)
953 type
= desc_base_type (type
);
955 if (TYPE_FIELD_BITSIZE (type
, 2*i
+which
-2) > 0)
956 return TYPE_FIELD_BITSIZE (type
, 2*i
+which
-2);
958 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2*i
+which
-2));
961 /* If TYPE is the type of an array-bounds structure, the type of its
962 Ith bound (numbering from 1). Otherwise, NULL. */
964 desc_index_type (struct type
* type
, int i
)
966 type
= desc_base_type (type
);
968 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
969 return lookup_struct_elt_type (type
, bound_name
[2*i
-2], 1);
974 /* The number of index positions in the array-bounds type TYPE. 0
977 desc_arity (struct type
* type
)
979 type
= desc_base_type (type
);
982 return TYPE_NFIELDS (type
) / 2;
987 /* Non-zero iff type is a simple array type (or pointer to one). */
989 ada_is_simple_array (struct type
* type
)
993 CHECK_TYPEDEF (type
);
994 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
995 || (TYPE_CODE (type
) == TYPE_CODE_PTR
996 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
999 /* Non-zero iff type belongs to a GNAT array descriptor. */
1001 ada_is_array_descriptor (struct type
* type
)
1003 struct type
* data_type
= desc_data_type (type
);
1007 CHECK_TYPEDEF (type
);
1010 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1011 && TYPE_TARGET_TYPE (data_type
) != NULL
1012 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1014 TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1015 && desc_arity (desc_bounds_type (type
)) > 0;
1018 /* Non-zero iff type is a partially mal-formed GNAT array
1019 descriptor. (FIXME: This is to compensate for some problems with
1020 debugging output from GNAT. Re-examine periodically to see if it
1023 ada_is_bogus_array_descriptor (struct type
*type
)
1027 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1028 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1029 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1030 && ! ada_is_array_descriptor (type
);
1034 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1035 (fat pointer) returns the type of the array data described---specifically,
1036 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1037 in from the descriptor; otherwise, they are left unspecified. If
1038 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1039 returns NULL. The result is simply the type of ARR if ARR is not
1042 ada_type_of_array (struct value
* arr
, int bounds
)
1044 if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1045 return decode_packed_array_type (VALUE_TYPE (arr
));
1047 if (! ada_is_array_descriptor (VALUE_TYPE (arr
)))
1048 return VALUE_TYPE (arr
);
1051 return check_typedef (TYPE_TARGET_TYPE (desc_data_type (VALUE_TYPE (arr
))));
1054 struct type
* elt_type
;
1056 struct value
* descriptor
;
1057 struct objfile
*objf
= TYPE_OBJFILE (VALUE_TYPE (arr
));
1059 elt_type
= ada_array_element_type (VALUE_TYPE (arr
), -1);
1060 arity
= ada_array_arity (VALUE_TYPE (arr
));
1062 if (elt_type
== NULL
|| arity
== 0)
1063 return check_typedef (VALUE_TYPE (arr
));
1065 descriptor
= desc_bounds (arr
);
1066 if (value_as_long (descriptor
) == 0)
1069 struct type
* range_type
= alloc_type (objf
);
1070 struct type
* array_type
= alloc_type (objf
);
1071 struct value
* low
= desc_one_bound (descriptor
, arity
, 0);
1072 struct value
* high
= desc_one_bound (descriptor
, arity
, 1);
1075 create_range_type (range_type
, VALUE_TYPE (low
),
1076 (int) value_as_long (low
),
1077 (int) value_as_long (high
));
1078 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1081 return lookup_pointer_type (elt_type
);
1085 /* If ARR does not represent an array, returns ARR unchanged.
1086 Otherwise, returns either a standard GDB array with bounds set
1087 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1088 GDB array. Returns NULL if ARR is a null fat pointer. */
1090 ada_coerce_to_simple_array_ptr (struct value
* arr
)
1092 if (ada_is_array_descriptor (VALUE_TYPE (arr
)))
1094 struct type
* arrType
= ada_type_of_array (arr
, 1);
1095 if (arrType
== NULL
)
1097 return value_cast (arrType
, value_copy (desc_data (arr
)));
1099 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1100 return decode_packed_array (arr
);
1105 /* If ARR does not represent an array, returns ARR unchanged.
1106 Otherwise, returns a standard GDB array describing ARR (which may
1107 be ARR itself if it already is in the proper form). */
1109 ada_coerce_to_simple_array (struct value
* arr
)
1111 if (ada_is_array_descriptor (VALUE_TYPE (arr
)))
1113 struct value
* arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1115 error ("Bounds unavailable for null array pointer.");
1116 return value_ind (arrVal
);
1118 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1119 return decode_packed_array (arr
);
1124 /* If TYPE represents a GNAT array type, return it translated to an
1125 ordinary GDB array type (possibly with BITSIZE fields indicating
1126 packing). For other types, is the identity. */
1128 ada_coerce_to_simple_array_type (struct type
*type
)
1130 struct value
* mark
= value_mark ();
1131 struct value
* dummy
= value_from_longest (builtin_type_long
, 0);
1132 struct type
* result
;
1133 VALUE_TYPE (dummy
) = type
;
1134 result
= ada_type_of_array (dummy
, 0);
1135 value_free_to_mark (dummy
);
1139 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1141 ada_is_packed_array_type (struct type
* type
)
1145 CHECK_TYPEDEF (type
);
1147 ada_type_name (type
) != NULL
1148 && strstr (ada_type_name (type
), "___XP") != NULL
;
1151 /* Given that TYPE is a standard GDB array type with all bounds filled
1152 in, and that the element size of its ultimate scalar constituents
1153 (that is, either its elements, or, if it is an array of arrays, its
1154 elements' elements, etc.) is *ELT_BITS, return an identical type,
1155 but with the bit sizes of its elements (and those of any
1156 constituent arrays) recorded in the BITSIZE components of its
1157 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1160 packed_array_type (struct type
* type
, long* elt_bits
)
1162 struct type
* new_elt_type
;
1163 struct type
* new_type
;
1164 LONGEST low_bound
, high_bound
;
1166 CHECK_TYPEDEF (type
);
1167 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1170 new_type
= alloc_type (TYPE_OBJFILE (type
));
1171 new_elt_type
= packed_array_type (check_typedef (TYPE_TARGET_TYPE (type
)),
1173 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1174 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1175 TYPE_NAME (new_type
) = ada_type_name (type
);
1177 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1178 &low_bound
, &high_bound
) < 0)
1179 low_bound
= high_bound
= 0;
1180 if (high_bound
< low_bound
)
1181 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1184 *elt_bits
*= (high_bound
- low_bound
+ 1);
1185 TYPE_LENGTH (new_type
) =
1186 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1189 /* TYPE_FLAGS (new_type) |= TYPE_FLAG_FIXED_INSTANCE; */
1190 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
1194 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE).
1197 decode_packed_array_type (struct type
* type
)
1199 struct symbol
** syms
;
1200 struct block
** blocks
;
1201 const char* raw_name
= ada_type_name (check_typedef (type
));
1202 char* name
= (char*) alloca (strlen (raw_name
) + 1);
1203 char* tail
= strstr (raw_name
, "___XP");
1204 struct type
* shadow_type
;
1208 memcpy (name
, raw_name
, tail
- raw_name
);
1209 name
[tail
- raw_name
] = '\000';
1211 /* NOTE: Use ada_lookup_symbol_list because of bug in some versions
1212 * of gcc (Solaris, e.g.). FIXME when compiler is fixed. */
1213 n
= ada_lookup_symbol_list (name
, get_selected_block (NULL
),
1214 VAR_NAMESPACE
, &syms
, &blocks
);
1215 for (i
= 0; i
< n
; i
+= 1)
1216 if (syms
[i
] != NULL
&& SYMBOL_CLASS (syms
[i
]) == LOC_TYPEDEF
1217 && STREQ (name
, ada_type_name (SYMBOL_TYPE (syms
[i
]))))
1221 warning ("could not find bounds information on packed array");
1224 shadow_type
= SYMBOL_TYPE (syms
[i
]);
1226 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1228 warning ("could not understand bounds information on packed array");
1232 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1234 warning ("could not understand bit size information on packed array");
1238 return packed_array_type (shadow_type
, &bits
);
1241 /* Given that ARR is a struct value* indicating a GNAT packed array,
1242 returns a simple array that denotes that array. Its type is a
1243 standard GDB array type except that the BITSIZEs of the array
1244 target types are set to the number of bits in each element, and the
1245 type length is set appropriately. */
1247 static struct value
*
1248 decode_packed_array (struct value
* arr
)
1250 struct type
* type
= decode_packed_array_type (VALUE_TYPE (arr
));
1254 error ("can't unpack array");
1258 return coerce_unspec_val_to_type (arr
, 0, type
);
1262 /* The value of the element of packed array ARR at the ARITY indices
1263 given in IND. ARR must be a simple array. */
1265 static struct value
*
1266 value_subscript_packed (struct value
* arr
, int arity
, struct value
** ind
)
1269 int bits
, elt_off
, bit_off
;
1270 long elt_total_bit_offset
;
1271 struct type
* elt_type
;
1275 elt_total_bit_offset
= 0;
1276 elt_type
= check_typedef (VALUE_TYPE (arr
));
1277 for (i
= 0; i
< arity
; i
+= 1)
1279 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1280 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1281 error ("attempt to do packed indexing of something other than a packed array");
1284 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1285 LONGEST lowerbound
, upperbound
;
1288 if (get_discrete_bounds (range_type
, &lowerbound
,
1291 warning ("don't know bounds of array");
1292 lowerbound
= upperbound
= 0;
1295 idx
= value_as_long (value_pos_atr (ind
[i
]));
1296 if (idx
< lowerbound
|| idx
> upperbound
)
1297 warning ("packed array index %ld out of bounds", (long) idx
);
1298 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1299 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1300 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
1303 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1304 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1306 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1308 if (VALUE_LVAL (arr
) == lval_internalvar
)
1309 VALUE_LVAL (v
) = lval_internalvar_component
;
1311 VALUE_LVAL (v
) = VALUE_LVAL (arr
);
1315 /* Non-zero iff TYPE includes negative integer values. */
1318 has_negatives (struct type
* type
)
1320 switch (TYPE_CODE (type
)) {
1324 return ! TYPE_UNSIGNED (type
);
1325 case TYPE_CODE_RANGE
:
1326 return TYPE_LOW_BOUND (type
) < 0;
1331 /* Create a new value of type TYPE from the contents of OBJ starting
1332 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1333 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1334 assigning through the result will set the field fetched from. OBJ
1335 may also be NULL, in which case, VALADDR+OFFSET must address the
1336 start of storage containing the packed value. The value returned
1337 in this case is never an lval.
1338 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1341 ada_value_primitive_packed_val (struct value
* obj
, char* valaddr
, long offset
, int bit_offset
,
1342 int bit_size
, struct type
* type
)
1345 int src
, /* Index into the source area. */
1346 targ
, /* Index into the target area. */
1348 srcBitsLeft
, /* Number of source bits left to move. */
1349 nsrc
, ntarg
, /* Number of source and target bytes. */
1350 unusedLS
, /* Number of bits in next significant
1351 * byte of source that are unused. */
1352 accumSize
; /* Number of meaningful bits in accum */
1353 unsigned char* bytes
; /* First byte containing data to unpack. */
1354 unsigned char* unpacked
;
1355 unsigned long accum
; /* Staging area for bits being transferred */
1357 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1358 /* Transmit bytes from least to most significant; delta is the
1359 * direction the indices move. */
1360 int delta
= BITS_BIG_ENDIAN
? -1 : 1;
1362 CHECK_TYPEDEF (type
);
1366 v
= allocate_value (type
);
1367 bytes
= (unsigned char*) (valaddr
+ offset
);
1369 else if (VALUE_LAZY (obj
))
1372 VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
, NULL
);
1373 bytes
= (unsigned char*) alloca (len
);
1374 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
1378 v
= allocate_value (type
);
1379 bytes
= (unsigned char*) VALUE_CONTENTS (obj
) + offset
;
1384 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
1385 if (VALUE_LVAL (obj
) == lval_internalvar
)
1386 VALUE_LVAL (v
) = lval_internalvar_component
;
1387 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
;
1388 VALUE_BITPOS (v
) = bit_offset
+ VALUE_BITPOS (obj
);
1389 VALUE_BITSIZE (v
) = bit_size
;
1390 if (VALUE_BITPOS (v
) >= HOST_CHAR_BIT
)
1392 VALUE_ADDRESS (v
) += 1;
1393 VALUE_BITPOS (v
) -= HOST_CHAR_BIT
;
1397 VALUE_BITSIZE (v
) = bit_size
;
1398 unpacked
= (unsigned char*) VALUE_CONTENTS (v
);
1400 srcBitsLeft
= bit_size
;
1402 ntarg
= TYPE_LENGTH (type
);
1406 memset (unpacked
, 0, TYPE_LENGTH (type
));
1409 else if (BITS_BIG_ENDIAN
)
1412 if (has_negatives (type
) &&
1413 ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
-1))))
1417 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
1420 switch (TYPE_CODE (type
))
1422 case TYPE_CODE_ARRAY
:
1423 case TYPE_CODE_UNION
:
1424 case TYPE_CODE_STRUCT
:
1425 /* Non-scalar values must be aligned at a byte boundary. */
1427 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
1428 /* And are placed at the beginning (most-significant) bytes
1434 targ
= TYPE_LENGTH (type
) - 1;
1440 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
1443 unusedLS
= bit_offset
;
1446 if (has_negatives (type
) && (bytes
[len
-1] & (1 << sign_bit_offset
)))
1453 /* Mask for removing bits of the next source byte that are not
1454 * part of the value. */
1455 unsigned int unusedMSMask
=
1456 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
))-1;
1457 /* Sign-extend bits for this byte. */
1458 unsigned int signMask
= sign
& ~unusedMSMask
;
1460 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
1461 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
1462 if (accumSize
>= HOST_CHAR_BIT
)
1464 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1465 accumSize
-= HOST_CHAR_BIT
;
1466 accum
>>= HOST_CHAR_BIT
;
1470 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
1477 accum
|= sign
<< accumSize
;
1478 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1479 accumSize
-= HOST_CHAR_BIT
;
1480 accum
>>= HOST_CHAR_BIT
;
1488 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1489 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
1492 move_bits (char* target
, int targ_offset
, char* source
, int src_offset
, int n
)
1494 unsigned int accum
, mask
;
1495 int accum_bits
, chunk_size
;
1497 target
+= targ_offset
/ HOST_CHAR_BIT
;
1498 targ_offset
%= HOST_CHAR_BIT
;
1499 source
+= src_offset
/ HOST_CHAR_BIT
;
1500 src_offset
%= HOST_CHAR_BIT
;
1501 if (BITS_BIG_ENDIAN
)
1503 accum
= (unsigned char) *source
;
1505 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1510 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
1511 accum_bits
+= HOST_CHAR_BIT
;
1513 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1516 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
1517 mask
= ((1 << chunk_size
) - 1) << unused_right
;
1520 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
1522 accum_bits
-= chunk_size
;
1529 accum
= (unsigned char) *source
>> src_offset
;
1531 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1535 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
1536 accum_bits
+= HOST_CHAR_BIT
;
1538 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1541 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
1543 (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
1545 accum_bits
-= chunk_size
;
1546 accum
>>= chunk_size
;
1554 /* Store the contents of FROMVAL into the location of TOVAL.
1555 Return a new value with the location of TOVAL and contents of
1556 FROMVAL. Handles assignment into packed fields that have
1557 floating-point or non-scalar types. */
1559 static struct value
*
1560 ada_value_assign (struct value
* toval
, struct value
* fromval
)
1562 struct type
* type
= VALUE_TYPE (toval
);
1563 int bits
= VALUE_BITSIZE (toval
);
1565 if (!toval
->modifiable
)
1566 error ("Left operand of assignment is not a modifiable lvalue.");
1570 if (VALUE_LVAL (toval
) == lval_memory
1572 && (TYPE_CODE (type
) == TYPE_CODE_FLT
1573 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
1576 (VALUE_BITPOS (toval
) + bits
+ HOST_CHAR_BIT
- 1)
1578 char* buffer
= (char*) alloca (len
);
1581 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
1582 fromval
= value_cast (type
, fromval
);
1584 read_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
, len
);
1585 if (BITS_BIG_ENDIAN
)
1586 move_bits (buffer
, VALUE_BITPOS (toval
),
1587 VALUE_CONTENTS (fromval
),
1588 TYPE_LENGTH (VALUE_TYPE (fromval
)) * TARGET_CHAR_BIT
- bits
,
1591 move_bits (buffer
, VALUE_BITPOS (toval
), VALUE_CONTENTS (fromval
),
1593 write_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
, len
);
1595 val
= value_copy (toval
);
1596 memcpy (VALUE_CONTENTS_RAW (val
), VALUE_CONTENTS (fromval
),
1597 TYPE_LENGTH (type
));
1598 VALUE_TYPE (val
) = type
;
1603 return value_assign (toval
, fromval
);
1607 /* The value of the element of array ARR at the ARITY indices given in IND.
1608 ARR may be either a simple array, GNAT array descriptor, or pointer
1612 ada_value_subscript (struct value
* arr
, int arity
, struct value
** ind
)
1616 struct type
* elt_type
;
1618 elt
= ada_coerce_to_simple_array (arr
);
1620 elt_type
= check_typedef (VALUE_TYPE (elt
));
1621 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
1622 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
1623 return value_subscript_packed (elt
, arity
, ind
);
1625 for (k
= 0; k
< arity
; k
+= 1)
1627 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
1628 error("too many subscripts (%d expected)", k
);
1629 elt
= value_subscript (elt
, value_pos_atr (ind
[k
]));
1634 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
1635 value of the element of *ARR at the ARITY indices given in
1636 IND. Does not read the entire array into memory. */
1639 ada_value_ptr_subscript (struct value
* arr
, struct type
* type
, int arity
, struct value
** ind
)
1643 for (k
= 0; k
< arity
; k
+= 1)
1648 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1649 error("too many subscripts (%d expected)", k
);
1650 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
1652 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
1656 idx
= value_sub (ind
[k
], value_from_longest (builtin_type_int
, lwb
));
1657 arr
= value_add (arr
, idx
);
1658 type
= TYPE_TARGET_TYPE (type
);
1661 return value_ind (arr
);
1664 /* If type is a record type in the form of a standard GNAT array
1665 descriptor, returns the number of dimensions for type. If arr is a
1666 simple array, returns the number of "array of"s that prefix its
1667 type designation. Otherwise, returns 0. */
1670 ada_array_arity (struct type
* type
)
1677 type
= desc_base_type (type
);
1680 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1681 return desc_arity (desc_bounds_type (type
));
1683 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
1686 type
= check_typedef (TYPE_TARGET_TYPE (type
));
1692 /* If TYPE is a record type in the form of a standard GNAT array
1693 descriptor or a simple array type, returns the element type for
1694 TYPE after indexing by NINDICES indices, or by all indices if
1695 NINDICES is -1. Otherwise, returns NULL. */
1698 ada_array_element_type (struct btype
* type
, int nindices
)
1700 type
= desc_base_type (type
);
1702 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1705 struct type
* p_array_type
;
1707 p_array_type
= desc_data_type (type
);
1709 k
= ada_array_arity (type
);
1713 /* Initially p_array_type = elt_type(*)[]...(k times)...[] */
1714 if (nindices
>= 0 && k
> nindices
)
1716 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
1717 while (k
> 0 && p_array_type
!= NULL
)
1719 p_array_type
= check_typedef (TYPE_TARGET_TYPE (p_array_type
));
1722 return p_array_type
;
1724 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
1726 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
1728 type
= TYPE_TARGET_TYPE (type
);
1737 /* The type of nth index in arrays of given type (n numbering from 1). Does
1738 not examine memory. */
1741 ada_index_type (struct type
* type
, int n
)
1743 type
= desc_base_type (type
);
1745 if (n
> ada_array_arity (type
))
1748 if (ada_is_simple_array (type
))
1752 for (i
= 1; i
< n
; i
+= 1)
1753 type
= TYPE_TARGET_TYPE (type
);
1755 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
1758 return desc_index_type (desc_bounds_type (type
), n
);
1761 /* Given that arr is an array type, returns the lower bound of the
1762 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
1763 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1764 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
1765 bounds type. It works for other arrays with bounds supplied by
1766 run-time quantities other than discriminants. */
1769 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
, struct type
** typep
)
1772 struct type
* index_type_desc
;
1774 if (ada_is_packed_array_type (arr_type
))
1775 arr_type
= decode_packed_array_type (arr_type
);
1777 if (arr_type
== NULL
|| ! ada_is_simple_array (arr_type
))
1780 *typep
= builtin_type_int
;
1781 return (LONGEST
) -which
;
1784 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
1785 type
= TYPE_TARGET_TYPE (arr_type
);
1789 index_type_desc
= ada_find_parallel_type (type
, "___XA");
1790 if (index_type_desc
== NULL
)
1792 struct type
* range_type
;
1793 struct type
* index_type
;
1797 type
= TYPE_TARGET_TYPE (type
);
1801 range_type
= TYPE_INDEX_TYPE (type
);
1802 index_type
= TYPE_TARGET_TYPE (range_type
);
1803 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
1804 index_type
= builtin_type_long
;
1806 *typep
= index_type
;
1808 (LONGEST
) (which
== 0
1809 ? TYPE_LOW_BOUND (range_type
)
1810 : TYPE_HIGH_BOUND (range_type
));
1814 struct type
* index_type
=
1815 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
-1),
1816 NULL
, TYPE_OBJFILE (arr_type
));
1818 *typep
= TYPE_TARGET_TYPE (index_type
);
1820 (LONGEST
) (which
== 0
1821 ? TYPE_LOW_BOUND (index_type
)
1822 : TYPE_HIGH_BOUND (index_type
));
1826 /* Given that arr is an array value, returns the lower bound of the
1827 nth index (numbering from 1) if which is 0, and the upper bound if
1828 which is 1. This routine will also work for arrays with bounds
1829 supplied by run-time quantities other than discriminants. */
1832 ada_array_bound (arr
, n
, which
)
1837 struct type
* arr_type
= VALUE_TYPE (arr
);
1839 if (ada_is_packed_array_type (arr_type
))
1840 return ada_array_bound (decode_packed_array (arr
), n
, which
);
1841 else if (ada_is_simple_array (arr_type
))
1844 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
1845 return value_from_longest (type
, v
);
1848 return desc_one_bound (desc_bounds (arr
), n
, which
);
1851 /* Given that arr is an array value, returns the length of the
1852 nth index. This routine will also work for arrays with bounds
1853 supplied by run-time quantities other than discriminants. Does not
1854 work for arrays indexed by enumeration types with representation
1855 clauses at the moment. */
1858 ada_array_length (struct value
* arr
, int n
)
1860 struct type
* arr_type
= check_typedef (VALUE_TYPE (arr
));
1861 struct type
* index_type_desc
;
1863 if (ada_is_packed_array_type (arr_type
))
1864 return ada_array_length (decode_packed_array (arr
), n
);
1866 if (ada_is_simple_array (arr_type
))
1870 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
1871 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
1872 return value_from_longest (type
, v
);
1876 value_from_longest (builtin_type_ada_int
,
1877 value_as_long (desc_one_bound (desc_bounds (arr
),
1879 - value_as_long (desc_one_bound (desc_bounds (arr
),
1885 /* Name resolution */
1887 /* The "demangled" name for the user-definable Ada operator corresponding
1891 ada_op_name (enum exp_opcode op
)
1895 for (i
= 0; ada_opname_table
[i
].mangled
!= NULL
; i
+= 1)
1897 if (ada_opname_table
[i
].op
== op
)
1898 return ada_opname_table
[i
].demangled
;
1900 error ("Could not find operator name for opcode");
1904 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
1905 references (OP_UNRESOLVED_VALUES) and converts operators that are
1906 user-defined into appropriate function calls. If CONTEXT_TYPE is
1907 non-null, it provides a preferred result type [at the moment, only
1908 type void has any effect---causing procedures to be preferred over
1909 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
1910 return type is preferred. The variable unresolved_names contains a list
1911 of character strings referenced by expout that should be freed.
1912 May change (expand) *EXP. */
1915 ada_resolve (struct expression
** expp
, struct type
* context_type
)
1919 ada_resolve_subexp (expp
, &pc
, 1, context_type
);
1922 /* Resolve the operator of the subexpression beginning at
1923 position *POS of *EXPP. "Resolving" consists of replacing
1924 OP_UNRESOLVED_VALUE with an appropriate OP_VAR_VALUE, replacing
1925 built-in operators with function calls to user-defined operators,
1926 where appropriate, and (when DEPROCEDURE_P is non-zero), converting
1927 function-valued variables into parameterless calls. May expand
1928 EXP. The CONTEXT_TYPE functions as in ada_resolve, above. */
1930 static struct value
*
1931 ada_resolve_subexp (struct expression
** expp
, int *pos
, int deprocedure_p
, struct type
* context_type
)
1935 struct expression
* exp
; /* Convenience: == *expp */
1936 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
1937 struct value
** argvec
; /* Vector of operand types (alloca'ed). */
1938 int nargs
; /* Number of operands */
1944 /* Pass one: resolve operands, saving their types and updating *pos. */
1948 /* case OP_UNRESOLVED_VALUE:*/
1949 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
1954 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
1955 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
1956 /* if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
1960 argvec = (struct value* *) alloca (sizeof (struct value*) * (nargs + 1));
1961 for (i = 0; i < nargs-1; i += 1)
1962 argvec[i] = ada_resolve_subexp (expp, pos, 1, NULL);
1968 ada_resolve_subexp (expp, pos, 0, NULL);
1969 for (i = 1; i < nargs; i += 1)
1970 ada_resolve_subexp (expp, pos, 1, NULL);
1976 /* FIXME: UNOP_QUAL should be defined in expression.h */
1980 ada_resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
1984 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
1985 /* case OP_ATTRIBUTE:
1986 nargs = longest_to_int (exp->elts[pc + 1].longconst) + 1;
1988 for (i = 0; i < nargs; i += 1)
1989 ada_resolve_subexp (expp, pos, 1, NULL);
1996 ada_resolve_subexp (expp
, pos
, 0, NULL
);
2005 arg1
= ada_resolve_subexp (expp
, pos
, 0, NULL
);
2007 ada_resolve_subexp (expp
, pos
, 1, NULL
);
2009 ada_resolve_subexp (expp
, pos
, 1, VALUE_TYPE (arg1
));
2017 error ("Unexpected operator during name resolution");
2032 case BINOP_LOGICAL_AND
:
2033 case BINOP_LOGICAL_OR
:
2034 case BINOP_BITWISE_AND
:
2035 case BINOP_BITWISE_IOR
:
2036 case BINOP_BITWISE_XOR
:
2039 case BINOP_NOTEQUAL
:
2046 case BINOP_SUBSCRIPT
:
2054 case UNOP_LOGICAL_NOT
:
2071 case OP_INTERNALVAR
:
2080 case STRUCTOP_STRUCT
:
2083 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2088 nargs
= longest_to_int (exp
->elts
[pc
+ 2].longconst
) + 1;
2089 nargs
-= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2090 /* A null array contains one dummy element to give the type. */
2096 /* FIXME: TERNOP_MBR should be defined in expression.h */
2102 /* FIXME: BINOP_MBR should be defined in expression.h */
2109 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2110 for (i
= 0; i
< nargs
; i
+= 1)
2111 argvec
[i
] = ada_resolve_subexp (expp
, pos
, 1, NULL
);
2117 /* Pass two: perform any resolution on principal operator. */
2123 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2124 /* case OP_UNRESOLVED_VALUE:
2126 struct symbol** candidate_syms;
2127 struct block** candidate_blocks;
2130 n_candidates = ada_lookup_symbol_list (exp->elts[pc + 2].name,
2131 exp->elts[pc + 1].block,
2136 if (n_candidates > 1)
2138 /* Types tend to get re-introduced locally, so if there
2139 are any local symbols that are not types, first filter
2142 for (j = 0; j < n_candidates; j += 1)
2143 switch (SYMBOL_CLASS (candidate_syms[j]))
2149 case LOC_REGPARM_ADDR:
2153 case LOC_BASEREG_ARG:
2159 if (j < n_candidates)
2162 while (j < n_candidates)
2164 if (SYMBOL_CLASS (candidate_syms[j]) == LOC_TYPEDEF)
2166 candidate_syms[j] = candidate_syms[n_candidates-1];
2167 candidate_blocks[j] = candidate_blocks[n_candidates-1];
2176 if (n_candidates == 0)
2177 error ("No definition found for %s",
2178 ada_demangle (exp->elts[pc + 2].name));
2179 else if (n_candidates == 1)
2181 else if (deprocedure_p
2182 && ! is_nonfunction (candidate_syms, n_candidates))
2184 i = ada_resolve_function (candidate_syms, candidate_blocks,
2185 n_candidates, NULL, 0,
2186 exp->elts[pc + 2].name, context_type);
2188 error ("Could not find a match for %s",
2189 ada_demangle (exp->elts[pc + 2].name));
2193 printf_filtered ("Multiple matches for %s\n",
2194 ada_demangle (exp->elts[pc+2].name));
2195 user_select_syms (candidate_syms, candidate_blocks,
2200 exp->elts[pc].opcode = exp->elts[pc + 3].opcode = OP_VAR_VALUE;
2201 exp->elts[pc + 1].block = candidate_blocks[i];
2202 exp->elts[pc + 2].symbol = candidate_syms[i];
2203 if (innermost_block == NULL ||
2204 contained_in (candidate_blocks[i], innermost_block))
2205 innermost_block = candidate_blocks[i];
2210 if (deprocedure_p
&&
2211 TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+2].symbol
)) == TYPE_CODE_FUNC
)
2213 replace_operator_with_call (expp
, pc
, 0, 0,
2214 exp
->elts
[pc
+2].symbol
,
2215 exp
->elts
[pc
+1].block
);
2222 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2223 /* if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
2225 struct symbol** candidate_syms;
2226 struct block** candidate_blocks;
2229 n_candidates = ada_lookup_symbol_list (exp->elts[pc + 5].name,
2230 exp->elts[pc + 4].block,
2234 if (n_candidates == 1)
2238 i = ada_resolve_function (candidate_syms, candidate_blocks,
2239 n_candidates, argvec, nargs-1,
2240 exp->elts[pc + 5].name, context_type);
2242 error ("Could not find a match for %s",
2243 ada_demangle (exp->elts[pc + 5].name));
2246 exp->elts[pc + 3].opcode = exp->elts[pc + 6].opcode = OP_VAR_VALUE;
2247 exp->elts[pc + 4].block = candidate_blocks[i];
2248 exp->elts[pc + 5].symbol = candidate_syms[i];
2249 if (innermost_block == NULL ||
2250 contained_in (candidate_blocks[i], innermost_block))
2251 innermost_block = candidate_blocks[i];
2263 case BINOP_BITWISE_AND
:
2264 case BINOP_BITWISE_IOR
:
2265 case BINOP_BITWISE_XOR
:
2267 case BINOP_NOTEQUAL
:
2275 case UNOP_LOGICAL_NOT
:
2277 if (possible_user_operator_p (op
, argvec
))
2279 struct symbol
** candidate_syms
;
2280 struct block
** candidate_blocks
;
2283 n_candidates
= ada_lookup_symbol_list (ada_mangle (ada_op_name (op
)),
2284 (struct block
*) NULL
,
2288 i
= ada_resolve_function (candidate_syms
, candidate_blocks
,
2289 n_candidates
, argvec
, nargs
,
2290 ada_op_name (op
), NULL
);
2294 replace_operator_with_call (expp
, pc
, nargs
, 1,
2295 candidate_syms
[i
], candidate_blocks
[i
]);
2302 return evaluate_subexp_type (exp
, pos
);
2305 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2306 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2308 /* The term "match" here is rather loose. The match is heuristic and
2309 liberal. FIXME: TOO liberal, in fact. */
2312 ada_type_match (ftype
, atype
, may_deref
)
2317 CHECK_TYPEDEF (ftype
);
2318 CHECK_TYPEDEF (atype
);
2320 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2321 ftype
= TYPE_TARGET_TYPE (ftype
);
2322 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2323 atype
= TYPE_TARGET_TYPE (atype
);
2325 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2326 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2329 switch (TYPE_CODE (ftype
))
2334 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2335 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2336 TYPE_TARGET_TYPE (atype
), 0);
2337 else return (may_deref
&&
2338 ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2340 case TYPE_CODE_ENUM
:
2341 case TYPE_CODE_RANGE
:
2342 switch (TYPE_CODE (atype
))
2345 case TYPE_CODE_ENUM
:
2346 case TYPE_CODE_RANGE
:
2352 case TYPE_CODE_ARRAY
:
2353 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2354 || ada_is_array_descriptor (atype
));
2356 case TYPE_CODE_STRUCT
:
2357 if (ada_is_array_descriptor (ftype
))
2358 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2359 || ada_is_array_descriptor (atype
));
2361 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2362 && ! ada_is_array_descriptor (atype
));
2364 case TYPE_CODE_UNION
:
2366 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2370 /* Return non-zero if the formals of FUNC "sufficiently match" the
2371 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2372 may also be an enumeral, in which case it is treated as a 0-
2373 argument function. */
2376 ada_args_match (struct symbol
* func
, struct value
** actuals
, int n_actuals
)
2379 struct type
* func_type
= SYMBOL_TYPE (func
);
2381 if (SYMBOL_CLASS (func
) == LOC_CONST
&&
2382 TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2383 return (n_actuals
== 0);
2384 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2387 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2390 for (i
= 0; i
< n_actuals
; i
+= 1)
2392 struct type
* ftype
= check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2393 struct type
* atype
= check_typedef (VALUE_TYPE (actuals
[i
]));
2395 if (! ada_type_match (TYPE_FIELD_TYPE (func_type
, i
),
2396 VALUE_TYPE (actuals
[i
]), 1))
2402 /* False iff function type FUNC_TYPE definitely does not produce a value
2403 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2404 FUNC_TYPE is not a valid function type with a non-null return type
2405 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2408 return_match (struct type
* func_type
, struct type
* context_type
)
2410 struct type
* return_type
;
2412 if (func_type
== NULL
)
2415 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2416 /* if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
2417 return_type = base_type (TYPE_TARGET_TYPE (func_type));
2419 return_type = base_type (func_type);*/
2420 if (return_type
== NULL
)
2423 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2424 /* context_type = base_type (context_type);*/
2426 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2427 return context_type
== NULL
|| return_type
== context_type
;
2428 else if (context_type
== NULL
)
2429 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2431 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
2435 /* Return the index in SYMS[0..NSYMS-1] of symbol for the
2436 function (if any) that matches the types of the NARGS arguments in
2437 ARGS. If CONTEXT_TYPE is non-null, and there is at least one match
2438 that returns type CONTEXT_TYPE, then eliminate other matches. If
2439 CONTEXT_TYPE is null, prefer a non-void-returning function.
2440 Asks the user if there is more than one match remaining. Returns -1
2441 if there is no such symbol or none is selected. NAME is used
2442 solely for messages. May re-arrange and modify SYMS in
2443 the process; the index returned is for the modified vector. BLOCKS
2444 is modified in parallel to SYMS. */
2447 ada_resolve_function (struct symbol
* syms
[], struct block
* blocks
[], int nsyms
,
2448 struct value
** args
, int nargs
, const char* name
,
2449 struct type
* context_type
)
2452 int m
; /* Number of hits */
2453 struct type
* fallback
;
2454 struct type
* return_type
;
2456 return_type
= context_type
;
2457 if (context_type
== NULL
)
2458 fallback
= builtin_type_void
;
2465 for (k
= 0; k
< nsyms
; k
+= 1)
2467 struct type
* type
= check_typedef (SYMBOL_TYPE (syms
[k
]));
2469 if (ada_args_match (syms
[k
], args
, nargs
)
2470 && return_match (SYMBOL_TYPE (syms
[k
]), return_type
))
2474 blocks
[m
] = blocks
[k
];
2478 if (m
> 0 || return_type
== fallback
)
2481 return_type
= fallback
;
2488 printf_filtered ("Multiple matches for %s\n", name
);
2489 user_select_syms (syms
, blocks
, m
, 1);
2495 /* Returns true (non-zero) iff demangled name N0 should appear before N1 */
2496 /* in a listing of choices during disambiguation (see sort_choices, below). */
2497 /* The idea is that overloadings of a subprogram name from the */
2498 /* same package should sort in their source order. We settle for ordering */
2499 /* such symbols by their trailing number (__N or $N). */
2501 mangled_ordered_before (char* N0
, char* N1
)
2505 else if (N0
== NULL
)
2510 for (k0
= strlen (N0
)-1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
2512 for (k1
= strlen (N1
)-1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
2514 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+1] != '\000'
2515 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+1] != '\000')
2519 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
-1] == '_')
2522 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
-1] == '_')
2524 if (n0
== n1
&& STREQN (N0
, N1
, n0
))
2525 return (atoi (N0
+k0
+1) < atoi (N1
+k1
+1));
2527 return (strcmp (N0
, N1
) < 0);
2531 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by their */
2532 /* mangled names, rearranging BLOCKS[0..NSYMS-1] according to the same */
2535 sort_choices (struct symbol
* syms
[], struct block
* blocks
[], int nsyms
)
2538 for (i
= 1; i
< nsyms
; i
+= 1)
2540 struct symbol
* sym
= syms
[i
];
2541 struct block
* block
= blocks
[i
];
2544 for (j
= i
-1; j
>= 0; j
-= 1)
2546 if (mangled_ordered_before (SYMBOL_NAME (syms
[j
]),
2549 syms
[j
+1] = syms
[j
];
2550 blocks
[j
+1] = blocks
[j
];
2553 blocks
[j
+1] = block
;
2557 /* Given a list of NSYMS symbols in SYMS and corresponding blocks in */
2558 /* BLOCKS, select up to MAX_RESULTS>0 by asking the user (if */
2559 /* necessary), returning the number selected, and setting the first */
2560 /* elements of SYMS and BLOCKS to the selected symbols and */
2561 /* corresponding blocks. Error if no symbols selected. BLOCKS may */
2562 /* be NULL, in which case it is ignored. */
2564 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
2565 to be re-integrated one of these days. */
2568 user_select_syms (struct symbol
* syms
[], struct block
* blocks
[], int nsyms
,
2572 int* chosen
= (int*) alloca (sizeof(int) * nsyms
);
2574 int first_choice
= (max_results
== 1) ? 1 : 2;
2576 if (max_results
< 1)
2577 error ("Request to select 0 symbols!");
2581 printf_unfiltered("[0] cancel\n");
2582 if (max_results
> 1)
2583 printf_unfiltered("[1] all\n");
2585 sort_choices (syms
, blocks
, nsyms
);
2587 for (i
= 0; i
< nsyms
; i
+= 1)
2589 if (syms
[i
] == NULL
)
2592 if (SYMBOL_CLASS (syms
[i
]) == LOC_BLOCK
)
2594 struct symtab_and_line sal
= find_function_start_sal (syms
[i
], 1);
2595 printf_unfiltered ("[%d] %s at %s:%d\n",
2597 SYMBOL_SOURCE_NAME (syms
[i
]),
2599 ? "<no source file available>"
2600 : sal
.symtab
->filename
,
2607 (SYMBOL_CLASS (syms
[i
]) == LOC_CONST
2608 && SYMBOL_TYPE (syms
[i
]) != NULL
2609 && TYPE_CODE (SYMBOL_TYPE (syms
[i
]))
2611 struct symtab
* symtab
= symtab_for_sym (syms
[i
]);
2613 if (SYMBOL_LINE (syms
[i
]) != 0 && symtab
!= NULL
)
2614 printf_unfiltered ("[%d] %s at %s:%d\n",
2616 SYMBOL_SOURCE_NAME (syms
[i
]),
2617 symtab
->filename
, SYMBOL_LINE (syms
[i
]));
2618 else if (is_enumeral
&&
2619 TYPE_NAME (SYMBOL_TYPE (syms
[i
])) != NULL
)
2621 printf_unfiltered ("[%d] ", i
+ first_choice
);
2622 ada_print_type (SYMBOL_TYPE (syms
[i
]), NULL
, gdb_stdout
, -1, 0);
2623 printf_unfiltered ("'(%s) (enumeral)\n",
2624 SYMBOL_SOURCE_NAME (syms
[i
]));
2626 else if (symtab
!= NULL
)
2627 printf_unfiltered (is_enumeral
2628 ? "[%d] %s in %s (enumeral)\n"
2629 : "[%d] %s at %s:?\n",
2631 SYMBOL_SOURCE_NAME (syms
[i
]),
2634 printf_unfiltered (is_enumeral
2635 ? "[%d] %s (enumeral)\n"
2637 i
+ first_choice
, SYMBOL_SOURCE_NAME (syms
[i
]));
2641 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
2644 for (i
= 0; i
< n_chosen
; i
+= 1)
2646 syms
[i
] = syms
[chosen
[i
]];
2648 blocks
[i
] = blocks
[chosen
[i
]];
2654 /* Read and validate a set of numeric choices from the user in the
2655 range 0 .. N_CHOICES-1. Place the results in increasing
2656 order in CHOICES[0 .. N-1], and return N.
2658 The user types choices as a sequence of numbers on one line
2659 separated by blanks, encoding them as follows:
2661 + A choice of 0 means to cancel the selection, throwing an error.
2662 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
2663 + The user chooses k by typing k+IS_ALL_CHOICE+1.
2665 The user is not allowed to choose more than MAX_RESULTS values.
2667 ANNOTATION_SUFFIX, if present, is used to annotate the input
2668 prompts (for use with the -f switch). */
2671 get_selections (int* choices
, int n_choices
, int max_results
,
2672 int is_all_choice
, char* annotation_suffix
)
2678 int first_choice
= is_all_choice
? 2 : 1;
2680 prompt
= getenv ("PS2");
2684 printf_unfiltered ("%s ", prompt
);
2685 gdb_flush (gdb_stdout
);
2687 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
2690 error_no_arg ("one or more choice numbers");
2694 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
2695 order, as given in args. Choices are validated. */
2701 while (isspace (*args
))
2703 if (*args
== '\0' && n_chosen
== 0)
2704 error_no_arg ("one or more choice numbers");
2705 else if (*args
== '\0')
2708 choice
= strtol (args
, &args2
, 10);
2709 if (args
== args2
|| choice
< 0 || choice
> n_choices
+ first_choice
- 1)
2710 error ("Argument must be choice number");
2714 error ("cancelled");
2716 if (choice
< first_choice
)
2718 n_chosen
= n_choices
;
2719 for (j
= 0; j
< n_choices
; j
+= 1)
2723 choice
-= first_choice
;
2725 for (j
= n_chosen
-1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
2728 if (j
< 0 || choice
!= choices
[j
])
2731 for (k
= n_chosen
-1; k
> j
; k
-= 1)
2732 choices
[k
+1] = choices
[k
];
2733 choices
[j
+1] = choice
;
2738 if (n_chosen
> max_results
)
2739 error ("Select no more than %d of the above", max_results
);
2744 /* Replace the operator of length OPLEN at position PC in *EXPP with a call */
2745 /* on the function identified by SYM and BLOCK, and taking NARGS */
2746 /* arguments. Update *EXPP as needed to hold more space. */
2749 replace_operator_with_call (struct expression
** expp
, int pc
, int nargs
,
2750 int oplen
, struct symbol
* sym
,
2751 struct block
* block
)
2753 /* A new expression, with 6 more elements (3 for funcall, 4 for function
2754 symbol, -oplen for operator being replaced). */
2755 struct expression
* newexp
= (struct expression
*)
2756 xmalloc (sizeof (struct expression
)
2757 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
2758 struct expression
* exp
= *expp
;
2760 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
2761 newexp
->language_defn
= exp
->language_defn
;
2762 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
2763 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
2764 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
2766 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
2767 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
2769 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
2770 newexp
->elts
[pc
+ 4].block
= block
;
2771 newexp
->elts
[pc
+ 5].symbol
= sym
;
2777 /* Type-class predicates */
2779 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type), or */
2783 numeric_type_p (struct type
* type
)
2788 switch (TYPE_CODE (type
))
2793 case TYPE_CODE_RANGE
:
2794 return (type
== TYPE_TARGET_TYPE (type
)
2795 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
2802 /* True iff TYPE is integral (an INT or RANGE of INTs). */
2805 integer_type_p (struct type
* type
)
2810 switch (TYPE_CODE (type
))
2814 case TYPE_CODE_RANGE
:
2815 return (type
== TYPE_TARGET_TYPE (type
)
2816 || integer_type_p (TYPE_TARGET_TYPE (type
)));
2823 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
2826 scalar_type_p (struct type
* type
)
2831 switch (TYPE_CODE (type
))
2834 case TYPE_CODE_RANGE
:
2835 case TYPE_CODE_ENUM
:
2844 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
2847 discrete_type_p (struct type
* type
)
2852 switch (TYPE_CODE (type
))
2855 case TYPE_CODE_RANGE
:
2856 case TYPE_CODE_ENUM
:
2864 /* Returns non-zero if OP with operatands in the vector ARGS could be
2865 a user-defined function. Errs on the side of pre-defined operators
2866 (i.e., result 0). */
2869 possible_user_operator_p (enum exp_opcode op
, struct value
* args
[])
2871 struct type
* type0
= check_typedef (VALUE_TYPE (args
[0]));
2872 struct type
* type1
=
2873 (args
[1] == NULL
) ? NULL
: check_typedef (VALUE_TYPE (args
[1]));
2884 return (! (numeric_type_p (type0
) && numeric_type_p (type1
)));
2888 case BINOP_BITWISE_AND
:
2889 case BINOP_BITWISE_IOR
:
2890 case BINOP_BITWISE_XOR
:
2891 return (! (integer_type_p (type0
) && integer_type_p (type1
)));
2894 case BINOP_NOTEQUAL
:
2899 return (! (scalar_type_p (type0
) && scalar_type_p (type1
)));
2902 return ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
&&
2903 (TYPE_CODE (type0
) != TYPE_CODE_PTR
||
2904 TYPE_CODE (TYPE_TARGET_TYPE (type0
))
2905 != TYPE_CODE_ARRAY
))
2906 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
&&
2907 (TYPE_CODE (type1
) != TYPE_CODE_PTR
||
2908 TYPE_CODE (TYPE_TARGET_TYPE (type1
))
2909 != TYPE_CODE_ARRAY
)));
2912 return (! (numeric_type_p (type0
) && integer_type_p (type1
)));
2916 case UNOP_LOGICAL_NOT
:
2918 return (! numeric_type_p (type0
));
2925 /** NOTE: In the following, we assume that a renaming type's name may
2926 * have an ___XD suffix. It would be nice if this went away at some
2929 /* If TYPE encodes a renaming, returns the renaming suffix, which
2930 * is XR for an object renaming, XRP for a procedure renaming, XRE for
2931 * an exception renaming, and XRS for a subprogram renaming. Returns
2932 * NULL if NAME encodes none of these. */
2934 ada_renaming_type (struct type
* type
)
2936 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
2938 const char* name
= type_name_no_tag (type
);
2939 const char* suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
2941 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
2950 /* Return non-zero iff SYM encodes an object renaming. */
2952 ada_is_object_renaming (struct symbol
* sym
)
2954 const char* renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
2955 return renaming_type
!= NULL
2956 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
2959 /* Assuming that SYM encodes a non-object renaming, returns the original
2960 * name of the renamed entity. The name is good until the end of
2963 ada_simple_renamed_entity (struct symbol
* sym
)
2966 const char* raw_name
;
2970 type
= SYMBOL_TYPE (sym
);
2971 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
2972 error ("Improperly encoded renaming.");
2974 raw_name
= TYPE_FIELD_NAME (type
, 0);
2975 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
2977 error ("Improperly encoded renaming.");
2979 result
= xmalloc (len
+ 1);
2980 /* FIXME: add_name_string_cleanup should be defined in parse.c */
2981 /* add_name_string_cleanup (result);*/
2982 strncpy (result
, raw_name
, len
);
2983 result
[len
] = '\000';
2988 /* Evaluation: Function Calls */
2990 /* Copy VAL onto the stack, using and updating *SP as the stack
2991 pointer. Return VAL as an lvalue. */
2993 static struct value
*
2994 place_on_stack (struct value
* val
, CORE_ADDR
* sp
)
2996 CORE_ADDR old_sp
= *sp
;
2999 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3000 STACK_ALIGN (TYPE_LENGTH (check_typedef (VALUE_TYPE (val
)))));
3002 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3003 TYPE_LENGTH (check_typedef (VALUE_TYPE (val
))));
3006 VALUE_LVAL (val
) = lval_memory
;
3007 if (INNER_THAN (1, 2))
3008 VALUE_ADDRESS (val
) = *sp
;
3010 VALUE_ADDRESS (val
) = old_sp
;
3015 /* Return the value ACTUAL, converted to be an appropriate value for a
3016 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3017 allocating any necessary descriptors (fat pointers), or copies of
3018 values not residing in memory, updating it as needed. */
3020 static struct value
*
3021 convert_actual (struct value
* actual
, struct type
* formal_type0
, CORE_ADDR
* sp
)
3023 struct type
* actual_type
= check_typedef (VALUE_TYPE (actual
));
3024 struct type
* formal_type
= check_typedef (formal_type0
);
3025 struct type
* formal_target
=
3026 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3027 ? check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3028 struct type
* actual_target
=
3029 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3030 ? check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3032 if (ada_is_array_descriptor (formal_target
)
3033 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3034 return make_array_descriptor (formal_type
, actual
, sp
);
3035 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3037 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3038 && ada_is_array_descriptor (actual_target
))
3039 return desc_data (actual
);
3040 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3042 if (VALUE_LVAL (actual
) != lval_memory
)
3045 actual_type
= check_typedef (VALUE_TYPE (actual
));
3046 val
= allocate_value (actual_type
);
3047 memcpy ((char*) VALUE_CONTENTS_RAW (val
),
3048 (char*) VALUE_CONTENTS (actual
),
3049 TYPE_LENGTH (actual_type
));
3050 actual
= place_on_stack (val
, sp
);
3052 return value_addr (actual
);
3055 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3056 return ada_value_ind (actual
);
3062 /* Push a descriptor of type TYPE for array value ARR on the stack at
3063 *SP, updating *SP to reflect the new descriptor. Return either
3064 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3065 to-descriptor type rather than a descriptor type), a struct value*
3066 representing a pointer to this descriptor. */
3068 static struct value
*
3069 make_array_descriptor (struct type
* type
, struct value
* arr
, CORE_ADDR
* sp
)
3071 struct type
* bounds_type
= desc_bounds_type (type
);
3072 struct type
* desc_type
= desc_base_type (type
);
3073 struct value
* descriptor
= allocate_value (desc_type
);
3074 struct value
* bounds
= allocate_value (bounds_type
);
3075 CORE_ADDR bounds_addr
;
3078 for (i
= ada_array_arity (check_typedef (VALUE_TYPE (arr
))); i
> 0; i
-= 1)
3080 modify_general_field (VALUE_CONTENTS (bounds
),
3081 value_as_long (ada_array_bound (arr
, i
, 0)),
3082 desc_bound_bitpos (bounds_type
, i
, 0),
3083 desc_bound_bitsize (bounds_type
, i
, 0));
3084 modify_general_field (VALUE_CONTENTS (bounds
),
3085 value_as_long (ada_array_bound (arr
, i
, 1)),
3086 desc_bound_bitpos (bounds_type
, i
, 1),
3087 desc_bound_bitsize (bounds_type
, i
, 1));
3090 bounds
= place_on_stack (bounds
, sp
);
3092 modify_general_field (VALUE_CONTENTS (descriptor
),
3094 fat_pntr_data_bitpos (desc_type
),
3095 fat_pntr_data_bitsize (desc_type
));
3096 modify_general_field (VALUE_CONTENTS (descriptor
),
3097 VALUE_ADDRESS (bounds
),
3098 fat_pntr_bounds_bitpos (desc_type
),
3099 fat_pntr_bounds_bitsize (desc_type
));
3101 descriptor
= place_on_stack (descriptor
, sp
);
3103 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3104 return value_addr (descriptor
);
3110 /* Assuming a dummy frame has been established on the target, perform any
3111 conversions needed for calling function FUNC on the NARGS actual
3112 parameters in ARGS, other than standard C conversions. Does
3113 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3114 does not match the number of arguments expected. Use *SP as a
3115 stack pointer for additional data that must be pushed, updating its
3119 ada_convert_actuals (struct value
* func
, int nargs
, struct value
* args
[], CORE_ADDR
* sp
)
3123 if (TYPE_NFIELDS (VALUE_TYPE (func
)) == 0
3124 || nargs
!= TYPE_NFIELDS (VALUE_TYPE (func
)))
3127 for (i
= 0; i
< nargs
; i
+= 1)
3129 convert_actual (args
[i
],
3130 TYPE_FIELD_TYPE (VALUE_TYPE (func
), i
),
3138 /* The vectors of symbols and blocks ultimately returned from */
3139 /* ada_lookup_symbol_list. */
3141 /* Current size of defn_symbols and defn_blocks */
3142 static size_t defn_vector_size
= 0;
3144 /* Current number of symbols found. */
3145 static int ndefns
= 0;
3147 static struct symbol
** defn_symbols
= NULL
;
3148 static struct block
** defn_blocks
= NULL
;
3150 /* Return the result of a standard (literal, C-like) lookup of NAME in
3151 * given NAMESPACE. */
3153 static struct symbol
*
3154 standard_lookup (const char* name
, namespace_enum
namespace)
3157 struct symtab
* symtab
;
3158 sym
= lookup_symbol (name
, (struct block
*) NULL
, namespace, 0, &symtab
);
3163 /* Non-zero iff there is at least one non-function/non-enumeral symbol */
3164 /* in SYMS[0..N-1]. We treat enumerals as functions, since they */
3165 /* contend in overloading in the same way. */
3167 is_nonfunction (struct symbol
* syms
[], int n
)
3171 for (i
= 0; i
< n
; i
+= 1)
3172 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
])) != TYPE_CODE_FUNC
3173 && TYPE_CODE (SYMBOL_TYPE (syms
[i
])) != TYPE_CODE_ENUM
)
3179 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3180 struct types. Otherwise, they may not. */
3183 equiv_types (struct type
* type0
, struct type
* type1
)
3187 if (type0
== NULL
|| type1
== NULL
3188 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3190 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3191 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3192 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3193 && STREQ (ada_type_name (type0
), ada_type_name (type1
)))
3199 /* True iff SYM0 represents the same entity as SYM1, or one that is
3200 no more defined than that of SYM1. */
3203 lesseq_defined_than (struct symbol
* sym0
, struct symbol
* sym1
)
3207 if (SYMBOL_NAMESPACE (sym0
) != SYMBOL_NAMESPACE (sym1
)
3208 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3211 switch (SYMBOL_CLASS (sym0
))
3217 struct type
* type0
= SYMBOL_TYPE (sym0
);
3218 struct type
* type1
= SYMBOL_TYPE (sym1
);
3219 char* name0
= SYMBOL_NAME (sym0
);
3220 char* name1
= SYMBOL_NAME (sym1
);
3221 int len0
= strlen (name0
);
3223 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3224 && (equiv_types (type0
, type1
)
3225 || (len0
< strlen (name1
) && STREQN (name0
, name1
, len0
)
3226 && STREQN (name1
+ len0
, "___XV", 5)));
3229 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3230 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3236 /* Append SYM to the end of defn_symbols, and BLOCK to the end of
3237 defn_blocks, updating ndefns, and expanding defn_symbols and
3238 defn_blocks as needed. Do not include SYM if it is a duplicate. */
3241 add_defn_to_vec (struct symbol
* sym
, struct block
* block
)
3246 if (SYMBOL_TYPE (sym
) != NULL
)
3247 CHECK_TYPEDEF (SYMBOL_TYPE (sym
));
3248 for (i
= 0; i
< ndefns
; i
+= 1)
3250 if (lesseq_defined_than (sym
, defn_symbols
[i
]))
3252 else if (lesseq_defined_than (defn_symbols
[i
], sym
))
3254 defn_symbols
[i
] = sym
;
3255 defn_blocks
[i
] = block
;
3260 tmp
= defn_vector_size
;
3261 GROW_VECT (defn_symbols
, tmp
, ndefns
+2);
3262 GROW_VECT (defn_blocks
, defn_vector_size
, ndefns
+2);
3264 defn_symbols
[ndefns
] = sym
;
3265 defn_blocks
[ndefns
] = block
;
3269 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3270 Check the global symbols if GLOBAL, the static symbols if not. Do
3271 wild-card match if WILD. */
3273 static struct partial_symbol
*
3274 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
, int global
, namespace_enumnamespace
, int wild
)
3276 struct partial_symbol
**start
;
3277 int name_len
= strlen (name
);
3278 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
3287 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
3288 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
3292 for (i
= 0; i
< length
; i
+= 1)
3294 struct partial_symbol
* psym
= start
[i
];
3296 if (SYMBOL_NAMESPACE (psym
) == namespace &&
3297 wild_match (name
, name_len
, SYMBOL_NAME (psym
)))
3307 i
= 0; U
= length
-1;
3311 struct partial_symbol
* psym
= start
[M
];
3312 if (SYMBOL_NAME (psym
)[0] < name
[0])
3314 else if (SYMBOL_NAME (psym
)[0] > name
[0])
3316 else if (strcmp (SYMBOL_NAME (psym
), name
) < 0)
3327 struct partial_symbol
*psym
= start
[i
];
3329 if (SYMBOL_NAMESPACE (psym
) == namespace)
3331 int cmp
= strncmp (name
, SYMBOL_NAME (psym
), name_len
);
3339 && is_name_suffix (SYMBOL_NAME (psym
) + name_len
))
3348 i
= 0; U
= length
-1;
3352 struct partial_symbol
*psym
= start
[M
];
3353 if (SYMBOL_NAME (psym
)[0] < '_')
3355 else if (SYMBOL_NAME (psym
)[0] > '_')
3357 else if (strcmp (SYMBOL_NAME (psym
), "_ada_") < 0)
3368 struct partial_symbol
* psym
= start
[i
];
3370 if (SYMBOL_NAMESPACE (psym
) == namespace)
3374 cmp
= (int) '_' - (int) SYMBOL_NAME (psym
)[0];
3377 cmp
= strncmp ("_ada_", SYMBOL_NAME (psym
), 5);
3379 cmp
= strncmp (name
, SYMBOL_NAME (psym
) + 5, name_len
);
3388 && is_name_suffix (SYMBOL_NAME (psym
) + name_len
+ 5))
3399 /* Find a symbol table containing symbol SYM or NULL if none. */
3400 static struct symtab
*
3401 symtab_for_sym (struct symbol
* sym
)
3404 struct objfile
*objfile
;
3406 struct symbol
*tmp_sym
;
3409 ALL_SYMTABS (objfile
, s
)
3411 switch (SYMBOL_CLASS (sym
))
3419 case LOC_CONST_BYTES
:
3420 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
3421 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
)
3424 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
3425 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
)
3432 switch (SYMBOL_CLASS (sym
))
3438 case LOC_REGPARM_ADDR
:
3443 case LOC_BASEREG_ARG
:
3444 for (j
= FIRST_LOCAL_BLOCK
;
3445 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
3447 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
3448 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
)
3460 /* Return a minimal symbol matching NAME according to Ada demangling
3461 rules. Returns NULL if there is no such minimal symbol. */
3463 struct minimal_symbol
*
3464 ada_lookup_minimal_symbol (const char* name
)
3466 struct objfile
* objfile
;
3467 struct minimal_symbol
* msymbol
;
3468 int wild_match
= (strstr (name
, "__") == NULL
);
3470 ALL_MSYMBOLS (objfile
, msymbol
)
3472 if (ada_match_name (SYMBOL_NAME (msymbol
), name
, wild_match
)
3473 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
3480 /* For all subprograms that statically enclose the subprogram of the
3481 * selected frame, add symbols matching identifier NAME in NAMESPACE
3482 * and their blocks to vectors *defn_symbols and *defn_blocks, as for
3483 * ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
3484 * wildcard prefix. At the moment, this function uses a heuristic to
3485 * find the frames of enclosing subprograms: it treats the
3486 * pointer-sized value at location 0 from the local-variable base of a
3487 * frame as a static link, and then searches up the call stack for a
3488 * frame with that same local-variable base. */
3490 add_symbols_from_enclosing_procs (const char* name
, namespace_enum
namespace, int wild_match
)
3493 static struct symbol static_link_sym
;
3494 static struct symbol
*static_link
;
3496 struct cleanup
* old_chain
= make_cleanup (null_cleanup
, NULL
);
3497 struct frame_info
* frame
;
3498 struct frame_info
* target_frame
;
3500 if (static_link
== NULL
)
3502 /* Initialize the local variable symbol that stands for the
3503 * static link (when it exists). */
3504 static_link
= &static_link_sym
;
3505 SYMBOL_NAME (static_link
) = "";
3506 SYMBOL_LANGUAGE (static_link
) = language_unknown
;
3507 SYMBOL_CLASS (static_link
) = LOC_LOCAL
;
3508 SYMBOL_NAMESPACE (static_link
) = VAR_NAMESPACE
;
3509 SYMBOL_TYPE (static_link
) = lookup_pointer_type (builtin_type_void
);
3510 SYMBOL_VALUE (static_link
) =
3511 - (long) TYPE_LENGTH (SYMBOL_TYPE (static_link
));
3514 frame
= selected_frame
;
3515 while (frame
!= NULL
&& ndefns
== 0)
3517 struct block
* block
;
3518 struct value
* target_link_val
= read_var_value (static_link
, frame
);
3519 CORE_ADDR target_link
;
3521 if (target_link_val
== NULL
)
3525 target_link
= target_link_val
;
3528 frame
= get_prev_frame (frame
);
3529 } while (frame
!= NULL
&& FRAME_LOCALS_ADDRESS (frame
) != target_link
);
3534 block
= get_frame_block (frame
, 0);
3535 while (block
!= NULL
&& block_function (block
) != NULL
&& ndefns
== 0)
3537 ada_add_block_symbols (block
, name
, namespace, NULL
, wild_match
);
3539 block
= BLOCK_SUPERBLOCK (block
);
3543 do_cleanups (old_chain
);
3547 /* True if TYPE is definitely an artificial type supplied to a symbol
3548 * for which no debugging information was given in the symbol file. */
3550 is_nondebugging_type (struct type
* type
)
3552 char* name
= ada_type_name (type
);
3553 return (name
!= NULL
&& STREQ (name
, "<variable, no debug info>"));
3556 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
3557 * duplicate other symbols in the list. (The only case I know of where
3558 * this happens is when object files containing stabs-in-ecoff are
3559 * linked with files containing ordinary ecoff debugging symbols (or no
3560 * debugging symbols)). Modifies SYMS to squeeze out deleted symbols,
3561 * and applies the same modification to BLOCKS to maintain the
3562 * correspondence between SYMS[i] and BLOCKS[i]. Returns the number
3563 * of symbols in the modified list. */
3565 remove_extra_symbols (struct symbol
** syms
, struct block
** blocks
, int nsyms
)
3572 if (SYMBOL_NAME (syms
[i
]) != NULL
&& SYMBOL_CLASS (syms
[i
]) == LOC_STATIC
3573 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
])))
3575 for (j
= 0; j
< nsyms
; j
+= 1)
3578 && SYMBOL_NAME (syms
[j
]) != NULL
3579 && STREQ (SYMBOL_NAME (syms
[i
]), SYMBOL_NAME (syms
[j
]))
3580 && SYMBOL_CLASS (syms
[i
]) == SYMBOL_CLASS (syms
[j
])
3581 && SYMBOL_VALUE_ADDRESS (syms
[i
])
3582 == SYMBOL_VALUE_ADDRESS (syms
[j
]))
3585 for (k
= i
+1; k
< nsyms
; k
+= 1)
3587 syms
[k
-1] = syms
[k
];
3588 blocks
[k
-1] = blocks
[k
];
3602 /* Find symbols in NAMESPACE matching NAME, in BLOCK0 and enclosing
3603 scope and in global scopes, returning the number of matches. Sets
3604 *SYMS to point to a vector of matching symbols, with *BLOCKS
3605 pointing to the vector of corresponding blocks in which those
3606 symbols reside. These two vectors are transient---good only to the
3607 next call of ada_lookup_symbol_list. Any non-function/non-enumeral symbol
3608 match within the nest of blocks whose innermost member is BLOCK0,
3609 is the outermost match returned (no other matches in that or
3610 enclosing blocks is returned). If there are any matches in or
3611 surrounding BLOCK0, then these alone are returned. */
3614 ada_lookup_symbol_list (const char *name
, struct block
*block0
,
3615 namespace_enum
namespace, struct symbol
*** syms
,
3616 struct block
*** blocks
)
3620 struct partial_symtab
*ps
;
3621 struct blockvector
*bv
;
3622 struct objfile
*objfile
;
3624 struct block
*block
;
3625 struct minimal_symbol
*msymbol
;
3626 int wild_match
= (strstr (name
, "__") == NULL
);
3636 /* Search specified block and its superiors. */
3639 while (block
!= NULL
)
3641 ada_add_block_symbols (block
, name
, namespace, NULL
, wild_match
);
3643 /* If we found a non-function match, assume that's the one. */
3644 if (is_nonfunction (defn_symbols
, ndefns
))
3647 block
= BLOCK_SUPERBLOCK (block
);
3650 /* If we found ANY matches in the specified BLOCK, we're done. */
3657 /* Now add symbols from all global blocks: symbol tables, minimal symbol
3658 tables, and psymtab's */
3660 ALL_SYMTABS (objfile
, s
)
3665 bv
= BLOCKVECTOR (s
);
3666 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3667 ada_add_block_symbols (block
, name
, namespace, objfile
, wild_match
);
3670 if (namespace == VAR_NAMESPACE
)
3672 ALL_MSYMBOLS (objfile
, msymbol
)
3674 if (ada_match_name (SYMBOL_NAME (msymbol
), name
, wild_match
))
3676 switch (MSYMBOL_TYPE (msymbol
))
3678 case mst_solib_trampoline
:
3681 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
3684 int old_ndefns
= ndefns
;
3686 bv
= BLOCKVECTOR (s
);
3687 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3688 ada_add_block_symbols (block
,
3689 SYMBOL_NAME (msymbol
),
3690 namespace, objfile
, wild_match
);
3691 if (ndefns
== old_ndefns
)
3693 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3694 ada_add_block_symbols (block
,
3695 SYMBOL_NAME (msymbol
),
3705 ALL_PSYMTABS (objfile
, ps
)
3709 && ada_lookup_partial_symbol (ps
, name
, 1, namespace, wild_match
))
3711 s
= PSYMTAB_TO_SYMTAB (ps
);
3714 bv
= BLOCKVECTOR (s
);
3715 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3716 ada_add_block_symbols (block
, name
, namespace, objfile
, wild_match
);
3720 /* Now add symbols from all per-file blocks if we've gotten no hits.
3721 (Not strictly correct, but perhaps better than an error).
3722 Do the symtabs first, then check the psymtabs */
3727 ALL_SYMTABS (objfile
, s
)
3732 bv
= BLOCKVECTOR (s
);
3733 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3734 ada_add_block_symbols (block
, name
, namespace, objfile
, wild_match
);
3737 ALL_PSYMTABS (objfile
, ps
)
3741 && ada_lookup_partial_symbol (ps
, name
, 0, namespace, wild_match
))
3743 s
= PSYMTAB_TO_SYMTAB(ps
);
3744 bv
= BLOCKVECTOR (s
);
3747 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3748 ada_add_block_symbols (block
, name
, namespace,
3749 objfile
, wild_match
);
3754 /* Finally, we try to find NAME as a local symbol in some lexically
3755 enclosing block. We do this last, expecting this case to be
3759 add_symbols_from_enclosing_procs (name
, namespace, wild_match
);
3765 ndefns
= remove_extra_symbols (defn_symbols
, defn_blocks
, ndefns
);
3768 *syms
= defn_symbols
;
3769 *blocks
= defn_blocks
;
3776 /* Return a symbol in NAMESPACE matching NAME, in BLOCK0 and enclosing
3777 * scope and in global scopes, or NULL if none. NAME is folded to
3778 * lower case first, unless it is surrounded in single quotes.
3779 * Otherwise, the result is as for ada_lookup_symbol_list, but is
3780 * disambiguated by user query if needed. */
3783 ada_lookup_symbol (const char *name
, struct block
*block0
, namespace_enum
namespace)
3785 struct symbol
** candidate_syms
;
3786 struct block
** candidate_blocks
;
3789 n_candidates
= ada_lookup_symbol_list (name
,
3791 &candidate_syms
, &candidate_blocks
);
3793 if (n_candidates
== 0)
3795 else if (n_candidates
!= 1)
3796 user_select_syms (candidate_syms
, candidate_blocks
, n_candidates
, 1);
3798 return candidate_syms
[0];
3802 /* True iff STR is a possible encoded suffix of a normal Ada name
3803 * that is to be ignored for matching purposes. Suffixes of parallel
3804 * names (e.g., XVE) are not included here. Currently, the possible suffixes
3805 * are given by the regular expression:
3806 * (X[nb]*)?(__[0-9]+|\$[0-9]+|___(LJM|X([FDBUP].*|R[^T]?)))?$
3810 is_name_suffix (const char* str
)
3816 while (str
[0] != '_' && str
[0] != '\0')
3818 if (str
[0] != 'n' && str
[0] != 'b')
3823 if (str
[0] == '\000')
3827 if (str
[1] != '_' || str
[2] == '\000')
3831 if (STREQ (str
+3, "LJM"))
3835 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B' ||
3836 str
[4] == 'U' || str
[4] == 'P')
3838 if (str
[4] == 'R' && str
[5] != 'T')
3842 for (k
= 2; str
[k
] != '\0'; k
+= 1)
3843 if (!isdigit (str
[k
]))
3847 if (str
[0] == '$' && str
[1] != '\000')
3849 for (k
= 1; str
[k
] != '\0'; k
+= 1)
3850 if (!isdigit (str
[k
]))
3857 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
3858 * PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
3859 * informational suffixes of NAME (i.e., for which is_name_suffix is
3862 wild_match (const char* patn
, int patn_len
, const char* name
)
3867 name_len
= strlen (name
);
3868 if (name_len
>= patn_len
+5 && STREQN (name
, "_ada_", 5)
3869 && STREQN (patn
, name
+5, patn_len
)
3870 && is_name_suffix (name
+patn_len
+5))
3873 while (name_len
>= patn_len
)
3875 if (STREQN (patn
, name
, patn_len
)
3876 && is_name_suffix (name
+patn_len
))
3879 name
+= 1; name_len
-= 1;
3880 } while (name_len
> 0
3881 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
3886 if (! islower (name
[2]))
3888 name
+= 2; name_len
-= 2;
3892 if (! islower (name
[1]))
3894 name
+= 1; name_len
-= 1;
3902 /* Add symbols from BLOCK matching identifier NAME in NAMESPACE to
3903 vector *defn_symbols, updating *defn_symbols (if necessary), *SZ (the size of
3904 the vector *defn_symbols), and *ndefns (the number of symbols
3905 currently stored in *defn_symbols). If WILD, treat as NAME with a
3906 wildcard prefix. OBJFILE is the section containing BLOCK. */
3909 ada_add_block_symbols (struct block
* block
, const char* name
,
3910 namespace_enum
namespace, struct objfile
* objfile
,
3914 int name_len
= strlen (name
);
3915 /* A matching argument symbol, if any. */
3916 struct symbol
*arg_sym
;
3917 /* Set true when we find a matching non-argument symbol */
3919 int is_sorted
= BLOCK_SHOULD_SORT (block
);
3922 arg_sym
= NULL
; found_sym
= 0;
3926 ALL_BLOCK_SYMBOLS (block
, i
, sym
)
3928 if (SYMBOL_NAMESPACE (sym
) == namespace &&
3929 wild_match (name
, name_len
, SYMBOL_NAME (sym
)))
3931 switch (SYMBOL_CLASS (sym
))
3937 case LOC_REGPARM_ADDR
:
3938 case LOC_BASEREG_ARG
:
3941 case LOC_UNRESOLVED
:
3945 fill_in_ada_prototype (sym
);
3946 add_defn_to_vec (fixup_symbol_section (sym
, objfile
), block
);
3957 i
= 0; U
= BLOCK_NSYMS (block
)-1;
3961 struct symbol
*sym
= BLOCK_SYM (block
, M
);
3962 if (SYMBOL_NAME (sym
)[0] < name
[0])
3964 else if (SYMBOL_NAME (sym
)[0] > name
[0])
3966 else if (strcmp (SYMBOL_NAME (sym
), name
) < 0)
3975 for (; i
< BLOCK_BUCKETS (block
); i
+= 1)
3976 for (sym
= BLOCK_BUCKET (block
, i
); sym
!= NULL
; sym
= sym
->hash_next
)
3978 if (SYMBOL_NAMESPACE (sym
) == namespace)
3980 int cmp
= strncmp (name
, SYMBOL_NAME (sym
), name_len
);
3986 i
= BLOCK_BUCKETS (block
);
3991 && is_name_suffix (SYMBOL_NAME (sym
) + name_len
))
3993 switch (SYMBOL_CLASS (sym
))
3999 case LOC_REGPARM_ADDR
:
4000 case LOC_BASEREG_ARG
:
4003 case LOC_UNRESOLVED
:
4007 fill_in_ada_prototype (sym
);
4008 add_defn_to_vec (fixup_symbol_section (sym
, objfile
),
4017 if (! found_sym
&& arg_sym
!= NULL
)
4019 fill_in_ada_prototype (arg_sym
);
4020 add_defn_to_vec (fixup_symbol_section (arg_sym
, objfile
), block
);
4025 arg_sym
= NULL
; found_sym
= 0;
4029 i
= 0; U
= BLOCK_NSYMS (block
)-1;
4033 struct symbol
*sym
= BLOCK_SYM (block
, M
);
4034 if (SYMBOL_NAME (sym
)[0] < '_')
4036 else if (SYMBOL_NAME (sym
)[0] > '_')
4038 else if (strcmp (SYMBOL_NAME (sym
), "_ada_") < 0)
4047 for (; i
< BLOCK_BUCKETS (block
); i
+= 1)
4048 for (sym
= BLOCK_BUCKET (block
, i
); sym
!= NULL
; sym
= sym
->hash_next
)
4050 struct symbol
*sym
= BLOCK_SYM (block
, i
);
4052 if (SYMBOL_NAMESPACE (sym
) == namespace)
4056 cmp
= (int) '_' - (int) SYMBOL_NAME (sym
)[0];
4059 cmp
= strncmp ("_ada_", SYMBOL_NAME (sym
), 5);
4061 cmp
= strncmp (name
, SYMBOL_NAME (sym
) + 5, name_len
);
4068 i
= BLOCK_BUCKETS (block
);
4073 && is_name_suffix (SYMBOL_NAME (sym
) + name_len
+ 5))
4075 switch (SYMBOL_CLASS (sym
))
4081 case LOC_REGPARM_ADDR
:
4082 case LOC_BASEREG_ARG
:
4085 case LOC_UNRESOLVED
:
4089 fill_in_ada_prototype (sym
);
4090 add_defn_to_vec (fixup_symbol_section (sym
, objfile
),
4098 /* NOTE: This really shouldn't be needed for _ada_ symbols.
4099 They aren't parameters, right? */
4100 if (! found_sym
&& arg_sym
!= NULL
)
4102 fill_in_ada_prototype (arg_sym
);
4103 add_defn_to_vec (fixup_symbol_section (arg_sym
, objfile
), block
);
4109 /* Function Types */
4111 /* Assuming that SYM is the symbol for a function, fill in its type
4112 with prototype information, if it is not already there. */
4115 fill_in_ada_prototype (struct symbol
* func
)
4126 || TYPE_CODE (SYMBOL_TYPE (func
)) != TYPE_CODE_FUNC
4127 || TYPE_FIELDS (SYMBOL_TYPE (func
)) != NULL
)
4130 /* We make each function type unique, so that each may have its own */
4131 /* parameter types. This particular way of doing so wastes space: */
4132 /* it would be nicer to build the argument types while the original */
4133 /* function type is being built (FIXME). */
4134 rtype
= check_typedef (TYPE_TARGET_TYPE (SYMBOL_TYPE (func
)));
4135 ftype
= alloc_type (TYPE_OBJFILE (SYMBOL_TYPE (func
)));
4136 make_function_type (rtype
, &ftype
);
4137 SYMBOL_TYPE (func
) = ftype
;
4139 b
= SYMBOL_BLOCK_VALUE (func
);
4143 TYPE_FIELDS (ftype
) =
4144 (struct field
*) xmalloc (sizeof (struct field
) * max_fields
);
4145 ALL_BLOCK_SYMBOLS (b
, i
, sym
)
4147 GROW_VECT (TYPE_FIELDS (ftype
), max_fields
, nargs
+1);
4149 switch (SYMBOL_CLASS (sym
))
4152 case LOC_REGPARM_ADDR
:
4153 TYPE_FIELD_BITPOS (ftype
, nargs
) = nargs
;
4154 TYPE_FIELD_BITSIZE (ftype
, nargs
) = 0;
4155 TYPE_FIELD_TYPE (ftype
, nargs
) =
4156 lookup_pointer_type (check_typedef (SYMBOL_TYPE (sym
)));
4157 TYPE_FIELD_NAME (ftype
, nargs
) = SYMBOL_NAME (sym
);
4165 case LOC_BASEREG_ARG
:
4166 TYPE_FIELD_BITPOS (ftype
, nargs
) = nargs
;
4167 TYPE_FIELD_BITSIZE (ftype
, nargs
) = 0;
4168 TYPE_FIELD_TYPE (ftype
, nargs
) = check_typedef (SYMBOL_TYPE (sym
));
4169 TYPE_FIELD_NAME (ftype
, nargs
) = SYMBOL_NAME (sym
);
4179 /* Re-allocate fields vector; if there are no fields, make the */
4180 /* fields pointer non-null anyway, to mark that this function type */
4181 /* has been filled in. */
4183 TYPE_NFIELDS (ftype
) = nargs
;
4186 static struct field dummy_field
= {0, 0, 0, 0};
4187 xfree (TYPE_FIELDS (ftype
));
4188 TYPE_FIELDS (ftype
) = &dummy_field
;
4192 struct field
* fields
=
4193 (struct field
*) TYPE_ALLOC (ftype
, nargs
* sizeof (struct field
));
4194 memcpy ((char*) fields
,
4195 (char*) TYPE_FIELDS (ftype
),
4196 nargs
* sizeof (struct field
));
4197 xfree (TYPE_FIELDS (ftype
));
4198 TYPE_FIELDS (ftype
) = fields
;
4203 /* Breakpoint-related */
4205 char no_symtab_msg
[] = "No symbol table is loaded. Use the \"file\" command.";
4207 /* Assuming that LINE is pointing at the beginning of an argument to
4208 'break', return a pointer to the delimiter for the initial segment
4209 of that name. This is the first ':', ' ', or end of LINE.
4212 ada_start_decode_line_1 (char* line
)
4214 /* [NOTE: strpbrk would be more elegant, but I am reluctant to be
4215 the first to use such a library function in GDB code.] */
4217 for (p
= line
; *p
!= '\000' && *p
!= ' ' && *p
!= ':'; p
+= 1)
4222 /* *SPEC points to a function and line number spec (as in a break
4223 command), following any initial file name specification.
4225 Return all symbol table/line specfications (sals) consistent with the
4226 information in *SPEC and FILE_TABLE in the
4228 + FILE_TABLE is null, or the sal refers to a line in the file
4229 named by FILE_TABLE.
4230 + If *SPEC points to an argument with a trailing ':LINENUM',
4231 then the sal refers to that line (or one following it as closely as
4233 + If *SPEC does not start with '*', the sal is in a function with
4236 Returns with 0 elements if no matching non-minimal symbols found.
4238 If *SPEC begins with a function name of the form <NAME>, then NAME
4239 is taken as a literal name; otherwise the function name is subject
4240 to the usual mangling.
4242 *SPEC is updated to point after the function/line number specification.
4244 FUNFIRSTLINE is non-zero if we desire the first line of real code
4245 in each function (this is ignored in the presence of a LINENUM spec.).
4247 If CANONICAL is non-NULL, and if any of the sals require a
4248 'canonical line spec', then *CANONICAL is set to point to an array
4249 of strings, corresponding to and equal in length to the returned
4250 list of sals, such that (*CANONICAL)[i] is non-null and contains a
4251 canonical line spec for the ith returned sal, if needed. If no
4252 canonical line specs are required and CANONICAL is non-null,
4253 *CANONICAL is set to NULL.
4255 A 'canonical line spec' is simply a name (in the format of the
4256 breakpoint command) that uniquely identifies a breakpoint position,
4257 with no further contextual information or user selection. It is
4258 needed whenever the file name, function name, and line number
4259 information supplied is insufficient for this unique
4260 identification. Currently overloaded functions, the name '*',
4261 or static functions without a filename yield a canonical line spec.
4262 The array and the line spec strings are allocated on the heap; it
4263 is the caller's responsibility to free them. */
4265 struct symtabs_and_lines
4266 ada_finish_decode_line_1 (char** spec
, struct symtab
* file_table
,
4267 int funfirstline
, char*** canonical
)
4269 struct symbol
** symbols
;
4270 struct block
** blocks
;
4271 struct block
* block
;
4272 int n_matches
, i
, line_num
;
4273 struct symtabs_and_lines selected
;
4274 struct cleanup
* old_chain
= make_cleanup (null_cleanup
, NULL
);
4279 char* unquoted_name
;
4281 if (file_table
== NULL
)
4282 block
= get_selected_block (NULL
);
4284 block
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (file_table
), STATIC_BLOCK
);
4286 if (canonical
!= NULL
)
4287 *canonical
= (char**) NULL
;
4294 while (**spec
!= '\000' &&
4295 ! strchr (ada_completer_word_break_characters
, **spec
))
4301 if (file_table
!= NULL
&& (*spec
)[0] == ':' && isdigit ((*spec
)[1]))
4303 line_num
= strtol (*spec
+ 1, spec
, 10);
4304 while (**spec
== ' ' || **spec
== '\t')
4311 error ("Wild-card function with no line number or file name.");
4313 return all_sals_for_line (file_table
->filename
, line_num
, canonical
);
4316 if (name
[0] == '\'')
4324 unquoted_name
= (char*) alloca (len
-1);
4325 memcpy (unquoted_name
, name
+1, len
-2);
4326 unquoted_name
[len
-2] = '\000';
4331 unquoted_name
= (char*) alloca (len
+1);
4332 memcpy (unquoted_name
, name
, len
);
4333 unquoted_name
[len
] = '\000';
4334 lower_name
= (char*) alloca (len
+ 1);
4335 for (i
= 0; i
< len
; i
+= 1)
4336 lower_name
[i
] = tolower (name
[i
]);
4337 lower_name
[len
] = '\000';
4341 if (lower_name
!= NULL
)
4342 n_matches
= ada_lookup_symbol_list (ada_mangle (lower_name
), block
,
4343 VAR_NAMESPACE
, &symbols
, &blocks
);
4345 n_matches
= ada_lookup_symbol_list (unquoted_name
, block
,
4346 VAR_NAMESPACE
, &symbols
, &blocks
);
4347 if (n_matches
== 0 && line_num
>= 0)
4348 error ("No line number information found for %s.", unquoted_name
);
4349 else if (n_matches
== 0)
4351 #ifdef HPPA_COMPILER_BUG
4352 /* FIXME: See comment in symtab.c::decode_line_1 */
4354 volatile struct symtab_and_line val
;
4355 #define volatile /*nothing*/
4357 struct symtab_and_line val
;
4359 struct minimal_symbol
* msymbol
;
4364 if (lower_name
!= NULL
)
4365 msymbol
= ada_lookup_minimal_symbol (ada_mangle (lower_name
));
4366 if (msymbol
== NULL
)
4367 msymbol
= ada_lookup_minimal_symbol (unquoted_name
);
4368 if (msymbol
!= NULL
)
4370 val
.pc
= SYMBOL_VALUE_ADDRESS (msymbol
);
4371 val
.section
= SYMBOL_BFD_SECTION (msymbol
);
4374 val
.pc
+= FUNCTION_START_OFFSET
;
4375 SKIP_PROLOGUE (val
.pc
);
4377 selected
.sals
= (struct symtab_and_line
*)
4378 xmalloc (sizeof (struct symtab_and_line
));
4379 selected
.sals
[0] = val
;
4384 if (!have_full_symbols () &&
4385 !have_partial_symbols () && !have_minimal_symbols ())
4386 error (no_symtab_msg
);
4388 error ("Function \"%s\" not defined.", unquoted_name
);
4389 return selected
; /* for lint */
4395 find_sal_from_funcs_and_line (file_table
->filename
, line_num
,
4396 symbols
, n_matches
);
4400 selected
.nelts
= user_select_syms (symbols
, blocks
, n_matches
, n_matches
);
4403 selected
.sals
= (struct symtab_and_line
*)
4404 xmalloc (sizeof (struct symtab_and_line
) * selected
.nelts
);
4405 memset (selected
.sals
, 0, selected
.nelts
* sizeof (selected
.sals
[i
]));
4406 make_cleanup (xfree
, selected
.sals
);
4409 while (i
< selected
.nelts
)
4411 if (SYMBOL_CLASS (symbols
[i
]) == LOC_BLOCK
)
4412 selected
.sals
[i
] = find_function_start_sal (symbols
[i
], funfirstline
);
4413 else if (SYMBOL_LINE (symbols
[i
]) != 0)
4415 selected
.sals
[i
].symtab
= symtab_for_sym (symbols
[i
]);
4416 selected
.sals
[i
].line
= SYMBOL_LINE (symbols
[i
]);
4418 else if (line_num
>= 0)
4420 /* Ignore this choice */
4421 symbols
[i
] = symbols
[selected
.nelts
-1];
4422 blocks
[i
] = blocks
[selected
.nelts
-1];
4423 selected
.nelts
-= 1;
4427 error ("Line number not known for symbol \"%s\"", unquoted_name
);
4431 if (canonical
!= NULL
&& (line_num
>= 0 || n_matches
> 1))
4433 *canonical
= (char**) xmalloc (sizeof(char*) * selected
.nelts
);
4434 for (i
= 0; i
< selected
.nelts
; i
+= 1)
4436 extended_canonical_line_spec (selected
.sals
[i
],
4437 SYMBOL_SOURCE_NAME (symbols
[i
]));
4440 discard_cleanups (old_chain
);
4444 /* The (single) sal corresponding to line LINE_NUM in a symbol table
4445 with file name FILENAME that occurs in one of the functions listed
4446 in SYMBOLS[0 .. NSYMS-1]. */
4447 static struct symtabs_and_lines
4448 find_sal_from_funcs_and_line (const char* filename
, int line_num
,
4449 struct symbol
** symbols
, int nsyms
)
4451 struct symtabs_and_lines sals
;
4452 int best_index
, best
;
4453 struct linetable
* best_linetable
;
4454 struct objfile
* objfile
;
4456 struct symtab
* best_symtab
;
4458 read_all_symtabs (filename
);
4460 best_index
= 0; best_linetable
= NULL
; best_symtab
= NULL
;
4462 ALL_SYMTABS (objfile
, s
)
4464 struct linetable
*l
;
4469 if (!STREQ (filename
, s
->filename
))
4472 ind
= find_line_in_linetable (l
, line_num
, symbols
, nsyms
, &exact
);
4482 if (best
== 0 || l
->item
[ind
].line
< best
)
4484 best
= l
->item
[ind
].line
;
4493 error ("Line number not found in designated function.");
4498 sals
.sals
= (struct symtab_and_line
*) xmalloc (sizeof (sals
.sals
[0]));
4500 INIT_SAL (&sals
.sals
[0]);
4502 sals
.sals
[0].line
= best_linetable
->item
[best_index
].line
;
4503 sals
.sals
[0].pc
= best_linetable
->item
[best_index
].pc
;
4504 sals
.sals
[0].symtab
= best_symtab
;
4509 /* Return the index in LINETABLE of the best match for LINE_NUM whose
4510 pc falls within one of the functions denoted by SYMBOLS[0..NSYMS-1].
4511 Set *EXACTP to the 1 if the match is exact, and 0 otherwise. */
4513 find_line_in_linetable (struct linetable
* linetable
, int line_num
,
4514 struct symbol
** symbols
, int nsyms
, int* exactp
)
4516 int i
, len
, best_index
, best
;
4518 if (line_num
<= 0 || linetable
== NULL
)
4521 len
= linetable
->nitems
;
4522 for (i
= 0, best_index
= -1, best
= 0; i
< len
; i
+= 1)
4525 struct linetable_entry
* item
= &(linetable
->item
[i
]);
4527 for (k
= 0; k
< nsyms
; k
+= 1)
4529 if (symbols
[k
] != NULL
&& SYMBOL_CLASS (symbols
[k
]) == LOC_BLOCK
4530 && item
->pc
>= BLOCK_START (SYMBOL_BLOCK_VALUE (symbols
[k
]))
4531 && item
->pc
< BLOCK_END (SYMBOL_BLOCK_VALUE (symbols
[k
])))
4538 if (item
->line
== line_num
)
4544 if (item
->line
> line_num
&& (best
== 0 || item
->line
< best
))
4555 /* Find the smallest k >= LINE_NUM such that k is a line number in
4556 LINETABLE, and k falls strictly within a named function that begins at
4557 or before LINE_NUM. Return -1 if there is no such k. */
4559 nearest_line_number_in_linetable (struct linetable
* linetable
, int line_num
)
4563 if (line_num
<= 0 || linetable
== NULL
|| linetable
->nitems
== 0)
4565 len
= linetable
->nitems
;
4567 i
= 0; best
= INT_MAX
;
4571 struct linetable_entry
* item
= &(linetable
->item
[i
]);
4573 if (item
->line
>= line_num
&& item
->line
< best
)
4576 CORE_ADDR start
, end
;
4579 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
4581 if (func_name
!= NULL
&& item
->pc
< end
)
4583 if (item
->line
== line_num
)
4587 struct symbol
* sym
=
4588 standard_lookup (func_name
, VAR_NAMESPACE
);
4589 if (is_plausible_func_for_line (sym
, line_num
))
4595 while (i
< len
&& linetable
->item
[i
].pc
< end
);
4605 return (best
== INT_MAX
) ? -1 : best
;
4609 /* Return the next higher index, k, into LINETABLE such that k > IND,
4610 entry k in LINETABLE has a line number equal to LINE_NUM, k
4611 corresponds to a PC that is in a function different from that
4612 corresponding to IND, and falls strictly within a named function
4613 that begins at a line at or preceding STARTING_LINE.
4614 Return -1 if there is no such k.
4615 IND == -1 corresponds to no function. */
4618 find_next_line_in_linetable (struct linetable
* linetable
, int line_num
,
4619 int starting_line
, int ind
)
4623 if (line_num
<= 0 || linetable
== NULL
|| ind
>= linetable
->nitems
)
4625 len
= linetable
->nitems
;
4629 CORE_ADDR start
, end
;
4631 if (find_pc_partial_function (linetable
->item
[ind
].pc
,
4632 (char**) NULL
, &start
, &end
))
4634 while (ind
< len
&& linetable
->item
[ind
].pc
< end
)
4647 struct linetable_entry
* item
= &(linetable
->item
[i
]);
4649 if (item
->line
>= line_num
)
4652 CORE_ADDR start
, end
;
4655 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
4657 if (func_name
!= NULL
&& item
->pc
< end
)
4659 if (item
->line
== line_num
)
4661 struct symbol
* sym
=
4662 standard_lookup (func_name
, VAR_NAMESPACE
);
4663 if (is_plausible_func_for_line (sym
, starting_line
))
4667 while ((i
+1) < len
&& linetable
->item
[i
+1].pc
< end
)
4679 /* True iff function symbol SYM starts somewhere at or before line #
4682 is_plausible_func_for_line (struct symbol
* sym
, int line_num
)
4684 struct symtab_and_line start_sal
;
4689 start_sal
= find_function_start_sal (sym
, 0);
4691 return (start_sal
.line
!= 0 && line_num
>= start_sal
.line
);
4695 debug_print_lines (struct linetable
* lt
)
4702 fprintf (stderr
, "\t");
4703 for (i
= 0; i
< lt
->nitems
; i
+= 1)
4704 fprintf (stderr
, "(%d->%p) ", lt
->item
[i
].line
, (void *) lt
->item
[i
].pc
);
4705 fprintf (stderr
, "\n");
4709 debug_print_block (struct block
* b
)
4714 fprintf (stderr
, "Block: %p; [0x%lx, 0x%lx]",
4715 b
, BLOCK_START(b
), BLOCK_END(b
));
4716 if (BLOCK_FUNCTION(b
) != NULL
)
4717 fprintf (stderr
, " Function: %s", SYMBOL_NAME (BLOCK_FUNCTION(b
)));
4718 fprintf (stderr
, "\n");
4719 fprintf (stderr
, "\t Superblock: %p\n", BLOCK_SUPERBLOCK(b
));
4720 fprintf (stderr
, "\t Symbols:");
4721 ALL_BLOCK_SYMBOLS (b
, i
, sym
)
4723 if (i
> 0 && i
% 4 == 0)
4724 fprintf (stderr
, "\n\t\t ");
4725 fprintf (stderr
, " %s", SYMBOL_NAME (sym
));
4727 fprintf (stderr
, "\n");
4731 debug_print_blocks (struct blockvector
* bv
)
4737 for (i
= 0; i
< BLOCKVECTOR_NBLOCKS (bv
); i
+= 1) {
4738 fprintf (stderr
, "%6d. ", i
);
4739 debug_print_block (BLOCKVECTOR_BLOCK (bv
, i
));
4744 debug_print_symtab (struct symtab
* s
)
4746 fprintf (stderr
, "Symtab %p\n File: %s; Dir: %s\n", s
,
4747 s
->filename
, s
->dirname
);
4748 fprintf (stderr
, " Blockvector: %p, Primary: %d\n",
4749 BLOCKVECTOR(s
), s
->primary
);
4750 debug_print_blocks (BLOCKVECTOR(s
));
4751 fprintf (stderr
, " Line table: %p\n", LINETABLE (s
));
4752 debug_print_lines (LINETABLE(s
));
4755 /* Read in all symbol tables corresponding to partial symbol tables
4756 with file name FILENAME. */
4758 read_all_symtabs (const char* filename
)
4760 struct partial_symtab
* ps
;
4761 struct objfile
* objfile
;
4763 ALL_PSYMTABS (objfile
, ps
)
4767 if (STREQ (filename
, ps
->filename
))
4768 PSYMTAB_TO_SYMTAB (ps
);
4772 /* All sals corresponding to line LINE_NUM in a symbol table from file
4773 FILENAME, as filtered by the user. If CANONICAL is not null, set
4774 it to a corresponding array of canonical line specs. */
4775 static struct symtabs_and_lines
4776 all_sals_for_line (const char* filename
, int line_num
, char*** canonical
)
4778 struct symtabs_and_lines result
;
4779 struct objfile
* objfile
;
4781 struct cleanup
* old_chain
= make_cleanup (null_cleanup
, NULL
);
4784 read_all_symtabs (filename
);
4786 result
.sals
= (struct symtab_and_line
*) xmalloc (4 * sizeof (result
.sals
[0]));
4789 make_cleanup (free_current_contents
, &result
.sals
);
4791 ALL_SYMTABS (objfile
, s
)
4793 int ind
, target_line_num
;
4797 if (!STREQ (s
->filename
, filename
))
4801 nearest_line_number_in_linetable (LINETABLE (s
), line_num
);
4802 if (target_line_num
== -1)
4809 find_next_line_in_linetable (LINETABLE (s
),
4810 target_line_num
, line_num
, ind
);
4815 GROW_VECT (result
.sals
, len
, result
.nelts
+1);
4816 INIT_SAL (&result
.sals
[result
.nelts
]);
4817 result
.sals
[result
.nelts
].line
= LINETABLE(s
)->item
[ind
].line
;
4818 result
.sals
[result
.nelts
].pc
= LINETABLE(s
)->item
[ind
].pc
;
4819 result
.sals
[result
.nelts
].symtab
= s
;
4824 if (canonical
!= NULL
|| result
.nelts
> 1)
4827 char** func_names
= (char**) alloca (result
.nelts
* sizeof (char*));
4828 int first_choice
= (result
.nelts
> 1) ? 2 : 1;
4830 int* choices
= (int*) alloca (result
.nelts
* sizeof (int));
4832 for (k
= 0; k
< result
.nelts
; k
+= 1)
4834 find_pc_partial_function (result
.sals
[k
].pc
, &func_names
[k
],
4835 (CORE_ADDR
*) NULL
, (CORE_ADDR
*) NULL
);
4836 if (func_names
[k
] == NULL
)
4837 error ("Could not find function for one or more breakpoints.");
4840 if (result
.nelts
> 1)
4842 printf_unfiltered("[0] cancel\n");
4843 if (result
.nelts
> 1)
4844 printf_unfiltered("[1] all\n");
4845 for (k
= 0; k
< result
.nelts
; k
+= 1)
4846 printf_unfiltered ("[%d] %s\n", k
+ first_choice
,
4847 ada_demangle (func_names
[k
]));
4849 n
= get_selections (choices
, result
.nelts
, result
.nelts
,
4850 result
.nelts
> 1, "instance-choice");
4852 for (k
= 0; k
< n
; k
+= 1)
4854 result
.sals
[k
] = result
.sals
[choices
[k
]];
4855 func_names
[k
] = func_names
[choices
[k
]];
4860 if (canonical
!= NULL
)
4862 *canonical
= (char**) xmalloc (result
.nelts
* sizeof (char**));
4863 make_cleanup (xfree
, *canonical
);
4864 for (k
= 0; k
< result
.nelts
; k
+= 1)
4867 extended_canonical_line_spec (result
.sals
[k
], func_names
[k
]);
4868 if ((*canonical
)[k
] == NULL
)
4869 error ("Could not locate one or more breakpoints.");
4870 make_cleanup (xfree
, (*canonical
)[k
]);
4875 discard_cleanups (old_chain
);
4880 /* A canonical line specification of the form FILE:NAME:LINENUM for
4881 symbol table and line data SAL. NULL if insufficient
4882 information. The caller is responsible for releasing any space
4886 extended_canonical_line_spec (struct symtab_and_line sal
, const char* name
)
4890 if (sal
.symtab
== NULL
|| sal
.symtab
->filename
== NULL
||
4894 r
= (char*) xmalloc (strlen (name
) + strlen (sal
.symtab
->filename
)
4895 + sizeof(sal
.line
)*3 + 3);
4896 sprintf (r
, "%s:'%s':%d", sal
.symtab
->filename
, name
, sal
.line
);
4901 int begin_bnum
= -1;
4903 int begin_annotate_level
= 0;
4906 begin_cleanup (void* dummy
)
4908 begin_annotate_level
= 0;
4912 begin_command (char *args
, int from_tty
)
4914 struct minimal_symbol
*msym
;
4915 CORE_ADDR main_program_name_addr
;
4916 char main_program_name
[1024];
4917 struct cleanup
* old_chain
= make_cleanup (begin_cleanup
, NULL
);
4918 begin_annotate_level
= 2;
4920 /* Check that there is a program to debug */
4921 if (!have_full_symbols () && !have_partial_symbols ())
4922 error ("No symbol table is loaded. Use the \"file\" command.");
4924 /* Check that we are debugging an Ada program */
4925 /* if (ada_update_initial_language (language_unknown, NULL) != language_ada)
4926 error ("Cannot find the Ada initialization procedure. Is this an Ada main program?");
4928 /* FIXME: language_ada should be defined in defs.h */
4930 /* Get the address of the name of the main procedure */
4931 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
4935 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
4936 if (main_program_name_addr
== 0)
4937 error ("Invalid address for Ada main program name.");
4939 /* Read the name of the main procedure */
4940 extract_string (main_program_name_addr
, main_program_name
);
4942 /* Put a temporary breakpoint in the Ada main program and run */
4943 do_command ("tbreak ", main_program_name
, 0);
4944 do_command ("run ", args
, 0);
4948 /* If we could not find the symbol containing the name of the
4949 main program, that means that the compiler that was used to build
4950 was not recent enough. In that case, we fallback to the previous
4951 mechanism, which is a little bit less reliable, but has proved to work
4952 in most cases. The only cases where it will fail is when the user
4953 has set some breakpoints which will be hit before the end of the
4954 begin command processing (eg in the initialization code).
4956 The begining of the main Ada subprogram is located by breaking
4957 on the adainit procedure. Since we know that the binder generates
4958 the call to this procedure exactly 2 calls before the call to the
4959 Ada main subprogram, it is then easy to put a breakpoint on this
4960 Ada main subprogram once we hit adainit.
4962 do_command ("tbreak adainit", 0);
4963 do_command ("run ", args
, 0);
4964 do_command ("up", 0);
4965 do_command ("tbreak +2", 0);
4966 do_command ("continue", 0);
4967 do_command ("step", 0);
4970 do_cleanups (old_chain
);
4974 is_ada_runtime_file (char *filename
)
4976 return (STREQN (filename
, "s-", 2) ||
4977 STREQN (filename
, "a-", 2) ||
4978 STREQN (filename
, "g-", 2) ||
4979 STREQN (filename
, "i-", 2));
4982 /* find the first frame that contains debugging information and that is not
4983 part of the Ada run-time, starting from fi and moving upward. */
4986 find_printable_frame (struct frame_info
*fi
, int level
)
4988 struct symtab_and_line sal
;
4990 for (; fi
!= NULL
; level
+= 1, fi
= get_prev_frame (fi
))
4992 /* If fi is not the innermost frame, that normally means that fi->pc
4993 points to *after* the call instruction, and we want to get the line
4994 containing the call, never the next line. But if the next frame is
4995 a signal_handler_caller or a dummy frame, then the next frame was
4996 not entered as the result of a call, and we want to get the line
4997 containing fi->pc. */
4999 find_pc_line (fi
->pc
,
5001 && !fi
->next
->signal_handler_caller
5002 && !frame_in_dummy (fi
->next
));
5003 if (sal
.symtab
&& !is_ada_runtime_file (sal
.symtab
->filename
))
5005 #if defined(__alpha__) && defined(__osf__) && !defined(VXWORKS_TARGET)
5006 /* libpthread.so contains some debugging information that prevents us
5007 from finding the right frame */
5009 if (sal
.symtab
->objfile
&&
5010 STREQ (sal
.symtab
->objfile
->name
, "/usr/shlib/libpthread.so"))
5013 selected_frame
= fi
;
5022 ada_report_exception_break (struct breakpoint
*b
)
5025 /* FIXME: break_on_exception should be defined in breakpoint.h */
5026 /* if (b->break_on_exception == 1)
5028 /* Assume that cond has 16 elements, the 15th
5029 being the exception */ /*
5030 if (b->cond && b->cond->nelts == 16)
5032 ui_out_text (uiout, "on ");
5033 ui_out_field_string (uiout, "exception",
5034 SYMBOL_NAME (b->cond->elts[14].symbol));
5037 ui_out_text (uiout, "on all exceptions");
5039 else if (b->break_on_exception == 2)
5040 ui_out_text (uiout, "on unhandled exception");
5041 else if (b->break_on_exception == 3)
5042 ui_out_text (uiout, "on assert failure");
5044 if (b->break_on_exception == 1)
5046 /* Assume that cond has 16 elements, the 15th
5047 being the exception */ /*
5048 if (b->cond && b->cond->nelts == 16)
5050 fputs_filtered ("on ", gdb_stdout);
5051 fputs_filtered (SYMBOL_NAME
5052 (b->cond->elts[14].symbol), gdb_stdout);
5055 fputs_filtered ("on all exceptions", gdb_stdout);
5057 else if (b->break_on_exception == 2)
5058 fputs_filtered ("on unhandled exception", gdb_stdout);
5059 else if (b->break_on_exception == 3)
5060 fputs_filtered ("on assert failure", gdb_stdout);
5066 ada_is_exception_sym (struct symbol
* sym
)
5068 char *type_name
= type_name_no_tag (SYMBOL_TYPE (sym
));
5070 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5071 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5072 && SYMBOL_CLASS (sym
) != LOC_CONST
5073 && type_name
!= NULL
5074 && STREQ (type_name
, "exception"));
5078 ada_maybe_exception_partial_symbol (struct partial_symbol
* sym
)
5080 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5081 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5082 && SYMBOL_CLASS (sym
) != LOC_CONST
);
5085 /* If ARG points to an Ada exception or assert breakpoint, rewrite
5086 into equivalent form. Return resulting argument string. Set
5087 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
5088 break on unhandled, 3 for assert, 0 otherwise. */
5089 char* ada_breakpoint_rewrite (char* arg
, int* break_on_exceptionp
)
5093 *break_on_exceptionp
= 0;
5094 /* FIXME: language_ada should be defined in defs.h */
5095 /* if (current_language->la_language == language_ada
5096 && STREQN (arg, "exception", 9) &&
5097 (arg[9] == ' ' || arg[9] == '\t' || arg[9] == '\0'))
5099 char *tok, *end_tok;
5102 *break_on_exceptionp = 1;
5105 while (*tok == ' ' || *tok == '\t')
5110 while (*end_tok != ' ' && *end_tok != '\t' && *end_tok != '\000')
5113 toklen = end_tok - tok;
5115 arg = (char*) xmalloc (sizeof ("__gnat_raise_nodefer_with_msg if "
5116 "long_integer(e) = long_integer(&)")
5118 make_cleanup (xfree, arg);
5120 strcpy (arg, "__gnat_raise_nodefer_with_msg");
5121 else if (STREQN (tok, "unhandled", toklen))
5123 *break_on_exceptionp = 2;
5124 strcpy (arg, "__gnat_unhandled_exception");
5128 sprintf (arg, "__gnat_raise_nodefer_with_msg if "
5129 "long_integer(e) = long_integer(&%.*s)",
5133 else if (current_language->la_language == language_ada
5134 && STREQN (arg, "assert", 6) &&
5135 (arg[6] == ' ' || arg[6] == '\t' || arg[6] == '\0'))
5137 char *tok = arg + 6;
5139 *break_on_exceptionp = 3;
5142 xmalloc (sizeof ("system__assertions__raise_assert_failure")
5143 + strlen (tok) + 1);
5144 make_cleanup (xfree, arg);
5145 sprintf (arg, "system__assertions__raise_assert_failure%s", tok);
5154 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5155 to be invisible to users. */
5158 ada_is_ignored_field (struct type
*type
, int field_num
)
5160 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5164 const char* name
= TYPE_FIELD_NAME (type
, field_num
);
5165 return (name
== NULL
5166 || (name
[0] == '_' && ! STREQN (name
, "_parent", 7)));
5170 /* True iff structure type TYPE has a tag field. */
5173 ada_is_tagged_type (struct type
*type
)
5175 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5178 return (ada_lookup_struct_elt_type (type
, "_tag", 1, NULL
) != NULL
);
5181 /* The type of the tag on VAL. */
5184 ada_tag_type (struct value
* val
)
5186 return ada_lookup_struct_elt_type (VALUE_TYPE (val
), "_tag", 0, NULL
);
5189 /* The value of the tag on VAL. */
5192 ada_value_tag (struct value
* val
)
5194 return ada_value_struct_elt (val
, "_tag", "record");
5197 /* The parent type of TYPE, or NULL if none. */
5200 ada_parent_type (struct type
*type
)
5204 CHECK_TYPEDEF (type
);
5206 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5209 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5210 if (ada_is_parent_field (type
, i
))
5211 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5216 /* True iff field number FIELD_NUM of structure type TYPE contains the
5217 parent-type (inherited) fields of a derived type. Assumes TYPE is
5218 a structure type with at least FIELD_NUM+1 fields. */
5221 ada_is_parent_field (struct type
*type
, int field_num
)
5223 const char* name
= TYPE_FIELD_NAME (check_typedef (type
), field_num
);
5224 return (name
!= NULL
&&
5225 (STREQN (name
, "PARENT", 6) || STREQN (name
, "_parent", 7)));
5228 /* True iff field number FIELD_NUM of structure type TYPE is a
5229 transparent wrapper field (which should be silently traversed when doing
5230 field selection and flattened when printing). Assumes TYPE is a
5231 structure type with at least FIELD_NUM+1 fields. Such fields are always
5235 ada_is_wrapper_field (struct type
*type
, int field_num
)
5237 const char* name
= TYPE_FIELD_NAME (type
, field_num
);
5238 return (name
!= NULL
5239 && (STREQN (name
, "PARENT", 6) || STREQ (name
, "REP")
5240 || STREQN (name
, "_parent", 7)
5241 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5244 /* True iff field number FIELD_NUM of structure or union type TYPE
5245 is a variant wrapper. Assumes TYPE is a structure type with at least
5246 FIELD_NUM+1 fields. */
5249 ada_is_variant_part (struct type
*type
, int field_num
)
5251 struct type
* field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5252 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5253 || (is_dynamic_field (type
, field_num
)
5254 && TYPE_CODE (TYPE_TARGET_TYPE (field_type
)) == TYPE_CODE_UNION
));
5257 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5258 whose discriminants are contained in the record type OUTER_TYPE,
5259 returns the type of the controlling discriminant for the variant. */
5262 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5264 char* name
= ada_variant_discrim_name (var_type
);
5266 ada_lookup_struct_elt_type (outer_type
, name
, 1, NULL
);
5268 return builtin_type_int
;
5273 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5274 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5275 represents a 'when others' clause; otherwise 0. */
5278 ada_is_others_clause (struct type
*type
, int field_num
)
5280 const char* name
= TYPE_FIELD_NAME (type
, field_num
);
5281 return (name
!= NULL
&& name
[0] == 'O');
5284 /* Assuming that TYPE0 is the type of the variant part of a record,
5285 returns the name of the discriminant controlling the variant. The
5286 value is valid until the next call to ada_variant_discrim_name. */
5289 ada_variant_discrim_name (struct type
*type0
)
5291 static char* result
= NULL
;
5292 static size_t result_len
= 0;
5295 const char* discrim_end
;
5296 const char* discrim_start
;
5298 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5299 type
= TYPE_TARGET_TYPE (type0
);
5303 name
= ada_type_name (type
);
5305 if (name
== NULL
|| name
[0] == '\000')
5308 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5311 if (STREQN (discrim_end
, "___XVN", 6))
5314 if (discrim_end
== name
)
5317 for (discrim_start
= discrim_end
; discrim_start
!= name
+3;
5320 if (discrim_start
== name
+1)
5322 if ((discrim_start
> name
+3 && STREQN (discrim_start
-3, "___", 3))
5323 || discrim_start
[-1] == '.')
5327 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5328 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5329 result
[discrim_end
-discrim_start
] = '\0';
5333 /* Scan STR for a subtype-encoded number, beginning at position K. Put the
5334 position of the character just past the number scanned in *NEW_K,
5335 if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL. Return 1
5336 if there was a valid number at the given position, and 0 otherwise. A
5337 "subtype-encoded" number consists of the absolute value in decimal,
5338 followed by the letter 'm' to indicate a negative number. Assumes 0m
5342 ada_scan_number (const char str
[], int k
, LONGEST
*R
, int *new_k
)
5346 if (! isdigit (str
[k
]))
5349 /* Do it the hard way so as not to make any assumption about
5350 the relationship of unsigned long (%lu scan format code) and
5353 while (isdigit (str
[k
]))
5355 RU
= RU
*10 + (str
[k
] - '0');
5362 *R
= (- (LONGEST
) (RU
-1)) - 1;
5368 /* NOTE on the above: Technically, C does not say what the results of
5369 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5370 number representable as a LONGEST (although either would probably work
5371 in most implementations). When RU>0, the locution in the then branch
5372 above is always equivalent to the negative of RU. */
5379 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5380 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5381 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5384 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5386 const char* name
= TYPE_FIELD_NAME (type
, field_num
);
5399 if (! ada_scan_number (name
, p
+ 1, &W
, &p
))
5408 if (! ada_scan_number (name
, p
+ 1, &L
, &p
)
5410 || ! ada_scan_number (name
, p
+ 1, &U
, &p
))
5412 if (val
>= L
&& val
<= U
)
5424 /* Given a value ARG1 (offset by OFFSET bytes)
5425 of a struct or union type ARG_TYPE,
5426 extract and return the value of one of its (non-static) fields.
5427 FIELDNO says which field. Differs from value_primitive_field only
5428 in that it can handle packed values of arbitrary type. */
5431 ada_value_primitive_field (struct value
* arg1
, int offset
, int fieldno
,
5432 struct type
*arg_type
)
5437 CHECK_TYPEDEF (arg_type
);
5438 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5440 /* Handle packed fields */
5442 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5444 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5445 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5447 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
5448 offset
+ bit_pos
/8, bit_pos
% 8,
5452 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5456 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5457 and search in it assuming it has (class) type TYPE.
5458 If found, return value, else return NULL.
5460 Searches recursively through wrapper fields (e.g., '_parent'). */
5463 ada_search_struct_field (char *name
, struct value
* arg
, int offset
,
5467 CHECK_TYPEDEF (type
);
5469 for (i
= TYPE_NFIELDS (type
)-1; i
>= 0; i
-= 1)
5471 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5473 if (t_field_name
== NULL
)
5476 else if (field_name_match (t_field_name
, name
))
5477 return ada_value_primitive_field (arg
, offset
, i
, type
);
5479 else if (ada_is_wrapper_field (type
, i
))
5482 ada_search_struct_field (name
, arg
,
5483 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
5484 TYPE_FIELD_TYPE (type
, i
));
5489 else if (ada_is_variant_part (type
, i
))
5492 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5493 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5495 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5498 ada_search_struct_field (name
, arg
,
5500 + TYPE_FIELD_BITPOS (field_type
, j
)/8,
5501 TYPE_FIELD_TYPE (field_type
, j
));
5510 /* Given ARG, a value of type (pointer to a)* structure/union,
5511 extract the component named NAME from the ultimate target structure/union
5512 and return it as a value with its appropriate type.
5514 The routine searches for NAME among all members of the structure itself
5515 and (recursively) among all members of any wrapper members
5518 ERR is a name (for use in error messages) that identifies the class
5519 of entity that ARG is supposed to be. */
5522 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5527 arg
= ada_coerce_ref (arg
);
5528 t
= check_typedef (VALUE_TYPE (arg
));
5530 /* Follow pointers until we get to a non-pointer. */
5532 while (TYPE_CODE (t
) == TYPE_CODE_PTR
|| TYPE_CODE (t
) == TYPE_CODE_REF
)
5534 arg
= ada_value_ind (arg
);
5535 t
= check_typedef (VALUE_TYPE (arg
));
5538 if ( TYPE_CODE (t
) != TYPE_CODE_STRUCT
5539 && TYPE_CODE (t
) != TYPE_CODE_UNION
)
5540 error ("Attempt to extract a component of a value that is not a %s.", err
);
5542 v
= ada_search_struct_field (name
, arg
, 0, t
);
5544 error ("There is no member named %s.", name
);
5549 /* Given a type TYPE, look up the type of the component of type named NAME.
5550 If DISPP is non-null, add its byte displacement from the beginning of a
5551 structure (pointed to by a value) of type TYPE to *DISPP (does not
5552 work for packed fields).
5554 Matches any field whose name has NAME as a prefix, possibly
5557 TYPE can be either a struct or union, or a pointer or reference to
5558 a struct or union. If it is a pointer or reference, its target
5559 type is automatically used.
5561 Looks recursively into variant clauses and parent types.
5563 If NOERR is nonzero, return NULL if NAME is not suitably defined. */
5566 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int noerr
, int *dispp
)
5575 CHECK_TYPEDEF (type
);
5576 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5577 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5579 type
= TYPE_TARGET_TYPE (type
);
5582 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
&&
5583 TYPE_CODE (type
) != TYPE_CODE_UNION
)
5585 target_terminal_ours ();
5586 gdb_flush (gdb_stdout
);
5587 fprintf_unfiltered (gdb_stderr
, "Type ");
5588 type_print (type
, "", gdb_stderr
, -1);
5589 error (" is not a structure or union type");
5592 type
= to_static_fixed_type (type
);
5594 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5596 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5600 if (t_field_name
== NULL
)
5603 else if (field_name_match (t_field_name
, name
))
5606 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5607 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5610 else if (ada_is_wrapper_field (type
, i
))
5613 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5618 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5623 else if (ada_is_variant_part (type
, i
))
5626 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5628 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5631 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5636 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5647 target_terminal_ours ();
5648 gdb_flush (gdb_stdout
);
5649 fprintf_unfiltered (gdb_stderr
, "Type ");
5650 type_print (type
, "", gdb_stderr
, -1);
5651 fprintf_unfiltered (gdb_stderr
, " has no component named ");
5652 error ("%s", name
== NULL
? "<null>" : name
);
5658 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5659 within a value of type OUTER_TYPE that is stored in GDB at
5660 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5661 numbering from 0) is applicable. Returns -1 if none are. */
5664 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5665 char* outer_valaddr
)
5670 struct type
* discrim_type
;
5671 char* discrim_name
= ada_variant_discrim_name (var_type
);
5672 LONGEST discrim_val
;
5676 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, &disp
);
5677 if (discrim_type
== NULL
)
5679 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5682 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5684 if (ada_is_others_clause (var_type
, i
))
5686 else if (ada_in_variant (discrim_val
, var_type
, i
))
5690 return others_clause
;
5695 /* Dynamic-Sized Records */
5697 /* Strategy: The type ostensibly attached to a value with dynamic size
5698 (i.e., a size that is not statically recorded in the debugging
5699 data) does not accurately reflect the size or layout of the value.
5700 Our strategy is to convert these values to values with accurate,
5701 conventional types that are constructed on the fly. */
5703 /* There is a subtle and tricky problem here. In general, we cannot
5704 determine the size of dynamic records without its data. However,
5705 the 'struct value' data structure, which GDB uses to represent
5706 quantities in the inferior process (the target), requires the size
5707 of the type at the time of its allocation in order to reserve space
5708 for GDB's internal copy of the data. That's why the
5709 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5710 rather than struct value*s.
5712 However, GDB's internal history variables ($1, $2, etc.) are
5713 struct value*s containing internal copies of the data that are not, in
5714 general, the same as the data at their corresponding addresses in
5715 the target. Fortunately, the types we give to these values are all
5716 conventional, fixed-size types (as per the strategy described
5717 above), so that we don't usually have to perform the
5718 'to_fixed_xxx_type' conversions to look at their values.
5719 Unfortunately, there is one exception: if one of the internal
5720 history variables is an array whose elements are unconstrained
5721 records, then we will need to create distinct fixed types for each
5722 element selected. */
5724 /* The upshot of all of this is that many routines take a (type, host
5725 address, target address) triple as arguments to represent a value.
5726 The host address, if non-null, is supposed to contain an internal
5727 copy of the relevant data; otherwise, the program is to consult the
5728 target at the target address. */
5730 /* Assuming that VAL0 represents a pointer value, the result of
5731 dereferencing it. Differs from value_ind in its treatment of
5732 dynamic-sized types. */
5735 ada_value_ind (struct value
* val0
)
5737 struct value
* val
= unwrap_value (value_ind (val0
));
5738 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5739 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
5743 /* The value resulting from dereferencing any "reference to"
5744 * qualifiers on VAL0. */
5745 static struct value
*
5746 ada_coerce_ref (struct value
* val0
)
5748 if (TYPE_CODE (VALUE_TYPE (val0
)) == TYPE_CODE_REF
) {
5749 struct value
* val
= val0
;
5751 val
= unwrap_value (val
);
5752 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5753 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
5759 /* Return OFF rounded upward if necessary to a multiple of
5760 ALIGNMENT (a power of 2). */
5763 align_value (unsigned int off
, unsigned int alignment
)
5765 return (off
+ alignment
- 1) & ~(alignment
- 1);
5768 /* Return the additional bit offset required by field F of template
5772 field_offset (struct type
*type
, int f
)
5774 int n
= TYPE_FIELD_BITPOS (type
, f
);
5775 /* Kludge (temporary?) to fix problem with dwarf output. */
5777 return (unsigned int) n
& 0xffff;
5783 /* Return the bit alignment required for field #F of template type TYPE. */
5786 field_alignment (struct type
*type
, int f
)
5788 const char* name
= TYPE_FIELD_NAME (type
, f
);
5789 int len
= (name
== NULL
) ? 0 : strlen (name
);
5792 if (len
< 8 || ! isdigit (name
[len
-1]))
5793 return TARGET_CHAR_BIT
;
5795 if (isdigit (name
[len
-2]))
5796 align_offset
= len
- 2;
5798 align_offset
= len
- 1;
5800 if (align_offset
< 7 || ! STREQN ("___XV", name
+align_offset
-6, 5))
5801 return TARGET_CHAR_BIT
;
5803 return atoi (name
+align_offset
) * TARGET_CHAR_BIT
;
5806 /* Find a type named NAME. Ignores ambiguity. */
5808 ada_find_any_type (const char *name
)
5812 sym
= standard_lookup (name
, VAR_NAMESPACE
);
5813 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5814 return SYMBOL_TYPE (sym
);
5816 sym
= standard_lookup (name
, STRUCT_NAMESPACE
);
5818 return SYMBOL_TYPE (sym
);
5823 /* Because of GNAT encoding conventions, several GDB symbols may match a
5824 given type name. If the type denoted by TYPE0 is to be preferred to
5825 that of TYPE1 for purposes of type printing, return non-zero;
5826 otherwise return 0. */
5828 ada_prefer_type (struct type
* type0
, struct type
* type1
)
5832 else if (type0
== NULL
)
5834 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
5836 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
5838 else if (ada_is_packed_array_type (type0
))
5840 else if (ada_is_array_descriptor (type0
) && ! ada_is_array_descriptor (type1
))
5842 else if (ada_renaming_type (type0
) != NULL
5843 && ada_renaming_type (type1
) == NULL
)
5848 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5849 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5851 ada_type_name (struct type
* type
)
5855 else if (TYPE_NAME (type
) != NULL
)
5856 return TYPE_NAME (type
);
5858 return TYPE_TAG_NAME (type
);
5861 /* Find a parallel type to TYPE whose name is formed by appending
5862 SUFFIX to the name of TYPE. */
5865 ada_find_parallel_type (struct type
*type
, const char *suffix
)
5868 static size_t name_len
= 0;
5869 struct symbol
** syms
;
5870 struct block
** blocks
;
5873 char* typename
= ada_type_name (type
);
5875 if (typename
== NULL
)
5878 len
= strlen (typename
);
5880 GROW_VECT (name
, name_len
, len
+strlen (suffix
)+1);
5882 strcpy (name
, typename
);
5883 strcpy (name
+ len
, suffix
);
5885 return ada_find_any_type (name
);
5889 /* If TYPE is a variable-size record type, return the corresponding template
5890 type describing its fields. Otherwise, return NULL. */
5893 dynamic_template_type (struct type
* type
)
5895 CHECK_TYPEDEF (type
);
5897 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5898 || ada_type_name (type
) == NULL
)
5902 int len
= strlen (ada_type_name (type
));
5903 if (len
> 6 && STREQ (ada_type_name (type
) + len
- 6, "___XVE"))
5906 return ada_find_parallel_type (type
, "___XVE");
5910 /* Assuming that TEMPL_TYPE is a union or struct type, returns
5911 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
5914 is_dynamic_field (struct type
* templ_type
, int field_num
)
5916 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
5918 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
5919 && strstr (name
, "___XVL") != NULL
;
5922 /* Assuming that TYPE is a struct type, returns non-zero iff TYPE
5923 contains a variant part. */
5926 contains_variant_part (struct type
* type
)
5930 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5931 || TYPE_NFIELDS (type
) <= 0)
5933 return ada_is_variant_part (type
, TYPE_NFIELDS (type
) - 1);
5936 /* A record type with no fields, . */
5938 empty_record (struct objfile
* objfile
)
5940 struct type
* type
= alloc_type (objfile
);
5941 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
5942 TYPE_NFIELDS (type
) = 0;
5943 TYPE_FIELDS (type
) = NULL
;
5944 TYPE_NAME (type
) = "<empty>";
5945 TYPE_TAG_NAME (type
) = NULL
;
5946 TYPE_FLAGS (type
) = 0;
5947 TYPE_LENGTH (type
) = 0;
5951 /* An ordinary record type (with fixed-length fields) that describes
5952 the value of type TYPE at VALADDR or ADDRESS (see comments at
5953 the beginning of this section) VAL according to GNAT conventions.
5954 DVAL0 should describe the (portion of a) record that contains any
5955 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
5956 an outer-level type (i.e., as opposed to a branch of a variant.) A
5957 variant field (unless unchecked) is replaced by a particular branch
5959 /* NOTE: Limitations: For now, we assume that dynamic fields and
5960 * variants occupy whole numbers of bytes. However, they need not be
5964 template_to_fixed_record_type (struct type
* type
, char* valaddr
,
5965 CORE_ADDR address
, struct value
* dval0
)
5967 struct value
* mark
= value_mark();
5970 int nfields
, bit_len
;
5974 nfields
= TYPE_NFIELDS (type
);
5975 rtype
= alloc_type (TYPE_OBJFILE (type
));
5976 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
5977 INIT_CPLUS_SPECIFIC (rtype
);
5978 TYPE_NFIELDS (rtype
) = nfields
;
5979 TYPE_FIELDS (rtype
) = (struct field
*)
5980 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
5981 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
5982 TYPE_NAME (rtype
) = ada_type_name (type
);
5983 TYPE_TAG_NAME (rtype
) = NULL
;
5984 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in
5986 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE;*/
5988 off
= 0; bit_len
= 0;
5989 for (f
= 0; f
< nfields
; f
+= 1)
5991 int fld_bit_len
, bit_incr
;
5993 align_value (off
, field_alignment (type
, f
))+TYPE_FIELD_BITPOS (type
,f
);
5994 /* NOTE: used to use field_offset above, but that causes
5995 * problems with really negative bit positions. So, let's
5996 * rediscover why we needed field_offset and fix it properly. */
5997 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
5998 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6000 if (ada_is_variant_part (type
, f
))
6002 struct type
*branch_type
;
6006 value_from_contents_and_address (rtype
, valaddr
, address
);
6011 to_fixed_variant_branch_type
6012 (TYPE_FIELD_TYPE (type
, f
),
6013 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6014 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
),
6016 if (branch_type
== NULL
)
6017 TYPE_NFIELDS (rtype
) -= 1;
6020 TYPE_FIELD_TYPE (rtype
, f
) = branch_type
;
6021 TYPE_FIELD_NAME (rtype
, f
) = "S";
6025 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6027 else if (is_dynamic_field (type
, f
))
6031 value_from_contents_and_address (rtype
, valaddr
, address
);
6035 TYPE_FIELD_TYPE (rtype
, f
) =
6038 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6039 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6040 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
),
6042 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6043 bit_incr
= fld_bit_len
=
6044 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6048 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6049 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6050 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6051 bit_incr
= fld_bit_len
=
6052 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6054 bit_incr
= fld_bit_len
=
6055 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6057 if (off
+ fld_bit_len
> bit_len
)
6058 bit_len
= off
+ fld_bit_len
;
6060 TYPE_LENGTH (rtype
) = bit_len
/ TARGET_CHAR_BIT
;
6062 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
), TYPE_LENGTH (type
));
6064 value_free_to_mark (mark
);
6065 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6066 error ("record type with dynamic size is larger than varsize-limit");
6070 /* As for template_to_fixed_record_type, but uses no run-time values.
6071 As a result, this type can only be approximate, but that's OK,
6072 since it is used only for type determinations. Works on both
6074 Representation note: to save space, we memoize the result of this
6075 function in the TYPE_TARGET_TYPE of the template type. */
6078 template_to_static_fixed_type (struct type
* templ_type
)
6084 if (TYPE_TARGET_TYPE (templ_type
) != NULL
)
6085 return TYPE_TARGET_TYPE (templ_type
);
6087 nfields
= TYPE_NFIELDS (templ_type
);
6088 TYPE_TARGET_TYPE (templ_type
) = type
= alloc_type (TYPE_OBJFILE (templ_type
));
6089 TYPE_CODE (type
) = TYPE_CODE (templ_type
);
6090 INIT_CPLUS_SPECIFIC (type
);
6091 TYPE_NFIELDS (type
) = nfields
;
6092 TYPE_FIELDS (type
) = (struct field
*)
6093 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6094 memset (TYPE_FIELDS (type
), 0, sizeof (struct field
) * nfields
);
6095 TYPE_NAME (type
) = ada_type_name (templ_type
);
6096 TYPE_TAG_NAME (type
) = NULL
;
6097 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6098 /* TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE; */
6099 TYPE_LENGTH (type
) = 0;
6101 for (f
= 0; f
< nfields
; f
+= 1)
6103 TYPE_FIELD_BITPOS (type
, f
) = 0;
6104 TYPE_FIELD_BITSIZE (type
, f
) = 0;
6106 if (is_dynamic_field (templ_type
, f
))
6108 TYPE_FIELD_TYPE (type
, f
) =
6109 to_static_fixed_type (TYPE_TARGET_TYPE
6110 (TYPE_FIELD_TYPE (templ_type
, f
)));
6111 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6115 TYPE_FIELD_TYPE (type
, f
) =
6116 check_typedef (TYPE_FIELD_TYPE (templ_type
, f
));
6117 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6124 /* A revision of TYPE0 -- a non-dynamic-sized record with a variant
6125 part -- in which the variant part is replaced with the appropriate
6128 to_record_with_fixed_variant_part (struct type
* type
, char* valaddr
,
6129 CORE_ADDR address
, struct value
* dval
)
6131 struct value
* mark
= value_mark();
6133 struct type
*branch_type
;
6134 int nfields
= TYPE_NFIELDS (type
);
6139 rtype
= alloc_type (TYPE_OBJFILE (type
));
6140 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6141 INIT_CPLUS_SPECIFIC (type
);
6142 TYPE_NFIELDS (rtype
) = TYPE_NFIELDS (type
);
6143 TYPE_FIELDS (rtype
) =
6144 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6145 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6146 sizeof (struct field
) * nfields
);
6147 TYPE_NAME (rtype
) = ada_type_name (type
);
6148 TYPE_TAG_NAME (rtype
) = NULL
;
6149 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6150 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6151 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6154 to_fixed_variant_branch_type
6155 (TYPE_FIELD_TYPE (type
, nfields
- 1),
6156 cond_offset_host (valaddr
,
6157 TYPE_FIELD_BITPOS (type
, nfields
-1) / TARGET_CHAR_BIT
),
6158 cond_offset_target (address
,
6159 TYPE_FIELD_BITPOS (type
, nfields
-1) / TARGET_CHAR_BIT
),
6161 if (branch_type
== NULL
)
6163 TYPE_NFIELDS (rtype
) -= 1;
6164 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6168 TYPE_FIELD_TYPE (rtype
, nfields
-1) = branch_type
;
6169 TYPE_FIELD_NAME (rtype
, nfields
-1) = "S";
6170 TYPE_FIELD_BITSIZE (rtype
, nfields
-1) = 0;
6171 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6172 - TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6178 /* An ordinary record type (with fixed-length fields) that describes
6179 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6180 beginning of this section]. Any necessary discriminants' values
6181 should be in DVAL, a record value; it should be NULL if the object
6182 at ADDR itself contains any necessary discriminant values. A
6183 variant field (unless unchecked) is replaced by a particular branch
6187 to_fixed_record_type (struct type
* type0
, char* valaddr
, CORE_ADDR address
,
6190 struct type
* templ_type
;
6192 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6193 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6196 templ_type
= dynamic_template_type (type0
);
6198 if (templ_type
!= NULL
)
6199 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6200 else if (contains_variant_part (type0
))
6201 return to_record_with_fixed_variant_part (type0
, valaddr
, address
, dval
);
6204 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6205 /* TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE; */
6211 /* An ordinary record type (with fixed-length fields) that describes
6212 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6213 union type. Any necessary discriminants' values should be in DVAL,
6214 a record value. That is, this routine selects the appropriate
6215 branch of the union at ADDR according to the discriminant value
6216 indicated in the union's type name. */
6219 to_fixed_variant_branch_type (struct type
* var_type0
, char* valaddr
,
6220 CORE_ADDR address
, struct value
* dval
)
6223 struct type
* templ_type
;
6224 struct type
* var_type
;
6226 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6227 var_type
= TYPE_TARGET_TYPE (var_type0
);
6229 var_type
= var_type0
;
6231 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6233 if (templ_type
!= NULL
)
6234 var_type
= templ_type
;
6237 ada_which_variant_applies (var_type
,
6238 VALUE_TYPE (dval
), VALUE_CONTENTS (dval
));
6241 return empty_record (TYPE_OBJFILE (var_type
));
6242 else if (is_dynamic_field (var_type
, which
))
6244 to_fixed_record_type
6245 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6246 valaddr
, address
, dval
);
6247 else if (contains_variant_part (TYPE_FIELD_TYPE (var_type
, which
)))
6249 to_fixed_record_type
6250 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6252 return TYPE_FIELD_TYPE (var_type
, which
);
6255 /* Assuming that TYPE0 is an array type describing the type of a value
6256 at ADDR, and that DVAL describes a record containing any
6257 discriminants used in TYPE0, returns a type for the value that
6258 contains no dynamic components (that is, no components whose sizes
6259 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6260 true, gives an error message if the resulting type's size is over
6265 to_fixed_array_type (struct type
* type0
, struct value
* dval
,
6268 struct type
* index_type_desc
;
6269 struct type
* result
;
6271 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6272 /* if (ada_is_packed_array_type (type0) /* revisit? */ /*
6273 || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
6276 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6277 if (index_type_desc
== NULL
)
6279 struct type
*elt_type0
= check_typedef (TYPE_TARGET_TYPE (type0
));
6280 /* NOTE: elt_type---the fixed version of elt_type0---should never
6281 * depend on the contents of the array in properly constructed
6282 * debugging data. */
6283 struct type
*elt_type
=
6284 ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6286 if (elt_type0
== elt_type
)
6289 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6290 elt_type
, TYPE_INDEX_TYPE (type0
));
6295 struct type
*elt_type0
;
6298 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6299 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6301 /* NOTE: result---the fixed version of elt_type0---should never
6302 * depend on the contents of the array in properly constructed
6303 * debugging data. */
6305 ada_to_fixed_type (check_typedef (elt_type0
), 0, 0, dval
);
6306 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6308 struct type
*range_type
=
6309 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6310 dval
, TYPE_OBJFILE (type0
));
6311 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6312 result
, range_type
);
6314 if (! ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6315 error ("array type with dynamic size is larger than varsize-limit");
6318 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6319 /* TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE; */
6324 /* A standard type (containing no dynamically sized components)
6325 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6326 DVAL describes a record containing any discriminants used in TYPE0,
6327 and may be NULL if there are none. */
6330 ada_to_fixed_type (struct type
* type
, char* valaddr
, CORE_ADDR address
,
6333 CHECK_TYPEDEF (type
);
6334 switch (TYPE_CODE (type
)) {
6337 case TYPE_CODE_STRUCT
:
6338 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6339 case TYPE_CODE_ARRAY
:
6340 return to_fixed_array_type (type
, dval
, 0);
6341 case TYPE_CODE_UNION
:
6345 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6349 /* A standard (static-sized) type corresponding as well as possible to
6350 TYPE0, but based on no runtime data. */
6353 to_static_fixed_type (struct type
* type0
)
6360 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6361 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6364 CHECK_TYPEDEF (type0
);
6366 switch (TYPE_CODE (type0
))
6370 case TYPE_CODE_STRUCT
:
6371 type
= dynamic_template_type (type0
);
6373 return template_to_static_fixed_type (type
);
6375 case TYPE_CODE_UNION
:
6376 type
= ada_find_parallel_type (type0
, "___XVU");
6378 return template_to_static_fixed_type (type
);
6383 /* A static approximation of TYPE with all type wrappers removed. */
6385 static_unwrap_type (struct type
* type
)
6387 if (ada_is_aligner_type (type
))
6389 struct type
* type1
= TYPE_FIELD_TYPE (check_typedef (type
), 0);
6390 if (ada_type_name (type1
) == NULL
)
6391 TYPE_NAME (type1
) = ada_type_name (type
);
6393 return static_unwrap_type (type1
);
6397 struct type
* raw_real_type
= ada_get_base_type (type
);
6398 if (raw_real_type
== type
)
6401 return to_static_fixed_type (raw_real_type
);
6405 /* In some cases, incomplete and private types require
6406 cross-references that are not resolved as records (for example,
6408 type FooP is access Foo;
6410 type Foo is array ...;
6411 ). In these cases, since there is no mechanism for producing
6412 cross-references to such types, we instead substitute for FooP a
6413 stub enumeration type that is nowhere resolved, and whose tag is
6414 the name of the actual type. Call these types "non-record stubs". */
6416 /* A type equivalent to TYPE that is not a non-record stub, if one
6417 exists, otherwise TYPE. */
6419 ada_completed_type (struct type
* type
)
6421 CHECK_TYPEDEF (type
);
6422 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6423 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
6424 || TYPE_TAG_NAME (type
) == NULL
)
6428 char* name
= TYPE_TAG_NAME (type
);
6429 struct type
* type1
= ada_find_any_type (name
);
6430 return (type1
== NULL
) ? type
: type1
;
6434 /* A value representing the data at VALADDR/ADDRESS as described by
6435 type TYPE0, but with a standard (static-sized) type that correctly
6436 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6437 type, then return VAL0 [this feature is simply to avoid redundant
6438 creation of struct values]. */
6441 ada_to_fixed_value (struct type
* type0
, char* valaddr
, CORE_ADDR address
,
6444 struct type
* type
= ada_to_fixed_type (type0
, valaddr
, address
, NULL
);
6445 if (type
== type0
&& val0
!= NULL
)
6447 else return value_from_contents_and_address (type
, valaddr
, address
);
6450 /* A value representing VAL, but with a standard (static-sized) type
6451 chosen to approximate the real type of VAL as well as possible, but
6452 without consulting any runtime values. For Ada dynamic-sized
6453 types, therefore, the type of the result is likely to be inaccurate. */
6456 ada_to_static_fixed_value (struct value
* val
)
6459 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val
)));
6460 if (type
== VALUE_TYPE (val
))
6463 return coerce_unspec_val_to_type (val
, 0, type
);
6472 /* Table mapping attribute numbers to names */
6473 /* NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h */
6475 static const char* attribute_names
[] = {
6493 ada_attribute_name (int n
)
6495 if (n
> 0 && n
< (int) ATR_END
)
6496 return attribute_names
[n
];
6498 return attribute_names
[0];
6501 /* Evaluate the 'POS attribute applied to ARG. */
6503 static struct value
*
6504 value_pos_atr (struct value
* arg
)
6506 struct type
*type
= VALUE_TYPE (arg
);
6508 if (! discrete_type_p (type
))
6509 error ("'POS only defined on discrete types");
6511 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6514 LONGEST v
= value_as_long (arg
);
6516 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6518 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6519 return value_from_longest (builtin_type_ada_int
, i
);
6521 error ("enumeration value is invalid: can't find 'POS");
6524 return value_from_longest (builtin_type_ada_int
, value_as_long (arg
));
6527 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6529 static struct value
*
6530 value_val_atr (struct type
*type
, struct value
* arg
)
6532 if (! discrete_type_p (type
))
6533 error ("'VAL only defined on discrete types");
6534 if (! integer_type_p (VALUE_TYPE (arg
)))
6535 error ("'VAL requires integral argument");
6537 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6539 long pos
= value_as_long (arg
);
6540 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6541 error ("argument to 'VAL out of range");
6543 value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6546 return value_from_longest (type
, value_as_long (arg
));
6552 /* True if TYPE appears to be an Ada character type.
6553 * [At the moment, this is true only for Character and Wide_Character;
6554 * It is a heuristic test that could stand improvement]. */
6557 ada_is_character_type (struct type
* type
)
6559 const char* name
= ada_type_name (type
);
6562 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6563 || TYPE_CODE (type
) == TYPE_CODE_INT
6564 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6565 && (STREQ (name
, "character") || STREQ (name
, "wide_character")
6566 || STREQ (name
, "unsigned char"));
6569 /* True if TYPE appears to be an Ada string type. */
6572 ada_is_string_type (struct type
*type
)
6574 CHECK_TYPEDEF (type
);
6576 && TYPE_CODE (type
) != TYPE_CODE_PTR
6577 && (ada_is_simple_array (type
) || ada_is_array_descriptor (type
))
6578 && ada_array_arity (type
) == 1)
6580 struct type
*elttype
= ada_array_element_type (type
, 1);
6582 return ada_is_character_type (elttype
);
6589 /* True if TYPE is a struct type introduced by the compiler to force the
6590 alignment of a value. Such types have a single field with a
6591 distinctive name. */
6594 ada_is_aligner_type (struct type
*type
)
6596 CHECK_TYPEDEF (type
);
6597 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
6598 && TYPE_NFIELDS (type
) == 1
6599 && STREQ (TYPE_FIELD_NAME (type
, 0), "F"));
6602 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6603 the parallel type. */
6606 ada_get_base_type (struct type
* raw_type
)
6608 struct type
* real_type_namer
;
6609 struct type
* raw_real_type
;
6610 struct type
* real_type
;
6612 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
6615 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
6616 if (real_type_namer
== NULL
6617 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
6618 || TYPE_NFIELDS (real_type_namer
) != 1)
6621 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
6622 if (raw_real_type
== NULL
)
6625 return raw_real_type
;
6628 /* The type of value designated by TYPE, with all aligners removed. */
6631 ada_aligned_type (struct type
* type
)
6633 if (ada_is_aligner_type (type
))
6634 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
6636 return ada_get_base_type (type
);
6640 /* The address of the aligned value in an object at address VALADDR
6641 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6644 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
6646 if (ada_is_aligner_type (type
))
6647 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
6649 TYPE_FIELD_BITPOS (type
, 0)/TARGET_CHAR_BIT
);
6654 /* The printed representation of an enumeration literal with encoded
6655 name NAME. The value is good to the next call of ada_enum_name. */
6657 ada_enum_name (const char* name
)
6663 if ((tmp
= strstr (name
, "__")) != NULL
)
6665 else if ((tmp
= strchr (name
, '.')) != NULL
)
6673 static char result
[16];
6675 if (name
[1] == 'U' || name
[1] == 'W')
6677 if (sscanf (name
+2, "%x", &v
) != 1)
6683 if (isascii (v
) && isprint (v
))
6684 sprintf (result
, "'%c'", v
);
6685 else if (name
[1] == 'U')
6686 sprintf (result
, "[\"%02x\"]", v
);
6688 sprintf (result
, "[\"%04x\"]", v
);
6696 static struct value
*
6697 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
6700 return (*exp
->language_defn
->evaluate_exp
) (expect_type
, exp
, pos
, noside
);
6703 /* Evaluate the subexpression of EXP starting at *POS as for
6704 evaluate_type, updating *POS to point just past the evaluated
6707 static struct value
*
6708 evaluate_subexp_type (struct expression
* exp
, int* pos
)
6710 return (*exp
->language_defn
->evaluate_exp
)
6711 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
6714 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6717 static struct value
*
6718 unwrap_value (struct value
* val
)
6720 struct type
* type
= check_typedef (VALUE_TYPE (val
));
6721 if (ada_is_aligner_type (type
))
6723 struct value
* v
= value_struct_elt (&val
, NULL
, "F",
6724 NULL
, "internal structure");
6725 struct type
* val_type
= check_typedef (VALUE_TYPE (v
));
6726 if (ada_type_name (val_type
) == NULL
)
6727 TYPE_NAME (val_type
) = ada_type_name (type
);
6729 return unwrap_value (v
);
6733 struct type
* raw_real_type
=
6734 ada_completed_type (ada_get_base_type (type
));
6736 if (type
== raw_real_type
)
6740 coerce_unspec_val_to_type
6741 (val
, 0, ada_to_fixed_type (raw_real_type
, 0,
6742 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
6747 static struct value
*
6748 cast_to_fixed (struct type
*type
, struct value
* arg
)
6752 if (type
== VALUE_TYPE (arg
))
6754 else if (ada_is_fixed_point_type (VALUE_TYPE (arg
)))
6755 val
= ada_float_to_fixed (type
,
6756 ada_fixed_to_float (VALUE_TYPE (arg
),
6757 value_as_long (arg
)));
6761 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
6762 val
= ada_float_to_fixed (type
, argd
);
6765 return value_from_longest (type
, val
);
6768 static struct value
*
6769 cast_from_fixed_to_double (struct value
* arg
)
6771 DOUBLEST val
= ada_fixed_to_float (VALUE_TYPE (arg
),
6772 value_as_long (arg
));
6773 return value_from_double (builtin_type_double
, val
);
6776 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
6777 * return the converted value. */
6778 static struct value
*
6779 coerce_for_assign (struct type
* type
, struct value
* val
)
6781 struct type
* type2
= VALUE_TYPE (val
);
6785 CHECK_TYPEDEF (type2
);
6786 CHECK_TYPEDEF (type
);
6788 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
&& TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6790 val
= ada_value_ind (val
);
6791 type2
= VALUE_TYPE (val
);
6794 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
6795 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6797 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
6798 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
6799 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
6800 error ("Incompatible types in assignment");
6801 VALUE_TYPE (val
) = type
;
6807 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
6808 int *pos
, enum noside noside
)
6811 enum ada_attribute atr
;
6812 int tem
, tem2
, tem3
;
6814 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
6817 struct value
* *argvec
;
6819 pc
= *pos
; *pos
+= 1;
6820 op
= exp
->elts
[pc
].opcode
;
6826 return unwrap_value (evaluate_subexp_standard (expect_type
, exp
, pos
, noside
));
6830 type
= exp
->elts
[pc
+ 1].type
;
6831 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
6832 if (noside
== EVAL_SKIP
)
6834 if (type
!= check_typedef (VALUE_TYPE (arg1
)))
6836 if (ada_is_fixed_point_type (type
))
6837 arg1
= cast_to_fixed (type
, arg1
);
6838 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6839 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
6840 else if (VALUE_LVAL (arg1
) == lval_memory
)
6842 /* This is in case of the really obscure (and undocumented,
6843 but apparently expected) case of (Foo) Bar.all, where Bar
6844 is an integer constant and Foo is a dynamic-sized type.
6845 If we don't do this, ARG1 will simply be relabeled with
6847 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
6848 return value_zero (to_static_fixed_type (type
), not_lval
);
6851 (type
, 0, VALUE_ADDRESS (arg1
) + VALUE_OFFSET (arg1
), 0);
6854 arg1
= value_cast (type
, arg1
);
6858 /* FIXME: UNOP_QUAL should be defined in expression.h */
6861 type = exp->elts[pc + 1].type;
6862 return ada_evaluate_subexp (type, exp, pos, noside);
6865 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6866 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
6867 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
6869 if (binop_user_defined_p (op
, arg1
, arg2
))
6870 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6873 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6874 arg2
= cast_to_fixed (VALUE_TYPE (arg1
), arg2
);
6875 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6876 error ("Fixed-point values must be assigned to fixed-point variables");
6878 arg2
= coerce_for_assign (VALUE_TYPE (arg1
), arg2
);
6879 return ada_value_assign (arg1
, arg2
);
6883 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6884 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6885 if (noside
== EVAL_SKIP
)
6887 if (binop_user_defined_p (op
, arg1
, arg2
))
6888 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6891 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6892 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6893 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6894 error ("Operands of fixed-point addition must have the same type");
6895 return value_cast (VALUE_TYPE (arg1
), value_add (arg1
, arg2
));
6899 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6900 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6901 if (noside
== EVAL_SKIP
)
6903 if (binop_user_defined_p (op
, arg1
, arg2
))
6904 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6907 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6908 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6909 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6910 error ("Operands of fixed-point subtraction must have the same type");
6911 return value_cast (VALUE_TYPE (arg1
), value_sub (arg1
, arg2
));
6916 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6917 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6918 if (noside
== EVAL_SKIP
)
6920 if (binop_user_defined_p (op
, arg1
, arg2
))
6921 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6923 if (noside
== EVAL_AVOID_SIDE_EFFECTS
6924 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
6925 return value_zero (VALUE_TYPE (arg1
), not_lval
);
6928 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6929 arg1
= cast_from_fixed_to_double (arg1
);
6930 if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6931 arg2
= cast_from_fixed_to_double (arg2
);
6932 return value_binop (arg1
, arg2
, op
);
6936 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6937 if (noside
== EVAL_SKIP
)
6939 if (unop_user_defined_p (op
, arg1
))
6940 return value_x_unop (arg1
, op
, EVAL_NORMAL
);
6941 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6942 return value_cast (VALUE_TYPE (arg1
), value_neg (arg1
));
6944 return value_neg (arg1
);
6946 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
6947 /* case OP_UNRESOLVED_VALUE:
6948 /* Only encountered when an unresolved symbol occurs in a
6949 context other than a function call, in which case, it is
6952 if (noside == EVAL_SKIP)
6955 error ("Unexpected unresolved symbol, %s, during evaluation",
6956 ada_demangle (exp->elts[pc + 2].name));
6960 if (noside
== EVAL_SKIP
)
6965 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
6969 (to_static_fixed_type
6970 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+2].symbol
))),
6975 arg1
= unwrap_value (evaluate_subexp_standard (expect_type
, exp
, pos
,
6977 return ada_to_fixed_value (VALUE_TYPE (arg1
), 0,
6978 VALUE_ADDRESS (arg1
) + VALUE_OFFSET(arg1
),
6984 tem2
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
6985 tem3
= longest_to_int (exp
->elts
[pc
+ 2].longconst
);
6986 nargs
= tem3
- tem2
+ 1;
6987 type
= expect_type
? check_typedef (expect_type
) : NULL_TYPE
;
6989 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
6990 for (tem
= 0; tem
== 0 || tem
< nargs
; tem
+= 1)
6991 /* At least one element gets inserted for the type */
6993 /* Ensure that array expressions are coerced into pointer objects. */
6994 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
6996 if (noside
== EVAL_SKIP
)
6998 return value_array (tem2
, tem3
, argvec
);
7003 /* Allocate arg vector, including space for the function to be
7004 called in argvec[0] and a terminating NULL */
7005 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7006 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 2));
7008 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7009 /* FIXME: name should be defined in expresion.h */
7010 /* if (exp->elts[*pos].opcode == OP_UNRESOLVED_VALUE)
7011 error ("Unexpected unresolved symbol, %s, during evaluation",
7012 ada_demangle (exp->elts[pc + 5].name));
7016 error ("unexpected code path, FIXME");
7020 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7021 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7024 if (noside
== EVAL_SKIP
)
7028 if (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_REF
)
7029 argvec
[0] = value_addr (argvec
[0]);
7031 if (ada_is_packed_array_type (VALUE_TYPE (argvec
[0])))
7032 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7034 type
= check_typedef (VALUE_TYPE (argvec
[0]));
7035 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7037 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type
))))
7039 case TYPE_CODE_FUNC
:
7040 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7042 case TYPE_CODE_ARRAY
:
7044 case TYPE_CODE_STRUCT
:
7045 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7046 argvec
[0] = ada_value_ind (argvec
[0]);
7047 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7050 error ("cannot subscript or call something of type `%s'",
7051 ada_type_name (VALUE_TYPE (argvec
[0])));
7056 switch (TYPE_CODE (type
))
7058 case TYPE_CODE_FUNC
:
7059 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7060 return allocate_value (TYPE_TARGET_TYPE (type
));
7061 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7062 case TYPE_CODE_STRUCT
:
7064 int arity
= ada_array_arity (type
);
7065 type
= ada_array_element_type (type
, nargs
);
7067 error ("cannot subscript or call a record");
7069 error ("wrong number of subscripts; expecting %d", arity
);
7070 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7071 return allocate_value (ada_aligned_type (type
));
7072 return unwrap_value (ada_value_subscript (argvec
[0], nargs
, argvec
+1));
7074 case TYPE_CODE_ARRAY
:
7075 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7077 type
= ada_array_element_type (type
, nargs
);
7079 error ("element type of array unknown");
7081 return allocate_value (ada_aligned_type (type
));
7084 unwrap_value (ada_value_subscript
7085 (ada_coerce_to_simple_array (argvec
[0]),
7087 case TYPE_CODE_PTR
: /* Pointer to array */
7088 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7089 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7091 type
= ada_array_element_type (type
, nargs
);
7093 error ("element type of array unknown");
7095 return allocate_value (ada_aligned_type (type
));
7098 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7102 error ("Internal error in evaluate_subexp");
7107 struct value
* array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7109 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7111 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7112 if (noside
== EVAL_SKIP
)
7115 /* If this is a reference to an array, then dereference it */
7116 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
7117 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7118 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7120 && !ada_is_array_descriptor (check_typedef (VALUE_TYPE
7123 array
= ada_coerce_ref (array
);
7126 if (noside
== EVAL_AVOID_SIDE_EFFECTS
&&
7127 ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7129 /* Try to dereference the array, in case it is an access to array */
7130 struct type
* arrType
= ada_type_of_array (array
, 0);
7131 if (arrType
!= NULL
)
7132 array
= value_at_lazy (arrType
, 0, NULL
);
7134 if (ada_is_array_descriptor (VALUE_TYPE (array
)))
7135 array
= ada_coerce_to_simple_array (array
);
7137 /* If at this point we have a pointer to an array, it means that
7138 it is a pointer to a simple (non-ada) array. We just then
7140 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
7141 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7142 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7145 array
= ada_value_ind (array
);
7148 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7149 /* The following will get the bounds wrong, but only in contexts
7150 where the value is not being requested (FIXME?). */
7153 return value_slice (array
, lowbound
, upper
- lowbound
+ 1);
7156 /* FIXME: UNOP_MBR should be defined in expression.h */
7159 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7160 type = exp->elts[pc + 1].type;
7162 if (noside == EVAL_SKIP)
7165 switch (TYPE_CODE (type))
7168 warning ("Membership test incompletely implemented; always returns true");
7169 return value_from_longest (builtin_type_int, (LONGEST) 1);
7171 case TYPE_CODE_RANGE:
7172 arg2 = value_from_longest (builtin_type_int,
7173 (LONGEST) TYPE_LOW_BOUND (type));
7174 arg3 = value_from_longest (builtin_type_int,
7175 (LONGEST) TYPE_HIGH_BOUND (type));
7177 value_from_longest (builtin_type_int,
7178 (value_less (arg1,arg3)
7179 || value_equal (arg1,arg3))
7180 && (value_less (arg2,arg1)
7181 || value_equal (arg2,arg1)));
7184 /* FIXME: BINOP_MBR should be defined in expression.h */
7187 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7188 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7190 if (noside == EVAL_SKIP)
7193 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7194 return value_zero (builtin_type_int, not_lval);
7196 tem = longest_to_int (exp->elts[pc + 1].longconst);
7198 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
7199 error ("invalid dimension number to '%s", "range");
7201 arg3 = ada_array_bound (arg2, tem, 1);
7202 arg2 = ada_array_bound (arg2, tem, 0);
7205 value_from_longest (builtin_type_int,
7206 (value_less (arg1,arg3)
7207 || value_equal (arg1,arg3))
7208 && (value_less (arg2,arg1)
7209 || value_equal (arg2,arg1)));
7211 /* FIXME: TERNOP_MBR should be defined in expression.h */
7213 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7214 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7215 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7217 if (noside == EVAL_SKIP)
7221 value_from_longest (builtin_type_int,
7222 (value_less (arg1,arg3)
7223 || value_equal (arg1,arg3))
7224 && (value_less (arg2,arg1)
7225 || value_equal (arg2,arg1)));
7227 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
7228 /* case OP_ATTRIBUTE:
7230 atr = (enum ada_attribute) longest_to_int (exp->elts[pc + 2].longconst);
7234 error ("unexpected attribute encountered");
7240 struct type* type_arg;
7241 if (exp->elts[*pos].opcode == OP_TYPE)
7243 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7245 type_arg = exp->elts[pc + 5].type;
7249 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7253 if (exp->elts[*pos].opcode != OP_LONG)
7254 error ("illegal operand to '%s", ada_attribute_name (atr));
7255 tem = longest_to_int (exp->elts[*pos+2].longconst);
7258 if (noside == EVAL_SKIP)
7261 if (type_arg == NULL)
7263 arg1 = ada_coerce_ref (arg1);
7265 if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
7266 arg1 = ada_coerce_to_simple_array (arg1);
7268 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
7269 error ("invalid dimension number to '%s",
7270 ada_attribute_name (atr));
7272 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7274 type = ada_index_type (VALUE_TYPE (arg1), tem);
7276 error ("attempt to take bound of something that is not an array");
7277 return allocate_value (type);
7283 error ("unexpected attribute encountered");
7285 return ada_array_bound (arg1, tem, 0);
7287 return ada_array_bound (arg1, tem, 1);
7289 return ada_array_length (arg1, tem);
7292 else if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE
7293 || TYPE_CODE (type_arg) == TYPE_CODE_INT)
7295 struct type* range_type;
7296 char* name = ada_type_name (type_arg);
7299 if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE)
7300 range_type = type_arg;
7302 error ("unimplemented type attribute");
7306 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
7310 error ("unexpected attribute encountered");
7312 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7313 TYPE_LOW_BOUND (range_type));
7315 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7316 TYPE_HIGH_BOUND (range_type));
7319 else if (TYPE_CODE (type_arg) == TYPE_CODE_ENUM)
7324 error ("unexpected attribute encountered");
7326 return value_from_longest
7327 (type_arg, TYPE_FIELD_BITPOS (type_arg, 0));
7329 return value_from_longest
7331 TYPE_FIELD_BITPOS (type_arg,
7332 TYPE_NFIELDS (type_arg) - 1));
7335 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
7336 error ("unimplemented type attribute");
7341 if (ada_is_packed_array_type (type_arg))
7342 type_arg = decode_packed_array_type (type_arg);
7344 if (tem < 1 || tem > ada_array_arity (type_arg))
7345 error ("invalid dimension number to '%s",
7346 ada_attribute_name (atr));
7348 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7350 type = ada_index_type (type_arg, tem);
7352 error ("attempt to take bound of something that is not an array");
7353 return allocate_value (type);
7359 error ("unexpected attribute encountered");
7361 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7362 return value_from_longest (type, low);
7364 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
7365 return value_from_longest (type, high);
7367 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7368 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
7369 return value_from_longest (type, high-low+1);
7375 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7376 if (noside == EVAL_SKIP)
7379 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7381 value_zero (ada_tag_type (arg1), not_lval);
7383 return ada_value_tag (arg1);
7387 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7388 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7389 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7390 if (noside == EVAL_SKIP)
7392 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7393 return value_zero (VALUE_TYPE (arg1), not_lval);
7395 return value_binop (arg1, arg2,
7396 atr == ATR_MIN ? BINOP_MIN : BINOP_MAX);
7400 struct type* type_arg = exp->elts[pc + 5].type;
7401 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7404 if (noside == EVAL_SKIP)
7407 if (! ada_is_modular_type (type_arg))
7408 error ("'modulus must be applied to modular type");
7410 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
7411 ada_modulus (type_arg));
7416 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7417 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7418 if (noside == EVAL_SKIP)
7420 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7421 return value_zero (builtin_type_ada_int, not_lval);
7423 return value_pos_atr (arg1);
7426 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7427 if (noside == EVAL_SKIP)
7429 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7430 return value_zero (builtin_type_ada_int, not_lval);
7432 return value_from_longest (builtin_type_ada_int,
7434 * TYPE_LENGTH (VALUE_TYPE (arg1)));
7437 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7438 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7439 type = exp->elts[pc + 5].type;
7440 if (noside == EVAL_SKIP)
7442 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7443 return value_zero (type, not_lval);
7445 return value_val_atr (type, arg1);
7448 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7449 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7450 if (noside
== EVAL_SKIP
)
7452 if (binop_user_defined_p (op
, arg1
, arg2
))
7453 return unwrap_value (value_x_binop (arg1
, arg2
, op
, OP_NULL
,
7456 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7457 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7459 return value_binop (arg1
, arg2
, op
);
7462 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7463 if (noside
== EVAL_SKIP
)
7465 if (unop_user_defined_p (op
, arg1
))
7466 return unwrap_value (value_x_unop (arg1
, op
, EVAL_NORMAL
));
7471 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7472 if (noside
== EVAL_SKIP
)
7474 if (value_less (arg1
, value_zero (VALUE_TYPE (arg1
), not_lval
)))
7475 return value_neg (arg1
);
7480 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
7481 expect_type
= TYPE_TARGET_TYPE (check_typedef (expect_type
));
7482 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
7483 if (noside
== EVAL_SKIP
)
7485 type
= check_typedef (VALUE_TYPE (arg1
));
7486 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7488 if (ada_is_array_descriptor (type
))
7489 /* GDB allows dereferencing GNAT array descriptors. */
7491 struct type
* arrType
= ada_type_of_array (arg1
, 0);
7492 if (arrType
== NULL
)
7493 error ("Attempt to dereference null array pointer.");
7494 return value_at_lazy (arrType
, 0, NULL
);
7496 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
7497 || TYPE_CODE (type
) == TYPE_CODE_REF
7498 /* In C you can dereference an array to get the 1st elt. */
7499 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
7503 (to_static_fixed_type
7504 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type
)))),
7506 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
7507 /* GDB allows dereferencing an int. */
7508 return value_zero (builtin_type_int
, lval_memory
);
7510 error ("Attempt to take contents of a non-pointer value.");
7512 arg1
= ada_coerce_ref (arg1
);
7513 type
= check_typedef (VALUE_TYPE (arg1
));
7515 if (ada_is_array_descriptor (type
))
7516 /* GDB allows dereferencing GNAT array descriptors. */
7517 return ada_coerce_to_simple_array (arg1
);
7519 return ada_value_ind (arg1
);
7521 case STRUCTOP_STRUCT
:
7522 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7523 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7524 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7525 if (noside
== EVAL_SKIP
)
7527 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7528 return value_zero (ada_aligned_type
7529 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7530 &exp
->elts
[pc
+ 2].string
,
7534 return unwrap_value (ada_value_struct_elt (arg1
,
7535 &exp
->elts
[pc
+ 2].string
,
7538 /* The value is not supposed to be used. This is here to make it
7539 easier to accommodate expressions that contain types. */
7541 if (noside
== EVAL_SKIP
)
7543 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7544 return allocate_value (builtin_type_void
);
7546 error ("Attempt to use a type name as an expression");
7549 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7550 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7551 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7552 if (noside
== EVAL_SKIP
)
7554 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7555 return value_zero (ada_aligned_type
7556 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7557 &exp
->elts
[pc
+ 2].string
,
7561 return unwrap_value (ada_value_struct_elt (arg1
,
7562 &exp
->elts
[pc
+ 2].string
,
7567 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
7573 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7574 type name that encodes the 'small and 'delta information.
7575 Otherwise, return NULL. */
7578 fixed_type_info (struct type
*type
)
7580 const char* name
= ada_type_name (type
);
7581 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
7583 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
)
7586 const char *tail
= strstr (name
, "___XF_");
7592 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
7593 return fixed_type_info (TYPE_TARGET_TYPE (type
));
7598 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7601 ada_is_fixed_point_type (struct type
*type
)
7603 return fixed_type_info (type
) != NULL
;
7606 /* Assuming that TYPE is the representation of an Ada fixed-point
7607 type, return its delta, or -1 if the type is malformed and the
7608 delta cannot be determined. */
7611 ada_delta (struct type
*type
)
7613 const char *encoding
= fixed_type_info (type
);
7616 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
7619 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
7622 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7623 factor ('SMALL value) associated with the type. */
7626 scaling_factor (struct type
*type
)
7628 const char *encoding
= fixed_type_info (type
);
7629 unsigned long num0
, den0
, num1
, den1
;
7632 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
7637 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
7639 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
7643 /* Assuming that X is the representation of a value of fixed-point
7644 type TYPE, return its floating-point equivalent. */
7647 ada_fixed_to_float (struct type
*type
, LONGEST x
)
7649 return (DOUBLEST
) x
* scaling_factor (type
);
7652 /* The representation of a fixed-point value of type TYPE
7653 corresponding to the value X. */
7656 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
7658 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
7662 /* VAX floating formats */
7664 /* Non-zero iff TYPE represents one of the special VAX floating-point
7667 ada_is_vax_floating_type (struct type
* type
)
7670 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
7673 && (TYPE_CODE (type
) == TYPE_CODE_INT
7674 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7675 && STREQN (ada_type_name (type
) + name_len
- 6, "___XF", 5);
7678 /* The type of special VAX floating-point type this is, assuming
7679 ada_is_vax_floating_point */
7681 ada_vax_float_type_suffix (struct type
* type
)
7683 return ada_type_name (type
)[strlen (ada_type_name (type
))-1];
7686 /* A value representing the special debugging function that outputs
7687 VAX floating-point values of the type represented by TYPE. Assumes
7688 ada_is_vax_floating_type (TYPE). */
7690 ada_vax_float_print_function (struct type
* type
)
7692 switch (ada_vax_float_type_suffix (type
)) {
7695 get_var_value ("DEBUG_STRING_F", 0);
7698 get_var_value ("DEBUG_STRING_D", 0);
7701 get_var_value ("DEBUG_STRING_G", 0);
7703 error ("invalid VAX floating-point type");
7710 /* Scan STR beginning at position K for a discriminant name, and
7711 return the value of that discriminant field of DVAL in *PX. If
7712 PNEW_K is not null, put the position of the character beyond the
7713 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
7714 not alter *PX and *PNEW_K if unsuccessful. */
7717 scan_discrim_bound (char *, int k
, struct value
* dval
, LONGEST
*px
, int *pnew_k
)
7719 static char *bound_buffer
= NULL
;
7720 static size_t bound_buffer_len
= 0;
7723 struct value
* bound_val
;
7725 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
7728 pend
= strstr (str
+k
, "__");
7732 k
+= strlen (bound
);
7736 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+k
) + 1);
7737 bound
= bound_buffer
;
7738 strncpy (bound_buffer
, str
+k
, pend
-(str
+k
));
7739 bound
[pend
-(str
+k
)] = '\0';
7744 ada_search_struct_field (bound
, dval
, 0, VALUE_TYPE (dval
));
7745 if (bound_val
== NULL
)
7748 *px
= value_as_long (bound_val
);
7754 /* Value of variable named NAME in the current environment. If
7755 no such variable found, then if ERR_MSG is null, returns 0, and
7756 otherwise causes an error with message ERR_MSG. */
7757 static struct value
*
7758 get_var_value (char* name
, char* err_msg
)
7760 struct symbol
** syms
;
7761 struct block
** blocks
;
7764 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (NULL
), VAR_NAMESPACE
,
7769 if (err_msg
== NULL
)
7772 error ("%s", err_msg
);
7775 return value_of_variable (syms
[0], blocks
[0]);
7778 /* Value of integer variable named NAME in the current environment. If
7779 no such variable found, then if ERR_MSG is null, returns 0, and sets
7780 *FLAG to 0. If successful, sets *FLAG to 1. */
7782 get_int_var_value (char* name
, char* err_msg
, int* flag
)
7784 struct value
* var_val
= get_var_value (name
, err_msg
);
7796 return value_as_long (var_val
);
7801 /* Return a range type whose base type is that of the range type named
7802 NAME in the current environment, and whose bounds are calculated
7803 from NAME according to the GNAT range encoding conventions.
7804 Extract discriminant values, if needed, from DVAL. If a new type
7805 must be created, allocate in OBJFILE's space. The bounds
7806 information, in general, is encoded in NAME, the base type given in
7807 the named range type. */
7810 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
7812 struct type
*raw_type
= ada_find_any_type (name
);
7813 struct type
*base_type
;
7817 if (raw_type
== NULL
)
7818 base_type
= builtin_type_int
;
7819 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
7820 base_type
= TYPE_TARGET_TYPE (raw_type
);
7822 base_type
= raw_type
;
7824 subtype_info
= strstr (name
, "___XD");
7825 if (subtype_info
== NULL
)
7829 static char *name_buf
= NULL
;
7830 static size_t name_len
= 0;
7831 int prefix_len
= subtype_info
- name
;
7837 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
7838 strncpy (name_buf
, name
, prefix_len
);
7839 name_buf
[prefix_len
] = '\0';
7842 bounds_str
= strchr (subtype_info
, '_');
7845 if (*subtype_info
== 'L')
7847 if (! ada_scan_number (bounds_str
, n
, &L
, &n
)
7848 && ! scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
7850 if (bounds_str
[n
] == '_')
7852 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
7858 strcpy (name_buf
+prefix_len
, "___L");
7859 L
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7862 if (*subtype_info
== 'U')
7864 if (! ada_scan_number (bounds_str
, n
, &U
, &n
)
7865 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
7870 strcpy (name_buf
+prefix_len
, "___U");
7871 U
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7874 if (objfile
== NULL
)
7875 objfile
= TYPE_OBJFILE (base_type
);
7876 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
7877 TYPE_NAME (type
) = name
;
7882 /* True iff NAME is the name of a range type. */
7884 ada_is_range_type_name (const char* name
)
7886 return (name
!= NULL
&& strstr (name
, "___XD"));
7892 /* True iff TYPE is an Ada modular type. */
7894 ada_is_modular_type (struct type
* type
)
7896 /* FIXME: base_type should be declared in gdbtypes.h, implemented in
7898 struct type
* subranged_type
; /* = base_type (type);*/
7900 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
7901 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
7902 && TYPE_UNSIGNED (subranged_type
));
7905 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
7907 ada_modulus (struct type
* type
)
7909 return TYPE_HIGH_BOUND (type
) + 1;
7916 /* Table mapping opcodes into strings for printing operators
7917 and precedences of the operators. */
7919 static const struct op_print ada_op_print_tab
[] =
7921 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
7922 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
7923 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
7924 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
7925 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
7926 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
7927 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
7928 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
7929 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
7930 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
7931 {">", BINOP_GTR
, PREC_ORDER
, 0},
7932 {"<", BINOP_LESS
, PREC_ORDER
, 0},
7933 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
7934 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
7935 {"+", BINOP_ADD
, PREC_ADD
, 0},
7936 {"-", BINOP_SUB
, PREC_ADD
, 0},
7937 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
7938 {"*", BINOP_MUL
, PREC_MUL
, 0},
7939 {"/", BINOP_DIV
, PREC_MUL
, 0},
7940 {"rem", BINOP_REM
, PREC_MUL
, 0},
7941 {"mod", BINOP_MOD
, PREC_MUL
, 0},
7942 {"**", BINOP_EXP
, PREC_REPEAT
, 0 },
7943 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
7944 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
7945 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
7946 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
7947 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
7948 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
7949 {".all", UNOP_IND
, PREC_SUFFIX
, 1}, /* FIXME: postfix .ALL */
7950 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1}, /* FIXME: postfix 'ACCESS */
7954 /* Assorted Types and Interfaces */
7956 struct type
* builtin_type_ada_int
;
7957 struct type
* builtin_type_ada_short
;
7958 struct type
* builtin_type_ada_long
;
7959 struct type
* builtin_type_ada_long_long
;
7960 struct type
* builtin_type_ada_char
;
7961 struct type
* builtin_type_ada_float
;
7962 struct type
* builtin_type_ada_double
;
7963 struct type
* builtin_type_ada_long_double
;
7964 struct type
* builtin_type_ada_natural
;
7965 struct type
* builtin_type_ada_positive
;
7966 struct type
* builtin_type_ada_system_address
;
7968 struct type
** const (ada_builtin_types
[]) =
7971 &builtin_type_ada_int
,
7972 &builtin_type_ada_long
,
7973 &builtin_type_ada_short
,
7974 &builtin_type_ada_char
,
7975 &builtin_type_ada_float
,
7976 &builtin_type_ada_double
,
7977 &builtin_type_ada_long_long
,
7978 &builtin_type_ada_long_double
,
7979 &builtin_type_ada_natural
,
7980 &builtin_type_ada_positive
,
7982 /* The following types are carried over from C for convenience. */
7985 &builtin_type_short
,
7987 &builtin_type_float
,
7988 &builtin_type_double
,
7989 &builtin_type_long_long
,
7991 &builtin_type_signed_char
,
7992 &builtin_type_unsigned_char
,
7993 &builtin_type_unsigned_short
,
7994 &builtin_type_unsigned_int
,
7995 &builtin_type_unsigned_long
,
7996 &builtin_type_unsigned_long_long
,
7997 &builtin_type_long_double
,
7998 &builtin_type_complex
,
7999 &builtin_type_double_complex
,
8003 /* Not really used, but needed in the ada_language_defn. */
8004 static void emit_char (int c
, struct ui_file
* stream
, int quoter
)
8006 ada_emit_char (c
, stream
, quoter
, 1);
8009 const struct language_defn ada_language_defn
= {
8010 "ada", /* Language name */
8013 /* FIXME: language_ada should be defined in defs.h */
8017 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8018 * that's not quite what this means. */
8021 ada_evaluate_subexp
,
8022 ada_printchar
, /* Print a character constant */
8023 ada_printstr
, /* Function to print string constant */
8024 emit_char
, /* Function to print single char (not used) */
8025 ada_create_fundamental_type
, /* Create fundamental type in this language */
8026 ada_print_type
, /* Print a type using appropriate syntax */
8027 ada_val_print
, /* Print a value using appropriate syntax */
8028 ada_value_print
, /* Print a top-level value */
8029 {"", "", "", ""}, /* Binary format info */
8031 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
8032 {"%ld", "", "d", ""}, /* Decimal format info */
8033 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
8035 /* Copied from c-lang.c. */
8036 {"0%lo", "0", "o", ""}, /* Octal format info */
8037 {"%ld", "", "d", ""}, /* Decimal format info */
8038 {"0x%lx", "0x", "x", ""}, /* Hex format info */
8040 ada_op_print_tab
, /* expression operators for printing */
8041 1, /* c-style arrays (FIXME?) */
8042 0, /* String lower bound (FIXME?) */
8043 &builtin_type_ada_char
,
8048 _initialize_ada_language ()
8050 builtin_type_ada_int
=
8051 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8053 "integer", (struct objfile
*) NULL
);
8054 builtin_type_ada_long
=
8055 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8057 "long_integer", (struct objfile
*) NULL
);
8058 builtin_type_ada_short
=
8059 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8061 "short_integer", (struct objfile
*) NULL
);
8062 builtin_type_ada_char
=
8063 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8065 "character", (struct objfile
*) NULL
);
8066 builtin_type_ada_float
=
8067 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8069 "float", (struct objfile
*) NULL
);
8070 builtin_type_ada_double
=
8071 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8073 "long_float", (struct objfile
*) NULL
);
8074 builtin_type_ada_long_long
=
8075 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8077 "long_long_integer", (struct objfile
*) NULL
);
8078 builtin_type_ada_long_double
=
8079 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8081 "long_long_float", (struct objfile
*) NULL
);
8082 builtin_type_ada_natural
=
8083 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8085 "natural", (struct objfile
*) NULL
);
8086 builtin_type_ada_positive
=
8087 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8089 "positive", (struct objfile
*) NULL
);
8092 builtin_type_ada_system_address
=
8093 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8094 (struct objfile
*) NULL
));
8095 TYPE_NAME (builtin_type_ada_system_address
) = "system__address";
8097 add_language (&ada_language_defn
);
8100 (add_set_cmd ("varsize-limit", class_support
, var_uinteger
,
8101 (char*) &varsize_limit
,
8102 "Set maximum bytes in dynamic-sized object.",
8105 varsize_limit
= 65536;
8107 add_com ("begin", class_breakpoint
, begin_command
,
8108 "Start the debugged program, stopping at the beginning of the\n\
8109 main program. You may specify command-line arguments to give it, as for\n\
8110 the \"run\" command (q.v.).");
8114 /* Create a fundamental Ada type using default reasonable for the current
8117 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8118 define fundamental types such as "int" or "double". Others (stabs or
8119 DWARF version 2, etc) do define fundamental types. For the formats which
8120 don't provide fundamental types, gdb can create such types using this
8123 FIXME: Some compilers distinguish explicitly signed integral types
8124 (signed short, signed int, signed long) from "regular" integral types
8125 (short, int, long) in the debugging information. There is some dis-
8126 agreement as to how useful this feature is. In particular, gcc does
8127 not support this. Also, only some debugging formats allow the
8128 distinction to be passed on to a debugger. For now, we always just
8129 use "short", "int", or "long" as the type name, for both the implicit
8130 and explicitly signed types. This also makes life easier for the
8131 gdb test suite since we don't have to account for the differences
8132 in output depending upon what the compiler and debugging format
8133 support. We will probably have to re-examine the issue when gdb
8134 starts taking it's fundamental type information directly from the
8135 debugging information supplied by the compiler. fnf@cygnus.com */
8137 static struct type
*
8138 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8140 struct type
*type
= NULL
;
8145 /* FIXME: For now, if we are asked to produce a type not in this
8146 language, create the equivalent of a C integer type with the
8147 name "<?type?>". When all the dust settles from the type
8148 reconstruction work, this should probably become an error. */
8149 type
= init_type (TYPE_CODE_INT
,
8150 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8151 0, "<?type?>", objfile
);
8152 warning ("internal error: no Ada fundamental type %d", typeid);
8155 type
= init_type (TYPE_CODE_VOID
,
8156 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8157 0, "void", objfile
);
8160 type
= init_type (TYPE_CODE_INT
,
8161 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8162 0, "character", objfile
);
8164 case FT_SIGNED_CHAR
:
8165 type
= init_type (TYPE_CODE_INT
,
8166 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8167 0, "signed char", objfile
);
8169 case FT_UNSIGNED_CHAR
:
8170 type
= init_type (TYPE_CODE_INT
,
8171 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8172 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8175 type
= init_type (TYPE_CODE_INT
,
8176 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8177 0, "short_integer", objfile
);
8179 case FT_SIGNED_SHORT
:
8180 type
= init_type (TYPE_CODE_INT
,
8181 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8182 0, "short_integer", objfile
);
8184 case FT_UNSIGNED_SHORT
:
8185 type
= init_type (TYPE_CODE_INT
,
8186 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8187 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8190 type
= init_type (TYPE_CODE_INT
,
8191 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8192 0, "integer", objfile
);
8194 case FT_SIGNED_INTEGER
:
8195 type
= init_type (TYPE_CODE_INT
,
8196 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8197 0, "integer", objfile
); /* FIXME -fnf */
8199 case FT_UNSIGNED_INTEGER
:
8200 type
= init_type (TYPE_CODE_INT
,
8201 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8202 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8205 type
= init_type (TYPE_CODE_INT
,
8206 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8207 0, "long_integer", objfile
);
8209 case FT_SIGNED_LONG
:
8210 type
= init_type (TYPE_CODE_INT
,
8211 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8212 0, "long_integer", objfile
);
8214 case FT_UNSIGNED_LONG
:
8215 type
= init_type (TYPE_CODE_INT
,
8216 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8217 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8220 type
= init_type (TYPE_CODE_INT
,
8221 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8222 0, "long_long_integer", objfile
);
8224 case FT_SIGNED_LONG_LONG
:
8225 type
= init_type (TYPE_CODE_INT
,
8226 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8227 0, "long_long_integer", objfile
);
8229 case FT_UNSIGNED_LONG_LONG
:
8230 type
= init_type (TYPE_CODE_INT
,
8231 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8232 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8235 type
= init_type (TYPE_CODE_FLT
,
8236 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8237 0, "float", objfile
);
8239 case FT_DBL_PREC_FLOAT
:
8240 type
= init_type (TYPE_CODE_FLT
,
8241 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8242 0, "long_float", objfile
);
8244 case FT_EXT_PREC_FLOAT
:
8245 type
= init_type (TYPE_CODE_FLT
,
8246 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8247 0, "long_long_float", objfile
);
8253 void ada_dump_symtab (struct symtab
* s
)
8256 fprintf (stderr
, "New symtab: [\n");
8257 fprintf (stderr
, " Name: %s/%s;\n",
8258 s
->dirname
? s
->dirname
: "?",
8259 s
->filename
? s
->filename
: "?");
8260 fprintf (stderr
, " Format: %s;\n", s
->debugformat
);
8261 if (s
->linetable
!= NULL
)
8263 fprintf (stderr
, " Line table (section %d):\n", s
->block_line_section
);
8264 for (i
= 0; i
< s
->linetable
->nitems
; i
+= 1)
8266 struct linetable_entry
* e
= s
->linetable
->item
+ i
;
8267 fprintf (stderr
, " %4ld: %8lx\n", (long) e
->line
, (long) e
->pc
);
8270 fprintf (stderr
, "]\n");