Skip to content

R
riscv-gcc-1
Commit b4d7b435 by Arnaud Charlet
Options

[multiple changes] 

2010-06-23  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Add_Internal_Interface_Entities): Generate internal
	entities for parent types that are interfaces. Needed in generics to
	handle formals that implement interfaces.
	(Derive_Subprograms): Add assertion for derivation of tagged types that
	do not cover interfaces. For generics, complete code that handles
	derivation of type that covers interfaces because the previous
	condition was weak (it required only name consistency; arguments were
	not checked). Add new code to locate primitives covering interfaces
	defined in generic units or instantiatons.
	* sem_util.adb (Has_Interfaces): Add missing support for derived types.
	* sem_ch6.adb (Check_Overriding_Indicator): Minor code cleanups.
	* exp_disp.adb (Make_Select_Specific_Data_Table): Skip primitives of
	interfaces that are parents of the type because they share the primary
	dispatch table.
	(Register_Primitive): Do not register primitives of interfaces that
	are parents of the type.
	* sem_ch13.adb (Analyze_Freeze_Entity): Add documentation.
	* exp_cg.adb (Write_Type_Info): When displaying overriding of interface
	primitives skip primitives of interfaces that are parents of the type.

2010-06-23  Ed Schonberg  <schonberg@adacore.com>

	* sem_attr.adb (Eval_Attribute): If the prefix is an array, the
	attribute cannot be constant-folded if an index type is a formal type,
	or is derived from one.
	* checks.adb (Determine_Range): ditto.

2010-06-23  Arnaud Charlet  <charlet@adacore.com>

	* gnat_ugn.texi, gnatxref.adb: Add support for --ext switch.

2010-06-23  Bob Duff  <duff@adacore.com>

	* g-pehage.ads, g-pehage.adb (Put): Fix off-by-one bug.
	(Insert): Disallow nul characters.
	(misc output routines): Assert no nul characters.

From-SVN: r161247
parent bc20523f
Showing with 350 additions and 135 deletions
gcc/ada/ChangeLog
2010-06-23 Javier Miranda <miranda@adacore.com>
* sem_ch3.adb (Add_Internal_Interface_Entities): Generate internal
entities for parent types that are interfaces. Needed in generics to
handle formals that implement interfaces.
(Derive_Subprograms): Add assertion for derivation of tagged types that
do not cover interfaces. For generics, complete code that handles
derivation of type that covers interfaces because the previous
condition was weak (it required only name consistency; arguments were
not checked). Add new code to locate primitives covering interfaces
defined in generic units or instantiatons.
* sem_util.adb (Has_Interfaces): Add missing support for derived types.
* sem_ch6.adb (Check_Overriding_Indicator): Minor code cleanups.
* exp_disp.adb (Make_Select_Specific_Data_Table): Skip primitives of
interfaces that are parents of the type because they share the primary
dispatch table.
(Register_Primitive): Do not register primitives of interfaces that
are parents of the type.
* sem_ch13.adb (Analyze_Freeze_Entity): Add documentation.
* exp_cg.adb (Write_Type_Info): When displaying overriding of interface
primitives skip primitives of interfaces that are parents of the type.
2010-06-23 Ed Schonberg <schonberg@adacore.com>
* sem_attr.adb (Eval_Attribute): If the prefix is an array, the
attribute cannot be constant-folded if an index type is a formal type,
or is derived from one.
* checks.adb (Determine_Range): ditto.
2010-06-23 Arnaud Charlet <charlet@adacore.com>
* gnat_ugn.texi, gnatxref.adb: Add support for --ext switch.
2010-06-23 Bob Duff <duff@adacore.com>
* g-pehage.ads, g-pehage.adb (Put): Fix off-by-one bug.
(Insert): Disallow nul characters.
(misc output routines): Assert no nul characters.
2010-06-23 Ed Schonberg <schonberg@adacore.com> 2010-06-23 Ed Schonberg <schonberg@adacore.com>
* exp_ch4.adb: Use predefined unsigned type in all cases. * exp_ch4.adb: Use predefined unsigned type in all cases.
......
gcc/ada/checks.adb
...@@ -3351,6 +3351,14 @@ package body Checks is ...@@ -3351,6 +3351,14 @@ package body Checks is
Indx := Next_Index (Indx); Indx := Next_Index (Indx);
end loop; end loop;
-- if The index type is a formal type, or derived from
-- one, the bounds are not static.
if Is_Generic_Type (Root_Type (Etype (Indx))) then
OK := False;
return;
end if;
Determine_Range Determine_Range
(Type_Low_Bound (Etype (Indx)), OK1, LL, LU, (Type_Low_Bound (Etype (Indx)), OK1, LL, LU,
Assume_Valid); Assume_Valid);
......
gcc/ada/exp_cg.adb
...@@ -572,7 +572,11 @@ package body Exp_CG is ...@@ -572,7 +572,11 @@ package body Exp_CG is
Prim_Op := Node (Prim_Elmt); Prim_Op := Node (Prim_Elmt);
Int_Alias := Interface_Alias (Prim_Op); Int_Alias := Interface_Alias (Prim_Op);
if Present (Int_Alias) and then (Alias (Prim_Op)) = Prim then if Present (Int_Alias)
and then not Is_Ancestor
(Find_Dispatching_Type (Int_Alias), Typ)
and then (Alias (Prim_Op)) = Prim
then
Write_Char (','); Write_Char (',');
Write_Int (UI_To_Int (Slot_Number (Int_Alias))); Write_Int (UI_To_Int (Slot_Number (Int_Alias)));
Write_Char (':'); Write_Char (':');
......
gcc/ada/exp_disp.adb
...@@ -6014,6 +6014,9 @@ package body Exp_Disp is ...@@ -6014,6 +6014,9 @@ package body Exp_Disp is
-- Look for primitive overriding an abstract interface subprogram -- Look for primitive overriding an abstract interface subprogram
if Present (Interface_Alias (Prim)) if Present (Interface_Alias (Prim))
and then not
Is_Ancestor
(Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
and then not Examined (UI_To_Int (DT_Position (Alias (Prim)))) and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
then then
Prim_Pos := DT_Position (Alias (Prim)); Prim_Pos := DT_Position (Alias (Prim));
...@@ -6721,6 +6724,13 @@ package body Exp_Disp is ...@@ -6721,6 +6724,13 @@ package body Exp_Disp is
pragma Assert (Is_Interface (Iface_Typ)); pragma Assert (Is_Interface (Iface_Typ));
-- No action needed for interfaces that are ancestors of Typ because
-- their primitives are located in the primary dispatch table.
if Is_Ancestor (Iface_Typ, Tag_Typ) then
return L;
end if;
Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
if not Is_Ancestor (Iface_Typ, Tag_Typ) if not Is_Ancestor (Iface_Typ, Tag_Typ)
......
gcc/ada/g-pehage.adb
...@@ -145,6 +145,9 @@ package body GNAT.Perfect_Hash_Generators is ...@@ -145,6 +145,9 @@ package body GNAT.Perfect_Hash_Generators is
-- Return a string which includes string Str or integer Int preceded by -- Return a string which includes string Str or integer Int preceded by
-- leading spaces if required by width W. -- leading spaces if required by width W.
function Trim_Trailing_Nuls (Str : String) return String;
-- Return Str, but with trailing NUL characters removed.
Output : File_Descriptor renames GNAT.OS_Lib.Standout; Output : File_Descriptor renames GNAT.OS_Lib.Standout;
-- Shortcuts -- Shortcuts
...@@ -524,6 +527,7 @@ package body GNAT.Perfect_Hash_Generators is ...@@ -524,6 +527,7 @@ package body GNAT.Perfect_Hash_Generators is
--------- ---------
procedure Add (C : Character) is procedure Add (C : Character) is
pragma Assert (C /= ASCII.NUL);
begin begin
Line (Last + 1) := C; Line (Last + 1) := C;
Last := Last + 1; Last := Last + 1;
...@@ -536,6 +540,11 @@ package body GNAT.Perfect_Hash_Generators is ...@@ -536,6 +540,11 @@ package body GNAT.Perfect_Hash_Generators is
procedure Add (S : String) is procedure Add (S : String) is
Len : constant Natural := S'Length; Len : constant Natural := S'Length;
begin begin
for J in S'Range loop
pragma Assert (S (J) /= ASCII.NUL);
null;
end loop;
Line (Last + 1 .. Last + Len) := S; Line (Last + 1 .. Last + Len) := S;
Last := Last + Len; Last := Last + Len;
end Add; end Add;
...@@ -1261,6 +1270,11 @@ package body GNAT.Perfect_Hash_Generators is ...@@ -1261,6 +1270,11 @@ package body GNAT.Perfect_Hash_Generators is
New_Line (Output); New_Line (Output);
end if; end if;
for J in Value'Range loop
pragma Assert (Value (J) /= ASCII.NUL);
null;
end loop;
WT.Set_Last (NK); WT.Set_Last (NK);
WT.Table (NK) := New_Word (Value); WT.Table (NK) := New_Word (Value);
NK := NK + 1; NK := NK + 1;
...@@ -1726,6 +1740,11 @@ package body GNAT.Perfect_Hash_Generators is ...@@ -1726,6 +1740,11 @@ package body GNAT.Perfect_Hash_Generators is
procedure Put (File : File_Descriptor; Str : String) is procedure Put (File : File_Descriptor; Str : String) is
Len : constant Natural := Str'Length; Len : constant Natural := Str'Length;
begin begin
for J in Str'Range loop
pragma Assert (Str (J) /= ASCII.NUL);
null;
end loop;
if Write (File, Str'Address, Len) /= Len then if Write (File, Str'Address, Len) /= Len then
raise Program_Error; raise Program_Error;
end if; end if;
...@@ -1768,13 +1787,12 @@ package body GNAT.Perfect_Hash_Generators is ...@@ -1768,13 +1787,12 @@ package body GNAT.Perfect_Hash_Generators is
Last := 0; Last := 0;
end if; end if;
if Last + Len + 3 > Max then if Last + Len + 3 >= Max then
Flush; Flush;
end if; end if;
if Last = 0 then if Last = 0 then
Line (Last + 1 .. Last + 5) := " "; Add (" ");
Last := Last + 5;
if F1 <= L1 then if F1 <= L1 then
if C1 = F1 and then C2 = F2 then if C1 = F1 and then C2 = F2 then
...@@ -1801,8 +1819,7 @@ package body GNAT.Perfect_Hash_Generators is ...@@ -1801,8 +1819,7 @@ package body GNAT.Perfect_Hash_Generators is
Add (' '); Add (' ');
end if; end if;
Line (Last + 1 .. Last + Len) := S; Add (S);
Last := Last + Len;
if C2 = L2 then if C2 = L2 then
Add (')'); Add (')');
...@@ -1869,7 +1886,8 @@ package body GNAT.Perfect_Hash_Generators is ...@@ -1869,7 +1886,8 @@ package body GNAT.Perfect_Hash_Generators is
K := Get_Key (J); K := Get_Key (J);
Put (File, Image (J, M), F1, L1, J, 1, 3, 1); Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
Put (File, WT.Table (Initial (J)).all, F1, L1, J, 1, 3, 3); Put (File, Trim_Trailing_Nuls (WT.Table (Initial (J)).all),
F1, L1, J, 1, 3, 3);
end loop; end loop;
end Put_Initial_Keys; end Put_Initial_Keys;
...@@ -1950,7 +1968,8 @@ package body GNAT.Perfect_Hash_Generators is ...@@ -1950,7 +1968,8 @@ package body GNAT.Perfect_Hash_Generators is
K := Get_Key (J); K := Get_Key (J);
Put (File, Image (J, M), F1, L1, J, 1, 3, 1); Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
Put (File, WT.Table (Reduced (J)).all, F1, L1, J, 1, 3, 3); Put (File, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all),
F1, L1, J, 1, 3, 3);
end loop; end loop;
end Put_Reduced_Keys; end Put_Reduced_Keys;
...@@ -2337,7 +2356,8 @@ package body GNAT.Perfect_Hash_Generators is ...@@ -2337,7 +2356,8 @@ package body GNAT.Perfect_Hash_Generators is
Same_Keys_Sets_Table (J).First .. Same_Keys_Sets_Table (J).First ..
Same_Keys_Sets_Table (J).Last Same_Keys_Sets_Table (J).Last
loop loop
Put (Output, WT.Table (Reduced (K)).all); Put (Output,
Trim_Trailing_Nuls (WT.Table (Reduced (K)).all));
New_Line (Output); New_Line (Output);
end loop; end loop;
Put (Output, "--"); Put (Output, "--");
...@@ -2488,6 +2508,20 @@ package body GNAT.Perfect_Hash_Generators is ...@@ -2488,6 +2508,20 @@ package body GNAT.Perfect_Hash_Generators is
return S; return S;
end Sum; end Sum;
------------------------
-- Trim_Trailing_Nuls --
------------------------
function Trim_Trailing_Nuls (Str : String) return String is
begin
for J in Str'Range loop
if Str (J) = ASCII.NUL then
return Str (Str'First .. J - 1);
end if;
end loop;
return Str;
end Trim_Trailing_Nuls;
--------------- ---------------
-- Type_Size -- -- Type_Size --
--------------- ---------------
......
gcc/ada/g-pehage.ads
...@@ -116,7 +116,7 @@ package GNAT.Perfect_Hash_Generators is ...@@ -116,7 +116,7 @@ package GNAT.Perfect_Hash_Generators is
-- Deallocate the internal structures and the words table -- Deallocate the internal structures and the words table
procedure Insert (Value : String); procedure Insert (Value : String);
-- Insert a new word in the table -- Insert a new word into the table. ASCII.NUL characters are not allowed.
Too_Many_Tries : exception; Too_Many_Tries : exception;
-- Raised after Tries unsuccessful runs -- Raised after Tries unsuccessful runs
......
gcc/ada/gnat_ugn.texi
...@@ -11909,6 +11909,13 @@ Do not look for sources in the system default directory. ...@@ -11909,6 +11909,13 @@ Do not look for sources in the system default directory.
@cindex @option{-nostdlib} (@command{gnatxref}) @cindex @option{-nostdlib} (@command{gnatxref})
Do not look for library files in the system default directory. Do not look for library files in the system default directory.
@item --ext=@var{extension}
@cindex @option{--ext} (@command{gnatxref})
Specify an alternate ali file extension. The default is @code{ali} and other
extensions (e.g. @code{sli} for SPARK library files) may be specified via this
switch. Note that if this switch overrides the default, which means that only
the new extension will be considered.
@item --RTS=@var{rts-path} @item --RTS=@var{rts-path}
@cindex @option{--RTS} (@command{gnatxref}) @cindex @option{--RTS} (@command{gnatxref})
Specifies the default location of the runtime library. Same meaning as the Specifies the default location of the runtime library. Same meaning as the
......
gcc/ada/gnatxref.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- -- Copyright (C) 1998-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -52,6 +52,9 @@ procedure Gnatxref is ...@@ -52,6 +52,9 @@ procedure Gnatxref is
RTS_Specified : String_Access := null; RTS_Specified : String_Access := null;
-- Used to detect multiple use of --RTS= switch -- Used to detect multiple use of --RTS= switch
EXT_Specified : String_Access := null;
-- Used to detect multiple use of --ext= switch
procedure Parse_Cmd_Line; procedure Parse_Cmd_Line;
-- Parse every switch on the command line -- Parse every switch on the command line
...@@ -79,7 +82,7 @@ procedure Gnatxref is ...@@ -79,7 +82,7 @@ procedure Gnatxref is
loop loop
case case
GNAT.Command_Line.Getopt GNAT.Command_Line.Getopt
("a aI: aO: d f g h I: nostdinc nostdlib p: u v -RTS=") ("a aI: aO: d f g h I: nostdinc nostdlib p: u v -RTS= -ext=")
is is
when ASCII.NUL => when ASCII.NUL =>
exit; exit;
...@@ -140,43 +143,70 @@ procedure Gnatxref is ...@@ -140,43 +143,70 @@ procedure Gnatxref is
-- Check that it is the first time we see this switch -- Check that it is the first time we see this switch
if RTS_Specified = null then if Full_Switch = "-RTS" then
RTS_Specified := new String'(GNAT.Command_Line.Parameter); if RTS_Specified = null then
RTS_Specified := new String'(GNAT.Command_Line.Parameter);
elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then
Osint.Fail ("--RTS cannot be specified multiple times"); Osint.Fail ("--RTS cannot be specified multiple times");
end if; end if;
Opt.No_Stdinc := True; Opt.No_Stdinc := True;
Opt.RTS_Switch := True; Opt.RTS_Switch := True;
declare declare
Src_Path_Name : constant String_Ptr := Src_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir Get_RTS_Search_Dir
(GNAT.Command_Line.Parameter, Include); (GNAT.Command_Line.Parameter,
Include);
Lib_Path_Name : constant String_Ptr := Lib_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir Get_RTS_Search_Dir
(GNAT.Command_Line.Parameter, Objects); (GNAT.Command_Line.Parameter,
Objects);
begin begin
if Src_Path_Name /= null and then Lib_Path_Name /= null then if Src_Path_Name /= null
Add_Search_Dirs (Src_Path_Name, Include); and then Lib_Path_Name /= null
Add_Search_Dirs (Lib_Path_Name, Objects); then
Add_Search_Dirs (Src_Path_Name, Include);
Add_Search_Dirs (Lib_Path_Name, Objects);
elsif Src_Path_Name = null
and then Lib_Path_Name = null
then
Osint.Fail ("RTS path not valid: missing " &
"adainclude and adalib directories");
elsif Src_Path_Name = null then
Osint.Fail ("RTS path not valid: missing " &
"adainclude directory");
elsif Src_Path_Name = null and then Lib_Path_Name = null then elsif Lib_Path_Name = null then
Osint.Fail ("RTS path not valid: missing " & Osint.Fail ("RTS path not valid: missing " &
"adainclude and adalib directories"); "adalib directory");
end if;
end;
elsif Src_Path_Name = null then elsif GNAT.Command_Line.Full_Switch = "-ext" then
Osint.Fail ("RTS path not valid: missing " &
"adainclude directory");
elsif Lib_Path_Name = null then -- Check that it is the first time we see this switch
Osint.Fail ("RTS path not valid: missing " &
"adalib directory"); if EXT_Specified = null then
EXT_Specified := new String'(GNAT.Command_Line.Parameter);
elsif EXT_Specified.all /= GNAT.Command_Line.Parameter then
Osint.Fail ("--ext cannot be specified multiple times");
end if; end if;
end;
if EXT_Specified'Length
= Osint.ALI_Default_Suffix'Length
then
Osint.ALI_Suffix := EXT_Specified.all'Access;
else
Osint.Fail ("--ext argument must have 3 characters");
end if;
end if;
when others => when others =>
Write_Usage; Write_Usage;
...@@ -239,6 +269,7 @@ procedure Gnatxref is ...@@ -239,6 +269,7 @@ procedure Gnatxref is
& " directory"); & " directory");
Put_Line (" -nostdlib Don't look for library files in the system" Put_Line (" -nostdlib Don't look for library files in the system"
& " default directory"); & " default directory");
Put_Line (" --ext=xxx Specify alternate ali file extension");
Put_Line (" --RTS=dir specify the default source and object search" Put_Line (" --RTS=dir specify the default source and object search"
& " path"); & " path");
Put_Line (" -p file Use file as the default project file"); Put_Line (" -p file Use file as the default project file");
......
gcc/ada/sem_attr.adb
...@@ -5633,10 +5633,10 @@ package body Sem_Attr is ...@@ -5633,10 +5633,10 @@ package body Sem_Attr is
while Present (N) loop while Present (N) loop
Static := Static and then Is_Static_Subtype (Etype (N)); Static := Static and then Is_Static_Subtype (Etype (N));
-- If however the index type is generic, attributes cannot -- If however the index type is generic, or derived from
-- be folded. -- one, attributes cannot be folded.
if Is_Generic_Type (Etype (N)) if Is_Generic_Type (Root_Type (Etype (N)))
and then Id /= Attribute_Component_Size and then Id /= Attribute_Component_Size
then then
return; return;
...@@ -6205,13 +6205,13 @@ package body Sem_Attr is ...@@ -6205,13 +6205,13 @@ package body Sem_Attr is
Ind : Node_Id; Ind : Node_Id;
begin begin
-- In the case of a generic index type, the bounds may appear static -- If any index type is a formal type, or derived from one, the
-- but the computation is not meaningful in this case, and may -- bounds are not static. Treating them as static can produce
-- generate a spurious warning. -- spurious warnings or improper constant folding.
Ind := First_Index (P_Type); Ind := First_Index (P_Type);
while Present (Ind) loop while Present (Ind) loop
if Is_Generic_Type (Etype (Ind)) then if Is_Generic_Type (Root_Type (Etype (Ind))) then
return; return;
end if; end if;
......
gcc/ada/sem_ch13.adb
...@@ -2366,7 +2366,9 @@ package body Sem_Ch13 is ...@@ -2366,7 +2366,9 @@ package body Sem_Ch13 is
-- code because their main purpose was to provide support to initialize -- code because their main purpose was to provide support to initialize
-- the secondary dispatch tables. They are now generated also when -- the secondary dispatch tables. They are now generated also when
-- compiling with no code generation to provide ASIS the relationship -- compiling with no code generation to provide ASIS the relationship
-- between interface primitives and tagged type primitives. -- between interface primitives and tagged type primitives. They are
-- also used to locate primitives covering interfaces when processing
-- generics (see Derive_Subprograms).
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then Ekind (E) = E_Record_Type and then Ekind (E) = E_Record_Type
...@@ -2374,6 +2376,12 @@ package body Sem_Ch13 is ...@@ -2374,6 +2376,12 @@ package body Sem_Ch13 is
and then not Is_Interface (E) and then not Is_Interface (E)
and then Has_Interfaces (E) and then Has_Interfaces (E)
then then
-- This would be a good common place to call the routine that checks
-- overriding of interface primitives (and thus factorize calls to
-- Check_Abstract_Overriding located at different contexts in the
-- compiler). However, this is not possible because it causes
-- spurious errors in case of late overriding.
Add_Internal_Interface_Entities (E); Add_Internal_Interface_Entities (E);
end if; end if;
end Analyze_Freeze_Entity; end Analyze_Freeze_Entity;
......
gcc/ada/sem_ch3.adb
...@@ -68,6 +68,7 @@ with Sem_Util; use Sem_Util; ...@@ -68,6 +68,7 @@ with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn; with Sem_Warn; use Sem_Warn;
with Stand; use Stand; with Stand; use Stand;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Snames; use Snames; with Snames; use Snames;
with Targparm; use Targparm; with Targparm; use Targparm;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
...@@ -1537,90 +1538,92 @@ package body Sem_Ch3 is ...@@ -1537,90 +1538,92 @@ package body Sem_Ch3 is
while Present (Iface_Elmt) loop while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt); Iface := Node (Iface_Elmt);
-- Exclude from this processing interfaces that are parents of -- Originally we excluded here from this processing interfaces that
-- Tagged_Type because their primitives are located in the primary -- are parents of Tagged_Type because their primitives are located
-- dispatch table (and hence no auxiliary internal entities are -- in the primary dispatch table (and hence no auxiliary internal
-- required to handle secondary dispatch tables in such case). -- entities are required to handle secondary dispatch tables in such
-- case). However, these auxiliary entities are also required to
-- handle derivations of interfaces in formals of generics (see
-- Derive_Subprograms).
if not Is_Ancestor (Iface, Tagged_Type) then Elmt := First_Elmt (Primitive_Operations (Iface));
Elmt := First_Elmt (Primitive_Operations (Iface)); while Present (Elmt) loop
while Present (Elmt) loop Iface_Prim := Node (Elmt);
Iface_Prim := Node (Elmt);
if not Is_Predefined_Dispatching_Operation (Iface_Prim) then if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
Prim := Prim :=
Find_Primitive_Covering_Interface Find_Primitive_Covering_Interface
(Tagged_Type => Tagged_Type, (Tagged_Type => Tagged_Type,
Iface_Prim => Iface_Prim); Iface_Prim => Iface_Prim);
if No (Prim) then if No (Prim) then
-- In some rare cases, a name conflict may have kept the -- In some rare cases, a name conflict may have kept the
-- operation completely hidden. Look for it in the list -- operation completely hidden. Look for it in the list
-- of primitive operations of the type. -- of primitive operations of the type.
declare declare
El : Elmt_Id; El : Elmt_Id;
begin
El := First_Elmt (Primitive_Operations (Tagged_Type));
while Present (El) loop
Prim := Node (El);
exit when Is_Subprogram (Prim)
and then Alias (Prim) = Iface_Prim;
Next_Elmt (El);
end loop;
-- If the operation was not explicitly overridden, it begin
-- should have been inherited as an abstract operation El := First_Elmt (Primitive_Operations (Tagged_Type));
-- so Prim can not be Empty at this stage. while Present (El) loop
Prim := Node (El);
exit when Is_Subprogram (Prim)
and then Alias (Prim) = Iface_Prim;
Next_Elmt (El);
end loop;
if No (El) then -- If the operation was not explicitly overridden, it
raise Program_Error; -- should have been inherited as an abstract operation
end if; -- so Prim can not be Empty at this stage.
end;
end if;
Derive_Subprogram if No (El) then
(New_Subp => New_Subp, raise Program_Error;
Parent_Subp => Iface_Prim, end if;
Derived_Type => Tagged_Type, end;
Parent_Type => Iface);
-- Ada 2005 (AI-251): Decorate internal entity Iface_Subp
-- associated with interface types. These entities are
-- only registered in the list of primitives of its
-- corresponding tagged type because they are only used
-- to fill the contents of the secondary dispatch tables.
-- Therefore they are removed from the homonym chains.
Set_Is_Hidden (New_Subp);
Set_Is_Internal (New_Subp);
Set_Alias (New_Subp, Prim);
Set_Is_Abstract_Subprogram (New_Subp,
Is_Abstract_Subprogram (Prim));
Set_Interface_Alias (New_Subp, Iface_Prim);
-- Internal entities associated with interface types are
-- only registered in the list of primitives of the tagged
-- type. They are only used to fill the contents of the
-- secondary dispatch tables. Therefore they are not needed
-- in the homonym chains.
Remove_Homonym (New_Subp);
-- Hidden entities associated with interfaces must have set
-- the Has_Delay_Freeze attribute to ensure that, in case of
-- locally defined tagged types (or compiling with static
-- dispatch tables generation disabled) the corresponding
-- entry of the secondary dispatch table is filled when
-- such an entity is frozen.
Set_Has_Delayed_Freeze (New_Subp);
end if; end if;
Next_Elmt (Elmt); Derive_Subprogram
end loop; (New_Subp => New_Subp,
end if; Parent_Subp => Iface_Prim,
Derived_Type => Tagged_Type,
Parent_Type => Iface);
-- Ada 2005 (AI-251): Decorate internal entity Iface_Subp
-- associated with interface types. These entities are
-- only registered in the list of primitives of its
-- corresponding tagged type because they are only used
-- to fill the contents of the secondary dispatch tables.
-- Therefore they are removed from the homonym chains.
Set_Is_Hidden (New_Subp);
Set_Is_Internal (New_Subp);
Set_Alias (New_Subp, Prim);
Set_Is_Abstract_Subprogram
(New_Subp, Is_Abstract_Subprogram (Prim));
Set_Interface_Alias (New_Subp, Iface_Prim);
-- Internal entities associated with interface types are
-- only registered in the list of primitives of the tagged
-- type. They are only used to fill the contents of the
-- secondary dispatch tables. Therefore they are not needed
-- in the homonym chains.
Remove_Homonym (New_Subp);
-- Hidden entities associated with interfaces must have set
-- the Has_Delay_Freeze attribute to ensure that, in case of
-- locally defined tagged types (or compiling with static
-- dispatch tables generation disabled) the corresponding
-- entry of the secondary dispatch table is filled when
-- such an entity is frozen.
Set_Has_Delayed_Freeze (New_Subp);
end if;
Next_Elmt (Elmt);
end loop;
Next_Elmt (Iface_Elmt); Next_Elmt (Iface_Elmt);
end loop; end loop;
...@@ -11955,7 +11958,7 @@ package body Sem_Ch3 is ...@@ -11955,7 +11958,7 @@ package body Sem_Ch3 is
-- non-abstract tagged types that can reference abstract primitives -- non-abstract tagged types that can reference abstract primitives
-- through its Alias attribute are the internal entities that have -- through its Alias attribute are the internal entities that have
-- attribute Interface_Alias, and these entities are generated later -- attribute Interface_Alias, and these entities are generated later
-- by Freeze_Record_Type). -- by Add_Internal_Interface_Entities).
if In_Private_Part (Current_Scope) if In_Private_Part (Current_Scope)
and then Is_Abstract_Type (Parent_Type) and then Is_Abstract_Type (Parent_Type)
...@@ -12734,6 +12737,12 @@ package body Sem_Ch3 is ...@@ -12734,6 +12737,12 @@ package body Sem_Ch3 is
-- corresponding operations of the actual. -- corresponding operations of the actual.
else else
pragma Assert (No (Node (Act_Elmt))
or else (Primitive_Names_Match (Subp, Node (Act_Elmt))
and then
Type_Conformant (Subp, Node (Act_Elmt),
Skip_Controlling_Formals => True)));
Derive_Subprogram Derive_Subprogram
(New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt));
...@@ -12839,7 +12848,11 @@ package body Sem_Ch3 is ...@@ -12839,7 +12848,11 @@ package body Sem_Ch3 is
or else or else
(Present (Generic_Actual) (Present (Generic_Actual)
and then Present (Act_Subp) and then Present (Act_Subp)
and then not Primitive_Names_Match (Subp, Act_Subp)) and then not
(Primitive_Names_Match (Subp, Act_Subp)
and then
Type_Conformant (Subp, Act_Subp,
Skip_Controlling_Formals => True)))
then then
pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual)); pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual));
...@@ -12849,14 +12862,73 @@ package body Sem_Ch3 is ...@@ -12849,14 +12862,73 @@ package body Sem_Ch3 is
-- Handle entities associated with interface primitives -- Handle entities associated with interface primitives
if Present (Alias (Subp)) if Present (Alias_Subp)
and then Is_Interface (Find_Dispatching_Type (Alias (Subp))) and then Is_Interface (Find_Dispatching_Type (Alias_Subp))
and then not Is_Predefined_Dispatching_Operation (Subp) and then not Is_Predefined_Dispatching_Operation (Subp)
then then
-- Search for the primitive in the homonym chain
Act_Subp := Act_Subp :=
Find_Primitive_Covering_Interface Find_Primitive_Covering_Interface
(Tagged_Type => Generic_Actual, (Tagged_Type => Generic_Actual,
Iface_Prim => Subp); Iface_Prim => Alias_Subp);
-- Previous search may not locate primitives covering
-- interfaces defined in generics units or instantiations.
-- (it fails if the covering primitive has formals whose
-- type is also defined in generics or instantiations).
-- In such case we search in the list of primitives of the
-- generic actual for the internal entity that links the
-- interface primitive and the covering primitive.
if No (Act_Subp)
and then Is_Generic_Type (Parent_Type)
then
-- This code has been designed to handle only generic
-- formals that implement interfaces that are defined
-- in a generic unit or instantiation. If this code is
-- needed for other cases we must review it because
-- (given that it relies on Original_Location to locate
-- the primitive of Generic_Actual that covers the
-- interface) it could leave linked through attribute
-- Alias entities of unrelated instantiations).
pragma Assert
(Is_Generic_Unit
(Scope (Find_Dispatching_Type (Alias_Subp)))
or else
Instantiation_Depth
(Sloc (Find_Dispatching_Type (Alias_Subp))) > 0);
declare
Iface_Prim_Loc : constant Source_Ptr :=
Original_Location (Sloc (Alias_Subp));
Elmt : Elmt_Id;
Prim : Entity_Id;
begin
Elmt :=
First_Elmt (Primitive_Operations (Generic_Actual));
Search : while Present (Elmt) loop
Prim := Node (Elmt);
if Present (Interface_Alias (Prim))
and then Original_Location
(Sloc (Interface_Alias (Prim)))
= Iface_Prim_Loc
then
Act_Subp := Alias (Prim);
exit Search;
end if;
Next_Elmt (Elmt);
end loop Search;
end;
end if;
pragma Assert (Present (Act_Subp)
or else Is_Abstract_Type (Generic_Actual)
or else Serious_Errors_Detected > 0);
-- Handle predefined primitives plus the rest of user-defined -- Handle predefined primitives plus the rest of user-defined
-- primitives -- primitives
...@@ -12874,6 +12946,10 @@ package body Sem_Ch3 is ...@@ -12874,6 +12946,10 @@ package body Sem_Ch3 is
Next_Elmt (Act_Elmt); Next_Elmt (Act_Elmt);
end loop; end loop;
if No (Act_Elmt) then
Act_Subp := Empty;
end if;
end if; end if;
end if; end if;
......
gcc/ada/sem_ch6.adb
...@@ -4568,7 +4568,7 @@ package body Sem_Ch6 is ...@@ -4568,7 +4568,7 @@ package body Sem_Ch6 is
elsif Must_Override (Spec) then elsif Must_Override (Spec) then
if Is_Overriding_Operation (Subp) then if Is_Overriding_Operation (Subp) then
Set_Is_Overriding_Operation (Subp); null;
elsif not Can_Override then elsif not Can_Override then
Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
...@@ -6477,8 +6477,8 @@ package body Sem_Ch6 is ...@@ -6477,8 +6477,8 @@ package body Sem_Ch6 is
or else Etype (Prim) = Etype (Iface_Prim) or else Etype (Prim) = Etype (Iface_Prim)
or else not Has_Controlling_Result (Prim) or else not Has_Controlling_Result (Prim)
then then
return Type_Conformant (Prim, Iface_Prim, return Type_Conformant
Skip_Controlling_Formals => True); (Iface_Prim, Prim, Skip_Controlling_Formals => True);
-- Case of a function returning an interface, or an access to one. -- Case of a function returning an interface, or an access to one.
-- Check that the return types correspond. -- Check that the return types correspond.
......
gcc/ada/sem_util.adb
...@@ -4497,15 +4497,13 @@ package body Sem_Util is ...@@ -4497,15 +4497,13 @@ package body Sem_Util is
(T : Entity_Id; (T : Entity_Id;
Use_Full_View : Boolean := True) return Boolean Use_Full_View : Boolean := True) return Boolean
is is
Typ : Entity_Id; Typ : Entity_Id := Base_Type (T);
begin begin
-- Handle concurrent types -- Handle concurrent types
if Is_Concurrent_Type (T) then if Is_Concurrent_Type (Typ) then
Typ := Corresponding_Record_Type (T); Typ := Corresponding_Record_Type (Typ);
else
Typ := T;
end if; end if;
if not Present (Typ) if not Present (Typ)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment