Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/einfo.adb @ 131:84e7813d76e9
gcc-8.2
| author | mir3636 |
|---|---|
| date | Thu, 25 Oct 2018 07:37:49 +0900 |
| parents | 04ced10e8804 |
| children | 1830386684a0 |
line wrap: on
line diff
--- a/gcc/ada/einfo.adb Fri Oct 27 22:46:09 2017 +0900 +++ b/gcc/ada/einfo.adb Thu Oct 25 07:37:49 2018 +0900 @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2018, 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- -- @@ -70,6 +70,7 @@ -- Homonym Node4 -- First_Rep_Item Node6 -- Freeze_Node Node7 + -- Prev_Entity Node36 -- Associated_Entity Node37 -- The usage of other fields (and the entity kinds to which it applies) @@ -117,7 +118,6 @@ -- Alignment Uint14 -- Normalized_Position Uint14 -- Postconditions_Proc Node14 - -- Shadow_Entities List14 -- Discriminant_Number Uint15 -- DT_Position Uint15 @@ -198,7 +198,6 @@ -- Corresponding_Remote_Type Node22 -- Enumeration_Rep_Expr Node22 -- Original_Record_Component Node22 - -- Private_View Node22 -- Protected_Formal Node22 -- Scope_Depth_Value Uint22 -- Shared_Var_Procs_Instance Node22 @@ -253,12 +252,13 @@ -- Access_Disp_Table_Elab_Flag Node30 -- Anonymous_Object Node30 -- Corresponding_Equality Node30 + -- Hidden_In_Formal_Instance Elist30 -- Last_Aggregate_Assignment Node30 -- Static_Initialization Node30 + -- Activation_Record_Component Node31 -- Derived_Type_Link Node31 -- Thunk_Entity Node31 - -- Activation_Record_Component Node31 -- Corresponding_Function Node32 -- Corresponding_Procedure Node32 @@ -273,8 +273,8 @@ -- Entry_Max_Queue_Lengths_Array Node35 -- Import_Pragma Node35 - -- Validated_Object Node36 - + -- Validated_Object Node38 + -- Predicated_Parent Node38 -- Class_Wide_Clone Node38 -- Protected_Subprogram Node39 @@ -624,12 +624,12 @@ -- Ignore_SPARK_Mode_Pragmas Flag301 -- Is_Initial_Condition_Procedure Flag302 - - -- (unused) Flag303 - -- (unused) Flag304 - -- (unused) Flag305 - -- (unused) Flag306 - -- (unused) Flag307 + -- Suppress_Elaboration_Warnings Flag303 + -- Is_Elaboration_Warnings_OK_Id Flag304 + -- Is_Activation_Record Flag305 + -- Needs_Activation_Record Flag306 + -- Is_Loop_Parameter Flag307 + -- (unused) Flag308 -- (unused) Flag309 @@ -1180,7 +1180,7 @@ pragma Assert (Is_Subprogram (Id) or else - Ekind (Id) = E_Package + Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) or else Is_Generic_Unit (Id)); return Node13 (Id); @@ -1191,7 +1191,7 @@ pragma Assert (Is_Subprogram (Id) or else - Ekind (Id) = E_Package + Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) or else Is_Generic_Unit (Id)); return Flag174 (Id); @@ -1264,14 +1264,14 @@ function Contract (Id : E) return N is begin pragma Assert - (Ekind_In (Id, E_Protected_Type, -- concurrent variants + (Ekind_In (Id, E_Protected_Type, -- concurrent types E_Task_Body, E_Task_Type) or else - Ekind_In (Id, E_Constant, -- object variants + Ekind_In (Id, E_Constant, -- objects E_Variable) or else - Ekind_In (Id, E_Entry, -- overloadable variants + Ekind_In (Id, E_Entry, -- overloadable E_Entry_Family, E_Function, E_Generic_Function, @@ -1280,11 +1280,11 @@ E_Procedure, E_Subprogram_Body) or else - Ekind_In (Id, E_Generic_Package, -- package variants + Ekind_In (Id, E_Generic_Package, -- packages E_Package, E_Package_Body) or else - Ekind (Id) = E_Void); -- special purpose + Ekind (Id) = E_Void); -- special purpose return Node34 (Id); end Contract; @@ -1565,7 +1565,7 @@ function Has_Discriminants (Id : E) return B is begin - pragma Assert (Nkind (Id) in N_Entity); + pragma Assert (Is_Type (Id)); return Flag5 (Id); end Has_Discriminants; @@ -1987,6 +1987,12 @@ return Node8 (Id); end Hiding_Loop_Variable; + function Hidden_In_Formal_Instance (Id : E) return L is + begin + pragma Assert (Ekind (Id) = E_Package); + return Elist30 (Id); + end Hidden_In_Formal_Instance; + function Homonym (Id : E) return E is begin return Node4 (Id); @@ -1995,12 +2001,12 @@ function Ignore_SPARK_Mode_Pragmas (Id : E) return B is begin pragma Assert - (Ekind_In (Id, E_Protected_Body, -- concurrent variants + (Ekind_In (Id, E_Protected_Body, -- concurrent types E_Protected_Type, E_Task_Body, E_Task_Type) or else - Ekind_In (Id, E_Entry, -- overloadable variants + Ekind_In (Id, E_Entry, -- overloadable E_Entry_Family, E_Function, E_Generic_Function, @@ -2009,7 +2015,7 @@ E_Procedure, E_Subprogram_Body) or else - Ekind_In (Id, E_Generic_Package, -- package variants + Ekind_In (Id, E_Generic_Package, -- packages E_Package, E_Package_Body)); return Flag301 (Id); @@ -2089,6 +2095,12 @@ return Flag69 (Id); end Is_Access_Constant; + function Is_Activation_Record (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_In_Parameter); + return Flag305 (Id); + end Is_Activation_Record; + function Is_Actual_Subtype (Id : E) return B is begin pragma Assert (Is_Type (Id)); @@ -2244,15 +2256,16 @@ function Is_Elaboration_Checks_OK_Id (Id : E) return B is begin - pragma Assert - (Ekind_In (Id, E_Constant, E_Variable) - or else Is_Entry (Id) - or else Is_Generic_Unit (Id) - or else Is_Subprogram (Id) - or else Is_Task_Type (Id)); + pragma Assert (Is_Elaboration_Target (Id)); return Flag148 (Id); end Is_Elaboration_Checks_OK_Id; + function Is_Elaboration_Warnings_OK_Id (Id : E) return B is + begin + pragma Assert (Is_Elaboration_Target (Id) or else Ekind (Id) = E_Void); + return Flag304 (Id); + end Is_Elaboration_Warnings_OK_Id; + function Is_Eliminated (Id : E) return B is begin return Flag124 (Id); @@ -2471,6 +2484,11 @@ return Flag194 (Id); end Is_Local_Anonymous_Access; + function Is_Loop_Parameter (Id : E) return B is + begin + return Flag307 (Id); + end Is_Loop_Parameter; + function Is_Machine_Code_Subprogram (Id : E) return B is begin pragma Assert (Is_Subprogram (Id)); @@ -2854,6 +2872,11 @@ return Flag208 (Id); end Must_Have_Preelab_Init; + function Needs_Activation_Record (Id : E) return B is + begin + return Flag306 (Id); + end Needs_Activation_Record; + function Needs_Debug_Info (Id : E) return B is begin return Flag147 (Id); @@ -3064,12 +3087,25 @@ return Node14 (Id); end Postconditions_Proc; + function Predicated_Parent (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Array_Subtype, + E_Record_Subtype, + E_Record_Subtype_With_Private)); + return Node38 (Id); + end Predicated_Parent; + function Predicates_Ignored (Id : E) return B is begin pragma Assert (Is_Type (Id)); return Flag288 (Id); end Predicates_Ignored; + function Prev_Entity (Id : E) return E is + begin + return Node36 (Id); + end Prev_Entity; + function Prival (Id : E) return E is begin pragma Assert (Is_Protected_Component (Id)); @@ -3088,12 +3124,6 @@ return Elist18 (Id); end Private_Dependents; - function Private_View (Id : E) return N is - begin - pragma Assert (Is_Private_Type (Id)); - return Node22 (Id); - end Private_View; - function Protected_Body_Subprogram (Id : E) return E is begin pragma Assert (Is_Subprogram (Id) or else Is_Entry (Id)); @@ -3276,12 +3306,6 @@ return Flag167 (Id); end Sec_Stack_Needed_For_Return; - function Shadow_Entities (Id : E) return S is - begin - pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); - return List14 (Id); - end Shadow_Entities; - function Shared_Var_Procs_Instance (Id : E) return E is begin pragma Assert (Ekind (Id) = E_Variable); @@ -3313,10 +3337,10 @@ function SPARK_Aux_Pragma (Id : E) return N is begin pragma Assert - (Ekind_In (Id, E_Protected_Type, -- concurrent variants + (Ekind_In (Id, E_Protected_Type, -- concurrent types E_Task_Type) or else - Ekind_In (Id, E_Generic_Package, -- package variants + Ekind_In (Id, E_Generic_Package, -- packages E_Package, E_Package_Body)); return Node41 (Id); @@ -3325,10 +3349,10 @@ function SPARK_Aux_Pragma_Inherited (Id : E) return B is begin pragma Assert - (Ekind_In (Id, E_Protected_Type, -- concurrent variants + (Ekind_In (Id, E_Protected_Type, -- concurrent types E_Task_Type) or else - Ekind_In (Id, E_Generic_Package, -- package variants + Ekind_In (Id, E_Generic_Package, -- packages E_Package, E_Package_Body)); return Flag266 (Id); @@ -3337,15 +3361,11 @@ function SPARK_Pragma (Id : E) return N is begin pragma Assert - (Ekind_In (Id, E_Protected_Body, -- concurrent variants - E_Protected_Type, - E_Task_Body, - E_Task_Type) - or else - Ekind_In (Id, E_Constant, -- object variants + (Ekind_In (Id, E_Constant, -- objects E_Variable) or else - Ekind_In (Id, E_Entry, -- overloadable variants + Ekind_In (Id, E_Abstract_State, -- overloadable + E_Entry, E_Entry_Family, E_Function, E_Generic_Function, @@ -3354,26 +3374,27 @@ E_Procedure, E_Subprogram_Body) or else - Ekind_In (Id, E_Generic_Package, -- package variants + Ekind_In (Id, E_Generic_Package, -- packages E_Package, E_Package_Body) or else - Ekind (Id) = E_Void); -- special purpose + Ekind (Id) = E_Void -- special purpose + or else + Ekind_In (Id, E_Protected_Body, -- types + E_Task_Body) + or else + Is_Type (Id)); return Node40 (Id); end SPARK_Pragma; function SPARK_Pragma_Inherited (Id : E) return B is begin pragma Assert - (Ekind_In (Id, E_Protected_Body, -- concurrent variants - E_Protected_Type, - E_Task_Body, - E_Task_Type) - or else - Ekind_In (Id, E_Constant, -- object variants + (Ekind_In (Id, E_Constant, -- objects E_Variable) or else - Ekind_In (Id, E_Entry, -- overloadable variants + Ekind_In (Id, E_Abstract_State, -- overloadable + E_Entry, E_Entry_Family, E_Function, E_Generic_Function, @@ -3382,11 +3403,16 @@ E_Procedure, E_Subprogram_Body) or else - Ekind_In (Id, E_Generic_Package, -- package variants + Ekind_In (Id, E_Generic_Package, -- packages E_Package, E_Package_Body) or else - Ekind (Id) = E_Void); -- special purpose + Ekind (Id) = E_Void -- special purpose + or else + Ekind_In (Id, E_Protected_Body, -- types + E_Task_Body) + or else + Is_Type (Id)); return Flag265 (Id); end SPARK_Pragma_Inherited; @@ -3486,6 +3512,11 @@ return Uint24 (Id); end Subps_Index; + function Suppress_Elaboration_Warnings (Id : E) return B is + begin + return Flag303 (Id); + end Suppress_Elaboration_Warnings; + function Suppress_Initialization (Id : E) return B is begin pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Variable); @@ -3561,7 +3592,7 @@ function Validated_Object (Id : E) return N is begin pragma Assert (Ekind (Id) = E_Variable); - return Node36 (Id); + return Node38 (Id); end Validated_Object; function Warnings_Off (Id : E) return B is @@ -4083,14 +4114,14 @@ procedure Set_Contract (Id : E; V : N) is begin pragma Assert - (Ekind_In (Id, E_Protected_Type, -- concurrent variants + (Ekind_In (Id, E_Protected_Type, -- concurrent types E_Task_Body, E_Task_Type) or else - Ekind_In (Id, E_Constant, -- object variants + Ekind_In (Id, E_Constant, -- objects E_Variable) or else - Ekind_In (Id, E_Entry, -- overloadable variants + Ekind_In (Id, E_Entry, -- overloadable E_Entry_Family, E_Function, E_Generic_Function, @@ -4099,11 +4130,11 @@ E_Procedure, E_Subprogram_Body) or else - Ekind_In (Id, E_Generic_Package, -- package variants + Ekind_In (Id, E_Generic_Package, -- packages E_Package, E_Package_Body) or else - Ekind (Id) = E_Void); -- special purpose + Ekind (Id) = E_Void); -- special purpose Set_Node34 (Id, V); end Set_Contract; @@ -4367,7 +4398,7 @@ pragma Assert (Is_Subprogram (Id) or else - Ekind (Id) = E_Package + Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) or else Is_Generic_Unit (Id)); Set_Node13 (Id, V); @@ -4378,7 +4409,7 @@ pragma Assert (Is_Subprogram (Id) or else - Ekind (Id) = E_Package + Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) or else Is_Generic_Unit (Id)); Set_Flag174 (Id, V); @@ -4712,7 +4743,7 @@ procedure Set_Has_Discriminants (Id : E; V : B := True) is begin - pragma Assert (Nkind (Id) in N_Entity); + pragma Assert (Is_Type (Id)); Set_Flag5 (Id, V); end Set_Has_Discriminants; @@ -5149,6 +5180,12 @@ Set_Node8 (Id, V); end Set_Hiding_Loop_Variable; + procedure Set_Hidden_In_Formal_Instance (Id : E; V : L) is + begin + pragma Assert (Ekind (Id) = E_Package); + Set_Elist30 (Id, V); + end Set_Hidden_In_Formal_Instance; + procedure Set_Homonym (Id : E; V : E) is begin pragma Assert (Id /= V); @@ -5164,12 +5201,12 @@ procedure Set_Ignore_SPARK_Mode_Pragmas (Id : E; V : B := True) is begin pragma Assert - (Ekind_In (Id, E_Protected_Body, -- concurrent variants + (Ekind_In (Id, E_Protected_Body, -- concurrent types E_Protected_Type, E_Task_Body, E_Task_Type) or else - Ekind_In (Id, E_Entry, -- overloadable variants + Ekind_In (Id, E_Entry, -- overloadable E_Entry_Family, E_Function, E_Generic_Function, @@ -5178,7 +5215,7 @@ E_Procedure, E_Subprogram_Body) or else - Ekind_In (Id, E_Generic_Package, -- package variants + Ekind_In (Id, E_Generic_Package, -- packages E_Package, E_Package_Body)); Set_Flag301 (Id, V); @@ -5265,6 +5302,12 @@ Set_Flag69 (Id, V); end Set_Is_Access_Constant; + procedure Set_Is_Activation_Record (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_In_Parameter); + Set_Flag305 (Id, V); + end Set_Is_Activation_Record; + procedure Set_Is_Actual_Subtype (Id : E; V : B := True) is begin pragma Assert (Is_Type (Id)); @@ -5436,15 +5479,16 @@ procedure Set_Is_Elaboration_Checks_OK_Id (Id : E; V : B := True) is begin - pragma Assert - (Ekind_In (Id, E_Constant, E_Variable) - or else Is_Entry (Id) - or else Is_Generic_Unit (Id) - or else Is_Subprogram (Id) - or else Is_Task_Type (Id)); + pragma Assert (Is_Elaboration_Target (Id)); Set_Flag148 (Id, V); end Set_Is_Elaboration_Checks_OK_Id; + procedure Set_Is_Elaboration_Warnings_OK_Id (Id : E; V : B := True) is + begin + pragma Assert (Is_Elaboration_Target (Id)); + Set_Flag304 (Id, V); + end Set_Is_Elaboration_Warnings_OK_Id; + procedure Set_Is_Eliminated (Id : E; V : B := True) is begin Set_Flag124 (Id, V); @@ -5662,6 +5706,11 @@ Set_Flag25 (Id, V); end Set_Is_Limited_Record; + procedure Set_Is_Loop_Parameter (Id : E; V : B := True) is + begin + Set_Flag307 (Id, V); + end Set_Is_Loop_Parameter; + procedure Set_Is_Machine_Code_Subprogram (Id : E; V : B := True) is begin pragma Assert (Is_Subprogram (Id)); @@ -5909,7 +5958,7 @@ procedure Set_Is_Uplevel_Referenced_Entity (Id : E; V : B := True) is begin pragma Assert - (Ekind_In (Id, E_Constant, E_Variable) + (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable) or else Is_Formal (Id) or else Is_Type (Id)); Set_Flag283 (Id, V); @@ -6058,6 +6107,11 @@ Set_Flag208 (Id, V); end Set_Must_Have_Preelab_Init; + procedure Set_Needs_Activation_Record (Id : E; V : B := True) is + begin + Set_Flag306 (Id, V); + end Set_Needs_Activation_Record; + procedure Set_Needs_Debug_Info (Id : E; V : B := True) is begin Set_Flag147 (Id, V); @@ -6270,6 +6324,14 @@ Set_Node14 (Id, V); end Set_Postconditions_Proc; + procedure Set_Predicated_Parent (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Array_Subtype, + E_Record_Subtype, + E_Record_Subtype_With_Private)); + Set_Node38 (Id, V); + end Set_Predicated_Parent; + procedure Set_Predicates_Ignored (Id : E; V : B) is begin pragma Assert (Is_Type (Id)); @@ -6300,11 +6362,10 @@ Set_Elist18 (Id, V); end Set_Private_Dependents; - procedure Set_Private_View (Id : E; V : N) is - begin - pragma Assert (Is_Private_Type (Id)); - Set_Node22 (Id, V); - end Set_Private_View; + procedure Set_Prev_Entity (Id : E; V : E) is + begin + Set_Node36 (Id, V); + end Set_Prev_Entity; procedure Set_Protected_Body_Subprogram (Id : E; V : E) is begin @@ -6492,12 +6553,6 @@ Set_Flag167 (Id, V); end Set_Sec_Stack_Needed_For_Return; - procedure Set_Shadow_Entities (Id : E; V : S) is - begin - pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); - Set_List14 (Id, V); - end Set_Shadow_Entities; - procedure Set_Shared_Var_Procs_Instance (Id : E; V : E) is begin pragma Assert (Ekind (Id) = E_Variable); @@ -6529,10 +6584,10 @@ procedure Set_SPARK_Aux_Pragma (Id : E; V : N) is begin pragma Assert - (Ekind_In (Id, E_Protected_Type, -- concurrent variants + (Ekind_In (Id, E_Protected_Type, -- concurrent types E_Task_Type) or else - Ekind_In (Id, E_Generic_Package, -- package variants + Ekind_In (Id, E_Generic_Package, -- packages E_Package, E_Package_Body)); Set_Node41 (Id, V); @@ -6541,10 +6596,10 @@ procedure Set_SPARK_Aux_Pragma_Inherited (Id : E; V : B := True) is begin pragma Assert - (Ekind_In (Id, E_Protected_Type, -- concurrent variants + (Ekind_In (Id, E_Protected_Type, -- concurrent types E_Task_Type) or else - Ekind_In (Id, E_Generic_Package, -- package variants + Ekind_In (Id, E_Generic_Package, -- packages E_Package, E_Package_Body)); Set_Flag266 (Id, V); @@ -6553,15 +6608,11 @@ procedure Set_SPARK_Pragma (Id : E; V : N) is begin pragma Assert - (Ekind_In (Id, E_Protected_Body, -- concurrent variants - E_Protected_Type, - E_Task_Body, - E_Task_Type) - or else - Ekind_In (Id, E_Constant, -- object variants + (Ekind_In (Id, E_Constant, -- objects E_Variable) or else - Ekind_In (Id, E_Entry, -- overloadable variants + Ekind_In (Id, E_Abstract_State, -- overloadable + E_Entry, E_Entry_Family, E_Function, E_Generic_Function, @@ -6570,26 +6621,27 @@ E_Procedure, E_Subprogram_Body) or else - Ekind_In (Id, E_Generic_Package, -- package variants + Ekind_In (Id, E_Generic_Package, -- packages E_Package, E_Package_Body) or else - Ekind (Id) = E_Void); -- special purpose + Ekind (Id) = E_Void -- special purpose + or else + Ekind_In (Id, E_Protected_Body, -- types + E_Task_Body) + or else + Is_Type (Id)); Set_Node40 (Id, V); end Set_SPARK_Pragma; procedure Set_SPARK_Pragma_Inherited (Id : E; V : B := True) is begin pragma Assert - (Ekind_In (Id, E_Protected_Body, -- concurrent variants - E_Protected_Type, - E_Task_Body, - E_Task_Type) - or else - Ekind_In (Id, E_Constant, -- object variants + (Ekind_In (Id, E_Constant, -- objects E_Variable) or else - Ekind_In (Id, E_Entry, -- overloadable variants + Ekind_In (Id, E_Abstract_State, -- overloadable + E_Entry, E_Entry_Family, E_Function, E_Generic_Function, @@ -6598,11 +6650,16 @@ E_Procedure, E_Subprogram_Body) or else - Ekind_In (Id, E_Generic_Package, -- package variants + Ekind_In (Id, E_Generic_Package, -- packages E_Package, E_Package_Body) or else - Ekind (Id) = E_Void); -- special purpose + Ekind (Id) = E_Void -- special purpose + or else + Ekind_In (Id, E_Protected_Body, -- types + E_Task_Body) + or else + Is_Type (Id)); Set_Flag265 (Id, V); end Set_SPARK_Pragma_Inherited; @@ -6711,6 +6768,11 @@ Set_Uint24 (Id, V); end Set_Subps_Index; + procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True) is + begin + Set_Flag303 (Id, V); + end Set_Suppress_Elaboration_Warnings; + procedure Set_Suppress_Initialization (Id : E; V : B := True) is begin pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Variable); @@ -6787,7 +6849,7 @@ procedure Set_Validated_Object (Id : E; V : N) is begin pragma Assert (Ekind (Id) = E_Variable); - Set_Node36 (Id, V); + Set_Node38 (Id, V); end Set_Validated_Object; procedure Set_Warnings_Off (Id : E; V : B := True) is @@ -7141,17 +7203,31 @@ -- Append_Entity -- ------------------- - procedure Append_Entity (Id : Entity_Id; V : Entity_Id) is - begin - if Last_Entity (V) = Empty then - Set_First_Entity (Id => V, V => Id); + procedure Append_Entity (Id : Entity_Id; Scop : Entity_Id) is + Last : constant Entity_Id := Last_Entity (Scop); + + begin + Set_Scope (Id, Scop); + Set_Prev_Entity (Id, Empty); -- Empty <-- Id + + -- The entity chain is empty + + if No (Last) then + Set_First_Entity (Scop, Id); + + -- Otherwise the entity chain has at least one element + else - Set_Next_Entity (Last_Entity (V), Id); + Link_Entities (Last, Id); -- Last <-- Id, Last --> Id end if; - Set_Next_Entity (Id, Empty); - Set_Scope (Id, V); - Set_Last_Entity (Id => V, V => Id); + -- NOTE: The setting of the Next_Entity attribute of Id must happen + -- here as opposed to at the beginning of the routine because doing + -- so causes the binder to hang. It is not clear why ??? + + Set_Next_Entity (Id, Empty); -- Id --> Empty + + Set_Last_Entity (Scop, Id); end Append_Entity; --------------- @@ -8044,14 +8120,34 @@ and then Is_Entity_Attribute_Name (Attribute_Name (N))); end Is_Entity_Name; + --------------------------- + -- Is_Elaboration_Target -- + --------------------------- + + function Is_Elaboration_Target (Id : Entity_Id) return Boolean is + begin + return + Ekind_In (Id, E_Constant, E_Variable) + or else Is_Entry (Id) + or else Is_Generic_Unit (Id) + or else Is_Subprogram (Id) + or else Is_Task_Type (Id); + end Is_Elaboration_Target; + ----------------------- -- Is_External_State -- ----------------------- function Is_External_State (Id : E) return B is begin + -- To qualify, the abstract state must appear with option "external" or + -- "synchronous" (SPARK RM 7.1.4(8) and (10)). + return - Ekind (Id) = E_Abstract_State and then Has_Option (Id, Name_External); + Ekind (Id) = E_Abstract_State + and then (Has_Option (Id, Name_External) + or else + Has_Option (Id, Name_Synchronous)); end Is_External_State; ------------------ @@ -8222,6 +8318,9 @@ function Is_Synchronized_State (Id : E) return B is begin + -- To qualify, the abstract state must appear with simple option + -- "synchronous" (SPARK RM 7.1.4(10)). + return Ekind (Id) = E_Abstract_State and then Has_Option (Id, Name_Synchronous); @@ -8260,7 +8359,7 @@ function Is_Wrapper_Package (Id : E) return B is begin - return (Ekind (Id) = E_Package and then Present (Related_Instance (Id))); + return Ekind (Id) = E_Package and then Present (Related_Instance (Id)); end Is_Wrapper_Package; ----------------- @@ -8293,6 +8392,23 @@ end if; end Last_Formal; + ------------------- + -- Link_Entities -- + ------------------- + + procedure Link_Entities (First : Entity_Id; Second : Node_Id) is + begin + if Present (Second) then + Set_Prev_Entity (Second, First); -- First <-- Second + end if; + + Set_Next_Entity (First, Second); -- First --> Second + end Link_Entities; + + ---------------------- + -- Model_Emin_Value -- + ---------------------- + function Model_Emin_Value (Id : E) return Uint is begin return Machine_Emin_Value (Id); @@ -8613,6 +8729,15 @@ return N; end Number_Formals; + ------------------------ + -- Object_Size_Clause -- + ------------------------ + + function Object_Size_Clause (Id : E) return N is + begin + return Get_Attribute_Definition_Clause (Id, Attribute_Object_Size); + end Object_Size_Clause; + -------------------- -- Parameter_Mode -- -------------------- @@ -8758,6 +8883,13 @@ then Typ := Full_View (Id); + elsif Ekind_In (Id, E_Array_Subtype, + E_Record_Subtype, + E_Record_Subtype_With_Private) + and then Present (Predicated_Parent (Id)) + then + Typ := Predicated_Parent (Id); + else Typ := Id; end if; @@ -8885,6 +9017,47 @@ Set_First_Rep_Item (E, N); end Record_Rep_Item; + ------------------- + -- Remove_Entity -- + ------------------- + + procedure Remove_Entity (Id : Entity_Id) is + Next : constant Entity_Id := Next_Entity (Id); + Prev : constant Entity_Id := Prev_Entity (Id); + Scop : constant Entity_Id := Scope (Id); + First : constant Entity_Id := First_Entity (Scop); + Last : constant Entity_Id := Last_Entity (Scop); + + begin + -- Eliminate any existing linkages from the entity + + Set_Prev_Entity (Id, Empty); -- Empty <-- Id + Set_Next_Entity (Id, Empty); -- Id --> Empty + + -- The eliminated entity was the only element in the entity chain + + if Id = First and then Id = Last then + Set_First_Entity (Scop, Empty); + Set_Last_Entity (Scop, Empty); + + -- The eliminated entity was the head of the entity chain + + elsif Id = First then + Set_First_Entity (Scop, Next); + + -- The eliminated entity was the tail of the entity chain + + elsif Id = Last then + Set_Last_Entity (Scop, Prev); + + -- Otherwise the eliminated entity comes from the middle of the entity + -- chain. + + else + Link_Entities (Prev, Next); -- Prev <-- Next, Prev --> Next + end if; + end Remove_Entity; + --------------- -- Root_Type -- --------------- @@ -9436,6 +9609,21 @@ end Underlying_Type; ------------------------ + -- Unlink_Next_Entity -- + ------------------------ + + procedure Unlink_Next_Entity (Id : Entity_Id) is + Next : constant Entity_Id := Next_Entity (Id); + + begin + if Present (Next) then + Set_Prev_Entity (Next, Empty); -- Empty <-- Next + end if; + + Set_Next_Entity (Id, Empty); -- Id --> Empty + end Unlink_Next_Entity; + + ------------------------ -- Write_Entity_Flags -- ------------------------ @@ -9601,6 +9789,7 @@ W ("Is_Abstract_Subprogram", Flag19 (Id)); W ("Is_Abstract_Type", Flag146 (Id)); W ("Is_Access_Constant", Flag69 (Id)); + W ("Is_Activation_Record", Flag305 (Id)); W ("Is_Actual_Subtype", Flag293 (Id)); W ("Is_Ada_2005_Only", Flag185 (Id)); W ("Is_Ada_2012_Only", Flag199 (Id)); @@ -9630,6 +9819,7 @@ W ("Is_Dispatch_Table_Entity", Flag234 (Id)); W ("Is_Dispatching_Operation", Flag6 (Id)); W ("Is_Elaboration_Checks_OK_Id", Flag148 (Id)); + W ("Is_Elaboration_Warnings_OK_Id", Flag304 (Id)); W ("Is_Eliminated", Flag124 (Id)); W ("Is_Entry_Formal", Flag52 (Id)); W ("Is_Exception_Handler", Flag286 (Id)); @@ -9669,6 +9859,7 @@ W ("Is_Limited_Interface", Flag197 (Id)); W ("Is_Limited_Record", Flag25 (Id)); W ("Is_Local_Anonymous_Access", Flag194 (Id)); + W ("Is_Loop_Parameter", Flag307 (Id)); W ("Is_Machine_Code_Subprogram", Flag137 (Id)); W ("Is_Non_Static_Subtype", Flag109 (Id)); W ("Is_Null_Init_Proc", Flag178 (Id)); @@ -9727,6 +9918,7 @@ W ("May_Inherit_Delayed_Rep_Aspects", Flag262 (Id)); W ("Must_Be_On_Byte_Boundary", Flag183 (Id)); W ("Must_Have_Preelab_Init", Flag208 (Id)); + W ("Needs_Activation_Record", Flag306 (Id)); W ("Needs_Debug_Info", Flag147 (Id)); W ("Needs_No_Actuals", Flag22 (Id)); W ("Never_Set_In_Source", Flag115 (Id)); @@ -9765,6 +9957,7 @@ W ("Static_Elaboration_Desired", Flag77 (Id)); W ("Stores_Attribute_Old_Prefix", Flag270 (Id)); W ("Strict_Alignment", Flag145 (Id)); + W ("Suppress_Elaboration_Warnings", Flag303 (Id)); W ("Suppress_Initialization", Flag105 (Id)); W ("Suppress_Style_Checks", Flag165 (Id)); W ("Suppress_Value_Tracking_On_Call", Flag217 (Id)); @@ -10136,7 +10329,9 @@ => Write_Str ("Component_Clause"); - when E_Function + when E_Entry + | E_Entry_Family + | E_Function | E_Procedure | E_Package | Generic_Unit_Kind @@ -10184,11 +10379,6 @@ => Write_Str ("Postconditions_Proc"); - when E_Generic_Package - | E_Package - => - Write_Str ("Shadow_Entities"); - when others => Write_Str ("Field14??"); end case; @@ -10624,15 +10814,6 @@ when E_Enumeration_Literal => Write_Str ("Enumeration_Rep_Expr"); - when E_Limited_Private_Subtype - | E_Limited_Private_Type - | E_Private_Subtype - | E_Private_Type - | E_Record_Subtype_With_Private - | E_Record_Type_With_Private - => - Write_Str ("Private_View"); - when Formal_Kind => Write_Str ("Protected_Formal"); @@ -10736,6 +10917,9 @@ procedure Write_Field24_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Package => + Write_Str ("Incomplete_Actuals"); + when Type_Kind | E_Constant | E_Variable @@ -10748,9 +10932,6 @@ => Write_Str ("Subps_Index"); - when E_Package => - Write_Str ("Incomplete_Actuals"); - when others => Write_Str ("Field24???"); end case; @@ -11116,14 +11297,9 @@ ------------------------ procedure Write_Field36_Name (Id : Entity_Id) is - begin - case Ekind (Id) is - when E_Variable => - Write_Str ("Validated_Object"); - - when others => - Write_Str ("Field36??"); - end case; + pragma Unreferenced (Id); + begin + Write_Str ("Prev_Entity"); end Write_Field36_Name; ------------------------ @@ -11146,7 +11322,16 @@ when E_Function | E_Procedure => - Write_Str ("class-wide clone"); + Write_Str ("Class_Wide_Clone"); + + when E_Array_Subtype + | E_Record_Subtype + | E_Record_Subtype_With_Private + => + Write_Str ("Predicated_Parent"); + + when E_Variable => + Write_Str ("Validated_Object"); when others => Write_Str ("Field38??"); @@ -11177,7 +11362,8 @@ procedure Write_Field40_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Constant + when E_Abstract_State + | E_Constant | E_Entry | E_Entry_Family | E_Function @@ -11189,12 +11375,11 @@ | E_Package_Body | E_Procedure | E_Protected_Body - | E_Protected_Type | E_Subprogram_Body | E_Task_Body - | E_Task_Type | E_Variable | E_Void + | Type_Kind => Write_Str ("SPARK_Pragma");