OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2016-05-02  Tristan Gingold  <gingold@adacore.com>

	* sem_ch3.adb (Analyze_Object_Declaration): Use Has_Protected
	to check for the no local protected objects restriction.

2016-05-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* einfo.adb Anonymous_Master now uses Node35.
	(Anonymous_Master): Update the assertion and node reference.
	(Set_Anonymous_Master): Update the assertion and node reference.
	(Write_Field35_Name): Add output for Anonymous_Master.
	(Write_Field36_Name): The output is now undefined.
	* einfo.ads Update the node and description of attribute
	Anonymous_Master. Remove prior occurrences in entities as this
	is now a type attribute.
	* exp_ch3.adb (Expand_Freeze_Array_Type): Remove local variable
	Ins_Node. Anonymous access- to-controlled component types no
	longer need finalization masters. The master is now built when
	a related allocator is expanded.
	(Expand_Freeze_Record_Type): Remove local variable Has_AACC. Do not
	detect whether the record type has at least one component of anonymous
	access-to- controlled type. These types no longer need finalization
	masters. The master is now built when a related allocator is expanded.
	* exp_ch4.adb Remove with and use clauses for Lib and Sem_Ch8.
	(Current_Anonymous_Master): Removed.
	(Expand_N_Allocator): Call Build_Anonymous_Master to create a
	finalization master for an anonymous access-to-controlled type.
	* exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call):
	Call routine Build_Anonymous_Master to create a finalization master
	for an anonymous access-to-controlled type.
	* exp_ch7.adb (Allows_Finalization_Master): New routine.
	(Build_Anonymous_Master): New routine.
	(Build_Finalization_Master): Remove formal parameter
	For_Anonymous. Use Allows_Finalization_Master to determine whether
	circumstances warrant a finalization master. This routine no
	longer creates masters for anonymous access-to-controlled types.
	(In_Deallocation_Instance): Removed.
	* exp_ch7.ads (Build_Anonymous_Master): New routine.
	(Build_Finalization_Master): Remove formal parameter For_Anonymous
	and update the comment on usage.
	* sem_util.adb (Get_Qualified_Name): New routines.
	(Output_Name): Reimplemented.
	(Output_Scope): Removed.
	* sem_util.ads (Get_Qualified_Name): New routines.

2016-05-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* debug.adb: Document the use of switch -gnatd.H.
	* gnat1drv.adb (Adjust_Global_Switches): Set ASIS_GNSA mode when
	-gnatd.H is present.
	(Gnat1drv): Suppress the call to gigi when ASIS_GNSA mode is active.
	* opt.ads: Add new option ASIS_GNSA_Mode.
	* sem_ch13.adb (Alignment_Error): New routine.
	(Analyze_Attribute_Definition_Clause): Suppress certain errors in
	ASIS mode for attribute clause Alignment, Machine_Radix, Size, and
	Stream_Size.
	(Check_Size): Use routine Size_Too_Small_Error to
	suppress certain errors in ASIS mode.
	(Get_Alignment_Value): Use routine Alignment_Error to suppress certain
	errors in ASIS mode.
	(Size_Too_Small_Error): New routine.

From-SVN: r235732
This commit is contained in:
Arnaud Charlet 2016-05-02 12:05:03 +02:00
parent 4871a41df9
commit 32b794c81a
15 changed files with 697 additions and 615 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
gcc/ada/ChangeLog
View File

@ -1,3 +1,65 @@
2016-05-02 Tristan Gingold <gingold@adacore.com>
* sem_ch3.adb (Analyze_Object_Declaration): Use Has_Protected
to check for the no local protected objects restriction.
2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb Anonymous_Master now uses Node35.
(Anonymous_Master): Update the assertion and node reference.
(Set_Anonymous_Master): Update the assertion and node reference.
(Write_Field35_Name): Add output for Anonymous_Master.
(Write_Field36_Name): The output is now undefined.
* einfo.ads Update the node and description of attribute
Anonymous_Master. Remove prior occurrences in entities as this
is now a type attribute.
* exp_ch3.adb (Expand_Freeze_Array_Type): Remove local variable
Ins_Node. Anonymous access- to-controlled component types no
longer need finalization masters. The master is now built when
a related allocator is expanded.
(Expand_Freeze_Record_Type): Remove local variable Has_AACC. Do not
detect whether the record type has at least one component of anonymous
access-to- controlled type. These types no longer need finalization
masters. The master is now built when a related allocator is expanded.
* exp_ch4.adb Remove with and use clauses for Lib and Sem_Ch8.
(Current_Anonymous_Master): Removed.
(Expand_N_Allocator): Call Build_Anonymous_Master to create a
finalization master for an anonymous access-to-controlled type.
* exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call):
Call routine Build_Anonymous_Master to create a finalization master
for an anonymous access-to-controlled type.
* exp_ch7.adb (Allows_Finalization_Master): New routine.
(Build_Anonymous_Master): New routine.
(Build_Finalization_Master): Remove formal parameter
For_Anonymous. Use Allows_Finalization_Master to determine whether
circumstances warrant a finalization master. This routine no
longer creates masters for anonymous access-to-controlled types.
(In_Deallocation_Instance): Removed.
* exp_ch7.ads (Build_Anonymous_Master): New routine.
(Build_Finalization_Master): Remove formal parameter For_Anonymous
and update the comment on usage.
* sem_util.adb (Get_Qualified_Name): New routines.
(Output_Name): Reimplemented.
(Output_Scope): Removed.
* sem_util.ads (Get_Qualified_Name): New routines.
2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
* debug.adb: Document the use of switch -gnatd.H.
* gnat1drv.adb (Adjust_Global_Switches): Set ASIS_GNSA mode when
-gnatd.H is present.
(Gnat1drv): Suppress the call to gigi when ASIS_GNSA mode is active.
* opt.ads: Add new option ASIS_GNSA_Mode.
* sem_ch13.adb (Alignment_Error): New routine.
(Analyze_Attribute_Definition_Clause): Suppress certain errors in
ASIS mode for attribute clause Alignment, Machine_Radix, Size, and
Stream_Size.
(Check_Size): Use routine Size_Too_Small_Error to
suppress certain errors in ASIS mode.
(Get_Alignment_Value): Use routine Alignment_Error to suppress certain
errors in ASIS mode.
(Size_Too_Small_Error): New routine.
2016-05-02 Arnaud Charlet <charlet@adacore.com>
* spark_xrefs.ads Description of the spark cross-references

5
gcc/ada/debug.adb
View File

@ -125,7 +125,7 @@ package body Debug is
-- d.E Turn selected errors into warnings
-- d.F Debug mode for GNATprove
-- d.G Ignore calls through generic formal parameters for elaboration
-- d.H
-- d.H GNSA mode for ASIS
-- d.I Do not ignore enum representation clauses in CodePeer mode
-- d.J Disable parallel SCIL generation mode
-- d.K
@ -630,6 +630,9 @@ package body Debug is
-- now fixed, but we provide this debug flag to revert to the previous
-- situation of ignoring such calls to aid in transition.
-- d.H Sets ASIS_GNSA_Mode to True. This signals the front end to suppress
-- the call to gigi in ASIS_Mode.
-- d.I Do not ignore enum representation clauses in CodePeer mode.
-- The default of ignoring representation clauses for enumeration
-- types in CodePeer is good for the majority of Ada code, but in some

36
gcc/ada/einfo.adb
View File

