[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:
parent
1db6c46d4d
commit
3ddfabe34f
|
@ -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"
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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);
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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));
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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
1515
gcc/ada/exp_ch7.adb
File diff suppressed because it is too large
Load Diff
|
@ -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;
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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;
|
||||
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
||||
|
|
|
@ -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;
|
||||
|
||||
----------------
|
||||
|
|
|
@ -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;
|
||||
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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);
|
||||
|
|
Loading…
Reference in New Issue