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

[multiple changes] 

2016-06-16  Hristian Kirtchev  <kirtchev@adacore.com>

	* atree.ads, atree.adb (Elist29): New routine.
	(Set_Elist29): New routine.
	* atree.h New definition for Elist29.
	* einfo.adb Subprograms_For_Type is now an Elist rather than
	a node. Has_Invariants is now a synthesized attribute
	and does not require a flag. Has_Own_Invariants
	is now Flag232. Has_Inherited_Invariants is
	Flag291. Is_Partial_Invariant_Procedure is Flag292.
	(Default_Init_Cond_Procedure): Reimplemented.
	(Has_Inherited_Invariants): New routine.
	(Has_Invariants): Reimplemented.
	(Has_Own_Invariants): New routine.
	(Invariant_Procedure): Reimplemented.
	(Is_Partial_Invariant_Procedure): New routine.
	(Partial_Invariant_Procedure): Reimplemented.
	(Predicate_Function): Reimplemented.
	(Predicate_Function_M): Reimplemented.
	(Set_Default_Init_Cond_Procedure): Reimplemented.
	(Set_Has_Inherited_Invariants): New routine.
	(Set_Has_Invariants): Removed.
	(Set_Has_Own_Invariants): New routine.
	(Set_Invariant_Procedure): Reimplemented.
	(Set_Is_Partial_Invariant_Procedure): New routine.
	(Set_Partial_Invariant_Procedure): Reimplemented.
	(Set_Predicate_Function): Reimplemented.
	(Set_Predicate_Function_M): Reimplemented.
	(Set_Subprograms_For_Type): Reimplemented.
	(Subprograms_For_Type): Reimplemented.
	(Write_Entity_Flags): Output Flag232 and Flag291.
	* einfo.ads Add new attributes Has_Inherited_Invariants
	Has_Own_Invariants Is_Partial_Invariant_Procedure
	Partial_Invariant_Procedure Change the documentation
	of attributes Has_Inheritable_Invariants Has_Invariants
	Invariant_Procedure Is_Invariant_Procedure Subprograms_For_Type
	(Has_Inherited_Invariants): New routine along with pragma Inline.
	(Has_Own_Invariants): New routine along with pragma Inline.
	(Is_Partial_Invariant_Procedure): New routine along with pragma Inline.
	(Partial_Invariant_Procedure): New routine.
	(Set_Has_Inherited_Invariants): New routine along with pragma Inline.
	(Set_Has_Invariants): Removed along with pragma Inline.
	(Set_Has_Own_Invariants): New routine along with pragma Inline.
	(Set_Is_Partial_Invariant_Procedure): New routine
	along with pragma Inline.
	(Set_Partial_Invariant_Procedure): New routine.
	(Set_Subprograms_For_Type): Update the signature.
	(Subprograms_For_Type): Update the signature.
	* exp_ch3.adb Remove with and use clauses for Sem_Ch13.
	(Build_Array_Invariant_Proc): Removed.
	(Build_Record_Invariant_Proc): Removed.
	(Freeze_Type): Build the body of the invariant procedure.
	(Insert_Component_Invariant_Checks): Removed.
	* exp_ch7.adb Add with and use clauses for Sem_Ch6, Sem_Ch13,
	and Stringt.
	(Build_Invariant_Procedure_Body): New routine.
	(Build_Invariant_Procedure_Declaration): New routine.
	* exp_ch7.ads (Build_Invariant_Procedure_Body): New routine.
	(Build_Invariant_Procedure_Declaration): New routine.
	* exp_ch9.adb (Build_Corresponding_Record): Do not propagate
	attributes related to invariants to the corresponding record
	when building the corresponding record. This is done by
	Build_Invariant_Procedure_Declaration.
	* exp_util.adb (Make_Invariant_Call): Reimplemented.
	* freeze.adb (Freeze_Array_Type): An array type requires an
	invariant procedure when its component type has invariants.
	(Freeze_Record_Type): A record type requires an invariant
	procedure when at least one of its components has an invariant.
	* sem_ch3.adb (Analyze_Private_Extension_Declaration): Inherit
	invariant-related attributes.
	(Analyze_Subtype_Declaration):
	Inherit invariant-related attributes.
	(Build_Derived_Record_Type): Inherit invariant-related attributes.
	(Check_Duplicate_Aspects): Reimplemented.
	(Get_Partial_View_Aspect): New routine.
	(Process_Full_View): Inherit invariant-related attributes. Reimplement
	the check on hidden inheritance of class-wide invariants.
	(Remove_Default_Init_Cond_Procedure): Reimplemented.
	* sem_ch6.adb (Analyze_Subprogram_Specification): Do not modify
	the controlling type for an invariant procedure declaration
	or body.
	(Is_Invariant_Procedure_Or_Body): New routine.
	* sem_ch7.adb (Analyze_Package_Specification): Build the partial
	invariant body in order to preanalyze and resolve all invariants
	of a private type at the end of the visible declarations. Build
	the full invariant body in order to preanalyze and resolve
	all invariants of a private type's full view at the end of
	the private declarations.
	(Preserve_Full_Attributes): Inherit invariant-related attributes.
	* sem_ch9.adb (Analyze_Protected_Type_Declaration): Ensure that
	aspects are analyzed with the proper view when the protected type
	is a completion of a private type. Inherit invariant-related attributes.
	(Analyze_Task_Type_Declaration): Ensure that
	aspects are analyzed with the proper view when the task type
	is a completion of a private type. Inherit invariant-related
	attributes.
	* sem_ch13.adb Remove with and use clauses for Stringt.
	(Build_Invariant_Procedure_Declaration): Removed.
	(Build_Invariant_Procedure): Removed.
	(Freeze_Entity_Checks): Do not build the body of the invariant
	procedure here.
	The body is built when the type is frozen in Freeze_Type.
	(Inherit_Aspects_At_Freeze_Point): Do not inherit any attributes
	related to invariants here because this leads to erroneous
	inheritance.
	(Replace_Node): Rename to Replace_Type_Ref.
	* sem_ch13.ads (Build_Invariant_Procedure_Declaration): Removed.
	(Build_Invariant_Procedure): Removed.
	* sem_prag.adb Add with and use clauses for Exp_Ch7.
	(Analyze_Pragma): Reimplement the analysis of pragma Invariant.
	* sem_res.adb (Resolve_Actuals): Emit a specialized error when
	the context is an invariant.
	* sem_util.adb (Get_Views): New routine.
	(Incomplete_Or_Partial_View): Consider generic packages when
	examining declarations.
	(Inspect_Decls): Consider full type
	declarations because they may denote a derivation from a
	private type.
	(Propagate_Invariant_Attributes): New routine.
	* sem_util.ads (Get_Views): New routine.
	(Propagate_Invariant_Attributes): New routine.

2016-06-16  Arnaud Charlet  <charlet@adacore.com>

	* pprint.adb (Expression_Image): Add better handling of UCs,
	we don't want to strip them all for clarity.

From-SVN: r237596
This commit is contained in:
Arnaud Charlet 2016-06-20 14:22:09 +02:00
parent 1db6c46d4d
commit 3ddfabe34f
23 changed files with 2752 additions and 1639 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
gcc/ada/ChangeLog
View File

@ -1,3 +1,131 @@
2016-06-16 Hristian Kirtchev <kirtchev@adacore.com>
* atree.ads, atree.adb (Elist29): New routine.
(Set_Elist29): New routine.
* atree.h New definition for Elist29.
* einfo.adb Subprograms_For_Type is now an Elist rather than
a node. Has_Invariants is now a synthesized attribute
and does not require a flag. Has_Own_Invariants
is now Flag232. Has_Inherited_Invariants is
Flag291. Is_Partial_Invariant_Procedure is Flag292.
(Default_Init_Cond_Procedure): Reimplemented.
(Has_Inherited_Invariants): New routine.
(Has_Invariants): Reimplemented.
(Has_Own_Invariants): New routine.
(Invariant_Procedure): Reimplemented.
(Is_Partial_Invariant_Procedure): New routine.
(Partial_Invariant_Procedure): Reimplemented.
(Predicate_Function): Reimplemented.
(Predicate_Function_M): Reimplemented.
(Set_Default_Init_Cond_Procedure): Reimplemented.
(Set_Has_Inherited_Invariants): New routine.
(Set_Has_Invariants): Removed.
(Set_Has_Own_Invariants): New routine.
(Set_Invariant_Procedure): Reimplemented.
(Set_Is_Partial_Invariant_Procedure): New routine.
(Set_Partial_Invariant_Procedure): Reimplemented.
(Set_Predicate_Function): Reimplemented.
(Set_Predicate_Function_M): Reimplemented.
(Set_Subprograms_For_Type): Reimplemented.
(Subprograms_For_Type): Reimplemented.
(Write_Entity_Flags): Output Flag232 and Flag291.
* einfo.ads Add new attributes Has_Inherited_Invariants
Has_Own_Invariants Is_Partial_Invariant_Procedure
Partial_Invariant_Procedure Change the documentation
of attributes Has_Inheritable_Invariants Has_Invariants
Invariant_Procedure Is_Invariant_Procedure Subprograms_For_Type
(Has_Inherited_Invariants): New routine along with pragma Inline.
(Has_Own_Invariants): New routine along with pragma Inline.
(Is_Partial_Invariant_Procedure): New routine along with pragma Inline.
(Partial_Invariant_Procedure): New routine.
(Set_Has_Inherited_Invariants): New routine along with pragma Inline.
(Set_Has_Invariants): Removed along with pragma Inline.
(Set_Has_Own_Invariants): New routine along with pragma Inline.
(Set_Is_Partial_Invariant_Procedure): New routine
along with pragma Inline.
(Set_Partial_Invariant_Procedure): New routine.
(Set_Subprograms_For_Type): Update the signature.
(Subprograms_For_Type): Update the signature.
* exp_ch3.adb Remove with and use clauses for Sem_Ch13.
(Build_Array_Invariant_Proc): Removed.
(Build_Record_Invariant_Proc): Removed.
(Freeze_Type): Build the body of the invariant procedure.
(Insert_Component_Invariant_Checks): Removed.
* exp_ch7.adb Add with and use clauses for Sem_Ch6, Sem_Ch13,
and Stringt.
(Build_Invariant_Procedure_Body): New routine.
(Build_Invariant_Procedure_Declaration): New routine.
* exp_ch7.ads (Build_Invariant_Procedure_Body): New routine.
(Build_Invariant_Procedure_Declaration): New routine.
* exp_ch9.adb (Build_Corresponding_Record): Do not propagate
attributes related to invariants to the corresponding record
when building the corresponding record. This is done by
Build_Invariant_Procedure_Declaration.
* exp_util.adb (Make_Invariant_Call): Reimplemented.
* freeze.adb (Freeze_Array_Type): An array type requires an
invariant procedure when its component type has invariants.
(Freeze_Record_Type): A record type requires an invariant
procedure when at least one of its components has an invariant.
* sem_ch3.adb (Analyze_Private_Extension_Declaration): Inherit
invariant-related attributes.
(Analyze_Subtype_Declaration):
Inherit invariant-related attributes.
(Build_Derived_Record_Type): Inherit invariant-related attributes.
(Check_Duplicate_Aspects): Reimplemented.
(Get_Partial_View_Aspect): New routine.
(Process_Full_View): Inherit invariant-related attributes. Reimplement
the check on hidden inheritance of class-wide invariants.
(Remove_Default_Init_Cond_Procedure): Reimplemented.
* sem_ch6.adb (Analyze_Subprogram_Specification): Do not modify
the controlling type for an invariant procedure declaration
or body.
(Is_Invariant_Procedure_Or_Body): New routine.
* sem_ch7.adb (Analyze_Package_Specification): Build the partial
invariant body in order to preanalyze and resolve all invariants
of a private type at the end of the visible declarations. Build
the full invariant body in order to preanalyze and resolve
all invariants of a private type's full view at the end of
the private declarations.
(Preserve_Full_Attributes): Inherit invariant-related attributes.
* sem_ch9.adb (Analyze_Protected_Type_Declaration): Ensure that
aspects are analyzed with the proper view when the protected type
is a completion of a private type. Inherit invariant-related attributes.
(Analyze_Task_Type_Declaration): Ensure that
aspects are analyzed with the proper view when the task type
is a completion of a private type. Inherit invariant-related
attributes.
* sem_ch13.adb Remove with and use clauses for Stringt.
(Build_Invariant_Procedure_Declaration): Removed.
(Build_Invariant_Procedure): Removed.
(Freeze_Entity_Checks): Do not build the body of the invariant
procedure here.
The body is built when the type is frozen in Freeze_Type.
(Inherit_Aspects_At_Freeze_Point): Do not inherit any attributes
related to invariants here because this leads to erroneous
inheritance.
(Replace_Node): Rename to Replace_Type_Ref.
* sem_ch13.ads (Build_Invariant_Procedure_Declaration): Removed.
(Build_Invariant_Procedure): Removed.
* sem_prag.adb Add with and use clauses for Exp_Ch7.
(Analyze_Pragma): Reimplement the analysis of pragma Invariant.
* sem_res.adb (Resolve_Actuals): Emit a specialized error when
the context is an invariant.
* sem_util.adb (Get_Views): New routine.
(Incomplete_Or_Partial_View): Consider generic packages when
examining declarations.
(Inspect_Decls): Consider full type
declarations because they may denote a derivation from a
private type.
(Propagate_Invariant_Attributes): New routine.
* sem_util.ads (Get_Views): New routine.
(Propagate_Invariant_Attributes): New routine.
2016-06-16 Arnaud Charlet <charlet@adacore.com>
* pprint.adb (Expression_Image): Add better handling of UCs,
we don't want to strip them all for clarity.
2016-06-20 Kyrylo Tkachov <kyrylo.tkachov@arm.com>
* exp_util.adb (Safe_Unchecked_Type_Conversion): Use "alignment"

17
gcc/ada/atree.adb
View File

@ -3317,6 +3317,17 @@ package body Atree is
end if;
end Elist26;
function Elist29 (N : Node_Id) return Elist_Id is
pragma Assert (Nkind (N) in N_Entity);
Value : constant Union_Id := Nodes.Table (N + 4).Field11;
begin
if Value = 0 then
return No_Elist;
else
return Elist_Id (Value);
end if;
end Elist29;
function Elist36 (N : Node_Id) return Elist_Id is
pragma Assert (Nkind (N) in N_Entity);
Value : constant Union_Id := Nodes.Table (N + 6).Field6;
@ -6109,6 +6120,12 @@ package body Atree is
Nodes.Table (N + 4).Field8 := Union_Id (Val);
end Set_Elist26;
procedure Set_Elist29 (N : Node_Id; Val : Elist_Id) is
begin
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field11 := Union_Id (Val);
end Set_Elist29;
procedure Set_Elist36 (N : Node_Id; Val : Elist_Id) is
begin
pragma Assert (Nkind (N) in N_Entity);

8
gcc/ada/atree.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- --
@ -1473,6 +1473,9 @@ package Atree is
function Elist26 (N : Node_Id) return Elist_Id;
pragma Inline (Elist26);
function Elist29 (N : Node_Id) return Elist_Id;
pragma Inline (Elist29);
function Elist36 (N : Node_Id) return Elist_Id;
pragma Inline (Elist36);
@ -2836,6 +2839,9 @@ package Atree is
procedure Set_Elist26 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist26);
procedure Set_Elist29 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist29);
procedure Set_Elist36 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist36);

3
gcc/ada/atree.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* 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- *
@ -526,6 +526,7 @@ extern Node_Id Current_Error_Node;
#define Elist24(N) Field24 (N)
#define Elist25(N) Field25 (N)
#define Elist26(N) Field26 (N)
#define Elist29(N) Field29 (N)
#define Elist36(N) Field36 (N)
#define Name1(N) Field1 (N)

411
gcc/ada/einfo.adb
View File