@ -265,10 +265,9 @@ package body Einfo is
-- Contract Node34
-- Anonymous_Master Node35
-- Import_Pragma Node35
-- Anonymous_Master Node36
-- Class_Wide_Preconds List38
-- Class_Wide_Postconds List39
@ -757,12 +756,8 @@ package body Einfo is
function Anonymous_Master (Id : E) return E is
begin
pragma Assert (Ekind_In (Id, E_Function,
E_Package,
E_Package_Body,
E_Procedure,
E_Subprogram_Body));
return Node36 (Id);
pragma Assert (Is_Type (Id));
return Node35 (Id);
end Anonymous_Master;
function Anonymous_Object (Id : E) return E is
@ -3682,12 +3677,8 @@ package body Einfo is
procedure Set_Anonymous_Master (Id : E; V : E) is
begin
pragma Assert (Ekind_In (Id, E_Function,
E_Package,
E_Package_Body,
E_Procedure,
E_Subprogram_Body));
Set_Node36 (Id, V);
pragma Assert (Is_Type (Id));
Set_Node35 (Id, V);
end Set_Anonymous_Master;
procedure Set_Anonymous_Object (Id : E; V : E) is
@ -10385,6 +10376,9 @@ package body Einfo is
procedure Write_Field35_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when Type_Kind =>
Write_Str ("Anonymous_Master");
when Subprogram_Kind =>
Write_Str ("Import_Pragma");
@ -10398,19 +10392,9 @@ package body Einfo is
------------------------
procedure Write_Field36_Name (Id : Entity_Id) is
pragma Unreferenced (Id);
begin
case Ekind (Id) is
when E_Function |
E_Operator |
E_Package |
E_Package_Body |
E_Procedure |
E_Subprogram_Body =>
Write_Str ("Anonymous_Master");
when others =>
Write_Str ("Field36??");
end case;
Write_Str ("Field36??");
end Write_Field36_Name;
------------------------

18
gcc/ada/einfo.ads
View File

@ -438,11 +438,11 @@ package Einfo is
-- definition clause with an (obsolescent) mod clause is converted
-- into an attribute definition clause for this purpose.
-- Anonymous_Master (Node36)
-- Defined in the entities of non-generic packages, subprograms and their
-- corresponding bodies. Contains the entity of a special heterogeneous
-- finalization master that services most anonymous access-to-controlled
-- allocations that occur within the unit.
-- Anonymous_Master (Node35)
-- Defined in all types. Contains the entity of an anonymous finalization
-- master which services all anonymous access types associated with the
-- same designated type within the current semantic unit. The attribute
-- is set reactively during the expansion of allocators.
-- Anonymous_Object (Node30)
-- Present in protected and task type entities. Contains the entity of
@ -5468,6 +5468,7 @@ package Einfo is
-- Derived_Type_Link (Node31)
-- No_Tagged_Streams_Pragma (Node32)
-- Linker_Section_Pragma (Node33)
-- Anonymous_Master (Node35)
-- Depends_On_Private (Flag14)
-- Disable_Controlled (Flag253)
@ -5668,8 +5669,8 @@ package Einfo is
-- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17)
-- Equivalent_Type (Node18) (always Empty for type)
-- Last_Entity (Node20)
-- Non_Limited_View (Node19)
-- Last_Entity (Node20)
-- SSO_Set_High_By_Default (Flag273) (base type only)
-- SSO_Set_Low_By_Default (Flag272) (base type only)
-- First_Component (synth)
@ -5919,7 +5920,6 @@ package Einfo is
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
-- Anonymous_Master (Node36) (non-generic case only)
-- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39)
-- SPARK_Pragma (Node40)
@ -6141,7 +6141,6 @@ package Einfo is
-- Current_Use_Clause (Node27)
-- Finalizer (Node28) (non-generic case only)
-- Contract (Node34)
-- Anonymous_Master (Node36) (non-generic case only)
-- SPARK_Pragma (Node40)
-- SPARK_Aux_Pragma (Node41)
-- Delay_Subprogram_Descriptors (Flag50)
@ -6179,7 +6178,6 @@ package Einfo is
-- Scope_Depth_Value (Uint22)
-- Finalizer (Node28) (non-generic case only)
-- Contract (Node34)
-- Anonymous_Master (Node36)
-- SPARK_Pragma (Node40)
-- SPARK_Aux_Pragma (Node41)
-- Contains_Ignored_Ghost_Code (Flag279)
@ -6233,7 +6231,6 @@ package Einfo is
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
-- Anonymous_Master (Node36) (non-generic case only)
-- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39)
-- SPARK_Pragma (Node40)
@ -6419,7 +6416,6 @@ package Einfo is
-- Scope_Depth_Value (Uint22)
-- Extra_Formals (Node28)
-- Contract (Node34)
-- Anonymous_Master (Node36)
-- SPARK_Pragma (Node40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- SPARK_Pragma_Inherited (Flag265)

157
gcc/ada/exp_ch3.adb
View File

@ -4600,8 +4600,6 @@ package body Exp_Ch3 is
Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
Ins_Node : Node_Id;
begin
-- Ensure that all freezing activities are properly flagged as Ghost
@ -4654,39 +4652,13 @@ package body Exp_Ch3 is
end if;
end if;
if Typ = Base then
if Has_Controlled_Component (Base) then
Build_Controlling_Procs (Base);
if Typ = Base and then Has_Controlled_Component (Base) then
Build_Controlling_Procs (Base);
if not Is_Limited_Type (Comp_Typ)
and then Number_Dimensions (Typ) = 1
then
Build_Slice_Assignment (Typ);
end if;
end if;
-- Create a finalization master to service the anonymous access
-- components of the array.
if Ekind (Comp_Typ) = E_Anonymous_Access_Type
and then Needs_Finalization (Designated_Type (Comp_Typ))
if not Is_Limited_Type (Comp_Typ)
and then Number_Dimensions (Typ) = 1
then
-- The finalization master is inserted before the declaration
-- of the array type. The only exception to this is when the
-- array type is an itype, in which case the master appears
-- before the related context.
if Is_Itype (Typ) then
Ins_Node := Associated_Node_For_Itype (Typ);
else
Ins_Node := Parent (Typ);
end if;
Build_Finalization_Master
(Typ => Comp_Typ,
For_Anonymous => True,
Context_Scope => Scope (Typ),
Insertion_Node => Ins_Node);
Build_Slice_Assignment (Typ);
end if;
end if;
@ -5044,13 +5016,12 @@ package body Exp_Ch3 is
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List (
Statements => New_List (
Make_Raise_Constraint_Error (Loc,
Condition => Make_Identifier (Loc, Name_uF),
Reason => CE_Invalid_Data),
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Integer_Literal (Loc, -1)))));
Expression => Make_Integer_Literal (Loc, -1)))));
-- If either of the restrictions No_Exceptions_Handlers/Propagation is
-- active then return -1 (we cannot usefully raise Constraint_Error in
@ -5060,10 +5031,9 @@ package body Exp_Ch3 is
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List (
Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Integer_Literal (Loc, -1)))));
Expression => Make_Integer_Literal (Loc, -1)))));
end if;
-- Now we can build the function body
@ -5137,9 +5107,11 @@ package body Exp_Ch3 is
Comp : Entity_Id;
Comp_Typ : Entity_Id;
Has_AACC : Boolean;
Predef_List : List_Id;
Wrapper_Decl_List : List_Id := No_List;
Wrapper_Body_List : List_Id := No_List;
Renamed_Eq : Node_Id := Empty;
-- Defining unit name for the predefined equality function in the case
-- where the type has a primitive operation that is a renaming of
@ -5147,9 +5119,6 @@ package body Exp_Ch3 is
-- user-defined equality function). Used to pass this entity from
-- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
Wrapper_Decl_List : List_Id := No_List;
Wrapper_Body_List : List_Id := No_List;
-- Start of processing for Expand_Freeze_Record_Type
begin
@ -5212,8 +5181,6 @@ package body Exp_Ch3 is
-- of the component types may have been private at the point of the
-- record declaration. Detect anonymous access-to-controlled components.
Has_AACC := False;
Comp := First_Component (Typ);
while Present (Comp) loop
Comp_Typ := Etype (Comp);
@ -5238,15 +5205,6 @@ package body Exp_Ch3 is
Set_Has_Controlled_Component (Typ);
end if;
-- Non-self-referential anonymous access-to-controlled component
if Ekind (Comp_Typ) = E_Anonymous_Access_Type
and then Needs_Finalization (Designated_Type (Comp_Typ))
and then Designated_Type (Comp_Typ) /= Typ
then
Has_AACC := True;
end if;
Next_Component (Comp);
end loop;
@ -5595,97 +5553,6 @@ package body Exp_Ch3 is
end;
end if;
-- Create a heterogeneous finalization master to service the anonymous
-- access-to-controlled components of the record type.
if Has_AACC then
declare
Encl_Scope : constant Entity_Id := Scope (Typ);
Ins_Node : constant Node_Id := Parent (Typ);
Loc : constant Source_Ptr := Sloc (Typ);
Fin_Mas_Id : Entity_Id;
Attributes_Set : Boolean := False;
Master_Built : Boolean := False;
-- Two flags which control the creation and initialization of a
-- common heterogeneous master.
begin
Comp := First_Component (Typ);
while Present (Comp) loop
Comp_Typ := Etype (Comp);
-- A non-self-referential anonymous access-to-controlled
-- component.
if Ekind (Comp_Typ) = E_Anonymous_Access_Type
and then Needs_Finalization (Designated_Type (Comp_Typ))
and then Designated_Type (Comp_Typ) /= Typ
then
-- Build a homogeneous master for the first anonymous
-- access-to-controlled component. This master may be
-- converted into a heterogeneous collection if more
-- components are to follow.
if not Master_Built then
Master_Built := True;
-- All anonymous access-to-controlled types allocate
-- on the global pool. Note that the finalization
-- master and the associated storage pool must be set
-- on the root type (both are "root type only").
Set_Associated_Storage_Pool
(Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
Build_Finalization_Master
(Typ => Root_Type (Comp_Typ),
For_Anonymous => True,
Context_Scope => Encl_Scope,
Insertion_Node => Ins_Node);
Fin_Mas_Id := Finalization_Master (Comp_Typ);
-- Subsequent anonymous access-to-controlled components
-- reuse the available master.
else
-- All anonymous access-to-controlled types allocate
-- on the global pool. Note that both the finalization
-- master and the associated storage pool must be set
-- on the root type (both are "root type only").
Set_Associated_Storage_Pool
(Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
-- Shared the master among multiple components
Set_Finalization_Master
(Root_Type (Comp_Typ), Fin_Mas_Id);
-- Convert the master into a heterogeneous collection.
-- Generate:
-- Set_Is_Heterogeneous (<Fin_Mas_Id>);
if not Attributes_Set then
Attributes_Set := True;
Insert_Action (Ins_Node,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_Set_Is_Heterogeneous), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Fin_Mas_Id, Loc))));
end if;
end if;
end if;
Next_Component (Comp);
end loop;
end;
end if;
-- Check whether individual components have a defined invariant, and add
-- the corresponding component invariant checks.

