Skip to content

R
riscv-gcc-1
Commit cc821e65 by Claire Dross Committed by Pierre-Marie de Rodat
Options

[Ada] Allow for GNATprove specific versions of routines from Sem_Disp 

2018-05-28  Claire Dross  <dross@adacore.com>

gcc/ada/

	* sem_disp.ads, sem_disp.adb (Inheritance_Utilities): Package for
	generic inheritance utilities.
	(Generic_Inherited_Subprograms): Generic version of
	Inherited_Subprograms, generic in Find_Dispatching_Type function.
	(Generic_Is_Overriding_Subprogram): Generic version of
	Is_Overriding_Subprogram, generic in Find_Dispatching_Type function.
	(Inherited_Subprograms): Instance of Generic_Inherited_Subprograms with
	Sem_Disp.Find_Dispatching_Type.
	(Is_Overriding_Subprogram): Instance of
	Generic_Is_Overriding_Subprogram with Sem_Disp.Find_Dispatching_Type.
	(Inheritance_Utilities_Inst): Instance of Inheritance_Utilities
	with Sem_Disp.Find_Dispatching_Type.

From-SVN: r260835
parent 0c386027
Showing with 175 additions and 102 deletions
gcc/ada/ChangeLog
2018-05-28 Claire Dross <dross@adacore.com>
* sem_disp.ads, sem_disp.adb (Inheritance_Utilities): Package for
generic inheritance utilities.
(Generic_Inherited_Subprograms): Generic version of
Inherited_Subprograms, generic in Find_Dispatching_Type function.
(Generic_Is_Overriding_Subprogram): Generic version of
Is_Overriding_Subprogram, generic in Find_Dispatching_Type function.
(Inherited_Subprograms): Instance of Generic_Inherited_Subprograms with
Sem_Disp.Find_Dispatching_Type.
(Is_Overriding_Subprogram): Instance of
Generic_Is_Overriding_Subprogram with Sem_Disp.Find_Dispatching_Type.
(Inheritance_Utilities_Inst): Instance of Inheritance_Utilities
with Sem_Disp.Find_Dispatching_Type.
2018-05-28 Eric Botcazou <ebotcazou@adacore.com> 2018-05-28 Eric Botcazou <ebotcazou@adacore.com>
* exp_ch4.adb (Expand_Composite_Equality): For a composite (or FP) * exp_ch4.adb (Expand_Composite_Equality): For a composite (or FP)
......
gcc/ada/sem_disp.adb
...@@ -2201,137 +2201,181 @@ package body Sem_Disp is ...@@ -2201,137 +2201,181 @@ package body Sem_Disp is
end Find_Primitive_Covering_Interface; end Find_Primitive_Covering_Interface;
--------------------------- ---------------------------
-- Inherited_Subprograms -- -- Inheritance_Utilities --
--------------------------- ---------------------------
function Inherited_Subprograms package body Inheritance_Utilities is
(S : Entity_Id;
No_Interfaces : Boolean := False;
Interfaces_Only : Boolean := False;
One_Only : Boolean := False) return Subprogram_List
is
Result : Subprogram_List (1 .. 6000);
-- 6000 here is intended to be infinity. We could use an expandable
-- table, but it would be awfully heavy, and there is no way that we
-- could reasonably exceed this value.
N : Nat := 0; ---------------------------
-- Number of entries in Result -- Inherited_Subprograms --
---------------------------
Parent_Op : Entity_Id; function Inherited_Subprograms
-- Traverses the Overridden_Operation chain (S : Entity_Id;
No_Interfaces : Boolean := False;
Interfaces_Only : Boolean := False;
One_Only : Boolean := False) return Subprogram_List
is
Result : Subprogram_List (1 .. 6000);
-- 6000 here is intended to be infinity. We could use an expandable
-- table, but it would be awfully heavy, and there is no way that we
-- could reasonably exceed this value.
procedure Store_IS (E : Entity_Id); N : Nat := 0;
-- Stores E in Result if not already stored -- Number of entries in Result
-------------- Parent_Op : Entity_Id;
-- Store_IS -- -- Traverses the Overridden_Operation chain
--------------
procedure Store_IS (E : Entity_Id) is procedure Store_IS (E : Entity_Id);
begin -- Stores E in Result if not already stored
for J in 1 .. N loop
if E = Result (J) then
return;
end if;
end loop;
N := N + 1; --------------
Result (N) := E; -- Store_IS --
end Store_IS; --------------
-- Start of processing for Inherited_Subprograms procedure Store_IS (E : Entity_Id) is
begin
for J in 1 .. N loop
if E = Result (J) then
return;
end if;
end loop;
begin N := N + 1;
pragma Assert (not (No_Interfaces and Interfaces_Only)); Result (N) := E;
end Store_IS;
if Present (S) and then Is_Dispatching_Operation (S) then -- Start of processing for Inherited_Subprograms
-- Deal with direct inheritance begin
pragma Assert (not (No_Interfaces and Interfaces_Only));
if not Interfaces_Only then -- When used from backends, visibility can be handled differently
Parent_Op := S; -- resulting in no dispatching type being found.
loop
Parent_Op := Overridden_Operation (Parent_Op);
exit when No (Parent_Op)
or else
(No_Interfaces
and then
Is_Interface (Find_Dispatching_Type (Parent_Op)));
if Is_Subprogram_Or_Generic_Subprogram (Parent_Op) then if Present (S)
Store_IS (Parent_Op); and then Is_Dispatching_Operation (S)
and then Present (Find_DT (S))
then
if One_Only then -- Deal with direct inheritance
goto Done;
if not Interfaces_Only then
Parent_Op := S;
loop
Parent_Op := Overridden_Operation (Parent_Op);
exit when No (Parent_Op)
or else
(No_Interfaces
and then
Is_Interface (Find_DT (Parent_Op)));
if Is_Subprogram_Or_Generic_Subprogram (Parent_Op) then
Store_IS (Parent_Op);
if One_Only then
goto Done;
end if;
end if; end if;
end if; end loop;
end loop; end if;
end if;
-- Now deal with interfaces -- Now deal with interfaces
if not No_Interfaces then if not No_Interfaces then
declare declare
Tag_Typ : Entity_Id; Tag_Typ : Entity_Id;
Prim : Entity_Id; Prim : Entity_Id;
Elmt : Elmt_Id; Elmt : Elmt_Id;
begin begin
Tag_Typ := Find_Dispatching_Type (S); Tag_Typ := Find_DT (S);
-- In the presence of limited views there may be no visible -- In the presence of limited views there may be no visible
-- dispatching type. Primitives will be inherited when non- -- dispatching type. Primitives will be inherited when non-
-- limited view is frozen. -- limited view is frozen.
if No (Tag_Typ) then if No (Tag_Typ) then
return Result (1 .. 0); return Result (1 .. 0);
end if; end if;
if Is_Concurrent_Type (Tag_Typ) then if Is_Concurrent_Type (Tag_Typ) then
Tag_Typ := Corresponding_Record_Type (Tag_Typ); Tag_Typ := Corresponding_Record_Type (Tag_Typ);
end if; end if;
-- Search primitive operations of dispatching type -- Search primitive operations of dispatching type
if Present (Tag_Typ) if Present (Tag_Typ)
and then Present (Primitive_Operations (Tag_Typ)) and then Present (Primitive_Operations (Tag_Typ))
then then
Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
while Present (Elmt) loop while Present (Elmt) loop
Prim := Node (Elmt); Prim := Node (Elmt);
-- The following test eliminates some odd cases in which -- The following test eliminates some odd cases in
-- Ekind (Prim) is Void, to be investigated further ??? -- which Ekind (Prim) is Void, to be investigated
-- further ???
if not Is_Subprogram_Or_Generic_Subprogram (Prim) then if not Is_Subprogram_Or_Generic_Subprogram (Prim) then
null; null;
-- For [generic] subprogram, look at interface alias -- For [generic] subprogram, look at interface
-- alias.
elsif Present (Interface_Alias (Prim)) elsif Present (Interface_Alias (Prim))
and then Alias (Prim) = S and then Alias (Prim) = S
then then
-- We have found a primitive covered by S -- We have found a primitive covered by S
Store_IS (Interface_Alias (Prim)); Store_IS (Interface_Alias (Prim));
if One_Only then if One_Only then
goto Done; goto Done;
end if;
end if; end if;
end if;
Next_Elmt (Elmt); Next_Elmt (Elmt);
end loop; end loop;
end if; end if;
end; end;
end if;
end if; end if;
end if;
<<Done>> <<Done>>
return Result (1 .. N);
end Inherited_Subprograms;
return Result (1 .. N); ------------------------------
end Inherited_Subprograms; -- Is_Overriding_Subprogram --
------------------------------
function Is_Overriding_Subprogram (E : Entity_Id) return Boolean is
Inherited : constant Subprogram_List :=
Inherited_Subprograms (E, One_Only => True);
begin
return Inherited'Length > 0;
end Is_Overriding_Subprogram;
end Inheritance_Utilities;
--------------------------------
-- Inheritance_Utilities_Inst --
--------------------------------
package Inheritance_Utilities_Inst is new
Inheritance_Utilities (Find_Dispatching_Type);
---------------------------
-- Inherited_Subprograms --
---------------------------
function Inherited_Subprograms
(S : Entity_Id;
No_Interfaces : Boolean := False;
Interfaces_Only : Boolean := False;
One_Only : Boolean := False) return Subprogram_List renames
Inheritance_Utilities_Inst.Inherited_Subprograms;
--------------------------- ---------------------------
-- Is_Dynamically_Tagged -- -- Is_Dynamically_Tagged --
...@@ -2410,12 +2454,8 @@ package body Sem_Disp is ...@@ -2410,12 +2454,8 @@ package body Sem_Disp is
-- Is_Overriding_Subprogram -- -- Is_Overriding_Subprogram --
------------------------------ ------------------------------
function Is_Overriding_Subprogram (E : Entity_Id) return Boolean is function Is_Overriding_Subprogram (E : Entity_Id) return Boolean renames
Inherited : constant Subprogram_List := Inheritance_Utilities_Inst.Is_Overriding_Subprogram;
Inherited_Subprograms (E, One_Only => True);
begin
return Inherited'Length > 0;
end Is_Overriding_Subprogram;
-------------------------- --------------------------
-- Is_Tag_Indeterminate -- -- Is_Tag_Indeterminate --
......
gcc/ada/sem_disp.ads
...@@ -100,6 +100,24 @@ package Sem_Disp is ...@@ -100,6 +100,24 @@ package Sem_Disp is
type Subprogram_List is array (Nat range <>) of Entity_Id; type Subprogram_List is array (Nat range <>) of Entity_Id;
-- Type returned by Inherited_Subprograms function -- Type returned by Inherited_Subprograms function
generic
with function Find_DT (Subp : Entity_Id) return Entity_Id;
package Inheritance_Utilities is
-- This package provides generic versions of inheritance utilities
-- provided here. These versions are used in GNATprove backend to
-- adapt these utilities to GNATprove specific version of visibility of
-- types.
function Inherited_Subprograms
(S : Entity_Id;
No_Interfaces : Boolean := False;
Interfaces_Only : Boolean := False;
One_Only : Boolean := False) return Subprogram_List;
function Is_Overriding_Subprogram (E : Entity_Id) return Boolean;
end Inheritance_Utilities;
function Inherited_Subprograms function Inherited_Subprograms
(S : Entity_Id; (S : Entity_Id;
No_Interfaces : Boolean := False; No_Interfaces : Boolean := False;
......
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