@ -245,7 +245,7 @@ package body Einfo is
-- Underlying_Record_View Node28
-- BIP_Initialization_Call Node29
-- Subprograms_For_Type Node29
-- Subprograms_For_Type Elist29
-- Anonymous_Object Node30
-- Corresponding_Equality Node30
@ -539,7 +539,7 @@ package body Einfo is
-- Has_Pragma_Inline_Always Flag230
-- Renamed_In_Spec Flag231
-- Has_Invariants Flag232
-- Has_Own_Invariants Flag232
-- Has_Pragma_Unmodified Flag233
-- Is_Dispatch_Table_Entity Flag234
-- Is_Trivial_Subprogram Flag235
@ -603,10 +603,11 @@ package body Einfo is
-- Predicates_Ignored Flag288
-- Has_Timing_Event Flag289
-- (unused) Flag290
-- (unused) Flag290 -- ??? flag breaks einfo.h
-- Has_Inherited_Invariants Flag291
-- Is_Partial_Invariant_Procedure Flag292
-- (unused) Flag291
-- (unused) Flag292
-- (unused) Flag293
-- (unused) Flag294
-- (unused) Flag295
@ -614,8 +615,8 @@ package body Einfo is
-- (unused) Flag297
-- (unused) Flag298
-- (unused) Flag299
-- (unused) Flag300
-- (unused) Flag301
-- (unused) Flag302
-- (unused) Flag303
@ -1610,18 +1611,18 @@ package body Einfo is
return Flag133 (Base_Type (Id));
end Has_Inherited_Default_Init_Cond;
function Has_Inherited_Invariants (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
return Flag291 (Id);
end Has_Inherited_Invariants;
function Has_Initial_Value (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Variable or else Is_Formal (Id));
return Flag219 (Id);
end Has_Initial_Value;
function Has_Invariants (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
return Flag232 (Id);
end Has_Invariants;
function Has_Loop_Entry_Attributes (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Loop);
@ -1675,6 +1676,12 @@ package body Einfo is
return Flag110 (Id);
end Has_Out_Or_In_Out_Parameter;
function Has_Own_Invariants (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
return Flag232 (Id);
end Has_Own_Invariants;
function Has_Per_Object_Constraint (Id : E) return B is
begin
return Flag154 (Id);
@ -2388,6 +2395,12 @@ package body Einfo is
return Flag215 (Base_Type (Id));
end Is_Param_Block_Component_Type;
function Is_Partial_Invariant_Procedure (Id : E) return B is
begin
pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
return Flag292 (Id);
end Is_Partial_Invariant_Procedure;
function Is_Potentially_Use_Visible (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
@ -3314,10 +3327,10 @@ package body Einfo is
return Node18 (Id);
end String_Literal_Low_Bound;
function Subprograms_For_Type (Id : E) return E is
function Subprograms_For_Type (Id : E) return L is
begin
pragma Assert (Is_Type (Id) or else Is_Subprogram (Id));
return Node29 (Id);
pragma Assert (Is_Type (Id));
return Elist29 (Id);
end Subprograms_For_Type;
function Subps_Index (Id : E) return U is
@ -4596,18 +4609,18 @@ package body Einfo is
Set_Flag133 (Base_Type (Id), V);
end Set_Has_Inherited_Default_Init_Cond;
procedure Set_Has_Inherited_Invariants (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
Set_Flag291 (Id, V);
end Set_Has_Inherited_Invariants;
procedure Set_Has_Initial_Value (Id : E; V : B := True) is
begin
pragma Assert (Ekind_In (Id, E_Variable, E_Out_Parameter));
Set_Flag219 (Id, V);
end Set_Has_Initial_Value;
procedure Set_Has_Invariants (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
Set_Flag232 (Id, V);
end Set_Has_Invariants;
procedure Set_Has_Loop_Entry_Attributes (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Loop);
@ -4662,6 +4675,12 @@ package body Einfo is
Set_Flag110 (Id, V);
end Set_Has_Out_Or_In_Out_Parameter;
procedure Set_Has_Own_Invariants (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
Set_Flag232 (Id, V);
end Set_Has_Own_Invariants;
procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True) is
begin
Set_Flag154 (Id, V);
@ -5442,6 +5461,12 @@ package body Einfo is
Set_Flag215 (Id, V);
end Set_Is_Param_Block_Component_Type;
procedure Set_Is_Partial_Invariant_Procedure (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Procedure);
Set_Flag292 (Id, V);
end Set_Is_Partial_Invariant_Procedure;
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
@ -5450,7 +5475,7 @@ package body Einfo is
procedure Set_Is_Predicate_Function (Id : E; V : B := True) is
begin
pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
pragma Assert (Ekind (Id) = E_Function);
Set_Flag255 (Id, V);
end Set_Is_Predicate_Function;
@ -6404,10 +6429,10 @@ package body Einfo is
Set_Node18 (Id, V);
end Set_String_Literal_Low_Bound;
procedure Set_Subprograms_For_Type (Id : E; V : E) is
procedure Set_Subprograms_For_Type (Id : E; V : L) is
begin
pragma Assert (Is_Type (Id) or else Is_Subprogram (Id));
Set_Node29 (Id, V);
pragma Assert (Is_Type (Id));
Set_Elist29 (Id, V);
end Set_Subprograms_For_Type;
procedure Set_Subps_Index (Id : E; V : U) is
@ -6945,22 +6970,30 @@ package body Einfo is
---------------------------------
function Default_Init_Cond_Procedure (Id : E) return E is
Subp_Id : Entity_Id;
Subp_Elmt : Elmt_Id;
Subp_Id : Entity_Id;
Subps : Elist_Id;
begin
pragma Assert
(Is_Type (Id)
and then (Has_Default_Init_Cond (Id)
or Has_Inherited_Default_Init_Cond (Id)));
or else Has_Inherited_Default_Init_Cond (Id)));
Subp_Id := Subprograms_For_Type (Base_Type (Id));
while Present (Subp_Id) loop
if Is_Default_Init_Cond_Procedure (Subp_Id) then
return Subp_Id;
end if;
Subps := Subprograms_For_Type (Base_Type (Id));
Subp_Id := Subprograms_For_Type (Subp_Id);
end loop;
if Present (Subps) then
Subp_Elmt := First_Elmt (Subps);
while Present (Subp_Elmt) loop
Subp_Id := Node (Subp_Elmt);
if Is_Default_Init_Cond_Procedure (Subp_Id) then
return Subp_Id;
end if;
Next_Elmt (Subp_Elmt);
end loop;
end if;
return Empty;
end Default_Init_Cond_Procedure;
@ -7370,6 +7403,15 @@ package body Einfo is
return False;
end Has_Interrupt_Handler;
--------------------
-- Has_Invariants --
--------------------
function Has_Invariants (Id : E) return B is
begin
return Has_Own_Invariants (Id) or else Has_Inherited_Invariants (Id);
end Has_Invariants;
--------------------------
-- Has_Non_Limited_View --
--------------------------
@ -7533,26 +7575,29 @@ package body Einfo is
-------------------------
function Invariant_Procedure (Id : E) return E is
S : Entity_Id;
Subp_Elmt : Elmt_Id;
Subp_Id : Entity_Id;
Subps : Elist_Id;
begin
pragma Assert (Is_Type (Id) and then Has_Invariants (Id));
pragma Assert (Is_Type (Id));
if No (Subprograms_For_Type (Id)) then
return Empty;
Subps := Subprograms_For_Type (Id);
else
S := Subprograms_For_Type (Id);
while Present (S) loop
if Is_Invariant_Procedure (S) then
return S;
else
S := Subprograms_For_Type (S);
if Present (Subps) then
Subp_Elmt := First_Elmt (Subps);
while Present (Subp_Elmt) loop
Subp_Id := Node (Subp_Elmt);
if Is_Invariant_Procedure (Subp_Id) then
return Subp_Id;
end if;
end loop;
return Empty;
Next_Elmt (Subp_Elmt);
end loop;
end if;
return Empty;
end Invariant_Procedure;
----------------------
@ -8261,46 +8306,81 @@ package body Einfo is
return Ekind (Id);
end Parameter_Mode;
---------------------------------
-- Partial_Invariant_Procedure --
---------------------------------
function Partial_Invariant_Procedure (Id : E) return E is
Subp_Elmt : Elmt_Id;
Subp_Id : Entity_Id;
Subps : Elist_Id;
begin
pragma Assert (Is_Type (Id));
Subps := Subprograms_For_Type (Id);
if Present (Subps) then
Subp_Elmt := First_Elmt (Subps);
while Present (Subp_Elmt) loop
Subp_Id := Node (Subp_Elmt);
if Is_Partial_Invariant_Procedure (Subp_Id) then
return Subp_Id;
end if;
Next_Elmt (Subp_Elmt);
end loop;
end if;
return Empty;
end Partial_Invariant_Procedure;
------------------------
-- Predicate_Function --
------------------------
function Predicate_Function (Id : E) return E is
S : Entity_Id;
T : Entity_Id;
Subp_Elmt : Elmt_Id;
Subp_Id : Entity_Id;
Subps : Elist_Id;
Typ : Entity_Id;
begin
pragma Assert (Is_Type (Id));
-- If type is private and has a completion, predicate may be defined
-- on the full view.
-- If type is private and has a completion, predicate may be defined on
-- the full view.
if Is_Private_Type (Id)
and then
(not Has_Predicates (Id) or else No (Subprograms_For_Type (Id)))
and then Present (Full_View (Id))
then
T := Full_View (Id);
Typ := Full_View (Id);
else
T := Id;
Typ := Id;
end if;
if No (Subprograms_For_Type (T)) then
return Empty;
Subps := Subprograms_For_Type (Typ);
else
S := Subprograms_For_Type (T);
while Present (S) loop
if Is_Predicate_Function (S) then
return S;
else
S := Subprograms_For_Type (S);
if Present (Subps) then
Subp_Elmt := First_Elmt (Subps);
while Present (Subp_Elmt) loop
Subp_Id := Node (Subp_Elmt);
if Ekind (Subp_Id) = E_Function
and then Is_Predicate_Function (Subp_Id)
then
return Subp_Id;
end if;
end loop;
return Empty;
Next_Elmt (Subp_Elmt);
end loop;
end if;
return Empty;
end Predicate_Function;
--------------------------
@ -8308,36 +8388,46 @@ package body Einfo is
--------------------------
function Predicate_Function_M (Id : E) return E is
S : Entity_Id;
T : Entity_Id;
Subp_Elmt : Elmt_Id;
Subp_Id : Entity_Id;
Subps : Elist_Id;
Typ : Entity_Id;
begin
pragma Assert (Is_Type (Id));
-- If type is private and has a completion, predicate may be defined
-- on the full view.
-- If type is private and has a completion, predicate may be defined on
-- the full view.
if Is_Private_Type (Id)
and then
(not Has_Predicates (Id) or else No (Subprograms_For_Type (Id)))
and then Present (Full_View (Id))
then
Typ := Full_View (Id);
if Is_Private_Type (Id) and then Present (Full_View (Id)) then
T := Full_View (Id);
else
T := Id;
Typ := Id;
end if;
if No (Subprograms_For_Type (T)) then
return Empty;
Subps := Subprograms_For_Type (Typ);
else
S := Subprograms_For_Type (T);
while Present (S) loop
if Is_Predicate_Function_M (S) then
return S;
else
S := Subprograms_For_Type (S);
if Present (Subps) then
Subp_Elmt := First_Elmt (Subps);
while Present (Subp_Elmt) loop
Subp_Id := Node (Subp_Elmt);
if Ekind (Subp_Id) = E_Function
and then Is_Predicate_Function_M (Subp_Id)
then
return Subp_Id;
end if;
end loop;
return Empty;
Next_Elmt (Subp_Elmt);
end loop;
end if;
return Empty;
end Predicate_Function_M;
-------------------------
@ -8563,8 +8653,10 @@ package body Einfo is
-------------------------------------
procedure Set_Default_Init_Cond_Procedure (Id : E; V : E) is
Base_Typ : Entity_Id;
Subp_Id : Entity_Id;
Base_Typ : Entity_Id;
Subp_Elmt : Elmt_Id;
Subp_Id : Entity_Id;
Subps : Elist_Id;
begin
-- Once set, this attribute cannot be reset
@ -8577,21 +8669,29 @@ package body Einfo is
pragma Assert
(Is_Type (Id)
and then (Has_Default_Init_Cond (Id)
or Has_Inherited_Default_Init_Cond (Id)));
or else Has_Inherited_Default_Init_Cond (Id)));
Base_Typ := Base_Type (Id);
Subps := Subprograms_For_Type (Base_Typ);
Subp_Id := Subprograms_For_Type (Base_Typ);
Set_Subprograms_For_Type (Base_Typ, V);
Set_Subprograms_For_Type (V, Subp_Id);
if No (Subps) then
Subps := New_Elmt_List;
Set_Subprograms_For_Type (Base_Typ, Subps);
end if;
-- Check for a duplicate procedure
Subp_Elmt := First_Elmt (Subps);
Prepend_Elmt (V, Subps);
-- Check for a duplicate default initial condition procedure
while Present (Subp_Elmt) loop
Subp_Id := Node (Subp_Elmt);
while Present (Subp_Id) loop
if Is_Default_Init_Cond_Procedure (Subp_Id) then
raise Program_Error;
end if;
Subp_Id := Subprograms_For_Type (Subp_Id);
Next_Elmt (Subp_Elmt);
end loop;
end Set_Default_Init_Cond_Procedure;
@ -8600,46 +8700,105 @@ package body Einfo is
-----------------------------
procedure Set_Invariant_Procedure (Id : E; V : E) is
S : Entity_Id;
Subp_Elmt : Elmt_Id;
Subp_Id : Entity_Id;
Subps : Elist_Id;
begin
pragma Assert (Is_Type (Id) and then Has_Invariants (Id));
pragma Assert (Is_Type (Id));
S := Subprograms_For_Type (Id);
Set_Subprograms_For_Type (Id, V);
Set_Subprograms_For_Type (V, S);
Subps := Subprograms_For_Type (Id);
-- Check for duplicate entry
if No (Subps) then
Subps := New_Elmt_List;
Set_Subprograms_For_Type (Id, Subps);
end if;
while Present (S) loop
if Is_Invariant_Procedure (S) then
Subp_Elmt := First_Elmt (Subps);
Prepend_Elmt (V, Subps);
-- Check for a duplicate invariant procedure
while Present (Subp_Elmt) loop
Subp_Id := Node (Subp_Elmt);
if Is_Invariant_Procedure (Subp_Id) then
raise Program_Error;
else
S := Subprograms_For_Type (S);
end if;
Next_Elmt (Subp_Elmt);
end loop;
end Set_Invariant_Procedure;
-------------------------------------
-- Set_Partial_Invariant_Procedure --
-------------------------------------
procedure Set_Partial_Invariant_Procedure (Id : E; V : E) is
Subp_Elmt : Elmt_Id;
Subp_Id : Entity_Id;
Subps : Elist_Id;
begin
pragma Assert (Is_Type (Id));
Subps := Subprograms_For_Type (Id);
if No (Subps) then
Subps := New_Elmt_List;
Set_Subprograms_For_Type (Id, Subps);
end if;
Subp_Elmt := First_Elmt (Subps);
Prepend_Elmt (V, Subps);
-- Check for a duplicate partial invariant procedure
while Present (Subp_Elmt) loop
Subp_Id := Node (Subp_Elmt);
if Is_Partial_Invariant_Procedure (Subp_Id) then
raise Program_Error;
end if;
Next_Elmt (Subp_Elmt);
end loop;
end Set_Partial_Invariant_Procedure;
----------------------------
-- Set_Predicate_Function --
----------------------------
procedure Set_Predicate_Function (Id : E; V : E) is
S : Entity_Id;
Subp_Elmt : Elmt_Id;
Subp_Id : Entity_Id;
Subps : Elist_Id;
begin
pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
S := Subprograms_For_Type (Id);
Set_Subprograms_For_Type (Id, V);
Set_Subprograms_For_Type (V, S);
Subps := Subprograms_For_Type (Id);
while Present (S) loop
if Is_Predicate_Function (S) then
if No (Subps) then
Subps := New_Elmt_List;
Set_Subprograms_For_Type (Id, Subps);
end if;
Subp_Elmt := First_Elmt (Subps);
Prepend_Elmt (V, Subps);
-- Check for a duplicate predication function
while Present (Subp_Elmt) loop
Subp_Id := Node (Subp_Elmt);
if Ekind (Subp_Id) = E_Function
and then Is_Predicate_Function (Subp_Id)
then
raise Program_Error;
else
S := Subprograms_For_Type (S);
end if;
Next_Elmt (Subp_Elmt);
end loop;
end Set_Predicate_Function;
@ -8648,23 +8807,35 @@ package body Einfo is
------------------------------
procedure Set_Predicate_Function_M (Id : E; V : E) is
S : Entity_Id;
Subp_Elmt : Elmt_Id;
Subp_Id : Entity_Id;
Subps : Elist_Id;
begin
pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
S := Subprograms_For_Type (Id);
Set_Subprograms_For_Type (Id, V);
Set_Subprograms_For_Type (V, S);
Subps := Subprograms_For_Type (Id);
-- Check for duplicates
if No (Subps) then
Subps := New_Elmt_List;
Set_Subprograms_For_Type (Id, Subps);
end if;
while Present (S) loop
if Is_Predicate_Function_M (S) then
Subp_Elmt := First_Elmt (Subps);
Prepend_Elmt (V, Subps);
-- Check for a duplicate predication function
while Present (Subp_Elmt) loop
Subp_Id := Node (Subp_Elmt);
if Ekind (Subp_Id) = E_Function
and then Is_Predicate_Function_M (Subp_Id)
then
raise Program_Error;
else
S := Subprograms_For_Type (S);
end if;
Next_Elmt (Subp_Elmt);
end loop;
end Set_Predicate_Function_M;
@ -8952,8 +9123,8 @@ package body Einfo is
W ("Has_Independent_Components", Flag34 (Id));
W ("Has_Inheritable_Invariants", Flag248 (Id));
W ("Has_Inherited_Default_Init_Cond", Flag133 (Id));
W ("Has_Inherited_Invariants", Flag291 (Id));
W ("Has_Initial_Value", Flag219 (Id));
W ("Has_Invariants", Flag232 (Id));
W ("Has_Loop_Entry_Attributes", Flag260 (Id));
W ("Has_Machine_Radix_Clause", Flag83 (Id));
W ("Has_Master_Entity", Flag21 (Id));
@ -8963,6 +9134,7 @@ package body Einfo is
W ("Has_Non_Standard_Rep", Flag75 (Id));
W ("Has_Out_Or_In_Out_Parameter", Flag110 (Id));
W ("Has_Object_Size_Clause", Flag172 (Id));
W ("Has_Own_Invariants", Flag232 (Id));
W ("Has_Per_Object_Constraint", Flag154 (Id));
W ("Has_Pragma_Controlled", Flag27 (Id));
W ("Has_Pragma_Elaborate_Body", Flag150 (Id));
@ -9086,6 +9258,7 @@ package body Einfo is
W ("Is_Packed", Flag51 (Id));
W ("Is_Packed_Array_Impl_Type", Flag138 (Id));
W ("Is_Param_Block_Component_Type", Flag215 (Id));
W ("Is_Partial_Invariant_Procedure", Flag292 (Id));
W ("Is_Potentially_Use_Visible", Flag9 (Id));
W ("Is_Predicate_Function", Flag255 (Id));
W ("Is_Predicate_Function_M", Flag256 (Id));

140
gcc/ada/einfo.ads
View File

@ -1698,19 +1698,22 @@ package Einfo is
-- usual manner.
-- Has_Inheritable_Invariants (Flag248)
-- Defined in all type entities. Set in private types from which one
-- or more Invariant'Class aspects will be inherited if a another type is
-- derived from the type (i.e. those types which have an Invariant'Class
-- aspect, or which inherit one or more Invariant'Class aspects). Also
-- set in the corresponding full types. Note that it might be the full
-- type which has inheritable invariants, and in this case the flag will
-- also be set in the private type.
-- Defined in all type entities. Set on private types and interface types
-- which define at least one class-wide invariant. Such invariants must
-- be inherited by derived types. The flag is also set on the full view
-- of a private type for completeness.
-- Has_Inherited_Default_Init_Cond (Flag133) [base type only]
-- Defined in all type entities. Set when a derived type inherits pragma
-- Default_Initial_Condition from its parent type. This flag is mutually
-- exclusive with flag Has_Default_Init_Cond.
-- Has_Inherited_Invariants (Flag291)
-- Defined in all type entities. Set on private extensions and derived
-- types which inherit at least on class-wide invariant from a parent or
-- an interface type. The flag is also set on the full view of a private
-- extension for completeness.
-- Has_Initial_Value (Flag219)
-- Defined in entities for variables and out parameters. Set if there
-- is an explicit initial value expression in the declaration of the
@ -1725,15 +1728,10 @@ package Einfo is
-- definition contains at least one procedure to which a pragma
-- Interrupt_Handler applies.
-- Has_Invariants (Flag232)
-- Defined in all type entities and in subprogram entities. Set in
-- private types if an Invariant or Invariant'Class aspect applies to the
-- type, or if the type inherits one or more Invariant'Class aspects.
-- Also set in the corresponding full type. Note: if this flag is set
-- True, then usually the Invariant_Procedure attribute is set once the
-- type is frozen, however this may not be true in some error situations.
-- Note that it might be the full type which has inheritable invariants,
-- and then the flag will also be set in the private type.
-- Has_Invariants (synthesized)
-- Defined in all type entities. True if the type defines at least one
-- invariant of its own or inherits at least one class-wide invariant
-- from a parent type or an interface.
-- Has_Loop_Entry_Attributes (Flag260)
-- Defined in E_Loop entities. Set when the loop is subject to at least
@ -1809,6 +1807,11 @@ package Einfo is
-- families. Set if they have at least one OUT or IN OUT parameter
-- (allowed for functions only in Ada 2012).
-- Has_Own_Invariants (Flag232)
-- Defined in all type entities. Set on any type which defines at least
-- one invariant of its own. The flag is also set on the full view of a
-- private extension or a private type for completeness.
-- Has_Per_Object_Constraint (Flag154)
-- Defined in E_Component entities. Set if the subtype of the component
-- has a per object constraint. Per object constraints result from the
@ -2189,15 +2192,18 @@ package Einfo is
-- ancestors (Ada 2005: AI-251).
-- Invariant_Procedure (synthesized)
-- Defined in types and subtypes. Set for private types if one or more
-- Invariant, or Invariant'Class, or inherited Invariant'Class aspects
-- apply to the type. Points to the entity for a procedure which checks
-- the invariant. This invariant procedure takes a single argument of the
-- given type, and returns if the invariant holds, or raises exception
-- Assertion_Error with an appropriate message if it does not hold. This
-- attribute is defined but always empty for private subtypes. This
-- attribute is also set for the corresponding full type.
--
-- Defined in types and subtypes. Set for private types and their full
-- views if one or more [class-wide] invariants apply to the type, or
-- when the type inherits class-wide invariants from a parent type or
-- an interface, or when the type is an array and its component type is
-- subject to an invariant, or when the type is record and contains a
-- component subject to an invariant (property is recursive). Points to
-- to the entity for a procedure which checks all these invariants. The
-- invariant procedure takes a single argument of the given type, and
-- returns if the invariant holds, or raises exception Assertion_Error
-- with an appropriate message if it does not hold. This attribute is
-- defined but always Empty for private subtypes.
-- Note: the reason this is marked as a synthesized attribute is that the
-- way this is stored is as an element of the Subprograms_For_Type field.
@ -2267,7 +2273,7 @@ package Einfo is
-- applies to both the partial view and the full view.
-- Is_Base_Type (synthesized)
-- Applies to type and subtype entities. True if entity is a base type
-- Applies to type and subtype entities. True if entity is a base type.
-- Is_Bit_Packed_Array (Flag122) [implementation base type only]
-- Defined in all entities. This flag is set for a packed array type that
@ -2325,9 +2331,9 @@ package Einfo is
-- which are not Completely_Hidden (e.g. discriminants of a root type).
-- Is_Composite_Type (synthesized)
-- Applies to all entities, true for all composite types and
-- subtypes. Either Is_Composite_Type or Is_Elementary_Type (but
-- not both) is true of any type.
-- Applies to all entities, true for all composite types and subtypes.
-- Either Is_Composite_Type or Is_Elementary_Type (but not both) is true
-- of any type.
-- Is_Concurrent_Record_Type (Flag20)
-- Defined in record types and subtypes. Set if the type was created
@ -2686,7 +2692,9 @@ package Einfo is
-- Is_Invariant_Procedure (Flag257)
-- Defined in functions and procedures. Set for a generated invariant
-- procedure to identify it easily.
-- procedure which verifies the invariants of both the partial and full
-- views of a private type or private extension as well as any inherited
-- class-wide invariants from parent types or interfaces.
-- Is_Itype (Flag91)
-- Defined in all entities. Set to indicate that a type is an Itype,
@ -2912,6 +2920,11 @@ package Einfo is
-- component of the parameter block record type generated by the compiler
-- for an entry or a select statement. Read by CodePeer.
-- Is_Partial_Invariant_Procedure (Flag292)
-- Defined in functions and procedures. Set for a generated invariant
-- procedure which verifies the invariants of the partial view of a
-- private type or private extension.
-- Is_Potentially_Use_Visible (Flag9)
-- Defined in all entities. Set if entity is potentially use visible,
-- i.e. it is defined in a package that appears in a currently active
@ -3738,6 +3751,18 @@ package Einfo is
-- of a single protected/task type, the references are examined as they
-- must appear only within the type defintion and the corresponding body.
-- Partial_Invariant_Procedure (synthesized)
-- Defined in types and subtypes. Set for private types when one or more
-- [class-wide] type invariants apply to them. Points to the entity for a
-- procedure which checks the invariant. This invariant procedure takes a
-- single argument of the given type, and returns if the invariant holds,
-- or raises exception Assertion_Error with an appropriate message if it
-- does not hold. This attribute is defined but always Empty for private
-- subtypes. This attribute is also set for the corresponding full type.
--
-- Note: the reason this is marked as a synthesized attribute is that the
-- way this is stored is as an element of the Subprograms_For_Type field.
-- Partial_View_Has_Unknown_Discr (Flag280)
-- Present in all types. Set to Indicate that the partial view of a type
-- has unknown discriminants. A default initialization of an object of
@ -4263,15 +4288,14 @@ package Einfo is
-- the low bound of the applicable index constraint if there is one,
-- or a copy of the low bound of the index base type if not.
-- Subprograms_For_Type (Node29)
-- Defined in all type and subprogram entities. This is used to hold
-- a list of subprogram entities for subprograms associated with the
-- type, linked through the Subprograms_For_Type field of the subprogram
-- entity. Basically this is a way of multiplexing the single field to
-- hold more than one entity (since we ran out of space in some type
-- entities). This is currently used for Invariant_Procedure and also
-- for Predicate_Function, and clients will always use the latter two
-- names to access entries in this list.
-- Subprograms_For_Type (Elist29)
-- Defined in all types. The list may contain the entities of the default
-- initial condition procedure, invariant procedure, and the two versions
-- of the predicate function.
--
-- Historical note: This attribute used to be a direct linked list of
-- entities rather than an Elist. The Elist allows greater flexibility
-- in inheritance of subprograms between views of the same type.
-- Subps_Index (Uint24)
-- Present in subprogram entries. Set if the subprogram contains nested
@ -5471,7 +5495,7 @@ package Einfo is
-- Pending_Access_Types (Elist15)
-- Related_Expression (Node24)
-- Current_Use_Clause (Node27)
-- Subprograms_For_Type (Node29)
-- Subprograms_For_Type (Elist29)
-- Derived_Type_Link (Node31)
-- No_Tagged_Streams_Pragma (Node32)
-- Linker_Section_Pragma (Node33)
@ -5495,11 +5519,12 @@ package Einfo is
-- Has_Discriminants (Flag5)
-- Has_Dynamic_Predicate_Aspect (Flag258)
-- Has_Independent_Components (Flag34) (base type only)
-- Has_Inheritable_Invariants (Flag248)
-- Has_Inheritable_Invariants (Flag248) (base type only)
-- Has_Inherited_Default_Init_Cond (Flag133) (base type only)
-- Has_Invariants (Flag232)
-- Has_Inherited_Invariants (Flag291) (base type only)
-- Has_Non_Standard_Rep (Flag75) (base type only)
-- Has_Object_Size_Clause (Flag172)
-- Has_Own_Invariants (Flag232) (base type only)
-- Has_Pragma_Preelab_Init (Flag221)
-- Has_Pragma_Unreferenced_Objects (Flag212)
-- Has_Predicates (Flag250)
@ -5553,11 +5578,13 @@ package Einfo is
-- Alignment_Clause (synth)
-- Base_Type (synth)
-- Default_Init_Cond_Procedure (synth)
-- Has_Invariants (synth)
-- Implementation_Base_Type (synth)
-- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
-- Is_Atomic_Or_VFA (synth)
-- Is_Controlled_Active (synth)
-- Partial_Invariant_Procedure (synth)
-- Predicate_Function (synth)
-- Predicate_Function_M (synth)
-- Root_Type (synth)
@ -5921,7 +5948,6 @@ package Einfo is
-- Overridden_Operation (Node26)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Extra_Formals (Node28)
-- Subprograms_For_Type (Node29)
-- Corresponding_Equality (Node30) (implicit /= only)
-- Thunk_Entity (Node31) (thunk case only)
-- Corresponding_Procedure (Node32) (generate C code only)
@ -5942,7 +5968,6 @@ package Einfo is
-- Has_Completion (Flag26)
-- Has_Controlling_Result (Flag98)
-- Has_Expanded_Contract (Flag240) (non-generic case only)
-- Has_Invariants (Flag232)
-- Has_Master_Entity (Flag21)
-- Has_Missing_Return (Flag142)
-- Has_Nested_Block_With_Handler (Flag101)
@ -5952,6 +5977,7 @@ package Einfo is
-- Is_Abstract_Subprogram (Flag19) (non-generic case only)
-- Is_Called (Flag102) (non-generic case only)
-- Is_Constructor (Flag76)
-- Is_Default_Init_Cond_Procedure (Flag132) (non-generic case only)
-- Is_Discrim_SO_Function (Flag176)
-- Is_Discriminant_Check_Function (Flag264)
-- Is_Eliminated (Flag124)
@ -5962,6 +5988,7 @@ package Einfo is
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Invariant_Procedure (Flag257) (non-generic case only)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Partial_Invariant_Procedure (Flag292) (non-generic case only)
-- Is_Predicate_Function (Flag255) (non-generic case only)
-- Is_Predicate_Function_M (Flag256) (non-generic case only)
-- Is_Primitive (Flag218)
@ -6094,13 +6121,11 @@ package Einfo is
-- Last_Entity (Node20)
-- Subps_Index (Uint24)
-- Overridden_Operation (Node26)
-- Subprograms_For_Type (Node29)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35)
-- SPARK_Pragma (Node40)
-- Default_Expressions_Processed (Flag108)
-- Has_Invariants (Flag232)
-- Has_Nested_Subprogram (Flag282)
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Machine_Code_Subprogram (Flag137)
@ -6254,7 +6279,6 @@ package Einfo is
-- Discard_Names (Flag88)
-- Has_Completion (Flag26)
-- Has_Expanded_Contract (Flag240) (non-generic case only)
-- Has_Invariants (Flag232)
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
-- Has_Nested_Subprogram (Flag282)
@ -6273,6 +6297,7 @@ package Einfo is
-- Is_Invariant_Procedure (Flag257) (non-generic case only)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Null_Init_Proc (Flag178)
-- Is_Partial_Invariant_Procedure (Flag292) (non-generic case only)
-- Is_Predicate_Function (Flag255) (non-generic case only)
-- Is_Predicate_Function_M (Flag256) (non-generic case only)
-- Is_Primitive (Flag218)
@ -6918,6 +6943,7 @@ package Einfo is
function Has_Independent_Components (Id : E) return B;
function Has_Inheritable_Invariants (Id : E) return B;
function Has_Inherited_Default_Init_Cond (Id : E) return B;
function Has_Inherited_Invariants (Id : E) return B;
function Has_Initial_Value (Id : E) return B;
function Has_Interrupt_Handler (Id : E) return B;
function Has_Invariants (Id : E) return B;
@ -6930,6 +6956,7 @@ package Einfo is
function Has_Non_Standard_Rep (Id : E) return B;
function Has_Object_Size_Clause (Id : E) return B;
function Has_Out_Or_In_Out_Parameter (Id : E) return B;
function Has_Own_Invariants (Id : E) return B;
function Has_Per_Object_Constraint (Id : E) return B;
function Has_Pragma_Controlled (Id : E) return B;
function Has_Pragma_Elaborate_Body (Id : E) return B;
@ -7058,6 +7085,7 @@ package Einfo is
function Is_Packed_Array_Impl_Type (Id : E) return B;
function Is_Potentially_Use_Visible (Id : E) return B;
function Is_Param_Block_Component_Type (Id : E) return B;
function Is_Partial_Invariant_Procedure (Id : E) return B;
function Is_Predicate_Function (Id : E) return B;
function Is_Predicate_Function_M (Id : E) return B;
function Is_Preelaborated (Id : E) return B;
@ -7208,7 +7236,7 @@ package Einfo is
function Strict_Alignment (Id : E) return B;
function String_Literal_Length (Id : E) return U;
function String_Literal_Low_Bound (Id : E) return N;
function Subprograms_For_Type (Id : E) return E;
function Subprograms_For_Type (Id : E) return L;
function Subps_Index (Id : E) return U;
function Suppress_Elaboration_Warnings (Id : E) return B;
function Suppress_Initialization (Id : E) return B;
@ -7589,8 +7617,8 @@ package Einfo is
procedure Set_Has_Independent_Components (Id : E; V : B := True);
procedure Set_Has_Inheritable_Invariants (Id : E; V : B := True);
procedure Set_Has_Inherited_Default_Init_Cond (Id : E; V : B := True);
procedure Set_Has_Inherited_Invariants (Id : E; V : B := True);
procedure Set_Has_Initial_Value (Id : E; V : B := True);
procedure Set_Has_Invariants (Id : E; V : B := True);
procedure Set_Has_Loop_Entry_Attributes (Id : E; V : B := True);
procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True);
procedure Set_Has_Master_Entity (Id : E; V : B := True);
@ -7600,6 +7628,7 @@ package Einfo is
procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True);
procedure Set_Has_Object_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Out_Or_In_Out_Parameter (Id : E; V : B := True);
procedure Set_Has_Own_Invariants (Id : E; V : B := True);
procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True);
procedure Set_Has_Pragma_Controlled (Id : E; V : B := True);
procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True);
@ -7732,6 +7761,7 @@ package Einfo is
procedure Set_Is_Packed (Id : E; V : B := True);
procedure Set_Is_Packed_Array_Impl_Type (Id : E; V : B := True);
procedure Set_Is_Param_Block_Component_Type (Id : E; V : B := True);
procedure Set_Is_Partial_Invariant_Procedure (Id : E; V : B := True);
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True);
procedure Set_Is_Predicate_Function (Id : E; V : B := True);
procedure Set_Is_Predicate_Function_M (Id : E; V : B := True);
@ -7882,7 +7912,7 @@ package Einfo is
procedure Set_Strict_Alignment (Id : E; V : B := True);
procedure Set_String_Literal_Length (Id : E; V : U);
procedure Set_String_Literal_Low_Bound (Id : E; V : N);
procedure Set_Subprograms_For_Type (Id : E; V : E);
procedure Set_Subprograms_For_Type (Id : E; V : L);
procedure Set_Subps_Index (Id : E; V : U);
procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True);
procedure Set_Suppress_Initialization (Id : E; V : B := True);
@ -7911,11 +7941,13 @@ package Einfo is
function Default_Init_Cond_Procedure (Id : E) return E;
function Invariant_Procedure (Id : E) return E;
function Partial_Invariant_Procedure (Id : E) return E;
function Predicate_Function (Id : E) return E;
function Predicate_Function_M (Id : E) return E;
procedure Set_Default_Init_Cond_Procedure (Id : E; V : E);
procedure Set_Invariant_Procedure (Id : E; V : E);
procedure Set_Partial_Invariant_Procedure (Id : E; V : E);
procedure Set_Predicate_Function (Id : E; V : E);
procedure Set_Predicate_Function_M (Id : E; V : E);
@ -8374,8 +8406,8 @@ package Einfo is
pragma Inline (Has_Independent_Components);
pragma Inline (Has_Inheritable_Invariants);
pragma Inline (Has_Inherited_Default_Init_Cond);
pragma Inline (Has_Inherited_Invariants);
pragma Inline (Has_Initial_Value);
pragma Inline (Has_Invariants);
pragma Inline (Has_Loop_Entry_Attributes);
pragma Inline (Has_Machine_Radix_Clause);
pragma Inline (Has_Master_Entity);
@ -8385,6 +8417,7 @@ package Einfo is
pragma Inline (Has_Non_Standard_Rep);
pragma Inline (Has_Object_Size_Clause);
pragma Inline (Has_Out_Or_In_Out_Parameter);
pragma Inline (Has_Own_Invariants);
pragma Inline (Has_Per_Object_Constraint);
pragma Inline (Has_Pragma_Controlled);
pragma Inline (Has_Pragma_Elaborate_Body);
@ -8550,6 +8583,7 @@ package Einfo is
pragma Inline (Is_Packed);
pragma Inline (Is_Packed_Array_Impl_Type);
pragma Inline (Is_Param_Block_Component_Type);
pragma Inline (Is_Partial_Invariant_Procedure);
pragma Inline (Is_Potentially_Use_Visible);
pragma Inline (Is_Predicate_Function);
pragma Inline (Is_Predicate_Function_M);
@ -8884,8 +8918,8 @@ package Einfo is
pragma Inline (Set_Has_Independent_Components);
pragma Inline (Set_Has_Inheritable_Invariants);
pragma Inline (Set_Has_Inherited_Default_Init_Cond);
pragma Inline (Set_Has_Inherited_Invariants);
pragma Inline (Set_Has_Initial_Value);
pragma Inline (Set_Has_Invariants);
pragma Inline (Set_Has_Loop_Entry_Attributes);
pragma Inline (Set_Has_Machine_Radix_Clause);
pragma Inline (Set_Has_Master_Entity);
@ -8895,6 +8929,7 @@ package Einfo is
pragma Inline (Set_Has_Non_Standard_Rep);
pragma Inline (Set_Has_Object_Size_Clause);
pragma Inline (Set_Has_Out_Or_In_Out_Parameter);
pragma Inline (Set_Has_Own_Invariants);
pragma Inline (Set_Has_Per_Object_Constraint);
pragma Inline (Set_Has_Pragma_Controlled);
pragma Inline (Set_Has_Pragma_Elaborate_Body);
@ -9026,6 +9061,7 @@ package Einfo is
pragma Inline (Set_Is_Packed);
pragma Inline (Set_Is_Packed_Array_Impl_Type);
pragma Inline (Set_Is_Param_Block_Component_Type);
pragma Inline (Set_Is_Partial_Invariant_Procedure);
pragma Inline (Set_Is_Potentially_Use_Visible);
pragma Inline (Set_Is_Predicate_Function);
pragma Inline (Set_Is_Predicate_Function_M);

