Patchwork [Ada] Improve output of type for error messages

login
register
mail settings
Submitter Arnaud Charlet
Date June 22, 2010, 12:42 p.m.
Message ID <20100622124237.GA8934@adacore.com>
Download mbox | patch
Permalink /patch/56473/
State New
Headers show

Comments

Arnaud Charlet - June 22, 2010, 12:42 p.m.
This patch generalizes the behavior of the error message circuit when
presented with a type that is an internal name where the first subtype
has a non-internal name. This allows simplification of a call in Sem_Res
and improves the output in the following case:

Compiling: inameerr.adb

     1. package body InameErr is
     2.    function Minus_One return T_Real is
     3.    begin
     4.       return Standard."-" (1.0) / 1.0;
                             |
        >>> expect type "T_Real" defined at inameerr.ads:2

     5.    end Minus_One;
     6. end InameErr;

Compiling: inameerr.ads

     1. generic
     2.    type T_Real is digits <>;
     3. package InameErr is
     4.    function Minus_One return T_Real;
     5. end InameErr;

The location of the definition of the type is new with
this patch.

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-06-22  Robert Dewar  <dewar@adacore.com>

	* errout.adb (Unwind_Internal_Type): Improve handling of First_Subtype
	test to catch more cases where first subtype is the results we want.
	* sem_res.adb (Make_Call_Into_Operator): Don't go to First_Subtype in
	error case, since Errout will now handle this correctly.
	* gcc-interface/Make-lang.in: Add Sem_Aux to list of GNATBIND objects.
	Update dependencies.

Patch

Index: sem_res.adb
===================================================================
--- sem_res.adb	(revision 161169)
+++ sem_res.adb	(working copy)
@@ -1444,7 +1444,7 @@  package body Sem_Res is
 
                null;
 
-               --  Operator may be defined in an extension of system
+            --  Operator may be defined in an extension of System
 
             elsif Present (System_Aux_Id)
               and then Scope (Opnd_Type) = System_Aux_Id
@@ -1452,13 +1452,10 @@  package body Sem_Res is
                null;
 
             else
-               --  Note: go to First_Subtype here to ensure the message has the
-               --  proper source type name (Typ may be an anonymous base type).
-
                --  Could we use Wrong_Type here??? (this would require setting
                --  Etype (N) to the actual type found where Typ was expected).
 
-               Error_Msg_NE ("expect type&", N, First_Subtype (Typ));
+               Error_Msg_NE ("expect }", N, Typ);
             end if;
          end if;
       end if;
Index: errout.adb
===================================================================
--- errout.adb	(revision 161170)
+++ errout.adb	(working copy)
@@ -43,6 +43,7 @@  with Opt;      use Opt;
 with Nlists;   use Nlists;
 with Output;   use Output;
 with Scans;    use Scans;
+with Sem_Aux;  use Sem_Aux;
 with Sinput;   use Sinput;
 with Sinfo;    use Sinfo;
 with Snames;   use Snames;
@@ -2824,7 +2825,7 @@  package body Errout is
       --  "type derived from" message more than once in the case where we climb
       --  up multiple levels.
 
-      loop
+      Find : loop
          Old_Ent := Ent;
 
          --  Implicit access type, use directly designated type In Ada 2005,
@@ -2872,7 +2873,7 @@  package body Errout is
                   Set_Msg_Str ("access to procedure ");
                end if;
 
-               exit;
+               exit Find;
 
             --  Type is access to object, named or anonymous
 
@@ -2910,51 +2911,54 @@  package body Errout is
          --  itself an internal name. This avoids the obvious loop (subtype ->
          --  basetype -> subtype) which would otherwise occur!)
 
-         elsif Present (Freeze_Node (Ent))
-           and then Present (First_Subtype_Link (Freeze_Node (Ent)))
-           and then
-             not Is_Internal_Name
-                   (Chars (First_Subtype_Link (Freeze_Node (Ent))))
-         then
-            Ent := First_Subtype_Link (Freeze_Node (Ent));
+         else
+            declare
+               FST : constant Entity_Id := First_Subtype (Ent);
 
-         --  Otherwise use root type
+            begin
+               if not Is_Internal_Name (Chars (FST)) then
+                  Ent := FST;
+                  exit Find;
 
-         else
-            if not Derived then
-               Buffer_Remove ("type ");
+                  --  Otherwise use root type
 
-               --  Test for "subtype of type derived from" which seems
-               --  excessive and is replaced by simply "type derived from"
+               else
+                  if not Derived then
+                     Buffer_Remove ("type ");
 
-               Buffer_Remove ("subtype of");
+                     --  Test for "subtype of type derived from" which seems
+                     --  excessive and is replaced by "type derived from".
 
-               --  Avoid duplication "type derived from type derived from"
+                     Buffer_Remove ("subtype of");
 
-               if not Buffer_Ends_With ("type derived from ") then
-                  Set_Msg_Str ("type derived from ");
-               end if;
+                     --  Avoid duplicated "type derived from type derived from"
 
-               Derived := True;
-            end if;
+                     if not Buffer_Ends_With ("type derived from ") then
+                        Set_Msg_Str ("type derived from ");
+                     end if;
+
+                     Derived := True;
+                  end if;
+               end if;
+            end;
 
             Ent := Etype (Ent);
          end if;
 
          --  If we are stuck in a loop, get out and settle for the internal
-         --  name after all. In this case we set to kill the message if it
-         --  is not the first error message (we really try hard not to show
-         --  the dirty laundry of the implementation to the poor user!)
+         --  name after all. In this case we set to kill the message if it is
+         --  not the first error message (we really try hard not to show the
+         --  dirty laundry of the implementation to the poor user!)
 
          if Ent = Old_Ent then
             Kill_Message := True;
-            exit;
+            exit Find;
          end if;
 
          --  Get out if we finally found a non-internal name to use
 
-         exit when not Is_Internal_Name (Chars (Ent));
-      end loop;
+         exit Find when not Is_Internal_Name (Chars (Ent));
+      end loop Find;
 
       if Mchar = '"' then
          Set_Msg_Char ('"');
Index: gcc-interface/Make-lang.in
===================================================================
--- gcc-interface/Make-lang.in	(revision 161152)
+++ gcc-interface/Make-lang.in	(working copy)
@@ -443,6 +443,7 @@  GNATBIND_OBJS = \
  ada/scng.o       \
  ada/scans.o      \
  ada/sdefault.o   \
+ ada/sem_aux.o    \
  ada/sinfo.o      \
  ada/sinput.o     \
  ada/sinput-c.o   \
@@ -1600,16 +1601,16 @@  ada/errout.o : ada/ada.ads ada/a-except.
    ada/fname.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \
    ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads ada/lib.adb \
    ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \
-   ada/nlists.adb ada/opt.ads ada/output.ads ada/scans.ads ada/sinfo.ads \
-   ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \
-   ada/stand.ads ada/stringt.ads ada/stylesw.ads ada/system.ads \
-   ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \
-   ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \
-   ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
-   ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
-   ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
-   ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
-   ada/urealp.ads ada/widechar.ads 
+   ada/nlists.adb ada/opt.ads ada/output.ads ada/scans.ads ada/sem_aux.ads \
+   ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \
+   ada/snames.ads ada/stand.ads ada/stringt.ads ada/stylesw.ads \
+   ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \
+   ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \
+   ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+   ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \
+   ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+   ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+   ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads 
 
 ada/erroutc.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
    ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
@@ -2570,10 +2571,10 @@  ada/gnatvsn.o : ada/ada.ads ada/a-unccon
    ada/gnatvsn.adb ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \
    ada/s-stoele.adb 
 
-ada/hlo.o : ada/ada.ads ada/a-unccon.ads ada/hlo.ads ada/hlo.adb \
-   ada/hostparm.ads ada/output.ads ada/system.ads ada/s-exctab.ads \
-   ada/s-stalib.ads ada/s-unstyp.ads ada/types.ads ada/unchconv.ads \
-   ada/unchdeal.ads 
+ada/hlo.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/hlo.ads \
+   ada/hlo.adb ada/hostparm.ads ada/output.ads ada/system.ads \
+   ada/s-exctab.ads ada/s-os_lib.ads ada/s-stalib.ads ada/s-string.ads \
+   ada/s-unstyp.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads 
 
 ada/hostparm.o : ada/ada.ads ada/a-unccon.ads ada/hostparm.ads \
    ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \