Skip to content

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

[multiple changes] 

2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* elists.ads, elists.adb (Prepend_Unique_Elmt): New routine.
	* exp_ch3.adb (Freeze_Type): Signal the DIC body is created for
	the purposes of freezing.
	* exp_util.adb Update the documentation and structure of the
	type map used in class-wide semantics of assertion expressions.
	(Add_Inherited_Tagged_DIC): There is really no need to preanalyze
	and resolve the triaged expression because all substitutions
	refer to the proper entities.  Update the replacement of
	references.
	(Build_DIC_Procedure_Body): Add formal parameter
	For_Freeze. Add local variable Build_Body. Inherited DIC pragmas
	are now only processed when freezing occurs.  Build a body only
	when one is needed.
	(Entity_Hash): Removed.
	(Map_Types): New routine.
	(Replace_Object_And_Primitive_References): Removed.
	(Replace_References): New routine.
	(Replace_Type_References): Moved to the library level of Exp_Util.
	(Type_Map_Hash): New routine.
	(Update_Primitives_Mapping): Update the mapping call.
	(Update_Primitives_Mapping_Of_Types): Removed.
	* exp_util.ads (Build_DIC_Procedure_Body): Add formal
	parameter For_Freeze and update the comment on usage.
	(Map_Types): New routine.
	(Replace_References): New routine.
	(Replace_Type_References): Moved to the library level of Exp_Util.
	(Update_Primitives_Mapping_Of_Types): Removed.
	* sem_ch7.adb (Preserve_Full_Attributes): Propagate the DIC
	properties of the private type to the full view in case the full
	view derives from a parent type and inherits a DIC pragma.
	* sem_prag.adb (Analyze_Pragma): Guard against a case where a
	DIC pragma is placed at the top of a declarative region.

2017-04-25  Arnaud Charlet  <charlet@adacore.com trojanek>

	* a-tasatt.adb: Complete previous change and use an unsigned
	int to avoid overflow checks.