515
gcc/ada/exp_ch3.adb
View File

@ -59,7 +59,6 @@ with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
@ -92,22 +91,6 @@ package body Exp_Ch3 is
-- used for attachment of any actions required in its construction.
-- It also supplies the source location used for the procedure.
function Build_Array_Invariant_Proc
(A_Type : Entity_Id;
Nod : Node_Id) return Node_Id;
-- If the component of type of array type has invariants, build procedure
-- that checks invariant on all components of the array. Ada 2012 specifies
-- that an invariant on some type T must be applied to in-out parameters
-- and return values that include a part of type T. If the array type has
-- an otherwise specified invariant, the component check procedure is
-- called from within the user-specified invariant. Otherwise this becomes
-- the invariant procedure for the array type.
function Build_Record_Invariant_Proc
(R_Type : Entity_Id;
Nod : Node_Id) return Node_Id;
-- Ditto for record types.
function Build_Discriminant_Formals
(Rec_Id : Entity_Id;
Use_Dl : Boolean) return List_Id;
@ -200,14 +183,6 @@ package body Exp_Ch3 is
-- Treat user-defined stream operations as renaming_as_body if the
-- subprogram they rename is not frozen when the type is frozen.
procedure Insert_Component_Invariant_Checks
(N : Node_Id;
Typ : Entity_Id;
Proc : Node_Id);
-- If a composite type has invariants and also has components with defined
-- invariants. the component invariant procedure is inserted into the user-
-- defined invariant procedure and added to the checks to be performed.
procedure Initialization_Warning (E : Entity_Id);
-- If static elaboration of the package is requested, indicate
-- when a type does meet the conditions for static initialization. If
@ -794,138 +769,6 @@ package body Exp_Ch3 is
end if;
end Build_Array_Init_Proc;
--------------------------------
-- Build_Array_Invariant_Proc --
--------------------------------
function Build_Array_Invariant_Proc
(A_Type : Entity_Id;
Nod : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
Object_Name : constant Name_Id := New_Internal_Name ('I');
-- Name for argument of invariant procedure
Object_Entity : constant Node_Id :=
Make_Defining_Identifier (Loc, Object_Name);
-- The procedure declaration entity for the argument
Body_Stmts : List_Id;
Index_List : List_Id;
Proc_Id : Entity_Id;
Proc_Body : Node_Id;
function Build_Component_Invariant_Call return Node_Id;
-- Create one statement to verify invariant on one array component,
-- designated by a full set of indexes.
function Check_One_Dimension (N : Int) return List_Id;
-- Create loop to check on one dimension of the array. The single
-- statement in the loop body checks the inner dimensions if any, or
-- else a single component. This procedure is called recursively, with
-- N being the dimension to be initialized. A call with N greater than
-- the number of dimensions generates the component initialization
-- and terminates the recursion.
------------------------------------
-- Build_Component_Invariant_Call --
------------------------------------
function Build_Component_Invariant_Call return Node_Id is
Comp : Node_Id;
begin
Comp :=
Make_Indexed_Component (Loc,
Prefix => New_Occurrence_Of (Object_Entity, Loc),
Expressions => Index_List);
return
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(Invariant_Procedure (Component_Type (A_Type)), Loc),
Parameter_Associations => New_List (Comp));
end Build_Component_Invariant_Call;
-------------------------
-- Check_One_Dimension --
-------------------------
function Check_One_Dimension (N : Int) return List_Id is
Index : Entity_Id;
begin
-- If all dimensions dealt with, we simply check invariant of the
-- component.
if N > Number_Dimensions (A_Type) then
return New_List (Build_Component_Invariant_Call);
-- Else generate one loop and recurse
else
Index :=
Make_Defining_Identifier (Loc, New_External_Name ('J', N));
Append (New_Occurrence_Of (Index, Loc), Index_List);
return New_List (
Make_Implicit_Loop_Statement (Nod,
Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => Index,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Object_Entity, Loc),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, N))))),
Statements => Check_One_Dimension (N + 1)));
end if;
end Check_One_Dimension;
-- Start of processing for Build_Array_Invariant_Proc
begin
Index_List := New_List;
Proc_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (A_Type), "CInvariant"));
Body_Stmts := Check_One_Dimension (1);
Proc_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc_Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Object_Entity,
Parameter_Type => New_Occurrence_Of (A_Type, Loc)))),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Body_Stmts));
Set_Ekind (Proc_Id, E_Procedure);
Set_Is_Public (Proc_Id, Is_Public (A_Type));
Set_Is_Internal (Proc_Id);
Set_Has_Completion (Proc_Id);
if not Debug_Generated_Code then
Set_Debug_Info_Off (Proc_Id);
end if;
return Proc_Body;
end Build_Array_Invariant_Proc;
--------------------------------
-- Build_Discr_Checking_Funcs --
--------------------------------
@ -3671,242 +3514,6 @@ package body Exp_Ch3 is
end if;
end Build_Record_Init_Proc;
--------------------------------
-- Build_Record_Invariant_Proc --
--------------------------------
function Build_Record_Invariant_Proc
(R_Type : Entity_Id;
Nod : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
Object_Name : constant Name_Id := New_Internal_Name ('I');
-- Name for argument of invariant procedure
Object_Entity : constant Node_Id :=
Make_Defining_Identifier (Loc, Object_Name);
-- The procedure declaration entity for the argument
Invariant_Found : Boolean;
-- Set if any component needs an invariant check.
Proc_Id : Entity_Id;
Proc_Body : Node_Id;
Stmts : List_Id;
Type_Def : Node_Id;
function Build_Invariant_Checks (Comp_List : Node_Id) return List_Id;
-- Recursive procedure that generates a list of checks for components
-- that need it, and recurses through variant parts when present.
function Build_Component_Invariant_Call
(Comp : Entity_Id) return Node_Id;
-- Build call to invariant procedure for a record component
------------------------------------
-- Build_Component_Invariant_Call --
------------------------------------
function Build_Component_Invariant_Call
(Comp : Entity_Id) return Node_Id
is
Call : Node_Id;
Proc : Entity_Id;
Sel_Comp : Node_Id;
Typ : Entity_Id;
begin
Typ := Etype (Comp);
Sel_Comp :=
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Object_Entity, Loc),
Selector_Name => New_Occurrence_Of (Comp, Loc));
if Is_Access_Type (Typ) then
-- If the access component designates a type with an invariant,
-- the check applies to the designated object. The access type
-- itself may have an invariant, in which case it applies to the
-- access value directly.
-- Note: we are assuming that invariants will not occur on both
-- the access type and the type that it designates. This is not
-- really justified but it is hard to imagine that this case will
-- ever cause trouble ???
if not (Has_Invariants (Typ)) then
Sel_Comp := Make_Explicit_Dereference (Loc, Sel_Comp);
Typ := Designated_Type (Typ);
end if;
end if;
-- The aspect is type-specific, so retrieve it from the base type
Proc := Invariant_Procedure (Base_Type (Typ));
if Has_Null_Body (Proc) then
return Make_Null_Statement (Loc);
end if;
Invariant_Found := True;
Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Proc, Loc),
Parameter_Associations => New_List (Sel_Comp));
if Is_Access_Type (Etype (Comp)) then
Call :=
Make_If_Statement (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd => Make_Null (Loc),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (Object_Entity, Loc),
Selector_Name => New_Occurrence_Of (Comp, Loc))),
Then_Statements => New_List (Call));
end if;
return Call;
end Build_Component_Invariant_Call;
----------------------------
-- Build_Invariant_Checks --
----------------------------
function Build_Invariant_Checks (Comp_List : Node_Id) return List_Id is
Decl : Node_Id;
Id : Entity_Id;
Stmts : List_Id;
begin
Stmts := New_List;
Decl := First_Non_Pragma (Component_Items (Comp_List));
while Present (Decl) loop
if Nkind (Decl) = N_Component_Declaration then
Id := Defining_Identifier (Decl);
if Has_Invariants (Etype (Id))
and then In_Open_Scopes (Scope (R_Type))
then
if Has_Unchecked_Union (R_Type) then
Error_Msg_NE
("invariants cannot be checked on components of "
& "unchecked_union type&?", Decl, R_Type);
return Empty_List;
else
Append_To (Stmts, Build_Component_Invariant_Call (Id));
end if;
elsif Is_Access_Type (Etype (Id))
and then not Is_Access_Constant (Etype (Id))
and then Has_Invariants (Designated_Type (Etype (Id)))
and then In_Open_Scopes (Scope (Designated_Type (Etype (Id))))
then
Append_To (Stmts, Build_Component_Invariant_Call (Id));
end if;
end if;
Next (Decl);
end loop;
if Present (Variant_Part (Comp_List)) then
declare
Variant_Alts : constant List_Id := New_List;
Var_Loc : Source_Ptr;
Variant : Node_Id;
Variant_Stmts : List_Id;
begin
Variant :=
First_Non_Pragma (Variants (Variant_Part (Comp_List)));
while Present (Variant) loop
Variant_Stmts :=
Build_Invariant_Checks (Component_List (Variant));
Var_Loc := Sloc (Variant);
Append_To (Variant_Alts,
Make_Case_Statement_Alternative (Var_Loc,
Discrete_Choices =>
New_Copy_List (Discrete_Choices (Variant)),
Statements => Variant_Stmts));
Next_Non_Pragma (Variant);
end loop;
-- The expression in the case statement is the reference to
-- the discriminant of the target object.
Append_To (Stmts,
Make_Case_Statement (Var_Loc,
Expression =>
Make_Selected_Component (Var_Loc,
Prefix => New_Occurrence_Of (Object_Entity, Var_Loc),
Selector_Name => New_Occurrence_Of
(Entity
(Name (Variant_Part (Comp_List))), Var_Loc)),
Alternatives => Variant_Alts));
end;
end if;
return Stmts;
end Build_Invariant_Checks;
-- Start of processing for Build_Record_Invariant_Proc
begin
Invariant_Found := False;
Type_Def := Type_Definition (Parent (R_Type));
if Nkind (Type_Def) = N_Record_Definition
and then not Null_Present (Type_Def)
then
Stmts := Build_Invariant_Checks (Component_List (Type_Def));
else
return Empty;
end if;
if not Invariant_Found then
return Empty;
end if;
-- The name of the invariant procedure reflects the fact that the
-- checks correspond to invariants on the component types. The
-- record type itself may have invariants that will create a separate
-- procedure whose name carries the Invariant suffix.
Proc_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (R_Type), "CInvariant"));
Proc_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc_Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Object_Entity,
Parameter_Type => New_Occurrence_Of (R_Type, Loc)))),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts));
Set_Ekind (Proc_Id, E_Procedure);
Set_Is_Public (Proc_Id, Is_Public (R_Type));
Set_Is_Internal (Proc_Id);
Set_Has_Completion (Proc_Id);
return Proc_Body;
-- Insert_After (Nod, Proc_Body);
-- Analyze (Proc_Body);
end Build_Record_Invariant_Proc;
----------------------------
-- Build_Slice_Assignment --
----------------------------
@ -4680,21 +4287,6 @@ package body Exp_Ch3 is
Build_Array_Init_Proc (Base, N);
end if;
if Has_Invariants (Component_Type (Base))
and then Typ = Base
and then In_Open_Scopes (Scope (Component_Type (Base)))
then
-- Generate component invariant checking procedure. This is only
-- relevant if the array type is within the scope of the component
-- type. Otherwise an array object can only be built using the public
-- subprograms for the component type, and calls to those will have
-- invariant checks. The invariant procedure is only generated for
-- a base type, not a subtype.
Insert_Component_Invariant_Checks
(N, Base, Build_Array_Invariant_Proc (Base, N));
end if;
Ghost_Mode := Save_Ghost_Mode;
end Expand_Freeze_Array_Type;
@ -5551,24 +5143,6 @@ package body Exp_Ch3 is
end;
end if;
-- Check whether individual components have a defined invariant, and add
-- the corresponding component invariant checks.
-- Do not create an invariant procedure for some internally generated
-- subtypes, in particular those created for objects of a class-wide
-- type. Such types may have components to which invariant apply, but
-- the corresponding checks will be applied when an object of the parent
-- type is constructed.
-- Such objects will show up in a class-wide postcondition, and the
-- invariant will be checked, if necessary, upon return from the
-- enclosing subprogram.
if not Is_Class_Wide_Equivalent_Type (Typ) then
Insert_Component_Invariant_Checks
(N, Typ, Build_Record_Invariant_Proc (Typ, N));
end if;
Ghost_Mode := Save_Ghost_Mode;
end Expand_Freeze_Record_Type;
@ -7476,11 +7050,11 @@ package body Exp_Ch3 is
elsif Ekind_In (Def_Id, E_Access_Type, E_General_Access_Type) then
declare
Loc : constant Source_Ptr := Sloc (N);
Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
Pool_Object : Entity_Id;
Loc : constant Source_Ptr := Sloc (N);
Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
Freeze_Action_Typ : Entity_Id;
Pool_Object : Entity_Id;
begin
-- Case 1
@ -7500,8 +7074,8 @@ package body Exp_Ch3 is
elsif Has_Storage_Size_Clause (Def_Id) then
declare
DT_Size : Node_Id;
DT_Align : Node_Id;
DT_Size : Node_Id;
begin
-- For unconstrained composite types we give a size of zero
@ -7746,6 +7320,16 @@ package body Exp_Ch3 is
Process_Pending_Access_Types (Def_Id);
Freeze_Stream_Operations (N, Def_Id);
-- Generate the [spec and] body of the invariant procedure tasked with
-- the runtime verification of all invariants that pertain to the type.
-- This includes invariants on the partial and full view, inherited
-- class-wide invariants from parent types or interfaces, and invariants
-- on array elements or record components.
if Has_Invariants (Def_Id) then
Build_Invariant_Procedure_Body (Def_Id);
end if;
Ghost_Mode := Save_Ghost_Mode;
return Result;
@ -8164,77 +7748,6 @@ package body Exp_Ch3 is
return Is_RTU (S1, System) or else Is_RTU (S1, Ada);
end In_Runtime;
---------------------------------------
-- Insert_Component_Invariant_Checks --
---------------------------------------
procedure Insert_Component_Invariant_Checks
(N : Node_Id;
Typ : Entity_Id;
Proc : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Typ);
Proc_Id : Entity_Id;
begin
if Present (Proc) then
Proc_Id := Defining_Entity (Proc);
if not Has_Invariants (Typ) then
Set_Has_Invariants (Typ);
Set_Is_Invariant_Procedure (Proc_Id);
Set_Invariant_Procedure (Typ, Proc_Id);
Insert_After (N, Proc);
Analyze (Proc);
else
-- Find already created invariant subprogram, insert body of
-- component invariant proc in its body, and add call after
-- other checks.
declare
Bod : Node_Id;
Inv_Id : constant Entity_Id := Invariant_Procedure (Typ);
Call : constant Node_Id :=
Make_Procedure_Call_Statement (Sloc (N),
Name => New_Occurrence_Of (Proc_Id, Loc),
Parameter_Associations =>
New_List
(New_Occurrence_Of (First_Formal (Inv_Id), Loc)));
begin
-- The invariant body has not been analyzed yet, so we do a
-- sequential search forward, and retrieve it by name.
Bod := Next (N);
while Present (Bod) loop
exit when Nkind (Bod) = N_Subprogram_Body
and then Chars (Defining_Entity (Bod)) = Chars (Inv_Id);
Next (Bod);
end loop;
-- If the body is not found, it is the case of an invariant
-- appearing on a full declaration in a private part, in
-- which case the type has been frozen but the invariant
-- procedure for the composite type not created yet. Create
-- body now.
if No (Bod) then
Build_Invariant_Procedure (Typ, Parent (Current_Scope));
Bod := Unit_Declaration_Node
(Corresponding_Body (Unit_Declaration_Node (Inv_Id)));
end if;
Append_To (Declarations (Bod), Proc);
Append_To (Statements (Handled_Statement_Sequence (Bod)), Call);
Analyze (Proc);
Analyze (Call);
end;
end if;
end if;
end Insert_Component_Invariant_Checks;
----------------------------
-- Initialization_Warning --
----------------------------

