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 195 additions and 56 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>
* exp_ch4.adb: Use predefined unsigned type in all cases.
......
gcc/ada/checks.adb
......@@ -3351,6 +3351,14 @@ package body Checks is
Indx := Next_Index (Indx);
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
(Type_Low_Bound (Etype (Indx)), OK1, LL, LU,
Assume_Valid);
......
gcc/ada/exp_cg.adb
......@@ -572,7 +572,11 @@ package body Exp_CG is
Prim_Op := Node (Prim_Elmt);
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_Int (UI_To_Int (Slot_Number (Int_Alias)));
Write_Char (':');
......
gcc/ada/exp_disp.adb
......@@ -6014,6 +6014,9 @@ package body Exp_Disp is
-- Look for primitive overriding an abstract interface subprogram
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))))
then
Prim_Pos := DT_Position (Alias (Prim));
......@@ -6721,6 +6724,13 @@ package body Exp_Disp is
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);
if not Is_Ancestor (Iface_Typ, Tag_Typ)
......
gcc/ada/g-pehage.adb
......@@ -145,6 +145,9 @@ package body GNAT.Perfect_Hash_Generators is
-- Return a string which includes string Str or integer Int preceded by
-- 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;
-- Shortcuts
......@@ -524,6 +527,7 @@ package body GNAT.Perfect_Hash_Generators is
---------
procedure Add (C : Character) is
pragma Assert (C /= ASCII.NUL);
begin
Line (Last + 1) := C;
Last := Last + 1;
......@@ -536,6 +540,11 @@ package body GNAT.Perfect_Hash_Generators is
procedure Add (S : String) is
Len : constant Natural := S'Length;
begin
for J in S'Range loop
pragma Assert (S (J) /= ASCII.NUL);
null;
end loop;
Line (Last + 1 .. Last + Len) := S;
Last := Last + Len;
end Add;
......@@ -1261,6 +1270,11 @@ package body GNAT.Perfect_Hash_Generators is
New_Line (Output);
end if;
for J in Value'Range loop
pragma Assert (Value (J) /= ASCII.NUL);
null;
end loop;
WT.Set_Last (NK);
WT.Table (NK) := New_Word (Value);
NK := NK + 1;
......@@ -1726,6 +1740,11 @@ package body GNAT.Perfect_Hash_Generators is
procedure Put (File : File_Descriptor; Str : String) is
Len : constant Natural := Str'Length;
begin
for J in Str'Range loop
pragma Assert (Str (J) /= ASCII.NUL);
null;
end loop;
if Write (File, Str'Address, Len) /= Len then
raise Program_Error;
end if;
......@@ -1768,13 +1787,12 @@ package body GNAT.Perfect_Hash_Generators is
Last := 0;
end if;
if Last + Len + 3 > Max then
if Last + Len + 3 >= Max then
Flush;
end if;
if Last = 0 then
Line (Last + 1 .. Last + 5) := " ";
Last := Last + 5;
Add (" ");
if F1 <= L1 then
if C1 = F1 and then C2 = F2 then
......@@ -1801,8 +1819,7 @@ package body GNAT.Perfect_Hash_Generators is
Add (' ');
end if;
Line (Last + 1 .. Last + Len) := S;
Last := Last + Len;
Add (S);
if C2 = L2 then
Add (')');
......@@ -1869,7 +1886,8 @@ package body GNAT.Perfect_Hash_Generators is
K := Get_Key (J);
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, 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 Put_Initial_Keys;
......@@ -1950,7 +1968,8 @@ package body GNAT.Perfect_Hash_Generators is
K := Get_Key (J);
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, 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 Put_Reduced_Keys;
......@@ -2337,7 +2356,8 @@ package body GNAT.Perfect_Hash_Generators is
Same_Keys_Sets_Table (J).First ..
Same_Keys_Sets_Table (J).Last
loop
Put (Output, WT.Table (Reduced (K)).all);
Put (Output,
Trim_Trailing_Nuls (WT.Table (Reduced (K)).all));
New_Line (Output);
end loop;
Put (Output, "--");
......@@ -2488,6 +2508,20 @@ package body GNAT.Perfect_Hash_Generators is
return S;
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 --
---------------
......
gcc/ada/g-pehage.ads
......@@ -116,7 +116,7 @@ package GNAT.Perfect_Hash_Generators is
-- Deallocate the internal structures and the words table
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;
-- Raised after Tries unsuccessful runs
......
gcc/ada/gnat_ugn.texi
......@@ -11909,6 +11909,13 @@ Do not look for sources in the system default directory.
@cindex @option{-nostdlib} (@command{gnatxref})
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}
@cindex @option{--RTS} (@command{gnatxref})
Specifies the default location of the runtime library. Same meaning as the
......
gcc/ada/gnatxref.adb
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -52,6 +52,9 @@ procedure Gnatxref is
RTS_Specified : String_Access := null;
-- 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;
-- Parse every switch on the command line
......@@ -79,7 +82,7 @@ procedure Gnatxref is
loop
case
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
when ASCII.NUL =>
exit;
......@@ -140,43 +143,70 @@ procedure Gnatxref is
-- Check that it is the first time we see this switch
if RTS_Specified = null then
RTS_Specified := new String'(GNAT.Command_Line.Parameter);
if Full_Switch = "-RTS" then
if RTS_Specified = null then
RTS_Specified := new String'(GNAT.Command_Line.Parameter);
elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then
Osint.Fail ("--RTS cannot be specified multiple times");
end if;
elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then
Osint.Fail ("--RTS cannot be specified multiple times");
end if;
Opt.No_Stdinc := True;
Opt.RTS_Switch := True;
Opt.No_Stdinc := True;
Opt.RTS_Switch := True;
declare
Src_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir
(GNAT.Command_Line.Parameter, Include);
declare
Src_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir
(GNAT.Command_Line.Parameter,
Include);
Lib_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir
(GNAT.Command_Line.Parameter, Objects);
Lib_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir
(GNAT.Command_Line.Parameter,
Objects);
begin
if Src_Path_Name /= null and then Lib_Path_Name /= null then
Add_Search_Dirs (Src_Path_Name, Include);
Add_Search_Dirs (Lib_Path_Name, Objects);
begin
if Src_Path_Name /= null
and then Lib_Path_Name /= null
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
Osint.Fail ("RTS path not valid: missing " &
"adainclude and adalib directories");
elsif Lib_Path_Name = null then
Osint.Fail ("RTS path not valid: missing " &
"adalib directory");
end if;
end;
elsif Src_Path_Name = null then
Osint.Fail ("RTS path not valid: missing " &
"adainclude directory");
elsif GNAT.Command_Line.Full_Switch = "-ext" then
elsif Lib_Path_Name = null then
Osint.Fail ("RTS path not valid: missing " &
"adalib directory");
-- Check that it is the first time we see this switch
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 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 =>
Write_Usage;
......@@ -239,6 +269,7 @@ procedure Gnatxref is
& " directory");
Put_Line (" -nostdlib Don't look for library files in the system"
& " default directory");
Put_Line (" --ext=xxx Specify alternate ali file extension");
Put_Line (" --RTS=dir specify the default source and object search"
& " path");
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
while Present (N) loop
Static := Static and then Is_Static_Subtype (Etype (N));
-- If however the index type is generic, attributes cannot
-- be folded.
-- If however the index type is generic, or derived from
-- 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
then
return;
......@@ -6205,13 +6205,13 @@ package body Sem_Attr is
Ind : Node_Id;
begin
-- In the case of a generic index type, the bounds may appear static
-- but the computation is not meaningful in this case, and may
-- generate a spurious warning.
-- If any index type is a formal type, or derived from one, the
-- bounds are not static. Treating them as static can produce
-- spurious warnings or improper constant folding.
Ind := First_Index (P_Type);
while Present (Ind) loop
if Is_Generic_Type (Etype (Ind)) then
if Is_Generic_Type (Root_Type (Etype (Ind))) then
return;
end if;
......
gcc/ada/sem_ch13.adb
......@@ -2366,7 +2366,9 @@ package body Sem_Ch13 is
-- code because their main purpose was to provide support to initialize
-- the secondary dispatch tables. They are now generated also when
-- 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
and then Ekind (E) = E_Record_Type
......@@ -2374,6 +2376,12 @@ package body Sem_Ch13 is
and then not Is_Interface (E)
and then Has_Interfaces (E)
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);
end if;
end Analyze_Freeze_Entity;
......
gcc/ada/sem_ch6.adb
......@@ -4568,7 +4568,7 @@ package body Sem_Ch6 is
elsif Must_Override (Spec) then
if Is_Overriding_Operation (Subp) then
Set_Is_Overriding_Operation (Subp);
null;
elsif not Can_Override then
Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
......@@ -6477,8 +6477,8 @@ package body Sem_Ch6 is
or else Etype (Prim) = Etype (Iface_Prim)
or else not Has_Controlling_Result (Prim)
then
return Type_Conformant (Prim, Iface_Prim,
Skip_Controlling_Formals => True);
return Type_Conformant
(Iface_Prim, Prim, Skip_Controlling_Formals => True);
-- Case of a function returning an interface, or an access to one.
-- Check that the return types correspond.
......
gcc/ada/sem_util.adb
......@@ -4497,15 +4497,13 @@ package body Sem_Util is
(T : Entity_Id;
Use_Full_View : Boolean := True) return Boolean
is
Typ : Entity_Id;
Typ : Entity_Id := Base_Type (T);
begin
-- Handle concurrent types
if Is_Concurrent_Type (T) then
Typ := Corresponding_Record_Type (T);
else
Typ := T;
if Is_Concurrent_Type (Typ) then
Typ := Corresponding_Record_Type (Typ);
end if;
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