207
gcc/ada/exp_ch4.adb
View File

@ -44,7 +44,6 @@ with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Inline; use Inline;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@ -57,7 +56,6 @@ with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
@ -92,12 +90,6 @@ package body Exp_Ch4 is
-- If a boolean array assignment can be done in place, build call to
-- corresponding library procedure.
function Current_Anonymous_Master return Entity_Id;
-- Return the entity of the heterogeneous finalization master belonging to
-- the current unit (either function, package or procedure). This master
-- services all anonymous access-to-controlled types. If the current unit
-- does not have such master, create one.
procedure Displace_Allocator_Pointer (N : Node_Id);
-- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
-- Expand_Allocator_Expression. Allocating class-wide interface objects
@ -410,202 +402,6 @@ package body Exp_Ch4 is
return;
end Build_Boolean_Array_Proc_Call;
------------------------------
-- Current_Anonymous_Master --
------------------------------
function Current_Anonymous_Master return Entity_Id is
function Create_Anonymous_Master
(Unit_Id : Entity_Id;
Unit_Decl : Node_Id) return Entity_Id;
-- Create a new anonymous master for a compilation unit denoted by its
-- entity Unit_Id and declaration Unit_Decl. The declaration of the new
-- master along with any specialized initialization is inserted at the
-- top of the unit's declarations (see body for special cases). Return
-- the entity of the anonymous master.
-----------------------------
-- Create_Anonymous_Master --
-----------------------------
function Create_Anonymous_Master
(Unit_Id : Entity_Id;
Unit_Decl : Node_Id) return Entity_Id
is
Insert_Nod : Node_Id := Empty;
-- The point of insertion into the declarative list of the unit. All
-- nodes are inserted before Insert_Nod.
procedure Insert_And_Analyze (Decls : List_Id; N : Node_Id);
-- Insert arbitrary node N in declarative list Decls and analyze it
------------------------
-- Insert_And_Analyze --
------------------------
procedure Insert_And_Analyze (Decls : List_Id; N : Node_Id) is
begin
-- The declarative list is already populated, the nodes are
-- inserted at the top of the list, preserving their order.
if Present (Insert_Nod) then
Insert_Before (Insert_Nod, N);
-- Otherwise append to the declarations to preserve order
else
Append_To (Decls, N);
end if;
Analyze (N);
end Insert_And_Analyze;
-- Local variables
Loc : constant Source_Ptr := Sloc (Unit_Id);
Spec_Id : constant Entity_Id := Unique_Defining_Entity (Unit_Decl);
Decls : List_Id;
FM_Id : Entity_Id;
Pref : Character;
Unit_Spec : Node_Id;
-- Start of processing for Create_Anonymous_Master
begin
-- Find the declarative list of the unit
if Nkind (Unit_Decl) = N_Package_Declaration then
Unit_Spec := Specification (Unit_Decl);
Decls := Visible_Declarations (Unit_Spec);
if No (Decls) then
Decls := New_List (Make_Null_Statement (Loc));
Set_Visible_Declarations (Unit_Spec, Decls);
end if;
-- Package or subprogram body
-- ??? A subprogram declaration that acts as a compilation unit may
-- contain a formal parameter of an anonymous access-to-controlled
-- type initialized by an allocator.
-- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
-- There is no suitable place to create the anonymous master as the
-- subprogram is not in a declarative list.
else
Decls := Declarations (Unit_Decl);
if No (Decls) then
Decls := New_List (Make_Null_Statement (Loc));
Set_Declarations (Unit_Decl, Decls);
end if;
end if;
-- The anonymous master and all initialization actions are inserted
-- before the first declaration (if any).
Insert_Nod := First (Decls);
-- Since the anonymous master and all its initialization actions are
-- inserted at top level, use the scope of the unit when analyzing.
Push_Scope (Spec_Id);
-- Step 1: Anonymous master creation
-- Use a unique prefix in case the same unit requires two anonymous
-- masters, one for the spec (S) and one for the body (B).
if Ekind_In (Unit_Id, E_Function, E_Package, E_Procedure) then
Pref := 'S';
else
Pref := 'B';
end if;
FM_Id :=
Make_Defining_Identifier (Loc,
New_External_Name
(Related_Id => Chars (Unit_Id),
Suffix => "AM",
Prefix => Pref));
Set_Anonymous_Master (Unit_Id, FM_Id);
-- Generate:
-- <FM_Id> : Finalization_Master;
Insert_And_Analyze (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => FM_Id,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
-- Step 2: Initialization actions
-- Generate:
-- Set_Base_Pool
-- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
Insert_And_Analyze (Decls,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (FM_Id, Loc),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
Attribute_Name => Name_Unrestricted_Access))));
-- Generate:
-- Set_Is_Heterogeneous (<FM_Id>);
Insert_And_Analyze (Decls,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Set_Is_Heterogeneous), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (FM_Id, Loc))));
Pop_Scope;
return FM_Id;
end Create_Anonymous_Master;
-- Local declarations
Unit_Decl : Node_Id;
Unit_Id : Entity_Id;
-- Start of processing for Current_Anonymous_Master
begin
Unit_Decl := Unit (Cunit (Current_Sem_Unit));
Unit_Id := Defining_Entity (Unit_Decl);
-- The compilation unit is a package instantiation. In this case the
-- anonymous master is associated with the package spec as both the
-- spec and body appear at the same level.
if Nkind (Unit_Decl) = N_Package_Body
and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
then
Unit_Id := Corresponding_Spec (Unit_Decl);
Unit_Decl := Unit_Declaration_Node (Unit_Id);
end if;
if Present (Anonymous_Master (Unit_Id)) then
return Anonymous_Master (Unit_Id);
-- Create a new anonymous master when allocating an object of anonymous
-- access-to-controlled type for the first time.
else
return Create_Anonymous_Master (Unit_Id, Unit_Decl);
end if;
end Current_Anonymous_Master;
--------------------------------
-- Displace_Allocator_Pointer --
--------------------------------
@ -4296,8 +4092,7 @@ package body Exp_Ch4 is
Set_Finalization_Master
(Root_Type (PtrT), Finalization_Master (Rel_Typ));
else
Set_Finalization_Master
(Root_Type (PtrT), Current_Anonymous_Master);
Build_Anonymous_Master (Root_Type (PtrT));
end if;
end if;