1515
gcc/ada/exp_ch7.adb
View File

File diff suppressed because it is too large Load Diff

19
gcc/ada/exp_ch7.ads
View File

@ -118,9 +118,24 @@ package Exp_Ch7 is
-- finalization master must be analyzed. Insertion_Node is the insertion
-- point before which the master is to be inserted.
procedure Build_Invariant_Procedure_Body
(Typ : Entity_Id;
Partial_Invariant : Boolean := False);
-- Create the body of the procedure which verifies the invariants of type
-- Typ at runtime. Flag Partial_Invariant should be set when Typ denotes a
-- private type, otherwise it is assumed that Typ denotes the full view of
-- a private type.
procedure Build_Invariant_Procedure_Declaration
(Typ : Entity_Id;
Partial_Invariant : Boolean := False);
-- Create the declaration of the procedure which verifies the invariants of
-- type Typ at runtime. Flag Partial_Invariant should be set when building
-- the invariant procedure for a private type.
procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id);
-- Build one controlling procedure when a late body overrides one of
-- the controlling operations.
-- Build one controlling procedure when a late body overrides one of the
-- controlling operations.
procedure Build_Object_Declarations
(Data : out Finalization_Exception_Data;

6
gcc/ada/exp_ch9.adb
View File

@ -1526,12 +1526,6 @@ package body Exp_Ch9 is
Set_Stored_Constraint (Rec_Ent, No_Elist);
Cdecls := New_List;
-- Propagate type invariants to the corresponding record type
Set_Has_Invariants (Rec_Ent, Has_Invariants (Ctyp));
Set_Has_Inheritable_Invariants (Rec_Ent,
Has_Inheritable_Invariants (Ctyp));
-- Use discriminals to create list of discriminants for record, and
-- create new discriminals for use in default expressions, etc. It is
-- worth noting that a task discriminant gives rise to 5 entities;

25
gcc/ada/exp_util.adb
View File

@ -6405,30 +6405,19 @@ package body Exp_Util is
-------------------------
function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Expr);
Typ : Entity_Id;
Loc : constant Source_Ptr := Sloc (Expr);
Typ : constant Entity_Id := Base_Type (Etype (Expr));
Proc_Id : Entity_Id;
begin
Typ := Etype (Expr);
pragma Assert (Has_Invariants (Typ));
-- Subtypes may be subject to invariants coming from their respective
-- base types. The subtype may be fully or partially private.
if Ekind_In (Typ, E_Array_Subtype,
E_Private_Subtype,
E_Record_Subtype,
E_Record_Subtype_With_Private)
then
Typ := Base_Type (Typ);
end if;
pragma Assert
(Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
Proc_Id := Invariant_Procedure (Typ);
pragma Assert (Present (Proc_Id));
return
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
Name => New_Occurrence_Of (Proc_Id, Loc),
Parameter_Associations => New_List (Relocate_Node (Expr)));
end Make_Invariant_Call;

41
gcc/ada/freeze.adb
View File

@ -2290,6 +2290,25 @@ package body Freeze is
Set_Has_Unchecked_Union (Arr);
end if;
-- The array type requires its own invariant procedure in order to
-- verify the component invariant over all elements.
if Has_Invariants (Component_Type (Arr))
or else
(Is_Access_Type (Component_Type (Arr))
and then Has_Invariants
(Designated_Type (Component_Type (Arr))))
then
Set_Has_Own_Invariants (Arr);
-- The array type is an implementation base type. Propagate the
-- same property to the first subtype.
if Is_Itype (Arr) then
Set_Has_Own_Invariants (First_Subtype (Arr));
end if;
end if;
-- Warn for pragma Pack overriding foreign convention
if Has_Foreign_Convention (Ctyp)
@ -4165,7 +4184,8 @@ package body Freeze is
Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result);
end if;
-- Check for controlled components and unchecked unions.
-- Check for controlled components, unchecked unions, and type
-- invariants.
Comp := First_Component (Rec);
while Present (Comp) loop
@ -4194,6 +4214,22 @@ package body Freeze is
Set_Has_Unchecked_Union (Rec);
end if;
-- The record type requires its own invariant procedure in
-- order to verify the invariant of each individual component.
-- Do not consider internal components such as _parent because
-- parent class-wide invariants are always inherited.
if Comes_From_Source (Comp)
and then
(Has_Invariants (Etype (Comp))
or else
(Is_Access_Type (Etype (Comp))
and then Has_Invariants
(Designated_Type (Etype (Comp)))))
then
Set_Has_Own_Invariants (Rec);
end if;
-- Scan component declaration for likely misuses of current
-- instance, either in a constraint or a default expression.
@ -5224,8 +5260,7 @@ package body Freeze is
and then not Is_Tagged_Type (E)
then
Error_Msg_NE
("Type_Invariant''Class cannot be specified for &",
Prag, E);
("Type_Invariant''Class cannot be specified for &", Prag, E);
Error_Msg_N
("\can only be specified for a tagged type", Prag);
end if;

19
gcc/ada/pprint.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2008-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2008-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- --
@ -542,13 +542,28 @@ package body Pprint is
when N_Parameter_Association =>
return Expr_Name (Explicit_Actual_Parameter (Expr));
when N_Type_Conversion | N_Unchecked_Type_Conversion =>
when N_Type_Conversion =>
-- Most conversions are not very interesting (used inside
-- expanded checks to convert to larger ranges), so skip them.
return Expr_Name (Expression (Expr));
when N_Unchecked_Type_Conversion =>
-- Only keep the type conversion in complex cases
if not Is_Scalar_Type (Etype (Expr))
or else not Is_Scalar_Type (Etype (Expression (Expr)))
or else Is_Modular_Integer_Type (Etype (Expr))
/= Is_Modular_Integer_Type (Etype (Expression (Expr)))
then
return Expr_Name (Subtype_Mark (Expr)) &
"(" & Expr_Name (Expression (Expr)) & ")";
else
return Expr_Name (Expression (Expr));
end if;
when N_Indexed_Component =>
if Take_Prefix then
return

663
gcc/ada/sem_ch13.adb
View File

@ -62,7 +62,6 @@ with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Stringt; use Stringt;
with Targparm; use Targparm;
with Ttypes; use Ttypes;
with Tbuild; use Tbuild;
@ -8080,576 +8079,6 @@ package body Sem_Ch13 is
return Prag;
end Build_Export_Import_Pragma;
-------------------------------------------
-- Build_Invariant_Procedure_Declaration --
-------------------------------------------
function Build_Invariant_Procedure_Declaration
(Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
Decl : Node_Id;
Obj_Id : Entity_Id;
SId : Entity_Id;
Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
begin
-- Check for duplicate definitions
if Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)) then
return Empty;
end if;
-- The related type may be subject to pragma Ghost. Set the mode now to
-- ensure that the invariant procedure is properly marked as Ghost.
Set_Ghost_Mode_From_Entity (Typ);
SId :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "Invariant"));
Set_Has_Invariants (Typ);
Set_Ekind (SId, E_Procedure);
Set_Etype (SId, Standard_Void_Type);
Set_Is_Invariant_Procedure (SId);
Set_Invariant_Procedure (Typ, SId);
-- Source Coverage Obligations might be attached to the invariant
-- expression this procedure evaluates, and we need debug info to be
-- able to assess the coverage achieved by evaluations.
if Opt.Generate_SCO then
Set_Needs_Debug_Info (SId);
end if;
-- Mark the invariant procedure explicitly as Ghost because it does not
-- come from source.
if Ghost_Mode > None then
Set_Is_Ghost_Entity (SId);
end if;
Obj_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
Set_Etype (Obj_Id, Typ);
Decl :=
Make_Subprogram_Declaration (Loc,
Make_Procedure_Specification (Loc,
Defining_Unit_Name => SId,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Obj_Id,
Parameter_Type => New_Occurrence_Of (Typ, Loc)))));
Ghost_Mode := Save_Ghost_Mode;
return Decl;
end Build_Invariant_Procedure_Declaration;
-------------------------------
-- Build_Invariant_Procedure --
-------------------------------
-- The procedure that is constructed here has the form
-- procedure typInvariant (Ixxx : typ) is
-- begin
-- pragma Check (Invariant, exp, "failed invariant from xxx");
-- pragma Check (Invariant, exp, "failed invariant from xxx");
-- ...
-- pragma Check (Invariant, exp, "failed inherited invariant from xxx");
-- ...
-- end typInvariant;
procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is
procedure Add_Invariants
(T : Entity_Id;
Obj_Id : Entity_Id;
Stmts : in out List_Id;
Inherit : Boolean);
-- Appends statements to Stmts for any invariants in the rep item chain
-- of the given type. If Inherit is False, then we only process entries
-- on the chain for the type Typ. If Inherit is True, then we ignore any
-- Invariant aspects, but we process all Invariant'Class aspects, adding
-- "inherited" to the exception message and generating an informational
-- message about the inheritance of an invariant.
--------------------
-- Add_Invariants --
--------------------
procedure Add_Invariants
(T : Entity_Id;
Obj_Id : Entity_Id;
Stmts : in out List_Id;
Inherit : Boolean)
is
procedure Add_Invariant (Prag : Node_Id);
-- Create a runtime check to verify the exression of invariant pragma
-- Prag. All generated code is added to list Stmts.
-------------------
-- Add_Invariant --
-------------------
procedure Add_Invariant (Prag : Node_Id) is
procedure Replace_Type_Reference (N : Node_Id);
-- Replace a single occurrence N of the subtype name with a
-- reference to the formal of the predicate function. N can be an
-- identifier referencing the subtype, or a selected component,
-- representing an appropriately qualified occurrence of the
-- subtype name.
procedure Replace_Type_References is
new Replace_Type_References_Generic (Replace_Type_Reference);
-- Traverse an expression replacing all occurrences of the subtype
-- name with appropriate references to the formal of the predicate
-- function. Note that we must ensure that the type and entity
-- information is properly set in the replacement node, since we
-- will do a Preanalyze call of this expression without proper
-- visibility of the procedure argument.
----------------------------
-- Replace_Type_Reference --
----------------------------
-- Note: See comments in Add_Predicates.Replace_Type_Reference
-- regarding handling of Sloc and Comes_From_Source.
procedure Replace_Type_Reference (N : Node_Id) is
Nloc : constant Source_Ptr := Sloc (N);
begin
-- Add semantic information to node to be rewritten, for ASIS
-- navigation needs.
if Nkind (N) = N_Identifier then
Set_Entity (N, T);
Set_Etype (N, T);
elsif Nkind (N) = N_Selected_Component then
Analyze (Prefix (N));
Set_Entity (Selector_Name (N), T);
Set_Etype (Selector_Name (N), T);
end if;
-- Invariant'Class, replace with T'Class (obj)
if Class_Present (Prag) then
-- In ASIS mode, an inherited item is already analyzed,
-- and the replacement has been done, so do not repeat
-- the transformation to prevent a malformed tree.
if ASIS_Mode
and then Nkind (Parent (N)) = N_Attribute_Reference
and then Attribute_Name (Parent (N)) = Name_Class
then
null;
else
Rewrite (N,
Make_Type_Conversion (Nloc,
Subtype_Mark =>
Make_Attribute_Reference (Nloc,
Prefix => New_Occurrence_Of (T, Nloc),
Attribute_Name => Name_Class),
Expression =>
Make_Identifier (Nloc, Chars (Obj_Id))));
Set_Entity (Expression (N), Obj_Id);
Set_Etype (Expression (N), Typ);
end if;
-- Invariant, replace with obj
else
Rewrite (N, Make_Identifier (Nloc, Chars (Obj_Id)));
Set_Entity (N, Obj_Id);
Set_Etype (N, Typ);
end if;
Set_Comes_From_Source (N, True);
end Replace_Type_Reference;
-- Local variables
Asp : constant Node_Id := Corresponding_Aspect (Prag);
Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
Ploc : constant Source_Ptr := Sloc (Prag);
Arg1 : Node_Id;
Arg2 : Node_Id;
Arg3 : Node_Id;
Assoc : List_Id;
Expr : Node_Id;
Str : String_Id;
-- Start of processing for Add_Invariant
begin
-- Extract the arguments of the invariant pragma
Arg1 := First (Pragma_Argument_Associations (Prag));
Arg2 := Next (Arg1);
Arg3 := Next (Arg2);
Arg1 := Get_Pragma_Arg (Arg1);
Arg2 := Get_Pragma_Arg (Arg2);
-- The caller requests processing of all Invariant'Class pragmas,
-- but the current pragma does not fall in this category. Return
-- as there is nothing left to do.
if Inherit then
if not Class_Present (Prag) then
return;
end if;
-- Otherwise the pragma must apply to the current type
elsif Entity (Arg1) /= T then
return;
end if;
Expr := New_Copy_Tree (Arg2);
-- Replace all occurrences of the type's name with references to
-- the formal parameter of the invariant procedure.
Replace_Type_References (Expr, T);
-- If the invariant pragma comes from an aspect, replace the saved
-- expression because we need the subtype references replaced for
-- the calls to Preanalyze_Spec_Expression in Check_Aspect_At_xxx
-- routines. This is not done for interited class-wide invariants
-- because the original pragma of the parent type must remain
-- unchanged.
if not Inherit and then Present (Asp) then
Set_Entity (Identifier (Asp), New_Copy_Tree (Expr));
end if;
-- Preanalyze the invariant expression to capture the visibility
-- of the proper package part. In general the expression is not
-- fully analyzed until the body of the invariant procedure is
-- analyzed at the end of the private part, but that yields the
-- wrong visibility.
-- Historical note: we used to set N as the parent, but a package
-- specification as the parent of an expression is bizarre.
Set_Parent (Expr, Parent (Arg2));
Preanalyze_Assert_Expression (Expr, Any_Boolean);
-- Both modifications performed below are not done for inherited
-- class-wide invariants because the origial aspect/pragma of the
-- parent type must remain unchanged.
if not Inherit then
-- A class-wide invariant may be inherited in a separate unit,
-- where the corresponding expression cannot be resolved by
-- visibility, because it refers to a local function. Propagate
-- semantic information to the original representation item, to
-- be used when an invariant procedure for a derived type is
-- constructed.
-- ??? Unclear how to handle class-wide invariants that are not
-- function calls.
if Class_Present (Prag)
and then Nkind (Expr) = N_Function_Call
and then Nkind (Arg2) = N_Indexed_Component
then
Rewrite (Arg2,
Make_Function_Call (Ploc,
Name =>
New_Occurrence_Of (Entity (Name (Expr)), Ploc),
Parameter_Associations => Expressions (Arg2)));
end if;
-- In ASIS mode, even if assertions are not enabled, we must
-- analyze the original expression in the aspect specification
-- because it is part of the original tree.
if ASIS_Mode and then Present (Asp) then
declare
Asp_Expr : constant Node_Id := Expression (Asp);
begin
Replace_Type_References (Asp_Expr, T);
Preanalyze_Assert_Expression (Asp_Expr, Any_Boolean);
end;
end if;
end if;
-- An ignored invariant must not generate a runtime check. Add a
-- null statement to ensure that the invariant procedure does get
-- a completing body.
if No (Stmts) then
Stmts := Empty_List;
end if;
if Is_Ignored (Prag) then
Append_To (Stmts, Make_Null_Statement (Ploc));
-- Otherwise the invariant is checked. Build a Check pragma to
-- verify the expression at runtime.
else
Assoc := New_List (
Make_Pragma_Argument_Association (Ploc,
Expression => Make_Identifier (Ploc, Nam)),
Make_Pragma_Argument_Association (Ploc,
Expression => Expr));
-- Handle the String argument (if any)
if Present (Arg3) then
Str := Strval (Get_Pragma_Arg (Arg3));
-- When inheriting an invariant, modify the message from
-- "failed invariant" to "failed inherited invariant".
if Inherit then
String_To_Name_Buffer (Str);
if Name_Buffer (1 .. 16) = "failed invariant" then
Insert_Str_In_Name_Buffer ("inherited ", 8);
Str := String_From_Name_Buffer;
end if;
end if;
Append_To (Assoc,
Make_Pragma_Argument_Association (Ploc,
Expression => Make_String_Literal (Ploc, Str)));
end if;
-- Generate:
-- pragma Check (Nam, Expr, Str);
Append_To (Stmts,
Make_Pragma (Ploc,
Pragma_Identifier =>
Make_Identifier (Ploc, Name_Check),
Pragma_Argument_Associations => Assoc));
end if;
-- Output an info message when inheriting an invariant and the
-- listing option is enabled.
if Inherit and Opt.List_Inherited_Aspects then
Error_Msg_Sloc := Sloc (Prag);
Error_Msg_N
("info: & inherits `Invariant''Class` aspect from #?L?", Typ);
end if;
end Add_Invariant;
-- Local variables
Ritem : Node_Id;
-- Start of processing for Add_Invariants
begin
Ritem := First_Rep_Item (T);
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
and then Pragma_Name (Ritem) = Name_Invariant
then
Add_Invariant (Ritem);
end if;
Next_Rep_Item (Ritem);
end loop;
end Add_Invariants;
-- Local variables
Loc : constant Source_Ptr := Sloc (Typ);
Priv_Decls : constant List_Id := Private_Declarations (N);
Vis_Decls : constant List_Id := Visible_Declarations (N);
Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
PBody : Node_Id;
PDecl : Node_Id;
SId : Entity_Id;
Spec : Node_Id;
Stmts : List_Id;
Obj_Id : Node_Id;
-- The entity of the formal for the procedure
-- Start of processing for Build_Invariant_Procedure
begin
-- The related type may be subject to pragma Ghost. Set the mode now to
-- ensure that the invariant procedure is properly marked as Ghost.
Set_Ghost_Mode_From_Entity (Typ);
Stmts := No_List;
PDecl := Empty;
PBody := Empty;
SId := Empty;
-- If the aspect specification exists for some view of the type, the
-- declaration for the procedure has been created.
if Has_Invariants (Typ) then
SId := Invariant_Procedure (Typ);
end if;
-- If the body is already present, nothing to do. This will occur when
-- the type is already frozen, which is the case when the invariant
-- appears in a private part, and the freezing takes place before the
-- final pass over full declarations.
-- See Exp_Ch3.Insert_Component_Invariant_Checks for details.
if Present (SId) then
PDecl := Unit_Declaration_Node (SId);
if Present (PDecl)
and then Nkind (PDecl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (PDecl))
then
Ghost_Mode := Save_Ghost_Mode;
return;
end if;
else
PDecl := Build_Invariant_Procedure_Declaration (Typ);
end if;
-- Recover formal of procedure, for use in the calls to invariant
-- functions (including inherited ones).
Obj_Id :=
Defining_Identifier
(First (Parameter_Specifications (Specification (PDecl))));
-- Add invariants for the current type
Add_Invariants
(T => Typ,
Obj_Id => Obj_Id,
Stmts => Stmts,
Inherit => False);
-- Add invariants for parent types
declare
Current_Typ : Entity_Id;
Parent_Typ : Entity_Id;
begin
Current_Typ := Typ;
loop
Parent_Typ := Etype (Current_Typ);
if Is_Private_Type (Parent_Typ)
and then Present (Full_View (Base_Type (Parent_Typ)))
then
Parent_Typ := Full_View (Base_Type (Parent_Typ));
end if;
exit when Parent_Typ = Current_Typ;
Current_Typ := Parent_Typ;
Add_Invariants
(T => Current_Typ,
Obj_Id => Obj_Id,
Stmts => Stmts,
Inherit => True);
end loop;
end;
-- Add invariants of progenitors
if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then
declare
Ifaces_List : Elist_Id;
AI : Elmt_Id;
Iface : Entity_Id;
begin
Collect_Interfaces (Typ, Ifaces_List);
AI := First_Elmt (Ifaces_List);
while Present (AI) loop
Iface := Node (AI);
if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
Add_Invariants
(T => Iface,
Obj_Id => Obj_Id,
Stmts => Stmts,
Inherit => True);
end if;
Next_Elmt (AI);
end loop;
end;
end if;
-- Build the procedure if we generated at least one Check pragma
if Stmts /= No_List then
Spec := Copy_Separate_Tree (Specification (PDecl));
PBody :=
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts));
-- The processing of an invariant pragma immediately generates the
-- invariant procedure spec, inserts it into the tree, and analyzes
-- it. If the spec has not been analyzed, then the invariant pragma
-- is being inherited and requires manual insertion and analysis.
if not Analyzed (PDecl) then
Append_To (Vis_Decls, PDecl);
Analyze (PDecl);
end if;
-- The invariant procedure body is inserted at the end of the private
-- declarations.
if Present (Priv_Decls) then
Append_To (Priv_Decls, PBody);
-- If the invariant appears on the full view of a private type,
-- then the analysis of the private part is already completed.
-- Manually analyze the new body in this case, otherwise wait
-- for the analysis of the private declarations to process the
-- body.
if In_Private_Part (Current_Scope) then
Analyze (PBody);
end if;
-- Otherwise there are no private declarations. This is either an
-- error or the related type is a private extension, in which case
-- it does not need a completion in a private part. Insert the body
-- at the end of the visible declarations and analyze immediately
-- because the related type is about to be frozen.
else
Append_To (Vis_Decls, PBody);
Analyze (PBody);
end if;
end if;
Ghost_Mode := Save_Ghost_Mode;
end Build_Invariant_Procedure;
-------------------------------
-- Build_Predicate_Functions --
-------------------------------
@ -11159,9 +10588,7 @@ package body Sem_Ch13 is
end if;
end Hide_Non_Overridden_Subprograms;
---------------------
-- Local variables --
---------------------
-- Local variables
E : constant Entity_Id := Entity (N);
@ -11324,14 +10751,14 @@ package body Sem_Ch13 is
Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
-- If we have a type with predicates, build predicate function. This
-- is not needed in the generic case, and is not needed within TSS
-- subprograms and other predefined primitives.
-- If we have a type with predicates, build predicate function. This is
-- not needed in the generic case, nor within TSS subprograms and other
-- predefined primitives.
if Non_Generic_Case
and then Is_Type (E)
and then Has_Predicates (E)
if Is_Type (E)
and then Non_Generic_Case
and then not Within_Internal_Subprogram
and then Has_Predicates (E)
then
Build_Predicate_Functions (E, N);
end if;
@ -11830,30 +11257,6 @@ package body Sem_Ch13 is
Set_Discard_Names (Typ);
end if;
-- Invariants
if not Has_Rep_Item (Typ, Name_Invariant, False)
and then Has_Rep_Item (Typ, Name_Invariant)
and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
(Get_Rep_Item (Typ, Name_Invariant))
then
Set_Has_Invariants (Typ);
if Class_Present (Get_Rep_Item (Typ, Name_Invariant)) then
Set_Has_Inheritable_Invariants (Typ);
end if;
-- If we have a subtype with invariants, whose base type does not have
-- invariants, copy these invariants to the base type. This happens for
-- the case of implicit base types created for scalar and array types.
elsif Has_Invariants (Typ)
and then not Has_Invariants (Base_Type (Typ))
then
Set_Has_Invariants (Base_Type (Typ));
Set_Invariant_Procedure (Base_Type (Typ), Invariant_Procedure (Typ));
end if;
-- Volatile
if not Has_Rep_Item (Typ, Name_Volatile, False)
@ -12636,7 +12039,7 @@ package body Sem_Ch13 is
if Has_Discriminants (E) then
Push_Scope (E);
-- Make discriminants visible for type declarations and protected
-- Make the discriminants visible for type declarations and protected
-- type declarations, not for subtype declarations (RM 13.1.1 (12/3))
if Nkind (Parent (E)) /= N_Subtype_Declaration then
@ -12891,18 +12294,15 @@ package body Sem_Ch13 is
procedure Replace_Type_References_Generic (N : Node_Id; T : Entity_Id) is
TName : constant Name_Id := Chars (T);
function Replace_Node (N : Node_Id) return Traverse_Result;
function Replace_Type_Ref (N : Node_Id) return Traverse_Result;
-- Processes a single node in the traversal procedure below, checking
-- if node N should be replaced, and if so, doing the replacement.
procedure Replace_Type_Refs is new Traverse_Proc (Replace_Node);
-- This instantiation provides the body of Replace_Type_References
----------------------
-- Replace_Type_Ref --
----------------------
------------------
-- Replace_Node --
------------------
function Replace_Node (N : Node_Id) return Traverse_Result is
function Replace_Type_Ref (N : Node_Id) return Traverse_Result is
S : Entity_Id;
P : Node_Id;
@ -12911,10 +12311,10 @@ package body Sem_Ch13 is
if Nkind (N) = N_Identifier then
-- If not the type name, check whether it is a reference to
-- some other type, which must be frozen before the predicate
-- function is analyzed, i.e. before the freeze node of the
-- type to which the predicate applies.
-- If not the type name, check whether it is a reference to some
-- other type, which must be frozen before the predicate function
-- is analyzed, i.e. before the freeze node of the type to which
-- the predicate applies.
if Chars (N) /= TName then
if Present (Current_Entity (N))
@ -12932,13 +12332,13 @@ package body Sem_Ch13 is
return Skip;
end if;
-- Case of selected component (which is what a qualification
-- looks like in the unanalyzed tree, which is what we have.
-- Case of selected component (which is what a qualification looks
-- like in the unanalyzed tree, which is what we have.
elsif Nkind (N) = N_Selected_Component then
-- If selector name is not our type, keeping going (we might
-- still have an occurrence of the type in the prefix).
-- If selector name is not our type, keeping going (we might still
-- have an occurrence of the type in the prefix).
if Nkind (Selector_Name (N)) /= N_Identifier
or else Chars (Selector_Name (N)) /= TName
@ -12959,8 +12359,8 @@ package body Sem_Ch13 is
return OK;
end if;
-- Do replace if prefix is an identifier matching the
-- scope that we are currently looking at.
-- Do replace if prefix is an identifier matching the scope
-- that we are currently looking at.
if Nkind (P) = N_Identifier
and then Chars (P) = Chars (S)
@ -12969,9 +12369,9 @@ package body Sem_Ch13 is
return Skip;
end if;
-- Go check scope above us if prefix is itself of the
-- form of a selected component, whose selector matches
-- the scope we are currently looking at.
-- Go check scope above us if prefix is itself of the form
-- of a selected component, whose selector matches the scope
-- we are currently looking at.
if Nkind (P) = N_Selected_Component
and then Nkind (Selector_Name (P)) = N_Identifier
@ -12995,7 +12395,9 @@ package body Sem_Ch13 is
else
return OK;
end if;
end Replace_Node;
end Replace_Type_Ref;
procedure Replace_Type_Refs is new Traverse_Proc (Replace_Type_Ref);
begin
Replace_Type_Refs (N);
@ -13057,17 +12459,18 @@ package body Sem_Ch13 is
Expr := Expression (ASN);
case A_Id is
-- For now we only deal with aspects that do not generate
-- subprograms, or that may mention current instances of
-- types. These will require special handling (???TBD).
when Aspect_Predicate |
Aspect_Predicate_Failure |
Aspect_Invariant =>
Aspect_Invariant =>
null;
when Aspect_Static_Predicate |
Aspect_Dynamic_Predicate =>
when Aspect_Dynamic_Predicate |
Aspect_Static_Predicate =>
-- Build predicate function specification and preanalyze
-- expression after type replacement.

21
gcc/ada/sem_ch13.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- --
@ -53,25 +53,6 @@ package Sem_Ch13 is
-- order is specified and there is at least one component clause. Adjusts
-- component positions according to either Ada 95 or Ada 2005 (AI-133).
function Build_Invariant_Procedure_Declaration
(Typ : Entity_Id) return Node_Id;
-- If a type declaration has a specified invariant aspect, build the
-- declaration for the procedure at once, so that calls to it can be
-- generated before the body of the invariant procedure is built. This
-- is needed in the presence of public expression functions that return
-- the type in question.
procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id);
-- Typ is a private type with invariants (indicated by Has_Invariants being
-- set for Typ, indicating the presence of pragma Invariant entries on the
-- rep chain, note that Invariant aspects have already been converted to
-- pragma Invariant), then this procedure builds the spec and body for the
-- corresponding Invariant procedure, inserting them at appropriate points
-- in the package specification N. Invariant_Procedure is set for Typ. Note
-- that this procedure is called at the end of processing the declarations
-- in the visible part (i.e. the right point for visibility analysis of
-- the invariant expression).
procedure Check_Record_Representation_Clause (N : Node_Id);
-- This procedure completes the analysis of a record representation clause
-- N. It is called at freeze time after adjustment of component clause bit

342
gcc/ada/sem_ch3.adb
View File

@ -4475,6 +4475,8 @@ package body Sem_Ch3 is
procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
Indic : constant Node_Id := Subtype_Indication (N);
T : constant Entity_Id := Defining_Identifier (N);
Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
Parent_Base : Entity_Id;
Parent_Type : Entity_Id;
@ -4540,8 +4542,8 @@ package body Sem_Ch3 is
elsif Is_Concurrent_Type (Parent_Type) then
Error_Msg_N
("parent type of a private extension cannot be "
& "a synchronized tagged type (RM 3.9.1 (3/1))", N);
("parent type of a private extension cannot be a synchronized "
& "tagged type (RM 3.9.1 (3/1))", N);
Set_Etype (T, Any_Type);
Set_Ekind (T, E_Limited_Private_Type);
@ -4562,7 +4564,6 @@ package body Sem_Ch3 is
if (not Is_Package_Or_Generic_Package (Current_Scope)
and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
or else In_Private_Part (Current_Scope)
then
Error_Msg_N ("invalid context for private extension", N);
end if;
@ -4589,13 +4590,26 @@ package body Sem_Ch3 is
Build_Derived_Record_Type (N, Parent_Type, T);
-- Propagate inherited invariant information. The new type has
-- invariants, if the parent type has inheritable invariants,
-- and these invariants can in turn be inherited.
-- A private extension inherits any class-wide invariants coming from a
-- parent type or an interface. Note that the invariant procedure of the
-- parent type should not be inherited because the private extension may
-- define invariants of its own.
if Has_Inheritable_Invariants (Parent_Type) then
Set_Has_Inheritable_Invariants (T);
Set_Has_Invariants (T);
Set_Has_Inherited_Invariants (T);
elsif Present (Interfaces (T)) then
Iface_Elmt := First_Elmt (Interfaces (T));
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
if Has_Inheritable_Invariants (Iface) then
Set_Has_Inherited_Invariants (T);
exit;
end if;
Next_Elmt (Iface_Elmt);
end loop;
end if;
-- Ada 2005 (AI-443): Synchronized private extension or a rewritten
@ -4617,33 +4631,29 @@ package body Sem_Ch3 is
(not Is_Interface (Parent_Type)
or else not Is_Synchronized_Interface (Parent_Type))
then
Error_Msg_NE ("parent type of & must be tagged limited " &
"or synchronized", N, T);
Error_Msg_NE
("parent type of & must be tagged limited or synchronized",
N, T);
end if;
-- The progenitors (if any) must be limited or synchronized
-- interfaces.
if Present (Interfaces (T)) then
declare
Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
Iface_Elmt := First_Elmt (Interfaces (T));
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
begin
Iface_Elmt := First_Elmt (Interfaces (T));
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
if not Is_Limited_Interface (Iface)
and then not Is_Synchronized_Interface (Iface)
then
Error_Msg_NE
("progenitor & must be limited or synchronized",
N, Iface);
end if;
if not Is_Limited_Interface (Iface)
and then not Is_Synchronized_Interface (Iface)
then
Error_Msg_NE ("progenitor & must be limited " &
"or synchronized", N, Iface);
end if;
Next_Elmt (Iface_Elmt);
end loop;
end;
Next_Elmt (Iface_Elmt);
end loop;
end if;
-- Regular derived extension, the parent must be a limited or
@ -5154,10 +5164,9 @@ package body Sem_Ch3 is
if Has_Predicates (T)
and then Present (Predicate_Function (T))
and then
((In_Instance and then not Comes_From_Source (N))
or else No (Aspect_Specifications (N)))
and then
((In_Instance and then not Comes_From_Source (N))
or else No (Aspect_Specifications (N)))
then
Set_Subprograms_For_Type (Id, Subprograms_For_Type (T));
@ -5167,6 +5176,11 @@ package body Sem_Ch3 is
end if;
end if;
-- Propagate invariant-related attributes from the base type to the
-- subtype.
Propagate_Invariant_Attributes (Id, From_Typ => Base_Type (T));
-- Remaining processing depends on characteristics of base type
T := Etype (Id);
@ -5228,9 +5242,9 @@ package body Sem_Ch3 is
if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
if Is_Scalar_Type (Etype (Id))
and then Scalar_Range (Id) /=
Scalar_Range (Etype (Subtype_Mark
(Subtype_Indication (N))))
and then Scalar_Range (Id) /=
Scalar_Range
(Etype (Subtype_Mark (Subtype_Indication (N))))
then
Apply_Range_Check
(Scalar_Range (Id),
@ -5301,14 +5315,6 @@ package body Sem_Ch3 is
end if;
end if;
-- A type invariant applies to any subtype in its scope, in particular
-- to a generic actual.
if Has_Invariants (T) and then In_Open_Scopes (Scope (T)) then
Set_Has_Invariants (Id);
Set_Invariant_Procedure (Id, Invariant_Procedure (T));
end if;
Set_Optimize_Alignment_Flags (Id);
Check_Eliminated (Id);
@ -5633,16 +5639,20 @@ package body Sem_Ch3 is
-- Complete setup of implicit base type
Set_First_Index (Implicit_Base, First_Index (T));
Set_Component_Type (Implicit_Base, Element_Type);
Set_Component_Size (Implicit_Base, Uint_0);
Set_Component_Type (Implicit_Base, Element_Type);
Set_Finalize_Storage_Only
(Implicit_Base,
Finalize_Storage_Only (Element_Type));
Set_First_Index (Implicit_Base, First_Index (T));
Set_Has_Controlled_Component
(Implicit_Base,
Has_Controlled_Component (Element_Type)
or else Is_Controlled_Active (Element_Type));
Set_Packed_Array_Impl_Type
(Implicit_Base, Empty);
Propagate_Concurrent_Flags (Implicit_Base, Element_Type);
Set_Component_Size (Implicit_Base, Uint_0);
Set_Packed_Array_Impl_Type (Implicit_Base, Empty);
Set_Has_Controlled_Component (Implicit_Base,
Has_Controlled_Component (Element_Type)
or else Is_Controlled_Active (Element_Type));
Set_Finalize_Storage_Only (Implicit_Base,
Finalize_Storage_Only (Element_Type));
-- Inherit the "ghostness" from the constrained array type
@ -8786,31 +8796,35 @@ package body Sem_Ch3 is
end;
end if;
-- Propagate inherited invariant information of parents
-- and progenitors
-- A derived type inherits any class-wide invariants coming
-- from a parent type or an interface. Note that the invariant
-- procedure of the parent type should not be inherited because
-- the derived type may define invariants of its own.
if Ada_Version >= Ada_2012
and then not Is_Interface (Derived_Type)
then
if Has_Inheritable_Invariants (Parent_Type) then
Set_Has_Invariants (Derived_Type);
Set_Has_Inheritable_Invariants (Derived_Type);
if Has_Inherited_Invariants (Parent_Type)
or else Has_Inheritable_Invariants (Parent_Type)
then
Set_Has_Inherited_Invariants (Derived_Type);
elsif not Is_Empty_Elmt_List (Ifaces_List) then
declare
AI : Elmt_Id;
Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
begin
AI := First_Elmt (Ifaces_List);
while Present (AI) loop
if Has_Inheritable_Invariants (Node (AI)) then
Set_Has_Invariants (Derived_Type);
Set_Has_Inheritable_Invariants (Derived_Type);
Iface_Elmt := First_Elmt (Ifaces_List);
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
if Has_Inheritable_Invariants (Iface) then
Set_Has_Inherited_Invariants (Derived_Type);
exit;
end if;
Next_Elmt (AI);
Next_Elmt (Iface_Elmt);
end loop;
end;
end if;
@ -16427,63 +16441,93 @@ package body Sem_Ch3 is
function Find_Type_Name (N : Node_Id) return Entity_Id is
Id : constant Entity_Id := Defining_Identifier (N);
Prev : Entity_Id;
New_Id : Entity_Id;
Prev : Entity_Id;
Prev_Par : Node_Id;
procedure Check_Duplicate_Aspects;
-- Check that aspects specified in a completion have not been specified
-- already in the partial view. Type_Invariant and others can be
-- specified on either view but never on both.
-- already in the partial view.
procedure Tag_Mismatch;
-- Diagnose a tagged partial view whose full view is untagged.
-- We post the message on the full view, with a reference to
-- the previous partial view. The partial view can be private
-- or incomplete, and these are handled in a different manner,
-- so we determine the position of the error message from the
-- respective slocs of both.
-- Diagnose a tagged partial view whose full view is untagged. We post
-- the message on the full view, with a reference to the previous
-- partial view. The partial view can be private or incomplete, and
-- these are handled in a different manner, so we determine the position
-- of the error message from the respective slocs of both.
-----------------------------
-- Check_Duplicate_Aspects --
-----------------------------
procedure Check_Duplicate_Aspects is
Prev_Aspects : constant List_Id := Aspect_Specifications (Prev_Par);
Full_Aspects : constant List_Id := Aspect_Specifications (N);
F_Spec, P_Spec : Node_Id;
function Get_Partial_View_Aspect (Asp : Node_Id) return Node_Id;
-- Return the corresponding aspect of the partial view which matches
-- the aspect id of Asp. Return Empty is no such aspect exists.
-----------------------------
-- Get_Partial_View_Aspect --
-----------------------------
function Get_Partial_View_Aspect (Asp : Node_Id) return Node_Id is
Asp_Id : constant Aspect_Id := Get_Aspect_Id (Asp);
Prev_Asps : constant List_Id := Aspect_Specifications (Prev_Par);
Prev_Asp : Node_Id;
begin
if Present (Prev_Asps) then
Prev_Asp := First (Prev_Asps);
while Present (Prev_Asp) loop
if Get_Aspect_Id (Prev_Asp) = Asp_Id then
return Prev_Asp;
end if;
Next (Prev_Asp);
end loop;
end if;
return Empty;
end Get_Partial_View_Aspect;
-- Local variables
Full_Asps : constant List_Id := Aspect_Specifications (N);
Full_Asp : Node_Id;
Part_Asp : Node_Id;
-- Start of processing for Check_Duplicate_Aspects
begin
if Present (Full_Aspects) then
F_Spec := First (Full_Aspects);
while Present (F_Spec) loop
if Present (Prev_Aspects) then
P_Spec := First (Prev_Aspects);
while Present (P_Spec) loop
if Chars (Identifier (P_Spec)) =
Chars (Identifier (F_Spec))
then
Error_Msg_N
("aspect already specified in private declaration",
F_Spec);
Remove (F_Spec);
return;
end if;
if Present (Full_Asps) then
Full_Asp := First (Full_Asps);
while Present (Full_Asp) loop
Part_Asp := Get_Partial_View_Aspect (Full_Asp);
Next (P_Spec);
end loop;
-- An aspect and its class-wide counterpart are two distinct
-- aspects and may apply to both views of an entity.
if Present (Part_Asp)
and then Class_Present (Part_Asp) = Class_Present (Full_Asp)
then
Error_Msg_N
("aspect already specified in private declaration",
Full_Asp);
Remove (Full_Asp);
return;
end if;
if Has_Discriminants (Prev)
and then not Has_Unknown_Discriminants (Prev)
and then Chars (Identifier (F_Spec)) =
Name_Implicit_Dereference
and then Get_Aspect_Id (Full_Asp) =
Aspect_Implicit_Dereference
then
Error_Msg_N ("cannot specify aspect " &
"if partial view has known discriminants", F_Spec);
Error_Msg_N
("cannot specify aspect if partial view has known "
& "discriminants", Full_Asp);
end if;
Next (F_Spec);
Next (Full_Asp);
end loop;
end if;
end Check_Duplicate_Aspects;
@ -19573,8 +19617,8 @@ package body Sem_Ch3 is
and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent)
then
Error_Msg_N
("parent of full type must descend from parent"
& " of private extension", Full_Indic);
("parent of full type must descend from parent of private "
& "extension", Full_Indic);
-- First check a formal restriction, and then proceed with checking
-- Ada rules. Since the formal restriction is not a serious error, we
@ -19628,9 +19672,9 @@ package body Sem_Ch3 is
while Present (Priv_Discr) and then Present (Full_Discr) loop
if Original_Record_Component (Priv_Discr) =
Original_Record_Component (Full_Discr)
or else
Corresponding_Discriminant (Priv_Discr) =
Corresponding_Discriminant (Full_Discr)
or else
Corresponding_Discriminant (Priv_Discr) =
Corresponding_Discriminant (Full_Discr)
then
null;
else
@ -19643,8 +19687,8 @@ package body Sem_Ch3 is
if Present (Priv_Discr) or else Present (Full_Discr) then
Error_Msg_N
("full view must inherit discriminants of the parent"
& " type used in the private extension", Full_Indic);
("full view must inherit discriminants of the parent "
& "type used in the private extension", Full_Indic);
elsif Priv_Constr and then not Full_Constr then
Error_Msg_N
@ -19662,13 +19706,13 @@ package body Sem_Ch3 is
-- known or unknown discriminants, then the full type
-- declaration shall define a definite subtype.
elsif not Has_Unknown_Discriminants (Priv_T)
elsif not Has_Unknown_Discriminants (Priv_T)
and then not Has_Discriminants (Priv_T)
and then not Is_Constrained (Full_T)
then
Error_Msg_N
("full view must define a constrained type if partial view"
& " has no discriminants", Full_T);
("full view must define a constrained type if partial view "
& "has no discriminants", Full_T);
end if;
-- ??????? Do we implement the following properly ?????
@ -20095,42 +20139,33 @@ package body Sem_Ch3 is
Mark_Full_View_As_Ghost (Priv_T, Full_T);
end if;
-- Propagate invariants to full type
-- Propagate invariant-related attributes from the private view to the
-- full view and its base type.
if Has_Invariants (Priv_T) then
Set_Has_Invariants (Full_T);
Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T));
end if;
Propagate_Invariant_Attributes (Full_T, From_Typ => Priv_T);
Propagate_Invariant_Attributes (Base_Type (Full_T), From_Typ => Priv_T);
if Has_Inheritable_Invariants (Priv_T) then
Set_Has_Inheritable_Invariants (Full_T);
end if;
-- AI12-0041: Detect an attempt to inherit a class-wide type invariant
-- in the full view without advertising the inheritance in the partial
-- view. This can only occur when the partial view has no parent type
-- and the full view has an interface as a parent. Any other scenarios
-- are illegal because implemented interfaces must match between the
-- two views.
-- Check hidden inheritance of class-wide type invariants
if Ada_Version >= Ada_2012
and then not Has_Inheritable_Invariants (Full_T)
and then In_Private_Part (Current_Scope)
and then Has_Interfaces (Full_T)
then
if Is_Tagged_Type (Priv_T) and then Is_Tagged_Type (Full_T) then
declare
Ifaces : Elist_Id;
AI : Elmt_Id;
Full_Par : constant Entity_Id := Etype (Full_T);
Priv_Par : constant Entity_Id := Etype (Priv_T);
begin
Collect_Interfaces (Full_T, Ifaces, Exclude_Parents => True);
AI := First_Elmt (Ifaces);
while Present (AI) loop
if Has_Inheritable_Invariants (Node (AI)) then
Error_Msg_N
("hidden inheritance of class-wide type invariants " &
"not allowed", N);
exit;
end if;
Next_Elmt (AI);
end loop;
if not Is_Interface (Priv_Par)
and then Is_Interface (Full_Par)
and then Has_Inheritable_Invariants (Full_Par)
then
Error_Msg_N
("hidden inheritance of class-wide type invariants not "
& "allowed", N);
end if;
end;
end if;
@ -20952,34 +20987,31 @@ package body Sem_Ch3 is
Private_To_Full_View : Boolean := False)
is
procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id);
-- Remove the default initial procedure (if any) from the rep chain of
-- type Typ.
-- Remove the default initial condition procedure (if any) from the
-- Subprograms_For_Type chain of type Typ.
----------------------------------------
-- Remove_Default_Init_Cond_Procedure --
----------------------------------------
procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id) is
Found : Boolean := False;
Prev : Entity_Id;
Subp : Entity_Id;
Subps : constant Elist_Id := Subprograms_For_Type (Typ);
Subp_Elmt : Elmt_Id;
Subp_Id : Entity_Id;
begin
Prev := Typ;
Subp := Subprograms_For_Type (Typ);
while Present (Subp) loop
if Is_Default_Init_Cond_Procedure (Subp) then
Found := True;
exit;
end if;
if Present (Subps) then
Subp_Elmt := First_Elmt (Subps);
while Present (Subp_Elmt) loop
Subp_Id := Node (Subp_Elmt);
Prev := Subp;
Subp := Subprograms_For_Type (Subp);
end loop;
if Is_Default_Init_Cond_Procedure (Subp_Id) then
Remove_Elmt (Subps, Subp_Elmt);
exit;
end if;
if Found then
Set_Subprograms_For_Type (Prev, Subprograms_For_Type (Subp));
Set_Subprograms_For_Type (Subp, Empty);
Next_Elmt (Subp_Elmt);
end loop;
end if;
end Remove_Default_Init_Cond_Procedure;

