From patchwork Tue Jun 22 12:42:37 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 56473 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 26D67B6F10 for ; Tue, 22 Jun 2010 22:42:59 +1000 (EST) Received: (qmail 3521 invoked by alias); 22 Jun 2010 12:42:52 -0000 Received: (qmail 3493 invoked by uid 22791); 22 Jun 2010 12:42:45 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 22 Jun 2010 12:42:36 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 0A3F1CB026D; Tue, 22 Jun 2010 14:42:38 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id I4X3krmkwTiD; Tue, 22 Jun 2010 14:42:37 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id E81A3CB024F; Tue, 22 Jun 2010 14:42:37 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id DE84BD9B31; Tue, 22 Jun 2010 14:42:37 +0200 (CEST) Date: Tue, 22 Jun 2010 14:42:37 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Improve output of type for error messages Message-ID: <20100622124237.GA8934@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 * 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. 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 \