6
gcc/ada/exp_ch6.adb
View File

@ -422,11 +422,7 @@ package body Exp_Ch6 is
if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
and then No (Finalization_Master (Ptr_Typ))
then
Build_Finalization_Master
(Typ => Ptr_Typ,
For_Anonymous => True,
Context_Scope => Scope (Ptr_Typ),
Insertion_Node => Associated_Node_For_Itype (Ptr_Typ));
Build_Anonymous_Master (Ptr_Typ);
end if;
-- Access-to-controlled types should always have a master

443
gcc/ada/exp_ch7.adb
View File

@ -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- --
@ -301,6 +301,9 @@ package body Exp_Ch7 is
Finalize_Case => TSS_Deep_Finalize,
Address_Case => TSS_Finalize_Address);
function Allows_Finalization_Master (Typ : Entity_Id) return Boolean;
-- Determine whether access type Typ may have a finalization master
procedure Build_Array_Deep_Procs (Typ : Entity_Id);
-- Build the deep Initialize/Adjust/Finalize for a record Typ with
-- Has_Controlled_Component set and store them using the TSS mechanism.
@ -427,6 +430,332 @@ package body Exp_Ch7 is
-- [Deep_]Finalize (Acc_Typ (V).all);
-- end;
--------------------------------
-- Allows_Finalization_Master --
--------------------------------
function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is
function In_Deallocation_Instance (E : Entity_Id) return Boolean;
-- Determine whether entity E is inside a wrapper package created for
-- an instance of Ada.Unchecked_Deallocation.
------------------------------
-- In_Deallocation_Instance --
------------------------------
function In_Deallocation_Instance (E : Entity_Id) return Boolean is
Pkg : constant Entity_Id := Scope (E);
Par : Node_Id := Empty;
begin
if Ekind (Pkg) = E_Package
and then Present (Related_Instance (Pkg))
and then Ekind (Related_Instance (Pkg)) = E_Procedure
then
Par := Generic_Parent (Parent (Related_Instance (Pkg)));
return
Present (Par)
and then Chars (Par) = Name_Unchecked_Deallocation
and then Chars (Scope (Par)) = Name_Ada
and then Scope (Scope (Par)) = Standard_Standard;
end if;
return False;
end In_Deallocation_Instance;
-- Local variables
Desig_Typ : constant Entity_Id := Designated_Type (Typ);
Ptr_Typ : constant Entity_Id :=
Root_Type_Of_Full_View (Base_Type (Typ));
-- Start of processing for Allows_Finalization_Master
begin
-- Certain run-time configurations and targets do not provide support
-- for controlled types and therefore do not need masters.
if Restriction_Active (No_Finalization) then
return False;
-- Do not consider C and C++ types since it is assumed that the non-Ada
-- side will handle their clean up.
elsif Convention (Desig_Typ) = Convention_C
or else Convention (Desig_Typ) = Convention_CPP
then
return False;
-- Do not consider types that return on the secondary stack
elsif Present (Associated_Storage_Pool (Ptr_Typ))
and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
then
return False;
-- Do not consider types which may never allocate an object
elsif No_Pool_Assigned (Ptr_Typ) then
return False;
-- Do not consider access types coming from Ada.Unchecked_Deallocation
-- instances. Even though the designated type may be controlled, the
-- access type will never participate in allocation.
elsif In_Deallocation_Instance (Ptr_Typ) then
return False;
-- Do not consider non-library access types when restriction
-- No_Nested_Finalization is in effect since masters are controlled
-- objects.
elsif Restriction_Active (No_Nested_Finalization)
and then not Is_Library_Level_Entity (Ptr_Typ)
then
return False;
-- Do not create finalization masters in GNATprove mode because this
-- causes unwanted extra expansion. A compilation in this mode must
-- keep the tree as close as possible to the original sources.
elsif GNATprove_Mode then
return False;
-- Otherwise the access type may use a finalization master
else
return True;
end if;
end Allows_Finalization_Master;
----------------------------
-- Build_Anonymous_Master --
----------------------------
procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is
function Create_Anonymous_Master
(Desig_Typ : Entity_Id;
Unit_Id : Entity_Id;
Unit_Decl : Node_Id) return Entity_Id;
-- Create a new anonymous finalization master for access type Ptr_Typ
-- with designated type Desig_Typ. The declaration of the master along
-- with its specialized initialization is inserted in the declarative
-- part of unit Unit_Decl. Unit_Id denotes the entity of Unit_Decl.
function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean;
-- Determine whether arbitrary node N appears within the subtree rooted
-- at node Root.
-----------------------------
-- Create_Anonymous_Master --
-----------------------------
function Create_Anonymous_Master
(Desig_Typ : Entity_Id;
Unit_Id : Entity_Id;
Unit_Decl : Node_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (Unit_Id);
Spec_Id : constant Entity_Id := Unique_Defining_Entity (Unit_Decl);
Decls : List_Id;
FM_Decl : Node_Id;
FM_Id : Entity_Id;
FM_Init : Node_Id;
Pref : Character;
Unit_Spec : Node_Id;
begin
-- Find the declarative list of the unit
if Nkind (Unit_Decl) = N_Package_Declaration then
Unit_Spec := Specification (Unit_Decl);
Decls := Visible_Declarations (Unit_Spec);
if No (Decls) then
Decls := New_List;
Set_Visible_Declarations (Unit_Spec, Decls);
end if;
-- Package body or subprogram case
-- ??? A subprogram spec or body that acts as a compilation unit may
-- contain a formal parameter of an anonymous access-to-controlled
-- type initialized by an allocator.
-- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
-- There is no suitable place to create the anonymous master as the
-- subprogram is not in a declarative list.
else
Decls := Declarations (Unit_Decl);
if No (Decls) then
Decls := New_List;
Set_Declarations (Unit_Decl, Decls);
end if;
end if;
-- Step 1: Anonymous master creation
-- Use a unique prefix in case the same unit requires two anonymous
-- masters, one for the spec (S) and one for the body (B).
if Ekind_In (Unit_Id, E_Function, E_Package, E_Procedure) then
Pref := 'S';
else
Pref := 'B';
end if;
-- The name of the anonymous master has the following format:
-- [BS]scopN__scop1__chars_of_desig_typAM
-- The name utilizes the fully qualified name of the designated type
-- in case two controlled types with the same name are declared in
-- different scopes and both have anonymous access types.
FM_Id :=
Make_Defining_Identifier (Loc,
New_External_Name
(Related_Id => Get_Qualified_Name (Desig_Typ),
Suffix => "AM",
Prefix => Pref));
-- Associate the anonymous master with the designated type. This
-- ensures that any additional anonymous access types with the same
-- designated type will share the same anonymous paster within the
-- same unit.
Set_Anonymous_Master (Desig_Typ, FM_Id);
-- Generate:
-- <FM_Id> : Finalization_Master;
FM_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => FM_Id,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
-- Step 2: Initialization actions
-- Generate:
-- Set_Base_Pool
-- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
FM_Init :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (FM_Id, Loc),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
Attribute_Name => Name_Unrestricted_Access)));
Prepend_To (Decls, FM_Init);
Prepend_To (Decls, FM_Decl);
-- Since the anonymous master and all its initialization actions are
-- inserted at top level, use the scope of the unit when analyzing.
Push_Scope (Spec_Id);
Analyze (FM_Decl);
Analyze (FM_Init);
Pop_Scope;
return FM_Id;
end Create_Anonymous_Master;
----------------
-- In_Subtree --
----------------
function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is
Par : Node_Id;
begin
-- Traverse the parent chain until reaching the same root
Par := N;
while Present (Par) loop
if Par = Root then
return True;
end if;
Par := Parent (Par);
end loop;
return False;
end In_Subtree;
-- Local variables
Desig_Typ : Entity_Id;
FM_Id : Entity_Id;
Priv_View : Entity_Id;
Unit_Decl : Node_Id;
Unit_Id : Entity_Id;
-- Start of processing for Build_Anonymous_Master
begin
-- Nothing to do if the circumstances do not allow for a finalization
-- master.
if not Allows_Finalization_Master (Ptr_Typ) then
return;
end if;
Unit_Decl := Unit (Cunit (Current_Sem_Unit));
Unit_Id := Defining_Entity (Unit_Decl);
-- The compilation unit is a package instantiation. In this case the
-- anonymous master is associated with the package spec as both the
-- spec and body appear at the same level.
if Nkind (Unit_Decl) = N_Package_Body
and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
then
Unit_Id := Corresponding_Spec (Unit_Decl);
Unit_Decl := Unit_Declaration_Node (Unit_Id);
end if;
-- Use the initial declaration of the designated type when it denotes
-- the full view of an incomplete or private type. This ensures that
-- types with one and two views are treated the same.
Desig_Typ := Directly_Designated_Type (Ptr_Typ);
Priv_View := Incomplete_Or_Partial_View (Desig_Typ);
if Present (Priv_View) then
Desig_Typ := Priv_View;
end if;
FM_Id := Anonymous_Master (Desig_Typ);
-- The designated type already has at least one anonymous access type
-- pointing to it within the current unit. Reuse the anonymous master
-- because the designated type is the same.
if Present (FM_Id)
and then In_Subtree (Declaration_Node (FM_Id), Root => Unit_Decl)
then
null;
-- Otherwise the designated type lacks an anonymous master or it is
-- declared in a different unit. Create a brand new master.
else
FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl);
end if;
Set_Finalization_Master (Ptr_Typ, FM_Id);
end Build_Anonymous_Master;
----------------------------
-- Build_Array_Deep_Procs --
----------------------------
@ -762,7 +1091,6 @@ package body Exp_Ch7 is
procedure Build_Finalization_Master
(Typ : Entity_Id;
For_Anonymous : Boolean := False;
For_Lib_Level : Boolean := False;
For_Private : Boolean := False;
Context_Scope : Entity_Id := Empty;
@ -773,10 +1101,6 @@ package body Exp_Ch7 is
Ptr_Typ : Entity_Id);
-- Add access type Ptr_Typ to the pending access type list for type Typ
function In_Deallocation_Instance (E : Entity_Id) return Boolean;
-- Determine whether entity E is inside a wrapper package created for
-- an instance of Ada.Unchecked_Deallocation.
-----------------------------
-- Add_Pending_Access_Type --
-----------------------------
@ -798,31 +1122,6 @@ package body Exp_Ch7 is
Prepend_Elmt (Ptr_Typ, List);
end Add_Pending_Access_Type;
------------------------------
-- In_Deallocation_Instance --
------------------------------
function In_Deallocation_Instance (E : Entity_Id) return Boolean is
Pkg : constant Entity_Id := Scope (E);
Par : Node_Id := Empty;
begin
if Ekind (Pkg) = E_Package
and then Present (Related_Instance (Pkg))
and then Ekind (Related_Instance (Pkg)) = E_Procedure
then
Par := Generic_Parent (Parent (Related_Instance (Pkg)));
return
Present (Par)
and then Chars (Par) = Name_Unchecked_Deallocation
and then Chars (Scope (Par)) = Name_Ada
and then Scope (Scope (Par)) = Standard_Standard;
end if;
return False;
end In_Deallocation_Instance;
-- Local variables
Desig_Typ : constant Entity_Id := Designated_Type (Typ);
@ -836,18 +1135,10 @@ package body Exp_Ch7 is
-- Start of processing for Build_Finalization_Master
begin
-- Certain run-time configurations and targets do not provide support
-- for controlled types.
-- Nothing to do if the circumstances do not allow for a finalization
-- master.
if Restriction_Active (No_Finalization) then
return;
-- Do not process C, C++ types since it is assumed that the non-Ada side
-- will handle their clean up.
elsif Convention (Desig_Typ) = Convention_C
or else Convention (Desig_Typ) = Convention_CPP
then
if not Allows_Finalization_Master (Typ) then
return;
-- Various machinery such as freezing may have already created a
@ -855,48 +1146,6 @@ package body Exp_Ch7 is
elsif Present (Finalization_Master (Ptr_Typ)) then
return;
-- Do not process types that return on the secondary stack
elsif Present (Associated_Storage_Pool (Ptr_Typ))
and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
then
return;
-- Do not process types which may never allocate an object
elsif No_Pool_Assigned (Ptr_Typ) then
return;
-- Do not process access types coming from Ada.Unchecked_Deallocation
-- instances. Even though the designated type may be controlled, the
-- access type will never participate in allocation.
elsif In_Deallocation_Instance (Ptr_Typ) then
return;
-- Ignore the general use of anonymous access types unless the context
-- requires a finalization master.
elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type
and then not For_Anonymous
then
return;
-- Do not process non-library access types when restriction No_Nested_
-- Finalization is in effect since masters are controlled objects.
elsif Restriction_Active (No_Nested_Finalization)
and then not Is_Library_Level_Entity (Ptr_Typ)
then
return;
-- Do not create finalization masters in GNATprove mode because this
-- unwanted extra expansion. A compilation in this mode keeps the tree
-- as close as possible to the original sources.
elsif GNATprove_Mode then
return;
end if;
declare
@ -1013,11 +1262,11 @@ package body Exp_Ch7 is
Add_Pending_Access_Type (Desig_Typ, Ptr_Typ);
end if;
-- A finalization master created for an anonymous access type or an
-- access designating a type with private components must be inserted
-- before a context-dependent node.
-- A finalization master created for an access designating a type
-- with private components is inserted before a context-dependent
-- node.
if For_Anonymous or For_Private then
if For_Private then
-- At this point both the scope of the context and the insertion
-- mode must be known.
@ -3693,15 +3942,6 @@ package body Exp_Ch7 is
end if;
end Check_Visibly_Controlled;
-------------------------------
-- CW_Or_Has_Controlled_Part --
-------------------------------
function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
begin
return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
end CW_Or_Has_Controlled_Part;
------------------
-- Convert_View --
------------------
@ -3764,6 +4004,15 @@ package body Exp_Ch7 is
end if;
end Convert_View;
-------------------------------
-- CW_Or_Has_Controlled_Part --
-------------------------------
function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
begin
return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
end CW_Or_Has_Controlled_Part;
------------------------
-- Enclosing_Function --
------------------------

24
gcc/ada/exp_ch7.ads
View File

@ -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- --
@ -35,6 +35,11 @@ package Exp_Ch7 is
-- Finalization Management --
-----------------------------
procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id);
-- Build a finalization master for an anonymous access-to-controlled type
-- denoted by Ptr_Typ. The master is inserted in the declarations of the
-- current unit.
procedure Build_Controlling_Procs (Typ : Entity_Id);
-- Typ is a record, and array type having controlled components.
-- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize
@ -99,22 +104,19 @@ package Exp_Ch7 is
procedure Build_Finalization_Master
(Typ : Entity_Id;
For_Anonymous : Boolean := False;
For_Lib_Level : Boolean := False;
For_Private : Boolean := False;
Context_Scope : Entity_Id := Empty;
Insertion_Node : Node_Id := Empty);
-- Build a finalization master for an access type. The designated type may
-- not necessarely be controlled or need finalization actions depending on
-- the context. Flag For_Anonymous must be set when creating a master for
-- an anonymous access type. Flag For_Lib_Level must be set when creating
-- a master for a build-in-place function call access result type. Flag
-- For_Private must be set when the designated type contains a private
-- component. Parameters Context_Scope and Insertion_Node must be used in
-- conjunction with flags For_Anonymous and For_Private. Context_Scope is
-- the scope of the context where the finalization master must be analyzed.
-- Insertion_Node is the insertion point before which the master is to be
-- inserted.
-- the context. Flag For_Lib_Level must be set when creating a master for a
-- build-in-place function call access result type. Flag For_Private must
-- be set when the designated type contains a private component. Parameters
-- Context_Scope and Insertion_Node must be used in conjunction with flag
-- For_Private. Context_Scope is the scope of the context where the
-- finalization master must be analyzed. Insertion_Node is the insertion
-- point before which the master is to be inserted.
procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id);
-- Build one controlling procedure when a late body overrides one of

