From 8405d93cb85e88f95daae9de30039cc9745f507d Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 6 Apr 2007 11:41:46 +0200 Subject: [PATCH] gnatvsn.ads, [...] (Get_Gnat_build_Type): Renamed Build_Type and made constant. 2007-04-06 Arnaud Charlet Eric Botcazou * gnatvsn.ads, comperr.adb (Get_Gnat_build_Type): Renamed Build_Type and made constant. * comperr.ads, comperr.adb (Compiler_Abort): Add third parameter Fallback_Loc. Use it as the sloc info when Current_Error_Node doesn't carry any. * fe.h (Compiler_Abort): Add third parameter. * misc.c (internal_error_function): Build third argument from current input location and pass it to Compiler_Abort. From-SVN: r123610 --- gcc/ada/comperr.adb | 21 +++++++++++++-------- gcc/ada/comperr.ads | 32 ++++++++++++++++++-------------- gcc/ada/fe.h | 2 +- gcc/ada/gnatvsn.ads | 6 +++--- gcc/ada/misc.c | 37 +++++++++++++++++++++++-------------- 5 files changed, 58 insertions(+), 40 deletions(-) diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index 648c4b1e059..e8a502c3fe7 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -71,8 +71,9 @@ package body Comperr is -------------------- procedure Compiler_Abort - (X : String; - Code : Integer := 0) + (X : String; + Code : Integer := 0; + Fallback_Loc : String := "") is -- The procedures below output a "bug box" with information about -- the cause of the compiler abort and about the preferred method @@ -96,8 +97,8 @@ package body Comperr is Write_Eol; end End_Line; - Is_GPL_Version : constant Boolean := Get_Gnat_Build_Type = GPL; - Is_FSF_Version : constant Boolean := Get_Gnat_Build_Type = FSF; + Is_GPL_Version : constant Boolean := Gnatvsn.Build_Type = GPL; + Is_FSF_Version : constant Boolean := Gnatvsn.Build_Type = FSF; -- Start of processing for Compiler_Abort @@ -213,10 +214,14 @@ package body Comperr is -- Output source location information - if Sloc (Current_Error_Node) <= Standard_Location - or else Sloc (Current_Error_Node) = No_Location - then - Write_Str ("| No source file position information available"); + if Sloc (Current_Error_Node) <= No_Location then + if Fallback_Loc'Length > 0 then + Write_Str ("| Error detected around "); + Write_Str (Fallback_Loc); + else + Write_Str ("| No source file position information available"); + end if; + End_Line; else Write_Str ("| Error detected at "); diff --git a/gcc/ada/comperr.ads b/gcc/ada/comperr.ads index b41cc9ad4a5..04917f2ffef 100644 --- a/gcc/ada/comperr.ads +++ b/gcc/ada/comperr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,14 +31,18 @@ package Comperr is procedure Compiler_Abort - (X : String; - Code : Integer := 0); - -- Signals an internal compiler error. Never returns control. Depending - -- on processing may end up raising Unrecoverable_Error, or exiting - -- directly. The message output is a "bug box" containing the - -- string passed as an argument. The node in Current_Error_Node is used - -- to provide the location where the error should be signalled. The - -- message includes the node id, and the code parameter if it is positive. + (X : String; + Code : Integer := 0; + Fallback_Loc : String := ""); + -- Signals an internal compiler error. Never returns control. Depending on + -- processing may end up raising Unrecoverable_Error, or exiting directly. + -- The message output is a "bug box" containing the first string passed as + -- an argument. The Sloc field of the node in Current_Error_Node is used to + -- provide the location where the error should be signalled. If this Sloc + -- value is set to No_Location or any of the other special location values, + -- then the Fallback_Loc argument string is used instead. The message text + -- includes the node id, and the code parameter if it is positive. + -- -- Note that this is only used at the outer level (to handle constraint -- errors or assert errors etc.) In the normal logic of the compiler we -- always use pragma Assert to check for errors, and if necessary an @@ -64,10 +68,10 @@ package Comperr is -- Most typically this file, if present, will be in the directory -- containing the run-time sources. - -- If this file is present, then it is a plain ASCII file, whose - -- contents replace the remaining text. The lines in this file should be - -- 72 characters or less to avoid misformatting the right boundary of the - -- box. Note that the file does not contain the vertical bar characters or - -- any leading spaces in lines. + -- If this file is present, then it is a plain ASCII file, whose contents + -- replace the remaining text. The lines in this file should be seventy-two + -- characters or less to avoid misformatting the right boundary of the box. + -- Note that the file does not contain the vertical bar characters or any + -- leading spaces in lines. end Comperr; diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 6e2dde3c1d6..f734d069a09 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -36,7 +36,7 @@ /* comperr: */ #define Compiler_Abort comperr__compiler_abort -extern int Compiler_Abort (Fat_Pointer, int) ATTRIBUTE_NORETURN; +extern int Compiler_Abort (Fat_Pointer, int, Fat_Pointer) ATTRIBUTE_NORETURN; /* csets: */ diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads index 009dbee1052..2cfa3b09146 100644 --- a/gcc/ada/gnatvsn.ads +++ b/gcc/ada/gnatvsn.ads @@ -46,10 +46,10 @@ package Gnatvsn is -- to e.g. pragma Ident. type Gnat_Build_Type is (FSF, GPL); - -- See Get_Gnat_Build_Type below for the meaning of these values. + -- See Build_Type below for the meaning of these values. - function Get_Gnat_Build_Type return Gnat_Build_Type; - -- This function returns one of the following values of Gnat_Build_Type: + Build_Type : constant Gnat_Build_Type := FSF; + -- Kind of GNAT build: -- -- FSF -- GNAT FSF version. This version of GNAT is part of a Free Software diff --git a/gcc/ada/misc.c b/gcc/ada/misc.c index bd22e7e71e0..8c539614360 100644 --- a/gcc/ada/misc.c +++ b/gcc/ada/misc.c @@ -378,10 +378,10 @@ static void internal_error_function (const char *msgid, va_list *ap) { text_info tinfo; - char *buffer; - char *p; - String_Template temp; - Fat_Pointer fp; + char *buffer, *p, *loc; + String_Template temp, temp_loc; + Fat_Pointer fp, fp_loc; + expanded_location s; /* Reset the pretty-printer. */ pp_clear_output_area (global_dc->printer); @@ -408,8 +408,20 @@ internal_error_function (const char *msgid, va_list *ap) fp.Bounds = &temp; fp.Array = buffer; + s = expand_location (input_location); +#ifdef USE_MAPPED_LOCATION + if (flag_show_column && s.column != 0) + asprintf (&loc, "%s:%d:%d", s.file, s.line, s.column); + else +#endif + asprintf (&loc, "%s:%d", s.file, s.line); + temp_loc.Low_Bound = 1; + temp_loc.High_Bound = strlen (loc); + fp_loc.Bounds = &temp_loc; + fp_loc.Array = loc; + Current_Error_Node = error_gnat_node; - Compiler_Abort (fp, -1); + Compiler_Abort (fp, -1, fp_loc); } /* Perform all the initialization steps that are language-specific. */ @@ -751,21 +763,19 @@ gnat_get_alias_set (tree type) return -1; } -/* GNU_TYPE is a type. Return its maxium size in bytes, if known, +/* GNU_TYPE is a type. Return its maximum size in bytes, if known, as a constant when possible. */ static tree gnat_type_max_size (tree gnu_type) { - /* First see what we can get from TYPE_SIZE_UNIT, which might not be - constant even for simple expressions if it has already been gimplified - and replaced by a VAR_DECL. */ - + /* First see what we can get from TYPE_SIZE_UNIT, which might not + be constant even for simple expressions if it has already been + elaborated and possibly replaced by a VAR_DECL. */ tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true); /* If we don't have a constant, see what we can get from TYPE_ADA_SIZE, - typically not gimplified. */ - + which should stay untouched. */ if (!host_integerp (max_unitsize, 1) && (TREE_CODE (gnu_type) == RECORD_TYPE || TREE_CODE (gnu_type) == UNION_TYPE @@ -775,8 +785,7 @@ gnat_type_max_size (tree gnu_type) tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true); /* If we have succeeded in finding a constant, round it up to the - type's alignment and return the result in byte units. */ - + type's alignment and return the result in units. */ if (host_integerp (max_adasize, 1)) max_unitsize = size_binop (CEIL_DIV_EXPR,