2017-04-25  Ed Schonberg  <schonberg@adacore.com>

	* sem_attr.adb (Analyze_Attribute, case 'Access): Specialize
	the error message when the attribute reference is an actual in
	a call to a subprogram inherited from a generic formal type with
	unknown discriminants, which makes the subprogram and its formal
	parameters intrinsic (see RM 6.3.1 (8) and (13)).

From-SVN: r247148
parent 2bb988bb
Showing with 1274 additions and 585 deletions
gcc/ada/ChangeLog
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* elists.ads, elists.adb (Prepend_Unique_Elmt): New routine.
* exp_ch3.adb (Freeze_Type): Signal the DIC body is created for
the purposes of freezing.
* exp_util.adb Update the documentation and structure of the
type map used in class-wide semantics of assertion expressions.
(Add_Inherited_Tagged_DIC): There is really no need to preanalyze
and resolve the triaged expression because all substitutions
refer to the proper entities. Update the replacement of
references.
(Build_DIC_Procedure_Body): Add formal parameter
For_Freeze. Add local variable Build_Body. Inherited DIC pragmas
are now only processed when freezing occurs. Build a body only
when one is needed.
(Entity_Hash): Removed.
(Map_Types): New routine.
(Replace_Object_And_Primitive_References): Removed.
(Replace_References): New routine.
(Replace_Type_References): Moved to the library level of Exp_Util.
(Type_Map_Hash): New routine.
(Update_Primitives_Mapping): Update the mapping call.
(Update_Primitives_Mapping_Of_Types): Removed.
* exp_util.ads (Build_DIC_Procedure_Body): Add formal
parameter For_Freeze and update the comment on usage.
(Map_Types): New routine.
(Replace_References): New routine.
(Replace_Type_References): Moved to the library level of Exp_Util.
(Update_Primitives_Mapping_Of_Types): Removed.
* sem_ch7.adb (Preserve_Full_Attributes): Propagate the DIC
properties of the private type to the full view in case the full
view derives from a parent type and inherits a DIC pragma.
* sem_prag.adb (Analyze_Pragma): Guard against a case where a
DIC pragma is placed at the top of a declarative region.
2017-04-25 Arnaud Charlet <charlet@adacore.com trojanek>
* a-tasatt.adb: Complete previous change and use an unsigned
int to avoid overflow checks.
2017-04-25 Ed Schonberg <schonberg@adacore.com>
* sem_attr.adb (Analyze_Attribute, case 'Access): Specialize
the error message when the attribute reference is an actual in
a call to a subprogram inherited from a generic formal type with
unknown discriminants, which makes the subprogram and its formal
parameters intrinsic (see RM 6.3.1 (8) and (13)).
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* sem_aggr.adb, inline.adb, einfo.adb, einfo.ads, scng.adb,
sem_prag.adb: Minor reformatting.
......
gcc/ada/a-tasatt.adb
......@@ -93,10 +93,11 @@ package body Ada.Task_Attributes is
function To_Attribute is new
Ada.Unchecked_Conversion (Atomic_Address, Attribute);
type Unsigned is mod 2 ** Integer'Size;
function To_Address is new
Ada.Unchecked_Conversion (Attribute, System.Address);
function To_Int is new
Ada.Unchecked_Conversion (Attribute, Integer);
function To_Unsigned is new
Ada.Unchecked_Conversion (Attribute, Unsigned);
pragma Warnings (On);
......@@ -121,7 +122,7 @@ package body Ada.Task_Attributes is
Fast_Path : constant Boolean :=
(Attribute'Size = Integer'Size
and then Attribute'Alignment <= Atomic_Address'Alignment
and then To_Int (Initial_Value) = 0)
and then To_Unsigned (Initial_Value) = 0)
or else (Attribute'Size = System.Address'Size
and then Attribute'Alignment <= Atomic_Address'Alignment
and then To_Address (Initial_Value) = System.Null_Address);
......@@ -303,7 +304,7 @@ package body Ada.Task_Attributes is
-- No finalization needed, simply set to Val
if Attribute'Size = Integer'Size then
TT.Attributes (Index) := Atomic_Address (To_Int (Val));
TT.Attributes (Index) := Atomic_Address (To_Unsigned (Val));
else
TT.Attributes (Index) := To_Address (Val);
end if;
......
gcc/ada/elists.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
......@@ -450,6 +450,17 @@ package body Elists is
Elists.Table (To).First := Elmts.Last;
end Prepend_Elmt;
-------------------------
-- Prepend_Unique_Elmt --
-------------------------
procedure Prepend_Unique_Elmt (N : Node_Or_Entity_Id; To : Elist_Id) is
begin
if not Contains (To, N) then
Prepend_Elmt (N, To);
end if;
end Prepend_Unique_Elmt;
-------------
-- Present --
-------------
......
gcc/ada/elists.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
......@@ -141,6 +141,10 @@ package Elists is
procedure Prepend_Elmt (N : Node_Or_Entity_Id; To : Elist_Id);
-- Appends N at the beginning of To, allocating a new element
procedure Prepend_Unique_Elmt (N : Node_Or_Entity_Id; To : Elist_Id);
-- Like Prepend_Elmt, except that a check is made to see if To already
-- contains N and if so the call has no effect.
procedure Insert_Elmt_After (N : Node_Or_Entity_Id; Elmt : Elmt_Id);
-- Add a new element (N) right after the pre-existing element Elmt
-- It is invalid to call this subprogram with Elmt = No_Elmt.
......
gcc/ada/exp_ch3.adb
......@@ -7515,7 +7515,7 @@ package body Exp_Ch3 is
-- verification of pragma Default_Initial_Condition's expression.
if Has_DIC (Def_Id) then
Build_DIC_Procedure_Body (Def_Id);
Build_DIC_Procedure_Body (Def_Id, For_Freeze => True);
end if;
-- Generate the [spec and] body of the invariant procedure tasked with
......
gcc/ada/exp_util.adb
......@@ -92,17 +92,27 @@ package body Exp_Util is
-- operations are mapped into the overriding operations of that current
-- type extension.
Primitives_Mapping_Size : constant := 511;
-- The contents of the map are as follows:
subtype Num_Primitives is Integer range 0 .. Primitives_Mapping_Size - 1;
function Entity_Hash (E : Entity_Id) return Num_Primitives;
-- Key Value
package Primitives_Mapping is new GNAT.HTable.Simple_HTable
(Header_Num => Num_Primitives,
-- Discriminant (Entity_Id) Discriminant (Entity_Id)
-- Discriminant (Entity_Id) Non-discriminant name (Entity_Id)
-- Discriminant (Entity_Id) Expression (Node_Id)
-- Primitive subprogram (Entity_Id) Primitive subprogram (Entity_Id)
-- Type (Entity_Id) Type (Entity_Id)
Type_Map_Size : constant := 511;
subtype Type_Map_Header is Integer range 0 .. Type_Map_Size - 1;
function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header;
package Type_Map is new GNAT.HTable.Simple_HTable
(Header_Num => Type_Map_Header,
Key => Entity_Id,
Element => Entity_Id,
Element => Node_Or_Entity_Id,
No_element => Empty,
Hash => Entity_Hash,
Hash => Type_Map_Hash,
Equal => "=");
-----------------------
......@@ -1086,7 +1096,7 @@ package body Exp_Util is
-- Determine whether entity has a renaming
New_E := Primitives_Mapping.Get (Entity (N));
New_E := Type_Map.Get (Entity (N));
if Present (New_E) then
Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
......@@ -1172,7 +1182,7 @@ package body Exp_Util is
Subp_Formal := First_Formal (Subp);
while Present (Par_Formal) and then Present (Subp_Formal) loop
Primitives_Mapping.Set (Par_Formal, Subp_Formal);
Type_Map.Set (Par_Formal, Subp_Formal);
Next_Formal (Par_Formal);
Next_Formal (Subp_Formal);
end loop;
......@@ -1210,7 +1220,10 @@ package body Exp_Util is
-- replaced by gotos which jump to the end of the routine and restore the
-- Ghost mode.
procedure Build_DIC_Procedure_Body (Typ : Entity_Id) is
procedure Build_DIC_Procedure_Body
(Typ : Entity_Id;
For_Freeze : Boolean := False)
is
procedure Add_DIC_Check
(DIC_Prag : Node_Id;
DIC_Expr : Node_Id;
......@@ -1249,34 +1262,6 @@ package body Exp_Util is
-- DIC_Prag. DIC_Typ is the owner of the DIC pragma. All generated code
-- is added to list Stmts.
procedure Replace_Object_And_Primitive_References
(Expr : Node_Id;
Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id;
Par_Obj : Entity_Id := Empty;
Deriv_Obj : Entity_Id := Empty);
-- Expr denotes an arbitrary expression. Par_Typ is a parent type in a
-- type hierarchy. Deriv_Typ is a type derived from Par_Typ. Par_Obj is
-- the formal parameter which emulates the current instance of Par_Typ.
-- Deriv_Obj is the formal parameter which emulates the current instance
-- of Deriv_Typ. Perform the following substitutions:
--
-- * Replace a reference to Par_Obj with a reference to Deriv_Obj if
-- applicable.
--
-- * Replace a call to an overridden parent primitive with a call to
-- the overriding derived type primitive.
--
-- * Replace a call to an inherited parent primitive with a call to
-- the internally-generated inherited derived type primitive.
procedure Replace_Type_References
(Expr : Node_Id;
Typ : Entity_Id;
Obj_Id : Entity_Id);
-- Substitute all references of the current instance of type Typ with
-- references to formal parameter Obj_Id within expression Expr.
-------------------
-- Add_DIC_Check --
-------------------
......@@ -1358,7 +1343,6 @@ package body Exp_Util is
Deriv_Typ : Entity_Id;
Stmts : in out List_Id)
is
Deriv_Decl : constant Node_Id := Declaration_Node (Deriv_Typ);
Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
DIC_Args : constant List_Id :=
Pragma_Argument_Associations (DIC_Prag);
......@@ -1383,6 +1367,9 @@ package body Exp_Util is
-- type's DIC procedure with a reference to the _object parameter
-- of the derived types' DIC procedure.
-- * Replace a reference to a discriminant of the parent type with
-- a suitable value from the point of view of the derived type.
-- * Replace a call to an overridden parent primitive with a call
-- to the overriding derived type primitive.
......@@ -1395,19 +1382,13 @@ package body Exp_Util is
pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
Replace_Object_And_Primitive_References
Replace_References
(Expr => Expr,
Par_Typ => Par_Typ,
Deriv_Typ => Deriv_Typ,
Par_Obj => First_Formal (Par_Proc),
Deriv_Obj => First_Formal (Deriv_Proc));
-- Preanalyze the DIC expression to detect errors and at the same
-- time capture the visibility of the proper package part.
Set_Parent (Expr, Deriv_Decl);
Preanalyze_Assert_Expression (Expr, Any_Boolean);
-- Once the DIC assertion expression is fully processed, add a check
-- to the statements of the DIC procedure.
......@@ -1531,200 +1512,6 @@ package body Exp_Util is
Stmts => Stmts);
end Add_Own_DIC;
---------------------------------------------
-- Replace_Object_And_Primitive_References --
---------------------------------------------
procedure Replace_Object_And_Primitive_References
(Expr : Node_Id;
Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id;
Par_Obj : Entity_Id := Empty;
Deriv_Obj : Entity_Id := Empty)
is
function Replace_Ref (Ref : Node_Id) return Traverse_Result;
-- Substitute a reference to an entity with a reference to the
-- corresponding entity stored in in table Primitives_Mapping.
-----------------
-- Replace_Ref --
-----------------
function Replace_Ref (Ref : Node_Id) return Traverse_Result is
Context : constant Node_Id := Parent (Ref);
Loc : constant Source_Ptr := Sloc (Ref);
New_Id : Entity_Id;
New_Ref : Node_Id;
Ref_Id : Entity_Id;
Result : Traverse_Result;
begin
Result := OK;
-- The current node denotes a reference
if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then
Ref_Id := Entity (Ref);
New_Id := Primitives_Mapping.Get (Ref_Id);
-- The reference mentions a parent type primitive which has a
-- corresponding derived type primitive.
if Present (New_Id) then
New_Ref := New_Occurrence_Of (New_Id, Loc);
-- The reference mentions the _object parameter of the parent
-- type's DIC procedure.
elsif Present (Par_Obj)
and then Present (Deriv_Obj)
and then Ref_Id = Par_Obj
then
New_Ref := New_Occurrence_Of (Deriv_Obj, Loc);
-- The reference to _object acts as an actual parameter in a
-- subprogram call which may be invoking a primitive of the
-- parent type:
-- Primitive (... _object ...);
-- The parent type primitive may not be overridden nor
-- inherited when it is declared after the derived type
-- definition:
-- type Parent is tagged private;
-- type Child is new Parent with private;
-- procedure Primitive (Obj : Parent);
-- In this scenario the _object parameter is converted to
-- the parent type.
if Nkind_In (Context, N_Function_Call,
N_Procedure_Call_Statement)
and then
No (Primitives_Mapping.Get (Entity (Name (Context))))
then
New_Ref := Convert_To (Par_Typ, New_Ref);
-- Do not process the generated type conversion because
-- both the parent type and the derived type are in the
-- Primitives_Mapping table. This will clobber the type
-- conversion by resetting its subtype mark.
Result := Skip;
end if;
-- Otherwise there is nothing to replace
else
New_Ref := Empty;
end if;
if Present (New_Ref) then
Rewrite (Ref, New_Ref);
-- Update the return type when the context of the reference
-- acts as the name of a function call. Note that the update
-- should not be performed when the reference appears as an
-- actual in the call.
if Nkind (Context) = N_Function_Call
and then Name (Context) = Ref
then
Set_Etype (Context, Etype (New_Id));
end if;
end if;
end if;
-- Reanalyze the reference due to potential replacements
if Nkind (Ref) in N_Has_Etype then
Set_Analyzed (Ref, False);
end if;
return Result;
end Replace_Ref;
procedure Replace_Refs is new Traverse_Proc (Replace_Ref);
-- Start of processing for Replace_Object_And_Primitive_References
begin
-- Map each primitive operation of the parent type to the proper
-- primitive of the derived type.
Update_Primitives_Mapping_Of_Types
(Par_Typ => Par_Typ,
Deriv_Typ => Deriv_Typ);
-- Inspect the input expression and perform substitutions where
-- necessary.
Replace_Refs (Expr);
end Replace_Object_And_Primitive_References;
-----------------------------
-- Replace_Type_References --
-----------------------------
procedure Replace_Type_References
(Expr : Node_Id;
Typ : Entity_Id;
Obj_Id : Entity_Id)
is
procedure Replace_Type_Ref (N : Node_Id);
-- Substitute a single reference of the current instance of type Typ
-- with a reference to Obj_Id.
----------------------
-- Replace_Type_Ref --
----------------------
procedure Replace_Type_Ref (N : Node_Id) is
Ref : Node_Id;
begin
-- Decorate the reference to Typ even though it may be rewritten
-- further down. This is done for two reasons:
-- 1) ASIS has all necessary semantic information in the
-- original tree.
-- 2) Routines which examine properties of the Original_Node
-- have some semantic information.
if Nkind (N) = N_Identifier then
Set_Entity (N, Typ);
Set_Etype (N, Typ);
elsif Nkind (N) = N_Selected_Component then
Analyze (Prefix (N));
Set_Entity (Selector_Name (N), Typ);
Set_Etype (Selector_Name (N), Typ);
end if;
-- Perform the following substitution:
-- Typ --> _object
Ref := Make_Identifier (Sloc (N), Chars (Obj_Id));
Set_Entity (Ref, Obj_Id);
Set_Etype (Ref, Typ);
Rewrite (N, Ref);
Set_Comes_From_Source (N, True);
end Replace_Type_Ref;
procedure Replace_Type_Refs is
new Replace_Type_References_Generic (Replace_Type_Ref);
-- Start of processing for Replace_Type_References
begin
Replace_Type_Refs (Expr, Typ);
end Replace_Type_References;
-- Local variables
Loc : constant Source_Ptr := Sloc (Typ);
......@@ -1740,6 +1527,9 @@ package body Exp_Util is
Proc_Id : Entity_Id;
Stmts : List_Id := No_List;
Build_Body : Boolean := False;
-- Flag set when the type requires a DIC procedure body to be built
Work_Typ : Entity_Id;
-- The working type
......@@ -1854,9 +1644,18 @@ package body Exp_Util is
DIC_Typ => DIC_Typ,
Stmts => Stmts);
-- Otherwise the working type inherits a DIC pragma from a parent type
Build_Body := True;
else
-- Otherwise the working type inherits a DIC pragma from a parent type.
-- This processing is carried out when the type is frozen because the
-- state of all parent discriminants is known at that point. Note that
-- it is semantically sound to delay the creation of the DIC procedure
-- body till the freeze point. If the type has a DIC pragma of its own,
-- then the DIC procedure body would have already been constructed at
-- the end of the visible declarations and all parent DIC pragmas are
-- effectively "hidden" and irrelevant.
elsif For_Freeze then
pragma Assert (Has_Inherited_DIC (Work_Typ));
pragma Assert (DIC_Typ /= Work_Typ);
......@@ -1882,66 +1681,71 @@ package body Exp_Util is
Deriv_Typ => Work_Typ,
Stmts => Stmts);
end if;
Build_Body := True;
end if;
End_Scope;
-- Produce an empty completing body in the following cases:
-- * Assertions are disabled
-- * The DIC Assertion_Policy is Ignore
-- * Pragma DIC appears without an argument
-- * Pragma DIC appears with argument "null"
if Build_Body then
if No (Stmts) then
Stmts := New_List (Make_Null_Statement (Loc));
end if;
-- Produce an empty completing body in the following cases:
-- * Assertions are disabled
-- * The DIC Assertion_Policy is Ignore
-- * Pragma DIC appears without an argument
-- * Pragma DIC appears with argument "null"
-- Generate:
-- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
-- begin
-- <Stmts>
-- end <Work_Typ>DIC;
if No (Stmts) then
Stmts := New_List (Make_Null_Statement (Loc));
end if;
-- Generate:
-- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
-- begin
-- <Stmts>
-- end <Work_Typ>DIC;
Proc_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Subprogram_Spec (Parent (Proc_Id)),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts));
Proc_Body_Id := Defining_Entity (Proc_Body);
Proc_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Subprogram_Spec (Parent (Proc_Id)),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts));
Proc_Body_Id := Defining_Entity (Proc_Body);
-- Perform minor decoration in case the body is not analyzed
-- Perform minor decoration in case the body is not analyzed
Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
Set_Etype (Proc_Body_Id, Standard_Void_Type);
Set_Scope (Proc_Body_Id, Current_Scope);
Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
Set_Etype (Proc_Body_Id, Standard_Void_Type);
Set_Scope (Proc_Body_Id, Current_Scope);
-- Link both spec and body to avoid generating duplicates
-- Link both spec and body to avoid generating duplicates
Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
Set_Corresponding_Spec (Proc_Body, Proc_Id);
Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
Set_Corresponding_Spec (Proc_Body, Proc_Id);
-- The body should not be inserted into the tree when the context is
-- ASIS or a generic unit because it is not part of the template. Note
-- that the body must still be generated in order to resolve the DIC
-- assertion expression.
-- The body should not be inserted into the tree when the context
-- is ASIS or a generic unit because it is not part of the template.
-- Note that the body must still be generated in order to resolve the
-- DIC assertion expression.
if ASIS_Mode or Inside_A_Generic then
null;
if ASIS_Mode or Inside_A_Generic then
null;
-- Semi-insert the body into the tree for GNATprove by setting its
-- Parent field. This allows for proper upstream tree traversals.
-- Semi-insert the body into the tree for GNATprove by setting its
-- Parent field. This allows for proper upstream tree traversals.
elsif GNATprove_Mode then
Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
elsif GNATprove_Mode then
Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
-- Otherwise the body is part of the freezing actions of the working
-- type.
-- Otherwise the body is part of the freezing actions of the working
-- type.
else
Append_Freeze_Action (Work_Typ, Proc_Body);
else
Append_Freeze_Action (Work_Typ, Proc_Body);
end if;
end if;
<<Leave>>
......@@ -3388,15 +3192,6 @@ package body Exp_Util is
end if;
end Ensure_Defined;
-----------------
-- Entity_Hash --
-----------------
function Entity_Hash (E : Entity_Id) return Num_Primitives is
begin
return Num_Primitives (E mod Primitives_Mapping_Size);
end Entity_Hash;
--------------------
-- Entry_Names_OK --
--------------------
......@@ -8289,155 +8084,734 @@ package body Exp_Util is
Constraints => List_Constr));
end Make_Subtype_From_Expr;
----------------------------
-- Matching_Standard_Type --
----------------------------
---------------
-- Map_Types --
---------------
function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is
pragma Assert (Is_Scalar_Type (Typ));
Siz : constant Uint := Esize (Typ);
procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id) is
begin
-- Floating-point cases
-- NOTE: Most of the routines in Map_Types are intentionally unnested to
-- avoid deep indentation of code.
if Is_Floating_Point_Type (Typ) then
if Siz <= Esize (Standard_Short_Float) then
return Standard_Short_Float;
elsif Siz <= Esize (Standard_Float) then
return Standard_Float;
elsif Siz <= Esize (Standard_Long_Float) then
return Standard_Long_Float;
elsif Siz <= Esize (Standard_Long_Long_Float) then
return Standard_Long_Long_Float;
else
raise Program_Error;
end if;
-- NOTE: Routines which deal with discriminant mapping operate on the
-- [underlying/record] full view of various types because those views
-- contain all discriminants and stored constraints.
-- Integer cases (includes fixed-point types)
procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id);
-- Subsidiary to Map_Primitives. Find a primitive in the inheritance or
-- overriding chain starting from Prim whose dispatching type is parent
-- type Par_Typ and add a mapping between the result and primitive Prim.
-- Unsigned integer cases (includes normal enumeration types)
function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id;
-- Subsidiary to Map_Primitives. Return the next ancestor primitive in
-- the inheritance or overriding chain of subprogram Subp. Return Empty
-- if no such primitive is available.
elsif Is_Unsigned_Type (Typ) then
if Siz <= Esize (Standard_Short_Short_Unsigned) then
return Standard_Short_Short_Unsigned;
elsif Siz <= Esize (Standard_Short_Unsigned) then
return Standard_Short_Unsigned;
elsif Siz <= Esize (Standard_Unsigned) then
return Standard_Unsigned;
elsif Siz <= Esize (Standard_Long_Unsigned) then
return Standard_Long_Unsigned;
elsif Siz <= Esize (Standard_Long_Long_Unsigned) then
return Standard_Long_Long_Unsigned;
else
raise Program_Error;
end if;
function Build_Chain
(Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id) return Elist_Id;
-- Subsidiary to Map_Discriminants. Recreate the derivation chain from
-- parent type Par_Typ leading down towards derived type Deriv_Typ. The
-- list has the form:
--
-- head tail
-- v v
-- <Ancestor_N> -> <Ancestor_N-1> -> <Ancestor_1> -> Deriv_Typ
--
-- Note that Par_Typ is not part of the resulting derivation chain
-- Signed integer cases
function Discriminated_View (Typ : Entity_Id) return Entity_Id;
-- Return the view of type Typ which could potentially contains either
-- the discriminants or stored constraints of the type.
else
if Siz <= Esize (Standard_Short_Short_Integer) then
return Standard_Short_Short_Integer;
elsif Siz <= Esize (Standard_Short_Integer) then
return Standard_Short_Integer;
elsif Siz <= Esize (Standard_Integer) then
return Standard_Integer;
elsif Siz <= Esize (Standard_Long_Integer) then
return Standard_Long_Integer;
elsif Siz <= Esize (Standard_Long_Long_Integer) then
return Standard_Long_Long_Integer;
else
raise Program_Error;
end if;
end if;
end Matching_Standard_Type;
function Find_Discriminant_Value
(Discr : Entity_Id;
Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id;
Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id;
-- Subsidiary to Map_Discriminants. Find the value of discriminant Discr
-- in the derivation chain starting from parent type Par_Typ leading to
-- derived type Deriv_Typ. The returned value is one of the following:
--
-- * An entity which is either a discriminant or a non-discriminant
-- name, and renames/constraints Discr.
--
-- * An expression which constraints Discr
--
-- Typ_Elmt is an element of the derivation chain created by routine
-- Build_Chain and denotes the current ancestor being examined.
-----------------------------
-- May_Generate_Large_Temp --
-----------------------------
procedure Map_Discriminants
(Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id);
-- Map each discriminant of type Par_Typ to a meaningful constraint
-- from the point of view of type Deriv_Typ.
-- At the current time, the only types that we return False for (i.e. where
-- we decide we know they cannot generate large temps) are ones where we
-- know the size is 256 bits or less at compile time, and we are still not
-- doing a thorough job on arrays and records ???
procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id);
-- Map each primitive of type Par_Typ to a corresponding primitive of
-- type Deriv_Typ.
function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
begin
if not Size_Known_At_Compile_Time (Typ) then
return False;
-------------------
-- Add_Primitive --
-------------------
elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
return False;
procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id) is
Par_Prim : Entity_Id;
elsif Is_Array_Type (Typ)
and then Present (Packed_Array_Impl_Type (Typ))
then
return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ));
begin
-- Inspect the inheritance chain through the Alias attribute and the
-- overriding chain through the Overridden_Operation looking for an
-- ancestor primitive with the appropriate dispatching type.
-- We could do more here to find other small types ???
Par_Prim := Prim;
while Present (Par_Prim) loop
exit when Find_Dispatching_Type (Par_Prim) = Par_Typ;
Par_Prim := Ancestor_Primitive (Par_Prim);
end loop;
else
return True;
end if;
end May_Generate_Large_Temp;
-- Create a mapping of the form:
------------------------
-- Needs_Finalization --
------------------------
-- parent type primitive -> derived type primitive
function Needs_Finalization (T : Entity_Id) return Boolean is
function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
-- If type is not frozen yet, check explicitly among its components,
-- because the Has_Controlled_Component flag is not necessarily set.
if Present (Par_Prim) then
Type_Map.Set (Par_Prim, Prim);
end if;
end Add_Primitive;
-----------------------------------
-- Has_Some_Controlled_Component --
-----------------------------------
------------------------
-- Ancestor_Primitive --
------------------------
function Has_Some_Controlled_Component
(Rec : Entity_Id) return Boolean
is
Comp : Entity_Id;
function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is
Inher_Prim : constant Entity_Id := Alias (Subp);
Over_Prim : constant Entity_Id := Overridden_Operation (Subp);
begin
if Has_Controlled_Component (Rec) then
return True;
-- The current subprogram overrides an ancestor primitive
elsif not Is_Frozen (Rec) then
if Is_Record_Type (Rec) then
Comp := First_Entity (Rec);
if Present (Over_Prim) then
return Over_Prim;
while Present (Comp) loop
if not Is_Type (Comp)
and then Needs_Finalization (Etype (Comp))
then
return True;
end if;
-- The current subprogram is an internally generated alias of an
-- inherited ancestor primitive.
Next_Entity (Comp);
end loop;
elsif Present (Inher_Prim) then
return Inher_Prim;
return False;
-- Otherwise the current subprogram is the root of the inheritance or
-- overriding chain.
else
return
Is_Array_Type (Rec)
and then Needs_Finalization (Component_Type (Rec));
end if;
else
return False;
return Empty;
end if;
end Has_Some_Controlled_Component;
end Ancestor_Primitive;
-- Start of processing for Needs_Finalization
-----------------
-- Build_Chain --
-----------------
begin
-- Certain run-time configurations and targets do not provide support
-- for controlled types.
function Build_Chain
(Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id) return Elist_Id
is
Anc_Typ : Entity_Id;
Chain : Elist_Id;
Curr_Typ : Entity_Id;
if Restriction_Active (No_Finalization) then
return False;
begin
Chain := New_Elmt_List;
-- C++ types are not considered controlled. It is assumed that the
-- Add the derived type to the derivation chain
Prepend_Elmt (Deriv_Typ, Chain);
-- Examine all ancestors starting from the derived type climbing
-- towards parent type Par_Typ.
Curr_Typ := Deriv_Typ;
loop
-- Work with the view which contains the discriminants and stored
-- constraints.
Anc_Typ := Discriminated_View (Base_Type (Etype (Curr_Typ)));
-- Use the first subtype when dealing with base types
if Is_Itype (Anc_Typ) then
Anc_Typ := First_Subtype (Anc_Typ);
end if;
-- Stop the climb when either the parent type has been reached or
-- there are no more ancestors left to examine.
exit when Anc_Typ = Curr_Typ or else Anc_Typ = Par_Typ;
Prepend_Unique_Elmt (Anc_Typ, Chain);
Curr_Typ := Anc_Typ;
end loop;
return Chain;
end Build_Chain;
------------------------
-- Discriminated_View --
------------------------
function Discriminated_View (Typ : Entity_Id) return Entity_Id is
T : Entity_Id;
begin
T := Typ;
-- Use the [underlying] full view when dealing with private types
-- because the view contains all inherited discriminants or stored
-- constraints.
if Is_Private_Type (T) then
if Present (Underlying_Full_View (T)) then
T := Underlying_Full_View (T);
elsif Present (Full_View (T)) then
T := Full_View (T);
end if;
end if;
-- Use the underlying record view when the type is an extenstion of
-- a parent type with unknown discriminants because the view contains
-- all inherited discriminants or stored constraints.
if Ekind (T) = E_Record_Type
and then Present (Underlying_Record_View (T))
then
T := Underlying_Record_View (T);
end if;
return T;
end Discriminated_View;
-----------------------------
-- Find_Discriminant_Value --
-----------------------------
function Find_Discriminant_Value
(Discr : Entity_Id;
Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id;
Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id
is
Discr_Pos : constant Uint := Discriminant_Number (Discr);
Typ : constant Entity_Id := Node (Typ_Elmt);
function Find_Constraint_Value
(Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id;
-- Given constraint Constr, find what it denotes. This is either:
--
-- * An entity which is either a discriminant or a name
--
-- * An expression
---------------------------
-- Find_Constraint_Value --
---------------------------
function Find_Constraint_Value
(Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id
is
begin
if Nkind (Constr) in N_Entity then
-- The constraint denotes a discriminant of the curren type
-- which renames the ancestor discriminant:
-- vv
-- type Typ (D1 : ...; DN : ...) is
-- new Anc (Discr => D1) with ...
-- ^^
if Ekind (Constr) = E_Discriminant then
-- The discriminant belongs to derived type Deriv_Typ. This
-- is the final value for the ancestor discriminant as the
-- derivations chain has been fully exhausted.
if Typ = Deriv_Typ then
return Constr;
-- Otherwise the discriminant may be renamed or constrained
-- at a lower level. Continue looking down the derivation
-- chain.
else
return
Find_Discriminant_Value
(Discr => Constr,
Par_Typ => Par_Typ,
Deriv_Typ => Deriv_Typ,
Typ_Elmt => Next_Elmt (Typ_Elmt));
end if;
-- Otherwise the constraint denotes a reference to some name
-- which results in a Girder discriminant:
-- vvvv
-- Name : ...;
-- type Typ (D1 : ...; DN : ...) is
-- new Anc (Discr => Name) with ...
-- ^^^^
-- Return the name as this is the proper constraint of the
-- discriminant.
else
return Constr;
end if;
-- The constraint denotes a reference to a name
elsif Is_Entity_Name (Constr) then
return Find_Constraint_Value (Entity (Constr));
-- Otherwise the current constraint is an expression which yields
-- a Girder discriminant:
-- type Typ (D1 : ...; DN : ...) is
-- new Anc (Discr => <expression>) with ...
-- ^^^^^^^^^^
-- Return the expression as this is the proper constraint of the
-- discriminant.
else
return Constr;
end if;
end Find_Constraint_Value;
-- Local variables
Constrs : constant Elist_Id := Stored_Constraint (Typ);
Constr_Elmt : Elmt_Id;
Pos : Uint;
Typ_Discr : Entity_Id;
-- Start of processing for Find_Discriminant_Value
begin
-- The algorithm for finding the value of a discriminant works as
-- follows. First, it recreates the derivation chain from Par_Typ
-- to Deriv_Typ as a list:
-- Par_Typ (shown for completeness)
-- v
-- Ancestor_N <-- head of chain
-- v
-- Ancestor_1
-- v
-- Deriv_Typ <-- tail of chain
-- The algorithm then traces the fate of a parent discriminant down
-- the derivation chain. At each derivation level, the discriminant
-- may be either inherited or constrained.
-- 1) Discriminant is inherited: there are two cases, depending on
-- which type is inheriting.
-- 1.1) Deriv_Typ is inheriting:
-- type Ancestor (D_1 : ...) is tagged ...
-- type Deriv_Typ is new Ancestor ...
-- In this case the inherited discriminant is the final value of
-- the parent discriminant because the end of the derivation chain
-- has been reached.
-- 1.2) Some other type is inheriting:
-- type Ancestor_1 (D_1 : ...) is tagged ...
-- type Ancestor_2 is new Ancestor_1 ...
-- In this case the algorithm continues to trace the fate of the
-- inherited discriminant down the derivation chain because it may
-- be further inherited or constrained.
-- 2) Discriminant is constrained: there are three cases, depending
-- on what the constraint is.
-- 2.1) The constraint is another discriminant (aka renaming):
-- type Ancestor_1 (D_1 : ...) is tagged ...
-- type Ancestor_2 (D_2 : ...) is new Ancestor_1 (D_1 => D_2) ...
-- In this case the constraining discriminant becomes the one to
-- track down the derivation chain. The algorithm already knows
-- that D_2 constrains D_1, therefore if the algorithm finds the
-- value of D_2, then this would also be the value for D_1.
-- 2.2) The constraint is a name (aka Girder):
-- Name : ...
-- type Ancestor_1 (D_1 : ...) is tagged ...
-- type Ancestor_2 is new Ancestor_1 (D_1 => Name) ...
-- In this case the name is the final value of D_1 because the
-- discriminant cannot be further constrained.
-- 2.3) The constraint is an expression (aka Girder):
-- type Ancestor_1 (D_1 : ...) is tagged ...
-- type Ancestor_2 is new Ancestor_1 (D_1 => 1 + 2) ...
-- Similar to 2.2, the expression is the final value of D_1
Pos := Uint_1;
-- When a derived type constrains its parent type, all constaints
-- appear in the Stored_Constraint list. Examine the list looking
-- for a positional match.
if Present (Constrs) then
Constr_Elmt := First_Elmt (Constrs);
while Present (Constr_Elmt) loop
-- The position of the current constraint matches that of the
-- ancestor discriminant.
if Pos = Discr_Pos then
return Find_Constraint_Value (Node (Constr_Elmt));
end if;
Next_Elmt (Constr_Elmt);
Pos := Pos + 1;
end loop;
-- Otherwise the derived type does not constraint its parent type in
-- which case it inherits the parent discriminants.
else
Typ_Discr := First_Discriminant (Typ);
while Present (Typ_Discr) loop
-- The position of the current discriminant matches that of the
-- ancestor discriminant.
if Pos = Discr_Pos then
return Find_Constraint_Value (Typ_Discr);
end if;
Next_Discriminant (Typ_Discr);
Pos := Pos + 1;
end loop;
end if;
-- A discriminant must always have a corresponding value. This is
-- either another discriminant, a name, or an expression. If this
-- point is reached, them most likely the derivation chain employs
-- the wrong views of types.
pragma Assert (False);
return Empty;
end Find_Discriminant_Value;
-----------------------
-- Map_Discriminants --
-----------------------
procedure Map_Discriminants
(Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id)
is
Deriv_Chain : constant Elist_Id := Build_Chain (Par_Typ, Deriv_Typ);
Discr : Entity_Id;
Discr_Val : Node_Or_Entity_Id;
begin
-- Examine each discriminant of parent type Par_Typ and find a
-- suitable value for it from the point of view of derived type
-- Deriv_Typ.
if Has_Discriminants (Par_Typ) then
Discr := First_Discriminant (Par_Typ);
while Present (Discr) loop
Discr_Val :=
Find_Discriminant_Value
(Discr => Discr,
Par_Typ => Par_Typ,
Deriv_Typ => Deriv_Typ,
Typ_Elmt => First_Elmt (Deriv_Chain));
-- Create a mapping of the form:
-- parent type discriminant -> value
Type_Map.Set (Discr, Discr_Val);
Next_Discriminant (Discr);
end loop;
end if;
end Map_Discriminants;
--------------------
-- Map_Primitives --
--------------------
procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id) is
Deriv_Prim : Entity_Id;
Par_Prim : Entity_Id;
Par_Prims : Elist_Id;
Prim_Elmt : Elmt_Id;
begin
-- Inspect the primitives of the derived type and determine whether
-- they relate to the primitives of the parent type. If there is a
-- meaningful relation, create a mapping of the form:
-- parent type primitive -> perived type primitive
if Present (Direct_Primitive_Operations (Deriv_Typ)) then
Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ));
while Present (Prim_Elmt) loop
Deriv_Prim := Node (Prim_Elmt);
if Is_Subprogram (Deriv_Prim)
and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ
then
Add_Primitive (Deriv_Prim, Par_Typ);
end if;
Next_Elmt (Prim_Elmt);
end loop;
end if;
-- If the parent operation is an interface operation, the overriding
-- indicator is not present. Instead, we get from the interface
-- operation the primitive of the current type that implements it.
if Is_Interface (Par_Typ) then
Par_Prims := Collect_Primitive_Operations (Par_Typ);
if Present (Par_Prims) then
Prim_Elmt := First_Elmt (Par_Prims);
while Present (Prim_Elmt) loop
Par_Prim := Node (Prim_Elmt);
Deriv_Prim :=
Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim);
if Present (Deriv_Prim) then
Type_Map.Set (Par_Prim, Deriv_Prim);
end if;
Next_Elmt (Prim_Elmt);
end loop;
end if;
end if;
end Map_Primitives;
-- Start of processing for Map_Types
begin
-- Nothing to do if there are no types to work with
if No (Parent_Type) or else No (Derived_Type) then
return;
-- Nothing to do if the mapping already exists
elsif Type_Map.Get (Parent_Type) = Derived_Type then
return;
-- Nothing to do if both types are not tagged. Note that untagged types
-- do not have primitive operations and their discriminants are already
-- handled by gigi.
elsif not Is_Tagged_Type (Parent_Type)
or else not Is_Tagged_Type (Derived_Type)
then
return;
end if;
-- Create a mapping of the form
-- parent type -> derived type
-- to prevent any subsequent attempts to produce the same relations
Type_Map.Set (Parent_Type, Derived_Type);
-- Create mappings of the form
-- parent type discriminant -> derived type discriminant
-- <or>
-- parent type discriminant -> constraint
-- Note that mapping of discriminants breaks privacy because it needs to
-- work with those views which contains the discriminants and any stored
-- constraints.
Map_Discriminants
(Par_Typ => Discriminated_View (Parent_Type),
Deriv_Typ => Discriminated_View (Derived_Type));
-- Create mappings of the form
-- parent type primitive -> derived type primitive
Map_Primitives
(Par_Typ => Parent_Type,
Deriv_Typ => Derived_Type);
end Map_Types;
----------------------------
-- Matching_Standard_Type --
----------------------------
function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is
pragma Assert (Is_Scalar_Type (Typ));
Siz : constant Uint := Esize (Typ);
begin
-- Floating-point cases
if Is_Floating_Point_Type (Typ) then
if Siz <= Esize (Standard_Short_Float) then
return Standard_Short_Float;
elsif Siz <= Esize (Standard_Float) then
return Standard_Float;
elsif Siz <= Esize (Standard_Long_Float) then
return Standard_Long_Float;
elsif Siz <= Esize (Standard_Long_Long_Float) then
return Standard_Long_Long_Float;
else
raise Program_Error;
end if;
-- Integer cases (includes fixed-point types)
-- Unsigned integer cases (includes normal enumeration types)
elsif Is_Unsigned_Type (Typ) then
if Siz <= Esize (Standard_Short_Short_Unsigned) then
return Standard_Short_Short_Unsigned;
elsif Siz <= Esize (Standard_Short_Unsigned) then
return Standard_Short_Unsigned;
elsif Siz <= Esize (Standard_Unsigned) then
return Standard_Unsigned;
elsif Siz <= Esize (Standard_Long_Unsigned) then
return Standard_Long_Unsigned;
elsif Siz <= Esize (Standard_Long_Long_Unsigned) then
return Standard_Long_Long_Unsigned;
else
raise Program_Error;
end if;
-- Signed integer cases
else
if Siz <= Esize (Standard_Short_Short_Integer) then
return Standard_Short_Short_Integer;
elsif Siz <= Esize (Standard_Short_Integer) then
return Standard_Short_Integer;
elsif Siz <= Esize (Standard_Integer) then
return Standard_Integer;
elsif Siz <= Esize (Standard_Long_Integer) then
return Standard_Long_Integer;
elsif Siz <= Esize (Standard_Long_Long_Integer) then
return Standard_Long_Long_Integer;
else
raise Program_Error;
end if;
end if;
end Matching_Standard_Type;
-----------------------------
-- May_Generate_Large_Temp --
-----------------------------
-- At the current time, the only types that we return False for (i.e. where
-- we decide we know they cannot generate large temps) are ones where we
-- know the size is 256 bits or less at compile time, and we are still not
-- doing a thorough job on arrays and records ???
function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
begin
if not Size_Known_At_Compile_Time (Typ) then
return False;
elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
return False;
elsif Is_Array_Type (Typ)
and then Present (Packed_Array_Impl_Type (Typ))
then
return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ));
-- We could do more here to find other small types ???
else
return True;
end if;
end May_Generate_Large_Temp;
------------------------
-- Needs_Finalization --
------------------------
function Needs_Finalization (T : Entity_Id) return Boolean is
function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
-- If type is not frozen yet, check explicitly among its components,
-- because the Has_Controlled_Component flag is not necessarily set.
-----------------------------------
-- Has_Some_Controlled_Component --
-----------------------------------
function Has_Some_Controlled_Component
(Rec : Entity_Id) return Boolean
is
Comp : Entity_Id;
begin
if Has_Controlled_Component (Rec) then
return True;
elsif not Is_Frozen (Rec) then
if Is_Record_Type (Rec) then
Comp := First_Entity (Rec);
while Present (Comp) loop
if not Is_Type (Comp)
and then Needs_Finalization (Etype (Comp))
then
return True;
end if;
Next_Entity (Comp);
end loop;
return False;
else
return
Is_Array_Type (Rec)
and then Needs_Finalization (Component_Type (Rec));
end if;
else
return False;
end if;
end Has_Some_Controlled_Component;
-- Start of processing for Needs_Finalization
begin
-- Certain run-time configurations and targets do not provide support
-- for controlled types.
if Restriction_Active (No_Finalization) then
return False;
-- C++ types are not considered controlled. It is assumed that the
-- non-Ada side will handle their clean up.
elsif Convention (T) = Convention_CPP then
......@@ -9521,6 +9895,321 @@ package body Exp_Util is
Scope_Suppress := Svg_Suppress;
end Remove_Side_Effects;
------------------------
-- Replace_References --
------------------------
procedure Replace_References
(Expr : Node_Id;
Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id;
Par_Obj : Entity_Id := Empty;
Deriv_Obj : Entity_Id := Empty)
is
function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean;
-- Determine whether node Ref denotes some component of Deriv_Obj
function Replace_Ref (Ref : Node_Id) return Traverse_Result;
-- Substitute a reference to an entity with the corresponding value
-- stored in table Type_Map.
function Type_Of_Formal
(Call : Node_Id;
Actual : Node_Id) return Entity_Id;
-- Find the type of the formal parameter which corresponds to actual
-- parameter Actual in subprogram call Call.
----------------------
-- Is_Deriv_Obj_Ref --
----------------------
function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean is
Par : constant Node_Id := Parent (Ref);
begin
-- Detect the folowing selected component form:
-- Deriv_Obj.(something)
return
Nkind (Par) = N_Selected_Component
and then Is_Entity_Name (Prefix (Par))
and then Entity (Prefix (Par)) = Deriv_Obj;
end Is_Deriv_Obj_Ref;
-----------------
-- Replace_Ref --
-----------------
function Replace_Ref (Ref : Node_Id) return Traverse_Result is
Context : constant Node_Id := Parent (Ref);
Loc : constant Source_Ptr := Sloc (Ref);
Ref_Id : Entity_Id;
Result : Traverse_Result;
New_Ref : Node_Id;
-- The new reference which is intended to substitute the old one
Old_Ref : Node_Id;
-- The reference designated for replacement. In certain cases this
-- may be a node other than Ref.
Val : Node_Or_Entity_Id;
-- The corresponding value of Ref from the type map
begin
-- Assume that the input reference is to be replaced and that the
-- traversal should examine the children of the reference.
Old_Ref := Ref;
Result := OK;
-- The input denotes a meaningful reference
if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then
Ref_Id := Entity (Ref);
Val := Type_Map.Get (Ref_Id);
-- The reference has a corresponding value in the type map, a
-- substitution is possible.
if Present (Val) then
-- The reference denotes a discriminant
if Ekind (Ref_Id) = E_Discriminant then
if Nkind (Val) in N_Entity then
-- The value denotes another discriminant. Replace as
-- follows:
-- _object.Discr -> _object.Val
if Ekind (Val) = E_Discriminant then
New_Ref := New_Occurrence_Of (Val, Loc);
-- Otherwise the value denotes the entity of a name which
-- constraints the discriminant. Replace as follows:
-- _object.Discr -> Val
else
pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
New_Ref := New_Occurrence_Of (Val, Loc);
Old_Ref := Parent (Old_Ref);
end if;
-- Otherwise the value denotes an arbitrary expression which
-- constraints the discriminant. Replace as follows:
-- _object.Discr -> Val
else
pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
New_Ref := New_Copy_Tree (Val);
Old_Ref := Parent (Old_Ref);
end if;
-- Otherwise the reference denotes a primitive. Replace as
-- follows:
-- Primitive -> Val
else
pragma Assert (Nkind (Val) in N_Entity);
New_Ref := New_Occurrence_Of (Val, Loc);
end if;
-- The reference mentions the _object parameter of the parent
-- type's DIC procedure. Replace as follows:
-- _object -> _object
elsif Present (Par_Obj)
and then Present (Deriv_Obj)
and then Ref_Id = Par_Obj
then
New_Ref := New_Occurrence_Of (Deriv_Obj, Loc);
-- The reference to _object acts as an actual parameter in a
-- subprogram call which may be invoking a primitive of the
-- parent type:
-- Primitive (... _object ...);
-- The parent type primitive may not be overridden nor
-- inherited when it is declared after the derived type
-- definition:
-- type Parent is tagged private;
-- type Child is new Parent with private;
-- procedure Primitive (Obj : Parent);
-- In this scenario the _object parameter is converted to the
-- parent type. Due to complications with partial/full views
-- and view swaps, the parent type is taken from the formal
-- parameter of the subprogram being called.
if Nkind_In (Context, N_Function_Call,
N_Procedure_Call_Statement)
and then No (Type_Map.Get (Entity (Name (Context))))
then
New_Ref :=
Convert_To (Type_Of_Formal (Context, Old_Ref), New_Ref);
-- Do not process the generated type conversion because
-- both the parent type and the derived type are in the
-- Type_Map table. This will clobber the type conversion
-- by resetting its subtype mark.
Result := Skip;
end if;
-- Otherwise there is nothing to replace
else
New_Ref := Empty;
end if;
if Present (New_Ref) then
Rewrite (Old_Ref, New_Ref);
-- Update the return type when the context of the reference
-- acts as the name of a function call. Note that the update
-- should not be performed when the reference appears as an
-- actual in the call.
if Nkind (Context) = N_Function_Call
and then Name (Context) = Old_Ref
then
Set_Etype (Context, Etype (Val));
end if;
end if;
end if;
-- Reanalyze the reference due to potential replacements
if Nkind (Old_Ref) in N_Has_Etype then
Set_Analyzed (Old_Ref, False);
end if;
return Result;
end Replace_Ref;
procedure Replace_Refs is new Traverse_Proc (Replace_Ref);
--------------------
-- Type_Of_Formal --
--------------------
function Type_Of_Formal
(Call : Node_Id;
Actual : Node_Id) return Entity_Id
is
A : Node_Id;
F : Entity_Id;
begin
-- Examine the list of actual and formal parameters in parallel
A := First (Parameter_Associations (Call));
F := First_Formal (Entity (Name (Call)));
while Present (A) and then Present (F) loop
if A = Actual then
return Etype (F);
end if;
Next (A);
Next_Formal (F);
end loop;
-- The actual parameter must always have a corresponding formal
pragma Assert (False);
return Empty;
end Type_Of_Formal;
-- Start of processing for Replace_References
begin
-- Map the attributes of the parent type to the proper corresponding
-- attributes of the derived type.
Map_Types
(Parent_Type => Par_Typ,
Derived_Type => Deriv_Typ);
-- Inspect the input expression and perform substitutions where
-- necessary.
Replace_Refs (Expr);
end Replace_References;
-----------------------------
-- Replace_Type_References --
-----------------------------
procedure Replace_Type_References
(Expr : Node_Id;
Typ : Entity_Id;
Obj_Id : Entity_Id)
is
procedure Replace_Type_Ref (N : Node_Id);
-- Substitute a single reference of the current instance of type Typ
-- with a reference to Obj_Id.
----------------------
-- Replace_Type_Ref --
----------------------
procedure Replace_Type_Ref (N : Node_Id) is
Ref : Node_Id;
begin
-- Decorate the reference to Typ even though it may be rewritten
-- further down. This is done for two reasons:
-- * ASIS has all necessary semantic information in the original
-- tree.
-- * Routines which examine properties of the Original_Node have
-- some semantic information.
if Nkind (N) = N_Identifier then
Set_Entity (N, Typ);
Set_Etype (N, Typ);
elsif Nkind (N) = N_Selected_Component then
Analyze (Prefix (N));
Set_Entity (Selector_Name (N), Typ);
Set_Etype (Selector_Name (N), Typ);
end if;
-- Perform the following substitution:
-- Typ -> _object
Ref := Make_Identifier (Sloc (N), Chars (Obj_Id));
Set_Entity (Ref, Obj_Id);
Set_Etype (Ref, Typ);
Rewrite (N, Ref);
Set_Comes_From_Source (N, True);
end Replace_Type_Ref;
procedure Replace_Type_Refs is
new Replace_Type_References_Generic (Replace_Type_Ref);
-- Start of processing for Replace_Type_References
begin
Replace_Type_Refs (Expr, Typ);
end Replace_Type_References;
---------------------------
-- Represented_As_Scalar --
---------------------------
......@@ -10964,6 +11653,15 @@ package body Exp_Util is
and then Esize (Left_Typ) = Esize (Result_Typ);
end Target_Has_Fixed_Ops;
-------------------
-- Type_Map_Hash --
-------------------
function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header is
begin
return Type_Map_Header (Id mod Type_Map_Size);
end Type_Map_Hash;
------------------------------------------
-- Type_May_Have_Bit_Aligned_Components --
------------------------------------------
......@@ -11015,163 +11713,11 @@ package body Exp_Util is
Subp_Id : Entity_Id)
is
begin
Update_Primitives_Mapping_Of_Types
(Par_Typ => Find_Dispatching_Type (Inher_Id),
Deriv_Typ => Find_Dispatching_Type (Subp_Id));
Map_Types
(Parent_Type => Find_Dispatching_Type (Inher_Id),
Derived_Type => Find_Dispatching_Type (Subp_Id));
end Update_Primitives_Mapping;
----------------------------------------
-- Update_Primitives_Mapping_Of_Types --
----------------------------------------
procedure Update_Primitives_Mapping_Of_Types
(Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id)
is
procedure Add_Primitive (Prim : Entity_Id);
-- Find a primitive in the inheritance/overriding chain starting from
-- Prim whose dispatching type is parent type Par_Typ and add a mapping
-- between the result and primitive Prim.
-------------------
-- Add_Primitive --
-------------------
procedure Add_Primitive (Prim : Entity_Id) is
function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id;
-- Return the next ancestor primitive in the inheritance/overriding
-- chain of subprogram Subp. Return Empty if no such primitive is
-- available.
------------------------
-- Ancestor_Primitive --
------------------------
function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is
Inher_Prim : constant Entity_Id := Alias (Subp);
Over_Prim : constant Entity_Id := Overridden_Operation (Subp);
begin
-- The current subprogram overrides an ancestor primitive
if Present (Over_Prim) then
return Over_Prim;
-- The current subprogram is an internally generated alias of an
-- inherited ancestor primitive.
elsif Present (Inher_Prim) then
return Inher_Prim;
-- Otherwise the current subprogram is the root of the inheritance
-- or overriding chain.
else
return Empty;
end if;
end Ancestor_Primitive;
-- Local variables
Par_Prim : Entity_Id;
-- Start of processing for Add_Primitive
begin
-- Inspect both the inheritance chain through the Alias attribute and
-- the overriding chain through the Overridden_Operation looking for
-- an ancestor primitive with the appropriate dispatching type.
Par_Prim := Prim;
while Present (Par_Prim) loop
exit when Find_Dispatching_Type (Par_Prim) = Par_Typ;
Par_Prim := Ancestor_Primitive (Par_Prim);
end loop;
-- Create a mapping of the form:
-- Parent type primitive -> derived type primitive
if Present (Par_Prim) then
Primitives_Mapping.Set (Par_Prim, Prim);
end if;
end Add_Primitive;
-- Local variables
Deriv_Prim : Entity_Id;
Par_Prim : Entity_Id;
Par_Prims : Elist_Id;
Prim_Elmt : Elmt_Id;
-- Start of processing for Update_Primitives_Mapping_Of_Types
begin
-- Nothing to do if there are no types to work with
if No (Par_Typ) or else No (Deriv_Typ) then
return;
-- Nothing to do if the mapping already exists
elsif Primitives_Mapping.Get (Par_Typ) = Deriv_Typ then
return;
end if;
-- Create a mapping of the form:
-- Parent type -> Derived type
-- to prevent any subsequent attempts to produce the same relations.
Primitives_Mapping.Set (Par_Typ, Deriv_Typ);
-- Inspect the primitives of the derived type and determine whether they
-- relate to the primitives of the parent type. If there is a meaningful
-- relation, create a mapping of the form:
-- Parent type primitive -> Derived type primitive
if Present (Direct_Primitive_Operations (Deriv_Typ)) then
Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ));
while Present (Prim_Elmt) loop
Deriv_Prim := Node (Prim_Elmt);
if Is_Subprogram (Deriv_Prim)
and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ
then
Add_Primitive (Deriv_Prim);
end if;
Next_Elmt (Prim_Elmt);
end loop;
end if;
-- If the parent operation is an interface operation, the overriding
-- indicator is not present. Instead, we get from the interface
-- operation the primitive of the current type that implements it.
if Is_Interface (Par_Typ) then
Par_Prims := Collect_Primitive_Operations (Par_Typ);
if Present (Par_Prims) then
Prim_Elmt := First_Elmt (Par_Prims);
while Present (Prim_Elmt) loop
Par_Prim := Node (Prim_Elmt);
Deriv_Prim :=
Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim);
if Present (Deriv_Prim) then
Primitives_Mapping.Set (Par_Prim, Deriv_Prim);
end if;
Next_Elmt (Prim_Elmt);
end loop;
end if;
end if;
end Update_Primitives_Mapping_Of_Types;
----------------------------------
-- Within_Case_Or_If_Expression --
----------------------------------
......
gcc/ada/exp_util.ads
......@@ -278,9 +278,13 @@ package Exp_Util is
-- Build a call to the DIC procedure of type Typ with Obj_Id as the actual
-- parameter.
procedure Build_DIC_Procedure_Body (Typ : Entity_Id);
procedure Build_DIC_Procedure_Body
(Typ : Entity_Id;
For_Freeze : Boolean := False);
-- Create the body of the procedure which verifies the assertion expression
-- of pragma Default_Initial_Condition at run time.
-- of pragma Default_Initial_Condition at run time. Flag For_Freeze should
-- be set when the body is construction as part of the freezing actions for
-- Typ.
procedure Build_DIC_Procedure_Declaration (Typ : Entity_Id);
-- Create the declaration of the procedure which verifies the assertion
......@@ -870,6 +874,19 @@ package Exp_Util is
-- wide type. Set Related_Id to request an external name for the subtype
-- rather than an internal temporary.
procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id);
-- Establish the following mapping between the attributes of tagged parent
-- type Parent_Type and tagged derived type Derived_Type.
--
-- * Map each discriminant of Parent_Type to ether the corresponding
-- discriminant of Derived_Type or come constraint.
-- * Map each primitive operation of Parent_Type to the corresponding
-- primitive of Derived_Type.
--
-- The mapping Parent_Type -> Derived_Type is also added to the table in
-- order to prevent subsequent attempts of the same mapping.
function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id;
-- Given a scalar subtype Typ, returns a matching type in standard that
-- has the same object size value. For example, a 16 bit signed type will
......@@ -995,6 +1012,37 @@ package Exp_Util is
-- renaming cannot be elaborated without evaluating the subexpression, so
-- gigi would resort to method 1) or 3) under the hood for them.
procedure Replace_References
(Expr : Node_Id;
Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id;
Par_Obj : Entity_Id := Empty;
Deriv_Obj : Entity_Id := Empty);
-- Expr denotes an arbitrary expression. Par_Typ is a tagged parent type
-- in a type hierarchy. Deriv_Typ is a tagged type derived from Par_Typ
-- with optional ancestors in between. Par_Obj is a formal parameter
-- which emulates the current instance of Par_Typ. Deriv_Obj is a formal
-- parameter which emulates the current instance of Deriv_Typ. Perform the
-- following substitutions in Expr:
--
-- * Replace a reference to Par_Obj with a reference to Deriv_Obj
--
-- * Replace a reference to a discriminant of Par_Typ with a suitable
-- value from the point of view of Deriv_Typ.
--
-- * Replace a call to an overridden primitive of Par_Typ with a call to
-- an overriding primitive of Deriv_Typ.
--
-- * Replace a call to an inherited primitive of Par_Type with a call to
-- the internally-generated inherited primitive of Deriv_Typ.
procedure Replace_Type_References
(Expr : Node_Id;
Typ : Entity_Id;
Obj_Id : Entity_Id);
-- Substitute all references of the current instance of type Typ with
-- references to formal parameter Obj_Id within expression Expr.
function Represented_As_Scalar (T : Entity_Id) return Boolean;
-- Returns True iff the implementation of this type in code generation
-- terms is scalar. This is true for scalars in the Ada sense, and for
......@@ -1103,12 +1151,6 @@ package Exp_Util is
-- when elaborating a contract for a subprogram, and when freezing a type
-- extension to verify legality rules on inherited conditions.
procedure Update_Primitives_Mapping_Of_Types
(Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id);
-- Map the primitive operations of parent type Par_Typ to the corresponding
-- primitives of derived type Deriv_Typ.
function Within_Case_Or_If_Expression (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N is within a case or an if expression
......
gcc/ada/sem_attr.adb
......@@ -10532,10 +10532,33 @@ package body Sem_Attr is
if Convention (Designated_Type (Btyp)) /=
Convention (Entity (P))
then
Error_Msg_FE
("subprogram & has wrong convention", P, Entity (P));
Error_Msg_Sloc := Sloc (Btyp);
Error_Msg_FE ("\does not match & declared#", P, Btyp);
-- The rule in 6.3.1 (8) deserves a special error
-- message.
if Convention (Btyp) = Convention_Intrinsic
and then Nkind (Parent (N)) = N_Procedure_Call_Statement
and then Is_Entity_Name (Name (Parent (N)))
and then Inside_A_Generic
then
declare
Subp : constant Entity_Id :=
Entity (Name (Parent (N)));
begin
if Convention (Subp) = Convention_Intrinsic then
Error_Msg_FE ("subprogram and its formal "
& "parameters have convention Intrinsic",
Parent (N), Subp);
Error_Msg_N
("actual cannot be access attribute", N);
end if;
end;
else
Error_Msg_FE
("subprogram & has wrong convention", P, Entity (P));
Error_Msg_Sloc := Sloc (Btyp);
Error_Msg_FE ("\does not match & declared#", P, Btyp);
end if;
if not Is_Itype (Btyp)
and then not Has_Convention_Pragma (Btyp)
......
gcc/ada/sem_ch7.adb
......@@ -2568,6 +2568,11 @@ package body Sem_Ch7 is
Propagate_DIC_Attributes (Full, From_Typ => Full_Base);
Propagate_DIC_Attributes (Full_Base, From_Typ => Full);
-- Propagate Default_Initial_Condition-related attributes from the
-- full view to the private view.
Propagate_DIC_Attributes (Priv, From_Typ => Full);
-- Propagate invariant-related attributes from the base type of the
-- full view to the full view and vice versa. This may seem strange,
-- but is necessary depending on which type triggered the generation
......
gcc/ada/sem_prag.adb
......@@ -13839,6 +13839,7 @@ package body Sem_Prag is
Check_No_Identifiers;
Check_At_Most_N_Arguments (1);
Typ := Empty;
Stmt := Prev (N);
while Present (Stmt) loop
......@@ -13880,6 +13881,14 @@ package body Sem_Prag is
Stmt := Prev (Stmt);
end loop;
-- The pragma does not apply to a legal construct, issue an error
-- and stop the analysis.
if No (Typ) then
Pragma_Misplaced;
return;
end if;
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
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