+ return tail + 5;
+ }
+ else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
+ return fixed_type_info (TYPE_TARGET_TYPE (type));
+ else
+ return NULL;
+}
+
+/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
+
+int
+ada_is_fixed_point_type (struct type *type)
+{
+ return fixed_type_info (type) != NULL;
+}
+
+/* Return non-zero iff TYPE represents a System.Address type. */
+
+int
+ada_is_system_address_type (struct type *type)
+{
+ return (TYPE_NAME (type)
+ && strcmp (TYPE_NAME (type), "system__address") == 0);
+}
+
+/* Assuming that TYPE is the representation of an Ada fixed-point
+ type, return its delta, or -1 if the type is malformed and the
+ delta cannot be determined. */
+
+DOUBLEST
+ada_delta (struct type *type)
+{
+ const char *encoding = fixed_type_info (type);
+ long num, den;
+
+ if (sscanf (encoding, "_%ld_%ld", &num, &den) < 2)
+ return -1.0;
+ else
+ return (DOUBLEST) num / (DOUBLEST) den;
+}
+
+/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
+ factor ('SMALL value) associated with the type. */
+
+static DOUBLEST
+scaling_factor (struct type *type)
+{
+ const char *encoding = fixed_type_info (type);
+ unsigned long num0, den0, num1, den1;
+ int n;
+
+ n = sscanf (encoding, "_%lu_%lu_%lu_%lu", &num0, &den0, &num1, &den1);
+
+ if (n < 2)
+ return 1.0;
+ else if (n == 4)
+ return (DOUBLEST) num1 / (DOUBLEST) den1;
+ else
+ return (DOUBLEST) num0 / (DOUBLEST) den0;
+}
+
+
+/* Assuming that X is the representation of a value of fixed-point
+ type TYPE, return its floating-point equivalent. */
+
+DOUBLEST
+ada_fixed_to_float (struct type *type, LONGEST x)
+{
+ return (DOUBLEST) x *scaling_factor (type);
+}
+
+/* The representation of a fixed-point value of type TYPE
+ corresponding to the value X. */
+
+LONGEST
+ada_float_to_fixed (struct type *type, DOUBLEST x)
+{
+ return (LONGEST) (x / scaling_factor (type) + 0.5);
+}
+
+
+ /* VAX floating formats */
+
+/* Non-zero iff TYPE represents one of the special VAX floating-point
+ types. */
+
+int
+ada_is_vax_floating_type (struct type *type)
+{
+ int name_len =
+ (ada_type_name (type) == NULL) ? 0 : strlen (ada_type_name (type));
+ return
+ name_len > 6
+ && (TYPE_CODE (type) == TYPE_CODE_INT
+ || TYPE_CODE (type) == TYPE_CODE_RANGE)
+ && strncmp (ada_type_name (type) + name_len - 6, "___XF", 5) == 0;
+}
+
+/* The type of special VAX floating-point type this is, assuming
+ ada_is_vax_floating_point. */
+
+int
+ada_vax_float_type_suffix (struct type *type)
+{
+ return ada_type_name (type)[strlen (ada_type_name (type)) - 1];
+}
+
+/* A value representing the special debugging function that outputs
+ VAX floating-point values of the type represented by TYPE. Assumes
+ ada_is_vax_floating_type (TYPE). */
+
+struct value *
+ada_vax_float_print_function (struct type *type)
+{
+ switch (ada_vax_float_type_suffix (type))
+ {
+ case 'F':
+ return get_var_value ("DEBUG_STRING_F", 0);
+ case 'D':
+ return get_var_value ("DEBUG_STRING_D", 0);
+ case 'G':
+ return get_var_value ("DEBUG_STRING_G", 0);
+ default:
+ error (_("invalid VAX floating-point type"));
+ }
+}
+\f
+
+ /* Range types */
+
+/* Scan STR beginning at position K for a discriminant name, and
+ return the value of that discriminant field of DVAL in *PX. If
+ PNEW_K is not null, put the position of the character beyond the
+ name scanned in *PNEW_K. Return 1 if successful; return 0 and do
+ not alter *PX and *PNEW_K if unsuccessful. */
+
+static int
+scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
+ int *pnew_k)
+{
+ static char *bound_buffer = NULL;
+ static size_t bound_buffer_len = 0;
+ char *bound;
+ char *pend;
+ struct value *bound_val;
+
+ if (dval == NULL || str == NULL || str[k] == '\0')
+ return 0;
+
+ pend = strstr (str + k, "__");
+ if (pend == NULL)
+ {
+ bound = str + k;
+ k += strlen (bound);
+ }
+ else
+ {
+ GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
+ bound = bound_buffer;
+ strncpy (bound_buffer, str + k, pend - (str + k));
+ bound[pend - (str + k)] = '\0';
+ k = pend - str;
+ }
+
+ bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
+ if (bound_val == NULL)
+ return 0;
+
+ *px = value_as_long (bound_val);
+ if (pnew_k != NULL)
+ *pnew_k = k;
+ return 1;
+}
+
+/* Value of variable named NAME in the current environment. If
+ no such variable found, then if ERR_MSG is null, returns 0, and
+ otherwise causes an error with message ERR_MSG. */
+
+static struct value *
+get_var_value (char *name, char *err_msg)
+{
+ struct ada_symbol_info *syms;
+ int nsyms;
+
+ nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
+ &syms);
+
+ if (nsyms != 1)
+ {
+ if (err_msg == NULL)
+ return 0;
+ else
+ error (("%s"), err_msg);
+ }
+
+ return value_of_variable (syms[0].sym, syms[0].block);
+}
+
+/* Value of integer variable named NAME in the current environment. If
+ no such variable found, returns 0, and sets *FLAG to 0. If
+ successful, sets *FLAG to 1. */
+
+LONGEST
+get_int_var_value (char *name, int *flag)
+{
+ struct value *var_val = get_var_value (name, 0);
+
+ if (var_val == 0)
+ {
+ if (flag != NULL)
+ *flag = 0;
+ return 0;
+ }
+ else
+ {
+ if (flag != NULL)
+ *flag = 1;
+ return value_as_long (var_val);
+ }
+}
+
+
+/* Return a range type whose base type is that of the range type named
+ NAME in the current environment, and whose bounds are calculated
+ from NAME according to the GNAT range encoding conventions.
+ Extract discriminant values, if needed, from DVAL. If a new type
+ must be created, allocate in OBJFILE's space. The bounds
+ information, in general, is encoded in NAME, the base type given in
+ the named range type. */
+
+static struct type *
+to_fixed_range_type (char *name, struct value *dval, struct objfile *objfile)
+{
+ struct type *raw_type = ada_find_any_type (name);
+ struct type *base_type;
+ char *subtype_info;
+
+ if (raw_type == NULL)
+ base_type = builtin_type_int32;
+ else if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
+ base_type = TYPE_TARGET_TYPE (raw_type);
+ else
+ base_type = raw_type;
+
+ subtype_info = strstr (name, "___XD");
+ if (subtype_info == NULL)
+ {
+ LONGEST L = discrete_type_low_bound (raw_type);
+ LONGEST U = discrete_type_high_bound (raw_type);
+ if (L < INT_MIN || U > INT_MAX)
+ return raw_type;
+ else
+ return create_range_type (alloc_type (objfile), raw_type,
+ discrete_type_low_bound (raw_type),
+ discrete_type_high_bound (raw_type));
+ }
+ else
+ {
+ static char *name_buf = NULL;
+ static size_t name_len = 0;
+ int prefix_len = subtype_info - name;
+ LONGEST L, U;
+ struct type *type;
+ char *bounds_str;
+ int n;
+
+ GROW_VECT (name_buf, name_len, prefix_len + 5);
+ strncpy (name_buf, name, prefix_len);
+ name_buf[prefix_len] = '\0';
+
+ subtype_info += 5;
+ bounds_str = strchr (subtype_info, '_');
+ n = 1;
+
+ if (*subtype_info == 'L')
+ {
+ if (!ada_scan_number (bounds_str, n, &L, &n)
+ && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
+ return raw_type;
+ if (bounds_str[n] == '_')
+ n += 2;
+ else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
+ n += 1;
+ subtype_info += 1;
+ }
+ else
+ {
+ int ok;
+ strcpy (name_buf + prefix_len, "___L");
+ L = get_int_var_value (name_buf, &ok);
+ if (!ok)
+ {
+ lim_warning (_("Unknown lower bound, using 1."));
+ L = 1;
+ }
+ }
+
+ if (*subtype_info == 'U')
+ {
+ if (!ada_scan_number (bounds_str, n, &U, &n)
+ && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
+ return raw_type;
+ }
+ else
+ {
+ int ok;
+ strcpy (name_buf + prefix_len, "___U");
+ U = get_int_var_value (name_buf, &ok);
+ if (!ok)
+ {
+ lim_warning (_("Unknown upper bound, using %ld."), (long) L);
+ U = L;
+ }
+ }
+
+ if (objfile == NULL)
+ objfile = TYPE_OBJFILE (base_type);
+ type = create_range_type (alloc_type (objfile), base_type, L, U);
+ TYPE_NAME (type) = name;
+ return type;
+ }
+}
+
+/* True iff NAME is the name of a range type. */
+
+int
+ada_is_range_type_name (const char *name)
+{
+ return (name != NULL && strstr (name, "___XD"));
+}
+\f
+
+ /* Modular types */
+
+/* True iff TYPE is an Ada modular type. */
+
+int
+ada_is_modular_type (struct type *type)
+{
+ struct type *subranged_type = base_type (type);
+
+ return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
+ && TYPE_CODE (subranged_type) == TYPE_CODE_INT
+ && TYPE_UNSIGNED (subranged_type));
+}
+
+/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
+
+ULONGEST
+ada_modulus (struct type * type)
+{
+ return (ULONGEST) (unsigned int) TYPE_HIGH_BOUND (type) + 1;
+}
+\f
+
+/* Ada exception catchpoint support:
+ ---------------------------------
+
+ We support 3 kinds of exception catchpoints:
+ . catchpoints on Ada exceptions
+ . catchpoints on unhandled Ada exceptions
+ . catchpoints on failed assertions
+
+ Exceptions raised during failed assertions, or unhandled exceptions
+ could perfectly be caught with the general catchpoint on Ada exceptions.
+ However, we can easily differentiate these two special cases, and having
+ the option to distinguish these two cases from the rest can be useful
+ to zero-in on certain situations.
+
+ Exception catchpoints are a specialized form of breakpoint,
+ since they rely on inserting breakpoints inside known routines
+ of the GNAT runtime. The implementation therefore uses a standard
+ breakpoint structure of the BP_BREAKPOINT type, but with its own set
+ of breakpoint_ops.
+
+ Support in the runtime for exception catchpoints have been changed
+ a few times already, and these changes affect the implementation
+ of these catchpoints. In order to be able to support several
+ variants of the runtime, we use a sniffer that will determine
+ the runtime variant used by the program being debugged.
+
+ At this time, we do not support the use of conditions on Ada exception
+ catchpoints. The COND and COND_STRING fields are therefore set
+ to NULL (most of the time, see below).
+
+ Conditions where EXP_STRING, COND, and COND_STRING are used:
+
+ When a user specifies the name of a specific exception in the case
+ of catchpoints on Ada exceptions, we store the name of that exception
+ in the EXP_STRING. We then translate this request into an actual
+ condition stored in COND_STRING, and then parse it into an expression
+ stored in COND. */
+
+/* The different types of catchpoints that we introduced for catching
+ Ada exceptions. */
+
+enum exception_catchpoint_kind
+{
+ ex_catch_exception,
+ ex_catch_exception_unhandled,
+ ex_catch_assert
+};
+
+/* Ada's standard exceptions. */
+
+static char *standard_exc[] = {
+ "constraint_error",
+ "program_error",
+ "storage_error",
+ "tasking_error"
+};
+
+typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
+
+/* A structure that describes how to support exception catchpoints
+ for a given executable. */
+
+struct exception_support_info
+{
+ /* The name of the symbol to break on in order to insert
+ a catchpoint on exceptions. */
+ const char *catch_exception_sym;
+
+ /* The name of the symbol to break on in order to insert
+ a catchpoint on unhandled exceptions. */
+ const char *catch_exception_unhandled_sym;
+
+ /* The name of the symbol to break on in order to insert
+ a catchpoint on failed assertions. */
+ const char *catch_assert_sym;
+
+ /* Assuming that the inferior just triggered an unhandled exception
+ catchpoint, this function is responsible for returning the address
+ in inferior memory where the name of that exception is stored.
+ Return zero if the address could not be computed. */
+ ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
+};
+
+static CORE_ADDR ada_unhandled_exception_name_addr (void);
+static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
+
+/* The following exception support info structure describes how to
+ implement exception catchpoints with the latest version of the
+ Ada runtime (as of 2007-03-06). */
+
+static const struct exception_support_info default_exception_support_info =
+{
+ "__gnat_debug_raise_exception", /* catch_exception_sym */
+ "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
+ "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
+ ada_unhandled_exception_name_addr
+};
+
+/* The following exception support info structure describes how to
+ implement exception catchpoints with a slightly older version
+ of the Ada runtime. */
+
+static const struct exception_support_info exception_support_info_fallback =
+{
+ "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
+ "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
+ "system__assertions__raise_assert_failure", /* catch_assert_sym */
+ ada_unhandled_exception_name_addr_from_raise
+};
+
+/* For each executable, we sniff which exception info structure to use
+ and cache it in the following global variable. */
+
+static const struct exception_support_info *exception_info = NULL;
+
+/* Inspect the Ada runtime and determine which exception info structure
+ should be used to provide support for exception catchpoints.
+
+ This function will always set exception_info, or raise an error. */
+
+static void
+ada_exception_support_info_sniffer (void)
+{
+ struct symbol *sym;
+
+ /* If the exception info is already known, then no need to recompute it. */
+ if (exception_info != NULL)
+ return;
+
+ /* Check the latest (default) exception support info. */
+ sym = standard_lookup (default_exception_support_info.catch_exception_sym,
+ NULL, VAR_DOMAIN);
+ if (sym != NULL)
+ {
+ exception_info = &default_exception_support_info;
+ return;
+ }
+
+ /* Try our fallback exception suport info. */
+ sym = standard_lookup (exception_support_info_fallback.catch_exception_sym,
+ NULL, VAR_DOMAIN);
+ if (sym != NULL)
+ {
+ exception_info = &exception_support_info_fallback;
+ return;
+ }
+
+ /* Sometimes, it is normal for us to not be able to find the routine
+ we are looking for. This happens when the program is linked with
+ the shared version of the GNAT runtime, and the program has not been
+ started yet. Inform the user of these two possible causes if
+ applicable. */
+
+ if (ada_update_initial_language (language_unknown, NULL) != language_ada)
+ error (_("Unable to insert catchpoint. Is this an Ada main program?"));
+
+ /* If the symbol does not exist, then check that the program is
+ already started, to make sure that shared libraries have been
+ loaded. If it is not started, this may mean that the symbol is
+ in a shared library. */
+
+ if (ptid_get_pid (inferior_ptid) == 0)
+ error (_("Unable to insert catchpoint. Try to start the program first."));
+
+ /* At this point, we know that we are debugging an Ada program and
+ that the inferior has been started, but we still are not able to
+ find the run-time symbols. That can mean that we are in
+ configurable run time mode, or that a-except as been optimized
+ out by the linker... In any case, at this point it is not worth
+ supporting this feature. */
+
+ error (_("Cannot insert catchpoints in this configuration."));
+}
+
+/* An observer of "executable_changed" events.
+ Its role is to clear certain cached values that need to be recomputed
+ each time a new executable is loaded by GDB. */
+
+static void
+ada_executable_changed_observer (void)
+{
+ /* If the executable changed, then it is possible that the Ada runtime
+ is different. So we need to invalidate the exception support info
+ cache. */
+ exception_info = NULL;
+}
+
+/* Return the name of the function at PC, NULL if could not find it.
+ This function only checks the debugging information, not the symbol
+ table. */
+
+static char *
+function_name_from_pc (CORE_ADDR pc)
+{
+ char *func_name;
+
+ if (!find_pc_partial_function (pc, &func_name, NULL, NULL))
+ return NULL;
+
+ return func_name;
+}
+
+/* True iff FRAME is very likely to be that of a function that is
+ part of the runtime system. This is all very heuristic, but is
+ intended to be used as advice as to what frames are uninteresting
+ to most users. */
+
+static int
+is_known_support_routine (struct frame_info *frame)
+{
+ struct symtab_and_line sal;
+ char *func_name;
+ int i;
+
+ /* If this code does not have any debugging information (no symtab),
+ This cannot be any user code. */
+
+ find_frame_sal (frame, &sal);
+ if (sal.symtab == NULL)
+ return 1;
+
+ /* If there is a symtab, but the associated source file cannot be
+ located, then assume this is not user code: Selecting a frame
+ for which we cannot display the code would not be very helpful
+ for the user. This should also take care of case such as VxWorks
+ where the kernel has some debugging info provided for a few units. */
+
+ if (symtab_to_fullname (sal.symtab) == NULL)
+ return 1;
+
+ /* Check the unit filename againt the Ada runtime file naming.
+ We also check the name of the objfile against the name of some
+ known system libraries that sometimes come with debugging info
+ too. */
+
+ for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
+ {
+ re_comp (known_runtime_file_name_patterns[i]);
+ if (re_exec (sal.symtab->filename))
+ return 1;
+ if (sal.symtab->objfile != NULL
+ && re_exec (sal.symtab->objfile->name))
+ return 1;
+ }
+
+ /* Check whether the function is a GNAT-generated entity. */
+
+ func_name = function_name_from_pc (get_frame_address_in_block (frame));
+ if (func_name == NULL)
+ return 1;
+
+ for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
+ {
+ re_comp (known_auxiliary_function_name_patterns[i]);
+ if (re_exec (func_name))
+ return 1;
+ }
+
+ return 0;
+}
+
+/* Find the first frame that contains debugging information and that is not
+ part of the Ada run-time, starting from FI and moving upward. */
+
+void
+ada_find_printable_frame (struct frame_info *fi)
+{
+ for (; fi != NULL; fi = get_prev_frame (fi))
+ {
+ if (!is_known_support_routine (fi))
+ {
+ select_frame (fi);
+ break;
+ }
+ }
+
+}
+
+/* Assuming that the inferior just triggered an unhandled exception
+ catchpoint, return the address in inferior memory where the name
+ of the exception is stored.
+
+ Return zero if the address could not be computed. */
+
+static CORE_ADDR
+ada_unhandled_exception_name_addr (void)
+{
+ return parse_and_eval_address ("e.full_name");
+}
+
+/* Same as ada_unhandled_exception_name_addr, except that this function
+ should be used when the inferior uses an older version of the runtime,
+ where the exception name needs to be extracted from a specific frame
+ several frames up in the callstack. */
+
+static CORE_ADDR
+ada_unhandled_exception_name_addr_from_raise (void)
+{
+ int frame_level;
+ struct frame_info *fi;
+
+ /* To determine the name of this exception, we need to select
+ the frame corresponding to RAISE_SYM_NAME. This frame is
+ at least 3 levels up, so we simply skip the first 3 frames
+ without checking the name of their associated function. */
+ fi = get_current_frame ();
+ for (frame_level = 0; frame_level < 3; frame_level += 1)
+ if (fi != NULL)
+ fi = get_prev_frame (fi);
+
+ while (fi != NULL)
+ {
+ const char *func_name =
+ function_name_from_pc (get_frame_address_in_block (fi));
+ if (func_name != NULL
+ && strcmp (func_name, exception_info->catch_exception_sym) == 0)
+ break; /* We found the frame we were looking for... */
+ fi = get_prev_frame (fi);