50
gcc/ada/sem_ch6.adb
View File

@ -4428,6 +4428,34 @@ package body Sem_Ch6 is
-- both subprogram bodies and subprogram declarations (specs).
function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
function Is_Invariant_Procedure_Or_Body (E : Entity_Id) return Boolean;
-- Determine whether entity E denotes the spec or body of an invariant
-- procedure.
------------------------------------
-- Is_Invariant_Procedure_Or_Body --
------------------------------------
function Is_Invariant_Procedure_Or_Body (E : Entity_Id) return Boolean is
Decl : constant Node_Id := Unit_Declaration_Node (E);
Spec : Entity_Id;
begin
if Nkind (Decl) = N_Subprogram_Body then
Spec := Corresponding_Spec (Decl);
else
Spec := E;
end if;
return
Present (Spec)
and then Ekind (Spec) = E_Procedure
and then (Is_Partial_Invariant_Procedure (Spec)
or else Is_Invariant_Procedure (Spec));
end Is_Invariant_Procedure_Or_Body;
-- Local variables
Designator : constant Entity_Id := Defining_Entity (N);
Formals : constant List_Id := Parameter_Specifications (N);
@ -4487,7 +4515,27 @@ package body Sem_Ch6 is
-- Same processing for an access parameter whose designated type is
-- derived from a synchronized interface.
if Ada_Version >= Ada_2005 then
-- This modification is not done for invariant procedures because
-- the corresponding record may not necessarely be visible when the
-- concurrent type acts as the full view of a private type.
-- package Pack is
-- type Prot is private with Type_Invariant => ...;
-- procedure ConcInvariant (Obj : Prot);
-- private
-- protected type Prot is ...;
-- type Concurrent_Record_Prot is record ...;
-- procedure ConcInvariant (Obj : Prot) is
-- ...
-- end ConcInvariant;
-- end Pack;
-- In the example above, both the spec and body of the invariant
-- procedure must utilize the private type as the controlling type.
if Ada_Version >= Ada_2005
and then not Is_Invariant_Procedure_Or_Body (Designator)
then
declare
Formal : Entity_Id;
Formal_Typ : Entity_Id;

114
gcc/ada/sem_ch7.adb
View File

@ -35,6 +35,7 @@ with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
with Exp_Dbug; use Exp_Dbug;
@ -1457,15 +1458,17 @@ package body Sem_Ch7 is
Inherit_Default_Init_Cond_Procedure (E);
end if;
-- If invariants are present, build the invariant procedure for a
-- private type, but not any of its subtypes or interface types.
-- Preanalyze and resolve the invariants of a private type at the
-- end of the visible declarations to catch potential errors. Note
-- that inherited class-wide invariants are not considered because
-- they have already been resolved.
if Has_Invariants (E) then
if Ekind (E) = E_Private_Subtype then
null;
else
Build_Invariant_Procedure (E, N);
end if;
if Ekind_In (E, E_Limited_Private_Type,
E_Private_Type,
E_Record_Type_With_Private)
and then Has_Own_Invariants (E)
then
Build_Invariant_Procedure_Body (E, Partial_Invariant => True);
end if;
end if;
@ -1473,7 +1476,7 @@ package body Sem_Ch7 is
end loop;
if Is_Remote_Call_Interface (Id)
and then Nkind (Parent (Parent (N))) = N_Compilation_Unit
and then Nkind (Parent (Parent (N))) = N_Compilation_Unit
then
Validate_RCI_Declarations (Id);
end if;
@ -1544,7 +1547,6 @@ package body Sem_Ch7 is
if Is_Compilation_Unit (Id) then
Install_Private_With_Clauses (Id);
else
-- The current compilation unit may include private with_clauses,
-- which are visible in the private part of the current nested
-- package, and have to be installed now. This is not done for
@ -1636,48 +1638,18 @@ package body Sem_Ch7 is
("full view of & does not have preelaborable initialization", E);
end if;
-- An invariant may appear on a full view of a type
-- Preanalyze and resolve the invariants of a private type's full
-- view at the end of the private declarations in case freezing did
-- not take place either due to errors or because the context is a
-- generic unit.
if Is_Type (E)
and then not Is_Private_Type (E)
and then Has_Private_Declaration (E)
and then Nkind (Parent (E)) = N_Full_Type_Declaration
and then Has_Invariants (E)
and then Serious_Errors_Detected > 0
then
declare
IP_Built : Boolean := False;
begin
if Has_Aspects (Parent (E)) then
declare
ASN : Node_Id;
begin
ASN := First (Aspect_Specifications (Parent (E)));
while Present (ASN) loop
if Nam_In (Chars (Identifier (ASN)),
Name_Invariant,
Name_Type_Invariant)
then
Build_Invariant_Procedure (E, N);
IP_Built := True;
exit;
end if;
Next (ASN);
end loop;
end;
end if;
-- Invariants may have been inherited from progenitors
if not IP_Built
and then Has_Interfaces (E)
and then Has_Inheritable_Invariants (E)
and then not Is_Interface (E)
and then not Is_Class_Wide_Type (E)
then
Build_Invariant_Procedure (E, N);
end if;
end;
Build_Invariant_Procedure_Body (E);
end if;
Next_Entity (E);
@ -2543,7 +2515,7 @@ package body Sem_Ch7 is
Priv_Elmt : Elmt_Id;
Priv_Sub : Entity_Id;
procedure Preserve_Full_Attributes (Priv, Full : Entity_Id);
procedure Preserve_Full_Attributes (Priv : Entity_Id; Full : Entity_Id);
-- Copy to the private declaration the attributes of the full view that
-- need to be available for the partial view also.
@ -2554,12 +2526,16 @@ package body Sem_Ch7 is
-- Preserve_Full_Attributes --
------------------------------
procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is
Priv_Is_Base_Type : constant Boolean := Is_Base_Type (Priv);
procedure Preserve_Full_Attributes
(Priv : Entity_Id;
Full : Entity_Id)
is
Full_Base : constant Entity_Id := Base_Type (Full);
Priv_Is_Base_Type : constant Boolean := Is_Base_Type (Priv);
begin
Set_Size_Info (Priv, (Full));
Set_RM_Size (Priv, RM_Size (Full));
Set_Size_Info (Priv, Full);
Set_RM_Size (Priv, RM_Size (Full));
Set_Size_Known_At_Compile_Time
(Priv, Size_Known_At_Compile_Time (Full));
Set_Is_Volatile (Priv, Is_Volatile (Full));
@ -2581,26 +2557,30 @@ package body Sem_Ch7 is
end if;
if Priv_Is_Base_Type then
Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full)));
Set_Is_Controlled (Priv, Is_Controlled (Full_Base));
Set_Finalize_Storage_Only
(Priv, Finalize_Storage_Only
(Base_Type (Full)));
Propagate_Concurrent_Flags
(Priv, Base_Type (Full));
(Priv, Finalize_Storage_Only (Full_Base));
Set_Has_Controlled_Component
(Priv, Has_Controlled_Component
(Base_Type (Full)));
(Priv, Has_Controlled_Component (Full_Base));
Propagate_Concurrent_Flags (Priv, Base_Type (Full));
end if;
Set_Freeze_Node (Priv, Freeze_Node (Full));
-- Propagate information of type invariants, which may be specified
-- for the full view.
-- 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
-- of the invariant procedure body. As a result, both the full view
-- and its base type carry the same invariant-related information.
if Has_Invariants (Full) and not Has_Invariants (Priv) then
Set_Has_Invariants (Priv);
Set_Subprograms_For_Type (Priv, Subprograms_For_Type (Full));
end if;
Propagate_Invariant_Attributes (Full, From_Typ => Full_Base);
Propagate_Invariant_Attributes (Full_Base, From_Typ => Full);
-- Propagate invariant-related attributes from the full view to the
-- private view.
Propagate_Invariant_Attributes (Priv, From_Typ => Full);
if Is_Tagged_Type (Priv)
and then Is_Tagged_Type (Full)
@ -2943,7 +2923,7 @@ package body Sem_Ch7 is
if Is_Overloadable (Subp) and then Is_Primitive (Subp) then
Error_Msg_NE
("type& must be completed in the private part",
Parent (Subp), Id);
Parent (Subp), Id);
-- The result type of an access-to-function type cannot be a
-- Taft-amendment type, unless the version is Ada 2012 or