28
gcc/ada/gnat1drv.adb
View File

@ -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- --
@ -180,6 +180,12 @@ procedure Gnat1drv is
if Operating_Mode = Check_Semantics and then Tree_Output then
ASIS_Mode := True;
-- Set ASIS GNSA mode if -gnatd.H is set
if Debug_Flag_Dot_HH then
ASIS_GNSA_Mode := True;
end if;
-- Turn off inlining in ASIS mode, since ASIS cannot handle the extra
-- information in the trees caused by inlining being active.
@ -1054,7 +1060,7 @@ begin
if GNATprove_Mode then
declare
Unused_E : constant Entity_Id :=
Rtsfind.RTE (Rtsfind.RE_Interrupt_Priority);
Rtsfind.RTE (Rtsfind.RE_Interrupt_Priority);
begin
null;
end;
@ -1176,13 +1182,11 @@ begin
-- We can generate code for a package declaration or a subprogram
-- declaration only if it does not required a body.
elsif Nkind_In (Main_Kind,
N_Package_Declaration,
N_Subprogram_Declaration)
elsif Nkind_In (Main_Kind, N_Package_Declaration,
N_Subprogram_Declaration)
and then
(not Body_Required (Main_Unit_Node)
or else
Distribution_Stub_Mode = Generate_Caller_Stub_Body)
or else Distribution_Stub_Mode = Generate_Caller_Stub_Body)
then
Back_End_Mode := Generate_Object;
@ -1247,8 +1251,7 @@ begin
if Back_End_Mode = Skip then
Set_Standard_Error;
Write_Str ("cannot generate code for ");
Write_Str ("file ");
Write_Str ("cannot generate code for file ");
Write_Name (Unit_File_Name (Main_Unit));
if Subunits_Missing then
@ -1320,11 +1323,16 @@ begin
-- Annotation is suppressed for targets where front-end layout is
-- enabled, because the front end determines representations.
-- The back-end is not invoked in ASIS mode with GNSA because all type
-- representation information will be provided by the GNSA back-end, not
-- gigi.
if Back_End_Mode = Declarations_Only
and then
(not (Back_Annotate_Rep_Info or Generate_SCIL or GNATprove_Mode)
or else Main_Kind = N_Subunit
or else Frontend_Layout_On_Target)
or else Frontend_Layout_On_Target
or else ASIS_GNSA_Mode)
then
Post_Compilation_Validation_Checks;
Errout.Finalize (Last_Call => True);

5
gcc/ada/opt.ads
View File

@ -208,6 +208,11 @@ package Opt is
-- Set to non-null when Bind_Alternate_Main_Name is True. This value
-- is modified as needed by Gnatbind.Scan_Bind_Arg.
ASIS_GNSA_Mode : Boolean := False;
-- GNAT
-- Enable GNSA back-end processing assuming ASIS_Mode is already set to
-- True. ASIS_GNSA mode suppresses the call to gigi.
ASIS_Mode : Boolean := False;
-- GNAT
-- Enable semantic checks and tree transformations that are important

193
gcc/ada/sem_ch13.adb
View File

