[Ada] Fix source location in bug box

[Arnaud Charlet <charlet@adacore.com>]

[-- 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,