[Ada] Fix source location in bug box

[Ada] Fix source location in bug box

[Arnaud Charlet]

[-- Attachment #1: Type: text/plain, Size: 1125 bytes --]

Tested on i686-linux, committed on trunk

Recent back-ends are moving away from the statement-at-a-time compilation
scheme to make it easier to perform global optimizations on the IL. They
operate either in function-at-a-time mode or even in unit-at-a-time mode.
The front-end (Gigi) cannot track the source location pointer within a
subprogram once its translation has been completed and it has been handed
down to the back-end. It is therefore necessary to rely past this point
on the source location pointer tracking done in the back-end in order to
print a meaningful, albeit sometimes imprecise, location information.

2007-04-06  Arnaud Charlet  <charlet@adacore.com>
	    Eric Botcazou <botcazou@adacore.com>

	* 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.


[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 10306 bytes --]

Index: gnatvsn.ads
===================================================================
--- gnatvsn.ads	(revision 123291)
+++ gnatvsn.ads	(working copy)
@@ -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
Index: comperr.adb
===================================================================
--- comperr.adb	(revision 123291)
+++ comperr.adb	(working copy)
@@ -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 ");
Index: comperr.ads
===================================================================
--- comperr.ads	(revision 123291)
+++ comperr.ads	(working copy)
@@ -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;
Index: comperr.adb
===================================================================
--- comperr.adb	(revision 123291)
+++ comperr.adb	(working copy)
@@ -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 ");
Index: fe.h
===================================================================
--- fe.h	(revision 123291)
+++ fe.h	(working copy)
@@ -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: */
 
Index: misc.c
===================================================================
--- misc.c	(revision 123291)
+++ misc.c	(working copy)
@@ -380,10 +380,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);
@@ -410,8 +410,20 @@ internal_error_function (const char *msg
   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.  */
@@ -753,21 +765,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
@@ -777,8 +787,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,

Re: [Ada] Fix source location in bug box

[Andreas Jaeger]

[-- Attachment #1: Type: text/plain, Size: 1864 bytes --]


Arnaud,

with current SVN bootstrap with ada fails now for me on both
Linux/x86-64 and Linux/PPC.

The error message is:
/abuild/aj/gcc/./prev-gcc/xgcc -B/abuild/aj/gcc/./prev-gcc/ -B/opt/gcc/4.3-devel/powerpc64-su
se-linux-gnu/bin/ -c -g -O2      -gnatpg -gnata -g -O1 -fno-inline \
 -I- -I. -Iada -I/cvs/gcc-svn/trunk/gcc/ada /cvs/gcc-svn/trunk/gcc/ada/a-except.adb -o ada/a-
except.o
+===========================GNAT BUG DETECTED==============================+
| 4.3.0 20070407 (experimental) (powerpc64-suse-linux-gnu) GCC error:      |
| in staticp, at tree.c:2017                                               |
| Error detected at a-exexda.adb:239:40                                    |
| Please submit a bug report; see http://gcc.gnu.org/bugs.html.            |
| Use a subject line meaningful to you and us to track the bug.            |
| Include the entire contents of this bug box in the report.               |
| Include the exact gcc or gnatmake command that you entered.              |
| Also include sources listed below in gnatchop format                     |
| (concatenated together with no headers between files).                   |
+==========================================================================+

Please include these source files with error report
Note that list may not be accurate in some cases,
so please double check that the problem can still
be reproduced with the set of files listed.

compilation abandoned
make[3]: *** [ada/a-except.o] Error 1

I don't know which of the patches broke it and will try to find the
culprit now,

Andreas
-- 
 Andreas Jaeger, aj@suse.de, http://www.suse.de/~aj/
  SUSE LINUX Products GmbH, GF: Markus Rex, HRB 16746 (AG Nürnberg)
   Maxfeldstr. 5, 90409 Nürnberg, Germany
    GPG fingerprint = 93A3 365E CE47 B889 DF7F  FED1 389A 563C C272 A126

[-- Attachment #2: Type: application/pgp-signature, Size: 188 bytes --]

Re: [Ada] Fix source location in bug box

[Andreas Schwab]

Andreas Jaeger <aj@suse.de> writes:

> +===========================GNAT BUG DETECTED==============================+
> | 4.3.0 20070407 (experimental) (powerpc64-suse-linux-gnu) GCC error:      |
> | in staticp, at tree.c:2017                                               |
> | Error detected at a-exexda.adb:239:40                                    |
> | Please submit a bug report; see http://gcc.gnu.org/bugs.html.            |
> | Use a subject line meaningful to you and us to track the bug.            |
> | Include the entire contents of this bug box in the report.               |
> | Include the exact gcc or gnatmake command that you entered.              |
> | Also include sources listed below in gnatchop format                     |
> | (concatenated together with no headers between files).                   |
> +==========================================================================+
>
> Please include these source files with error report
> Note that list may not be accurate in some cases,
> so please double check that the problem can still
> be reproduced with the set of files listed.
>
> compilation abandoned
> make[3]: *** [ada/a-except.o] Error 1
>
> I don't know which of the patches broke it and will try to find the
> culprit now,

See <http://gcc.gnu.org/ml/gcc-patches/2007-04/msg00305.html>.

Andreas.

-- 
Andreas Schwab, SuSE Labs, schwab@suse.de
SuSE Linux Products GmbH, Maxfeldstraße 5, 90409 Nürnberg, Germany
PGP key fingerprint = 58CA 54C7 6D53 942B 1756  01D3 44D5 214B 8276 4ED5
"And now for something completely different."