@ -4758,9 +4758,8 @@ package body Sem_Ch13 is
elsif Is_Subprogram (U_Ent) then
if Has_Homonym (U_Ent) then
Error_Msg_N
("address clause cannot be given " &
"for overloaded subprogram",
Nam);
("address clause cannot be given for overloaded "
& "subprogram", Nam);
return;
end if;
@ -4802,8 +4801,8 @@ package body Sem_Ch13 is
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("?j?attaching interrupt to task entry is an " &
"obsolescent feature (RM J.7.1)", N);
("?j?attaching interrupt to task entry is an obsolescent "
& "feature (RM J.7.1)", N);
Error_Msg_N
("\?j?use interrupt procedure instead", N);
end if;
@ -5022,12 +5021,17 @@ package body Sem_Ch13 is
Set_Has_Alignment_Clause (U_Ent);
-- Tagged type case, check for attempt to set alignment to a
-- value greater than Max_Align, and reset if so.
-- value greater than Max_Align, and reset if so. This error
-- is suppressed in ASIS mode to allow for different ASIS
-- back-ends or ASIS-based tools to query the illegal clause.
if Is_Tagged_Type (U_Ent) and then Align > Max_Align then
if Is_Tagged_Type (U_Ent)
and then Align > Max_Align
and then not ASIS_Mode
then
Error_Msg_N
("alignment for & set to Maximum_Aligment??", Nam);
Set_Alignment (U_Ent, Max_Align);
Set_Alignment (U_Ent, Max_Align);
-- All other cases
@ -5100,7 +5104,7 @@ package body Sem_Ch13 is
end if;
Btype := Base_Type (U_Ent);
Ctyp := Component_Type (Btype);
Ctyp := Component_Type (Btype);
if Duplicate_Clause then
null;
@ -5324,8 +5328,8 @@ package body Sem_Ch13 is
Error_Msg_NE
("??non-unique external tag supplied for &", N, U_Ent);
Error_Msg_N
("\??same external tag applies to all "
& "subprogram calls", N);
("\??same external tag applies to all subprogram calls",
N);
Error_Msg_N
("\??corresponding internal tag cannot be obtained", N);
end if;
@ -5363,8 +5367,8 @@ package body Sem_Ch13 is
if From_Aspect_Specification (N) then
if not Is_Concurrent_Type (U_Ent) then
Error_Msg_N
("Interrupt_Priority can only be defined for task "
& "and protected object", Nam);
("Interrupt_Priority can only be defined for task and "
& "protected object", Nam);
elsif Duplicate_Clause then
null;
@ -5456,9 +5460,15 @@ package body Sem_Ch13 is
if Radix = 2 then
null;
elsif Radix = 10 then
Set_Machine_Radix_10 (U_Ent);
else
-- The following error is suppressed in ASIS mode to allow for
-- different ASIS back-ends or ASIS-based tools to query the
-- illegal clause.
elsif not ASIS_Mode then
Error_Msg_N ("machine radix value must be 2 or 10", Expr);
end if;
end if;
@ -5486,7 +5496,14 @@ package body Sem_Ch13 is
else
Check_Size (Expr, U_Ent, Size, Biased);
if Is_Scalar_Type (U_Ent) then
-- The following errors are suppressed in ASIS mode to allow
-- for different ASIS back-ends or ASIS-based tools to query
-- the illegal clause.
if ASIS_Mode then
null;
elsif Is_Scalar_Type (U_Ent) then
if Size /= 8 and then Size /= 16 and then Size /= 32
and then UI_Mod (Size, 64) /= 0
then
@ -5573,8 +5590,8 @@ package body Sem_Ch13 is
begin
if not (Is_Record_Type (U_Ent) or else Is_Array_Type (U_Ent)) then
Error_Msg_N
("Scalar_Storage_Order can only be defined for "
& "record or array type", Nam);
("Scalar_Storage_Order can only be defined for record or "
& "array type", Nam);
elsif Duplicate_Clause then
null;
@ -5598,8 +5615,8 @@ package body Sem_Ch13 is
Set_Reverse_Storage_Order (Base_Type (U_Ent), True);
else
Error_Msg_N
("non-default Scalar_Storage_Order "
& "not supported on target", Expr);
("non-default Scalar_Storage_Order not supported on "
& "target", Expr);
end if;
end if;
@ -5696,21 +5713,22 @@ package body Sem_Ch13 is
-- For objects, set Esize only
else
if Is_Elementary_Type (Etyp) then
if Size /= System_Storage_Unit
and then
Size /= System_Storage_Unit * 2
and then
Size /= System_Storage_Unit * 4
and then
Size /= System_Storage_Unit * 8
then
Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
Error_Msg_N
("size for primitive object must be a power of 2"
& " in the range ^-^", N);
end if;
-- The following error is suppressed in ASIS mode to allow
-- for different ASIS back-ends or ASIS-based tools to query
-- the illegal clause.
if Is_Elementary_Type (Etyp)
and then Size /= System_Storage_Unit
and then Size /= System_Storage_Unit * 2
and then Size /= System_Storage_Unit * 4
and then Size /= System_Storage_Unit * 8
and then not ASIS_Mode
then
Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
Error_Msg_N
("size for primitive object must be a power of 2 in "
& "the range ^-^", N);
end if;
Set_Esize (U_Ent, Size);
@ -5955,8 +5973,8 @@ package body Sem_Ch13 is
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("?j?storage size clause for task is an " &
"obsolescent feature (RM J.9)", N);
("?j?storage size clause for task is an obsolescent "
& "feature (RM J.9)", N);
Error_Msg_N ("\?j?use Storage_Size pragma instead", N);
end if;
end if;
@ -6024,24 +6042,29 @@ package body Sem_Ch13 is
null;
elsif Is_Elementary_Type (U_Ent) then
if Size /= System_Storage_Unit
and then
Size /= System_Storage_Unit * 2
and then
Size /= System_Storage_Unit * 4
and then
Size /= System_Storage_Unit * 8
-- The following errors are suppressed in ASIS mode to allow
-- for different ASIS back-ends or ASIS-based tools to query
-- the illegal clause.
if ASIS_Mode then
null;
elsif Size /= System_Storage_Unit
and then Size /= System_Storage_Unit * 2
and then Size /= System_Storage_Unit * 4
and then Size /= System_Storage_Unit * 8
then
Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
Error_Msg_N
("stream size for elementary type must be a"
& " power of 2 and at least ^", N);
("stream size for elementary type must be a power of 2 "
& "and at least ^", N);
elsif RM_Size (U_Ent) > Size then
Error_Msg_Uint_1 := RM_Size (U_Ent);
Error_Msg_N
("stream size for elementary type must be a"
& " power of 2 and at least ^", N);
("stream size for elementary type must be a power of 2 "
& "and at least ^", N);
end if;
Set_Has_Stream_Size_Clause (U_Ent);
@ -6787,12 +6810,10 @@ package body Sem_Ch13 is
and then Lbit /= No_Uint
then
if Posit < 0 then
Error_Msg_N
("position cannot be negative", Position (CC));
Error_Msg_N ("position cannot be negative", Position (CC));
elsif Fbit < 0 then
Error_Msg_N
("first bit cannot be negative", First_Bit (CC));
Error_Msg_N ("first bit cannot be negative", First_Bit (CC));
-- The Last_Bit specified in a component clause must not be
-- less than the First_Bit minus one (RM-13.5.1(10)).
@ -6885,8 +6906,8 @@ package body Sem_Ch13 is
Intval (Last_Bit (CC))
then
Error_Msg_N
("component clause inconsistent "
& "with representation of ancestor", CC);
("component clause inconsistent with "
& "representation of ancestor", CC);
elsif Warn_On_Redundant_Constructs then
Error_Msg_N
@ -10870,13 +10891,36 @@ package body Sem_Ch13 is
Siz : Uint;
Biased : out Boolean)
is
procedure Size_Too_Small_Error (Min_Siz : Uint);
-- Emit an error concerning illegal size Siz. Min_Siz denotes the
-- minimum size.
--------------------------
-- Size_Too_Small_Error --
--------------------------
procedure Size_Too_Small_Error (Min_Siz : Uint) is
begin
-- This error is suppressed in ASIS mode to allow for different ASIS
-- back-ends or ASIS-based tools to query the illegal clause.
if not ASIS_Mode then
Error_Msg_Uint_1 := Min_Siz;
Error_Msg_NE ("size for & too small, minimum allowed is ^", N, T);
end if;
end Size_Too_Small_Error;
-- Local variables
UT : constant Entity_Id := Underlying_Type (T);
M : Uint;
-- Start of processing for Check_Size
begin
Biased := False;
-- Reject patently improper size values.
-- Reject patently improper size values
if Is_Elementary_Type (T)
and then Siz > UI_From_Int (Int'Last)
@ -10945,9 +10989,7 @@ package body Sem_Ch13 is
return;
else
Error_Msg_Uint_1 := Asiz;
Error_Msg_NE
("size for& too small, minimum allowed is ^", N, T);
Size_Too_Small_Error (Asiz);
Set_Esize (T, Asiz);
Set_RM_Size (T, Asiz);
end if;
@ -10962,9 +11004,7 @@ package body Sem_Ch13 is
-- since we don't know all the characteristics of the type that can
-- affect the size (e.g. a specified small) till freeze time.
elsif Is_Fixed_Point_Type (UT)
and then not Is_Frozen (UT)
then
elsif Is_Fixed_Point_Type (UT) and then not Is_Frozen (UT) then
null;
-- Cases for which a minimum check is required
@ -10988,10 +11028,8 @@ package body Sem_Ch13 is
M := UI_From_Int (Minimum_Size (UT, Biased => True));
if Siz < M then
Error_Msg_Uint_1 := M;
Error_Msg_NE
("size for& too small, minimum allowed is ^", N, T);
Set_Esize (T, M);
Size_Too_Small_Error (M);
Set_Esize (T, M);
Set_RM_Size (T, M);
else
Biased := True;
@ -11513,14 +11551,36 @@ package body Sem_Ch13 is
-------------------------
function Get_Alignment_Value (Expr : Node_Id) return Uint is
procedure Alignment_Error;
-- Issue an error concerning a negatize or zero alignment represented by
-- expression Expr.
---------------------
-- Alignment_Error --
---------------------
procedure Alignment_Error is
begin
-- This error is suppressed in ASIS mode to allow for different ASIS
-- back-ends or ASIS-based tools to query the illegal clause.
if not ASIS_Mode then
Error_Msg_N ("alignment value must be positive", Expr);
end if;
end Alignment_Error;
-- Local variables
Align : constant Uint := Static_Integer (Expr);
-- Start of processing for Get_Alignment_Value
begin
if Align = No_Uint then
return No_Uint;
elsif Align <= 0 then
Error_Msg_N ("alignment value must be positive", Expr);
Alignment_Error;
return No_Uint;
else
@ -11532,8 +11592,7 @@ package body Sem_Ch13 is
exit when M = Align;
if M > Align then
Error_Msg_N
("alignment value must be power of 2", Expr);
Alignment_Error;
return No_Uint;
end if;
end;

9
gcc/ada/sem_ch3.adb
View File

@ -3560,9 +3560,7 @@ package body Sem_Ch3 is
-- Special checks for protected objects not at library level
if Is_Protected_Type (T)
and then not Is_Library_Level_Entity (Id)
then
if Has_Protected (T) and then not Is_Library_Level_Entity (Id) then
Check_Restriction (No_Local_Protected_Objects, Id);
-- Protected objects with interrupt handlers must be at library level
@ -3574,7 +3572,10 @@ package body Sem_Ch3 is
-- AI05-0303: The AI is in fact a binding interpretation, and thus
-- applies to the '95 version of the language as well.
if Has_Interrupt_Handler (T) and then Ada_Version < Ada_95 then
if Is_Protected_Type (T)
and then Has_Interrupt_Handler (T)
and then Ada_Version < Ada_95
then
Error_Msg_N
("interrupt object can only be declared at library level", Id);
end if;

105
gcc/ada/sem_util.adb
View File

@ -8322,6 +8322,73 @@ package body Sem_Util is
return Get_Pragma_Id (Pragma_Name (N));
end Get_Pragma_Id;
------------------------
-- Get_Qualified_Name --
------------------------
function Get_Qualified_Name
(Id : Entity_Id;
Suffix : Entity_Id := Empty) return Name_Id
is
Suffix_Nam : Name_Id := No_Name;
begin
if Present (Suffix) then
Suffix_Nam := Chars (Suffix);
end if;
return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id));
end Get_Qualified_Name;
function Get_Qualified_Name
(Nam : Name_Id;
Suffix : Name_Id := No_Name;
Scop : Entity_Id := Current_Scope) return Name_Id
is
procedure Add_Scope (S : Entity_Id);
-- Add the fully qualified form of scope S to the name buffer. The
-- format is:
-- s-1__s__
---------------
-- Add_Scope --
---------------
procedure Add_Scope (S : Entity_Id) is
begin
if S = Empty then
null;
elsif S = Standard_Standard then
null;
else
Add_Scope (Scope (S));
Get_Name_String_And_Append (Chars (S));
Add_Str_To_Name_Buffer ("__");
end if;
end Add_Scope;
-- Start of processing for Get_Qualified_Name
begin
Name_Len := 0;
Add_Scope (Scop);
-- Append the base name after all scopes have been chained
Get_Name_String_And_Append (Nam);
-- Append the suffix (if present)
if Suffix /= No_Name then
Add_Str_To_Name_Buffer ("__");
Get_Name_String_And_Append (Suffix);
end if;
return Name_Find;
end Get_Qualified_Name;
-----------------------
-- Get_Reason_String --
-----------------------
@ -17762,39 +17829,13 @@ package body Sem_Util is
-----------------
procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is
procedure Output_Scope (S : Entity_Id);
-- Add the fully qualified form of scope S to the name buffer. The
-- qualification format is:
-- scope1__scopeN__
------------------
-- Output_Scope --
------------------
procedure Output_Scope (S : Entity_Id) is
begin
if S = Empty then
null;
elsif S = Standard_Standard then
null;
else
Output_Scope (Scope (S));
Add_Str_To_Name_Buffer (Get_Name_String (Chars (S)));
Add_Str_To_Name_Buffer ("__");
end if;
end Output_Scope;
-- Start of processing for Output_Name
begin
Name_Len := 0;
Output_Scope (Scop);
Add_Str_To_Name_Buffer (Get_Name_String (Nam));
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Str
(Get_Name_String
(Get_Qualified_Name
(Nam => Nam,
Suffix => No_Name,
Scop => Scop)));
Write_Eol;
end Output_Name;

14
gcc/ada/sem_util.ads
View File

@ -950,6 +950,20 @@ package Sem_Util is
pragma Inline (Get_Pragma_Id);
-- Obtains the Pragma_Id from the Chars field of Pragma_Identifier (N)
function Get_Qualified_Name
(Id : Entity_Id;
Suffix : Entity_Id := Empty) return Name_Id;
-- Obtain the fully qualified form of entity Id. The format is:
-- scope_of_id-1__scope_of_id__chars_of_id__chars_of_suffix
function Get_Qualified_Name
(Nam : Name_Id;
Suffix : Name_Id := No_Name;
Scop : Entity_Id := Current_Scope) return Name_Id;
-- Obtain the fully qualified form of name Nam assuming it appears in scope
-- Scop. The format is:
-- scop-1__scop__nam__suffix
procedure Get_Reason_String (N : Node_Id);
-- Recursive routine to analyze reason argument for pragma Warnings. The
-- value of the reason argument is appended to the current string using