43
gcc/ada/sem_ch9.adb
View File

@ -2037,11 +2037,21 @@ package body Sem_Ch9 is
Set_Is_Constrained (T, not Has_Discriminants (T));
-- If aspects are present, analyze them now. They can make references
-- to the discriminants of the type, but not to any components.
-- If aspects are present, analyze them now. They can make references to
-- the discriminants of the type, but not to any components.
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Def_Id);
-- The protected type is the full view of a private type. Analyze the
-- aspects with the entity of the private type to ensure that after
-- both views are exchanged, the aspect are actually associated with
-- the full view.
if T /= Def_Id and then Is_Private_Type (Def_Id) then
Analyze_Aspect_Specifications (N, T);
else
Analyze_Aspect_Specifications (N, Def_Id);
end if;
end if;
Analyze (Protected_Definition (N));
@ -2194,6 +2204,11 @@ package body Sem_Ch9 is
Set_Must_Have_Preelab_Init (T);
end if;
-- Propagate invariant-related attributes from the private type to
-- the protected type.
Propagate_Invariant_Attributes (T, From_Typ => Def_Id);
-- Create corresponding record now, because some private dependents
-- may be subtypes of the partial view.
@ -3071,7 +3086,17 @@ package body Sem_Ch9 is
Set_Is_Constrained (T, not Has_Discriminants (T));
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Def_Id);
-- The task type is the full view of a private type. Analyze the
-- aspects with the entity of the private type to ensure that after
-- both views are exchanged, the aspect are actually associated with
-- the full view.
if T /= Def_Id and then Is_Private_Type (Def_Id) then
Analyze_Aspect_Specifications (N, T);
else
Analyze_Aspect_Specifications (N, Def_Id);
end if;
end if;
if Present (Task_Definition (N)) then
@ -3102,9 +3127,8 @@ package body Sem_Ch9 is
-- Case of a completion of a private declaration
if T /= Def_Id
and then Is_Private_Type (Def_Id)
then
if T /= Def_Id and then Is_Private_Type (Def_Id) then
-- Deal with preelaborable initialization. Note that this processing
-- is done by Process_Full_View, but as can be seen below, in this
-- case the call to Process_Full_View is skipped if any serious
@ -3114,6 +3138,11 @@ package body Sem_Ch9 is
Set_Must_Have_Preelab_Init (T);
end if;
-- Propagate invariant-related attributes from the private type to
-- task type.
Propagate_Invariant_Attributes (T, From_Typ => Def_Id);
-- Create corresponding record now, because some private dependents
-- may be subtypes of the partial view.

115
gcc/ada/sem_prag.adb
View File

@ -39,6 +39,7 @@ with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
with Exp_Dist; use Exp_Dist;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
@ -16503,7 +16504,19 @@ package body Sem_Prag is
when Pragma_Invariant => Invariant : declare
Discard : Boolean;
Typ : Entity_Id;
Type_Id : Node_Id;
Typ_Arg : Node_Id;
CRec_Typ : Entity_Id;
-- The corresponding record type of Full_Typ
Full_Base : Entity_Id;
-- The base type of Full_Typ
Full_Typ : Entity_Id;
-- The full view of Typ
Priv_Typ : Entity_Id;
-- The partial view of Typ
begin
GNAT_Pragma;
@ -16519,14 +16532,16 @@ package body Sem_Prag is
Check_Arg_Is_Local_Name (Arg1);
Type_Id := Get_Pragma_Arg (Arg1);
Find_Type (Type_Id);
Typ := Entity (Type_Id);
Typ_Arg := Get_Pragma_Arg (Arg1);
Find_Type (Typ_Arg);
Typ := Entity (Typ_Arg);
-- Nothing to do of the related type is erroneous in some way
if Typ = Any_Type then
return;
-- Invariants allowed in interface types (RM 7.3.2(3/3))
-- AI12-0041: Invariants are allowed in interface types
elsif Is_Interface (Typ) then
null;
@ -16536,26 +16551,46 @@ package body Sem_Prag is
-- a class-wide invariant can only appear on a private declaration
-- or private extension, not a completion.
elsif Ekind_In (Typ, E_Private_Type,
E_Record_Type_With_Private,
E_Limited_Private_Type)
-- A [class-wide] invariant may be associated a [limited] private
-- type or a private extension.
elsif Ekind_In (Typ, E_Limited_Private_Type,
E_Private_Type,
E_Record_Type_With_Private)
then
null;
elsif In_Private_Part (Current_Scope)
and then Has_Private_Declaration (Typ)
-- A non-class-wide invariant may be associated with the full view
-- of a [limited] private type or a private extension.
elsif Has_Private_Declaration (Typ)
and then not Class_Present (N)
then
null;
elsif In_Private_Part (Current_Scope) then
-- A class-wide invariant may appear on the partial view only
elsif Class_Present (N) then
Error_Pragma_Arg
("pragma% only allowed for private type declared in "
& "visible part", Arg1);
("pragma % only allowed for private type", Arg1);
return;
-- A regular invariant may appear on both views
else
Error_Pragma_Arg
("pragma% only allowed for private type", Arg1);
("pragma % only allowed for private type or corresponding "
& "full view", Arg1);
return;
end if;
-- An invariant associated with an abstract type (this includes
-- interfaces) must be class-wide.
if Is_Abstract_Type (Typ) and then not Class_Present (N) then
Error_Pragma_Arg
("pragma % not allowed for abstract type", Arg1);
return;
end if;
-- A pragma that applies to a Ghost entity becomes Ghost for the
@ -16563,37 +16598,39 @@ package body Sem_Prag is
Mark_Pragma_As_Ghost (N, Typ);
-- Not allowed for abstract type in the non-class case (it is
-- allowed to use Invariant'Class for abstract types).
-- The pragma defines a type-specific invariant, the type is said
-- to have invariants of its "own".
if Is_Abstract_Type (Typ) and then not Class_Present (N) then
Error_Pragma_Arg
("pragma% not allowed for abstract type", Arg1);
end if;
Set_Has_Own_Invariants (Typ);
-- Link the pragma on to the rep item chain, for processing when
-- the type is frozen.
Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
-- Note that the type has at least one invariant, and also that
-- it has inheritable invariants if we have Invariant'Class
-- or Type_Invariant'Class. Build the corresponding invariant
-- procedure declaration, so that calls to it can be generated
-- before the body is built (e.g. within an expression function).
-- Interface types have no invariant procedure; their invariants
-- are propagated to the build invariant procedure of all the
-- types covering the interface type.
if not Is_Interface (Typ) then
Insert_After_And_Analyze
(N, Build_Invariant_Procedure_Declaration (Typ));
end if;
-- If the invariant is class-wide, then it can be inherited by
-- derived or interface implementing types. The type is said to
-- have "inheritable" invariants.
if Class_Present (N) then
Set_Has_Inheritable_Invariants (Typ);
end if;
Get_Views (Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
-- Propagate invariant-related attributes to all views of the type
-- and any additional types that may have been created.
Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Typ);
Propagate_Invariant_Attributes (Full_Typ, From_Typ => Typ);
Propagate_Invariant_Attributes (Full_Base, From_Typ => Typ);
Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Typ);
-- Chain the pragma on to the rep item chain, for processing when
-- the type is frozen.
Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
-- Create the declaration of the invariant procedure which will
-- verify the invariant at run-time. Note that interfaces do not
-- carry such a declaration.
Build_Invariant_Procedure_Declaration (Typ);
end Invariant;
----------------

21
gcc/ada/sem_res.adb
View File

@ -4223,14 +4223,19 @@ package body Sem_Res is
then
Error_Msg_NE ("actual for& must be a variable", A, F);
if Is_Subprogram (Current_Scope)
and then
(Is_Invariant_Procedure (Current_Scope)
or else Is_Predicate_Function (Current_Scope))
then
Error_Msg_N
("function used in predicate cannot "
& "modify its argument", F);
if Is_Subprogram (Current_Scope) then
if Is_Invariant_Procedure (Current_Scope)
or else Is_Partial_Invariant_Procedure (Current_Scope)
then
Error_Msg_N
("function used in invariant cannot modify its "
& "argument", F);
elsif Is_Predicate_Function (Current_Scope) then
Error_Msg_N
("function used in predicate cannot modify its "
& "argument", F);
end if;
end if;
end if;

155
gcc/ada/sem_util.adb
View File

@ -8622,6 +8622,76 @@ package body Sem_Util is
return Empty;
end Get_User_Defined_Eq;
---------------
-- Get_Views --
---------------
procedure Get_Views
(Typ : Entity_Id;
Priv_Typ : out Entity_Id;
Full_Typ : out Entity_Id;
Full_Base : out Entity_Id;
CRec_Typ : out Entity_Id)
is
begin
-- Assume that none of the views can be recovered
Priv_Typ := Empty;
Full_Typ := Empty;
Full_Base := Empty;
CRec_Typ := Empty;
-- The input type is private
if Is_Private_Type (Typ) then
Priv_Typ := Typ;
Full_Typ := Full_View (Priv_Typ);
if Present (Full_Typ) then
Full_Base := Base_Type (Full_Typ);
if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then
CRec_Typ := Corresponding_Record_Type (Full_Typ);
end if;
end if;
-- The input type is the corresponding record type of a protected or a
-- task type.
elsif Ekind (Typ) = E_Record_Type
and then Is_Concurrent_Record_Type (Typ)
then
CRec_Typ := Typ;
Full_Typ := Corresponding_Concurrent_Type (CRec_Typ);
Full_Base := Base_Type (Full_Typ);
Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
-- Otherwise the input type could be the full view of a private type
else
Full_Typ := Typ;
Full_Base := Base_Type (Full_Typ);
if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then
CRec_Typ := Corresponding_Record_Type (Full_Typ);
end if;
-- The type is the full view of a private type, obtain the partial
-- view.
if Has_Private_Declaration (Full_Typ)
and then not Is_Private_Type (Full_Typ)
then
Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
-- The full view of a private type should always have a partial
-- view.
pragma Assert (Present (Priv_Typ));
end if;
end if;
end Get_Views;
-----------------------
-- Has_Access_Values --
-----------------------
@ -10988,20 +11058,31 @@ package body Sem_Util is
while Present (Decl) loop
Match := Empty;
-- The partial view of a Taft-amendment type is an incomplete
-- type.
if Taft then
if Nkind (Decl) = N_Incomplete_Type_Declaration then
Match := Defining_Identifier (Decl);
end if;
else
if Nkind_In (Decl, N_Private_Extension_Declaration,
-- Otherwise look for a private type whose full view matches the
-- input type. Note that this checks full_type_declaration nodes
-- to account for derivations from a private type where the type
-- declaration hold the partial view and the full view is an
-- itype.
elsif Nkind_In (Decl, N_Full_Type_Declaration,
N_Private_Extension_Declaration,
N_Private_Type_Declaration)
then
Match := Defining_Identifier (Decl);
end if;
then
Match := Defining_Identifier (Decl);
end if;
-- Guard against unanalyzed entities
if Present (Match)
and then Is_Type (Match)
and then Present (Full_View (Match))
and then Full_View (Match) = Id
then
@ -11040,7 +11121,9 @@ package body Sem_Util is
Pkg_Decl : Node_Id := Pkg;
begin
if Present (Pkg) and then Ekind (Pkg) = E_Package then
if Present (Pkg)
and then Ekind_In (Pkg, E_Generic_Package, E_Package)
then
while Nkind (Pkg_Decl) /= N_Package_Specification loop
Pkg_Decl := Parent (Pkg_Decl);
end loop;
@ -18519,13 +18602,71 @@ package body Sem_Util is
Set_Sloc (Endl, Loc);
end Process_End_Label;
------------------------------------
-- Propagate_Invariant_Attributes --
------------------------------------
procedure Propagate_Invariant_Attributes
(Typ : Entity_Id;
From_Typ : Entity_Id)
is
Full_IP : Entity_Id;
Part_IP : Entity_Id;
begin
if Present (Typ) and then Present (From_Typ) then
pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ));
-- Nothing to do if both the source and the destination denote the
-- same type.
if From_Typ = Typ then
return;
end if;
Full_IP := Invariant_Procedure (From_Typ);
Part_IP := Partial_Invariant_Procedure (From_Typ);
-- The setting of the attributes is intentionally conservative. This
-- prevents accidental clobbering of enabled attributes.
if Has_Inheritable_Invariants (From_Typ)
and then not Has_Inheritable_Invariants (Typ)
then
Set_Has_Inheritable_Invariants (Typ, True);
end if;
if Has_Inherited_Invariants (From_Typ)
and then not Has_Inherited_Invariants (Typ)
then
Set_Has_Inherited_Invariants (Typ, True);
end if;
if Has_Own_Invariants (From_Typ)
and then not Has_Own_Invariants (Typ)
then
Set_Has_Own_Invariants (Typ, True);
end if;
if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then
Set_Invariant_Procedure (Typ, Full_IP);
end if;
if Present (Part_IP) and then No (Partial_Invariant_Procedure (Typ))
then
Set_Partial_Invariant_Procedure (Typ, Part_IP);
end if;
end if;
end Propagate_Invariant_Attributes;
--------------------------------
-- Propagate_Concurrent_Flags --
--------------------------------
procedure Propagate_Concurrent_Flags
(Typ : Entity_Id;
Comp_Typ : Entity_Id) is
Comp_Typ : Entity_Id)
is
begin
if Has_Task (Comp_Typ) then
Set_Has_Task (Typ);

20
gcc/ada/sem_util.ads
View File

@ -1005,6 +1005,20 @@ package Sem_Util is
-- For a type entity, return the entity of the primitive equality function
-- for the type if it exists, otherwise return Empty.
procedure Get_Views
(Typ : Entity_Id;
Priv_Typ : out Entity_Id;
Full_Typ : out Entity_Id;
Full_Base : out Entity_Id;
CRec_Typ : out Entity_Id);
-- Obtain the partial and full view of type Typ and in addition any extra
-- types the full view may have. The return entities are as follows:
--
-- Priv_Typ - the partial view (a private type)
-- Full_Typ - the full view
-- Full_Base - the base type of the full view
-- CRec_Typ - the corresponding record type of the full view
function Has_Access_Values (T : Entity_Id) return Boolean;
-- Returns true if type or subtype T is an access type, or has a component
-- (at any recursive level) that is an access type. This is a conservative
@ -2022,6 +2036,12 @@ package Sem_Util is
-- parameter Ent gives the entity to which the End_Label refers,
-- and to which cross-references are to be generated.
procedure Propagate_Invariant_Attributes
(Typ : Entity_Id;
From_Typ : Entity_Id);
-- Inherit all invariant-related attributes form type From_Typ. Typ is the
-- destination type.
procedure Propagate_Concurrent_Flags
(Typ : Entity_Id;
Comp_Typ : Entity_Id);