===================================================================
@@ -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;
===================================================================
@@ -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 ('"');
===================================================================
@@ -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 \
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.