diff options
| -rw-r--r-- | gcc/ada/einfo.adb | 1681 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 3326 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 1154 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 918 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.ads | 80 | ||||
| -rw-r--r-- | gcc/ada/exp_ch8.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.adb | 330 | ||||
| -rw-r--r-- | gcc/ada/s-finimp.adb | 130 | ||||
| -rw-r--r-- | gcc/ada/s-finimp.ads | 94 | ||||
| -rw-r--r-- | gcc/ada/s-taskin.ads | 23 | ||||
| -rw-r--r-- | gcc/ada/s-tassta.adb | 79 | ||||
| -rw-r--r-- | gcc/ada/s-tassta.ads | 20 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 372 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.ads | 23 |
14 files changed, 4576 insertions, 3671 deletions
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 51c97daaaeb..8707301143a 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -238,240 +238,240 @@ package body Einfo is -- are used for the flags Analyzed, Comes_From_Source, and Error_Posted, -- which are common to all nodes, including entity nodes. - -- Is_Frozen Flag4 - -- Has_Discriminants Flag5 - -- Is_Dispatching_Operation Flag6 - -- Is_Immediately_Visible Flag7 - -- In_Use Flag8 - -- Is_Potentially_Use_Visible Flag9 - -- Is_Public Flag10 - - -- Is_Inlined Flag11 - -- Is_Constrained Flag12 - -- Is_Generic_Type Flag13 - -- Depends_On_Private Flag14 - -- Is_Aliased Flag15 - -- Is_Volatile Flag16 - -- Is_Internal Flag17 - -- Has_Delayed_Freeze Flag18 - -- Is_Abstract Flag19 - -- Is_Concurrent_Record_Type Flag20 - - -- Has_Master_Entity Flag21 - -- Needs_No_Actuals Flag22 - -- Has_Storage_Size_Clause Flag23 - -- Is_Imported Flag24 - -- Is_Limited_Record Flag25 - -- Has_Completion Flag26 - -- Has_Pragma_Controlled Flag27 - -- Is_Statically_Allocated Flag28 - -- Has_Size_Clause Flag29 - -- Has_Task Flag30 - - -- Checks_May_Be_Suppressed Flag31 - -- Kill_Elaboration_Checks Flag32 - -- Kill_Range_Checks Flag33 - -- Kill_Tag_Checks Flag34 - -- Is_Class_Wide_Equivalent_Type Flag35 - -- Referenced_As_LHS Flag36 - -- Is_Known_Non_Null Flag37 - -- Can_Never_Be_Null Flag38 - -- Is_Overriding_Operation Flag39 - -- Body_Needed_For_SAL Flag40 - - -- Treat_As_Volatile Flag41 - -- Is_Controlled Flag42 - -- Has_Controlled_Component Flag43 - -- Is_Pure Flag44 - -- In_Private_Part Flag45 - -- Has_Alignment_Clause Flag46 - -- Has_Exit Flag47 - -- In_Package_Body Flag48 - -- Reachable Flag49 - -- Delay_Subprogram_Descriptors Flag50 - - -- Is_Packed Flag51 - -- Is_Entry_Formal Flag52 - -- Is_Private_Descendant Flag53 - -- Return_Present Flag54 - -- Is_Tagged_Type Flag55 - -- Has_Homonym Flag56 - -- Is_Hidden Flag57 - -- Non_Binary_Modulus Flag58 - -- Is_Preelaborated Flag59 - -- Is_Shared_Passive Flag60 - - -- Is_Remote_Types Flag61 - -- Is_Remote_Call_Interface Flag62 - -- Is_Character_Type Flag63 - -- Is_Intrinsic_Subprogram Flag64 - -- Has_Record_Rep_Clause Flag65 - -- Has_Enumeration_Rep_Clause Flag66 - -- Has_Small_Clause Flag67 - -- Has_Component_Size_Clause Flag68 - -- Is_Access_Constant Flag69 - -- Is_First_Subtype Flag70 - - -- Has_Completion_In_Body Flag71 - -- Has_Unknown_Discriminants Flag72 - -- Is_Child_Unit Flag73 - -- Is_CPP_Class Flag74 - -- Has_Non_Standard_Rep Flag75 - -- Is_Constructor Flag76 - -- Is_Thread_Body Flag77 - -- Is_Tag Flag78 - -- Has_All_Calls_Remote Flag79 - -- Is_Constr_Subt_For_U_Nominal Flag80 - - -- Is_Asynchronous Flag81 - -- Has_Gigi_Rep_Item Flag82 - -- Has_Machine_Radix_Clause Flag83 - -- Machine_Radix_10 Flag84 - -- Is_Atomic Flag85 - -- Has_Atomic_Components Flag86 - -- Has_Volatile_Components Flag87 - -- Discard_Names Flag88 - -- Is_Interrupt_Handler Flag89 - -- Returns_By_Ref Flag90 - - -- Is_Itype Flag91 - -- Size_Known_At_Compile_Time Flag92 - -- Has_Subprogram_Descriptor Flag93 - -- Is_Generic_Actual_Type Flag94 - -- Uses_Sec_Stack Flag95 - -- Warnings_Off Flag96 - -- Is_Controlling_Formal Flag97 - -- Has_Controlling_Result Flag98 - -- Is_Exported Flag99 - -- Has_Specified_Layout Flag100 - - -- Has_Nested_Block_With_Handler Flag101 - -- Is_Called Flag102 - -- Is_Completely_Hidden Flag103 - -- Address_Taken Flag104 - -- Suppress_Init_Proc Flag105 - -- Is_Limited_Composite Flag106 - -- Is_Private_Composite Flag107 - -- Default_Expressions_Processed Flag108 - -- Is_Non_Static_Subtype Flag109 - -- Has_External_Tag_Rep_Clause Flag110 - - -- Is_Formal_Subprogram Flag111 - -- Is_Renaming_Of_Object Flag112 - -- No_Return Flag113 - -- Delay_Cleanups Flag114 - -- Never_Set_In_Source Flag115 - -- Is_Visible_Child_Unit Flag116 - -- Is_Unchecked_Union Flag117 - -- Is_For_Access_Subtype Flag118 - -- Has_Convention_Pragma Flag119 - -- Has_Primitive_Operations Flag120 - - -- Has_Pragma_Pack Flag121 - -- Is_Bit_Packed_Array Flag122 - -- Has_Unchecked_Union Flag123 - -- Is_Eliminated Flag124 - -- C_Pass_By_Copy Flag125 - -- Is_Instantiated Flag126 - -- Is_Valued_Procedure Flag127 - -- (used for Component_Alignment) Flag128 - -- (used for Component_Alignment) Flag129 - -- Is_Generic_Instance Flag130 - - -- No_Pool_Assigned Flag131 - -- Is_AST_Entry Flag132 - -- Is_VMS_Exception Flag133 - -- Is_Optional_Parameter Flag134 - -- Has_Aliased_Components Flag135 - -- No_Strict_Aliasing Flag136 - -- Is_Machine_Code_Subprogram Flag137 - -- Is_Packed_Array_Type Flag138 - -- Has_Biased_Representation Flag139 - -- Has_Complex_Representation Flag140 - - -- Is_Constr_Subt_For_UN_Aliased Flag141 - -- Has_Missing_Return Flag142 - -- Has_Recursive_Call Flag143 - -- Is_Unsigned_Type Flag144 - -- Strict_Alignment Flag145 - -- (unused) Flag146 - -- Needs_Debug_Info Flag147 - -- Suppress_Elaboration_Warnings Flag148 - -- Is_Compilation_Unit Flag149 - -- Has_Pragma_Elaborate_Body Flag150 - - -- Vax_Float Flag151 - -- Entry_Accepted Flag152 - -- Is_Obsolescent Flag153 - -- Has_Per_Object_Constraint Flag154 - -- Has_Private_Declaration Flag155 - -- Referenced Flag156 - -- Has_Pragma_Inline Flag157 - -- Finalize_Storage_Only Flag158 - -- From_With_Type Flag159 - -- Is_Package_Body_Entity Flag160 - - -- Has_Qualified_Name Flag161 - -- Nonzero_Is_True Flag162 - -- Is_True_Constant Flag163 - -- Reverse_Bit_Order Flag164 - -- Suppress_Style_Checks Flag165 - -- Debug_Info_Off Flag166 - -- Sec_Stack_Needed_For_Return Flag167 - -- Materialize_Entity Flag168 - -- Function_Returns_With_DSP Flag169 - -- Is_Known_Valid Flag170 - - -- Is_Hidden_Open_Scope Flag171 - -- Has_Object_Size_Clause Flag172 - -- Has_Fully_Qualified_Name Flag173 - -- Elaboration_Entity_Required Flag174 - -- Has_Forward_Instantiation Flag175 - -- Is_Discrim_SO_Function Flag176 - -- Size_Depends_On_Discriminant Flag177 - -- Is_Null_Init_Proc Flag178 - -- Has_Pragma_Pure_Function Flag179 - -- Has_Pragma_Unreferenced Flag180 - - -- Has_Contiguous_Rep Flag181 - -- Has_Xref_Entry Flag182 - -- Must_Be_On_Byte_Boundary Flag183 - -- Has_Stream_Size_Clause Flag184 - -- Is_Ada_2005_Only Flag185 - -- Is_Interface Flag186 - -- Has_Constrained_Partial_View Flag187 - -- Has_Persistent_BSS Flag188 - -- Is_Pure_Unit_Access_Type Flag189 - -- Has_Specified_Stream_Input Flag190 - - -- Has_Specified_Stream_Output Flag191 - -- Has_Specified_Stream_Read Flag192 - -- Has_Specified_Stream_Write Flag193 - -- Is_Local_Anonymous_Access Flag194 - -- Is_Primitive_Wrapper Flag195 - -- Was_Hidden Flag196 - -- Is_Limited_Interface Flag197 - -- Is_Protected_Interface Flag198 - -- Is_Synchronized_Interface Flag199 - -- Is_Task_Interface Flag200 - - -- Has_Anon_Block_Suffix Flag201 - -- Itype_Printed Flag202 - -- Has_Pragma_Pure Flag203 - -- Is_Known_Null Flag204 - -- Low_Bound_Known Flag205 - -- Is_Visible_Formal Flag206 - -- Known_To_Have_Preelab_Init Flag207 - -- Must_Have_Preelab_Init Flag208 - -- Is_Return_Object Flag209 - -- Elaborate_Body_Desirable Flag210 - - -- Has_Static_Discriminants Flag211 - - -- (unused) Flag212 - -- (unused) Flag213 - -- (unused) Flag214 - -- (unused) Flag215 + -- Is_Frozen Flag4 + -- Has_Discriminants Flag5 + -- Is_Dispatching_Operation Flag6 + -- Is_Immediately_Visible Flag7 + -- In_Use Flag8 + -- Is_Potentially_Use_Visible Flag9 + -- Is_Public Flag10 + + -- Is_Inlined Flag11 + -- Is_Constrained Flag12 + -- Is_Generic_Type Flag13 + -- Depends_On_Private Flag14 + -- Is_Aliased Flag15 + -- Is_Volatile Flag16 + -- Is_Internal Flag17 + -- Has_Delayed_Freeze Flag18 + -- Is_Abstract_Subprogram Flag19 + -- Is_Concurrent_Record_Type Flag20 + + -- Has_Master_Entity Flag21 + -- Needs_No_Actuals Flag22 + -- Has_Storage_Size_Clause Flag23 + -- Is_Imported Flag24 + -- Is_Limited_Record Flag25 + -- Has_Completion Flag26 + -- Has_Pragma_Controlled Flag27 + -- Is_Statically_Allocated Flag28 + -- Has_Size_Clause Flag29 + -- Has_Task Flag30 + + -- Checks_May_Be_Suppressed Flag31 + -- Kill_Elaboration_Checks Flag32 + -- Kill_Range_Checks Flag33 + -- Kill_Tag_Checks Flag34 + -- Is_Class_Wide_Equivalent_Type Flag35 + -- Referenced_As_LHS Flag36 + -- Is_Known_Non_Null Flag37 + -- Can_Never_Be_Null Flag38 + -- Is_Overriding_Operation Flag39 + -- Body_Needed_For_SAL Flag40 + + -- Treat_As_Volatile Flag41 + -- Is_Controlled Flag42 + -- Has_Controlled_Component Flag43 + -- Is_Pure Flag44 + -- In_Private_Part Flag45 + -- Has_Alignment_Clause Flag46 + -- Has_Exit Flag47 + -- In_Package_Body Flag48 + -- Reachable Flag49 + -- Delay_Subprogram_Descriptors Flag50 + + -- Is_Packed Flag51 + -- Is_Entry_Formal Flag52 + -- Is_Private_Descendant Flag53 + -- Return_Present Flag54 + -- Is_Tagged_Type Flag55 + -- Has_Homonym Flag56 + -- Is_Hidden Flag57 + -- Non_Binary_Modulus Flag58 + -- Is_Preelaborated Flag59 + -- Is_Shared_Passive Flag60 + + -- Is_Remote_Types Flag61 + -- Is_Remote_Call_Interface Flag62 + -- Is_Character_Type Flag63 + -- Is_Intrinsic_Subprogram Flag64 + -- Has_Record_Rep_Clause Flag65 + -- Has_Enumeration_Rep_Clause Flag66 + -- Has_Small_Clause Flag67 + -- Has_Component_Size_Clause Flag68 + -- Is_Access_Constant Flag69 + -- Is_First_Subtype Flag70 + + -- Has_Completion_In_Body Flag71 + -- Has_Unknown_Discriminants Flag72 + -- Is_Child_Unit Flag73 + -- Is_CPP_Class Flag74 + -- Has_Non_Standard_Rep Flag75 + -- Is_Constructor Flag76 + -- Is_Thread_Body Flag77 + -- Is_Tag Flag78 + -- Has_All_Calls_Remote Flag79 + -- Is_Constr_Subt_For_U_Nominal Flag80 + + -- Is_Asynchronous Flag81 + -- Has_Gigi_Rep_Item Flag82 + -- Has_Machine_Radix_Clause Flag83 + -- Machine_Radix_10 Flag84 + -- Is_Atomic Flag85 + -- Has_Atomic_Components Flag86 + -- Has_Volatile_Components Flag87 + -- Discard_Names Flag88 + -- Is_Interrupt_Handler Flag89 + -- Returns_By_Ref Flag90 + + -- Is_Itype Flag91 + -- Size_Known_At_Compile_Time Flag92 + -- Has_Subprogram_Descriptor Flag93 + -- Is_Generic_Actual_Type Flag94 + -- Uses_Sec_Stack Flag95 + -- Warnings_Off Flag96 + -- Is_Controlling_Formal Flag97 + -- Has_Controlling_Result Flag98 + -- Is_Exported Flag99 + -- Has_Specified_Layout Flag100 + + -- Has_Nested_Block_With_Handler Flag101 + -- Is_Called Flag102 + -- Is_Completely_Hidden Flag103 + -- Address_Taken Flag104 + -- Suppress_Init_Proc Flag105 + -- Is_Limited_Composite Flag106 + -- Is_Private_Composite Flag107 + -- Default_Expressions_Processed Flag108 + -- Is_Non_Static_Subtype Flag109 + -- Has_External_Tag_Rep_Clause Flag110 + + -- Is_Formal_Subprogram Flag111 + -- Is_Renaming_Of_Object Flag112 + -- No_Return Flag113 + -- Delay_Cleanups Flag114 + -- Never_Set_In_Source Flag115 + -- Is_Visible_Child_Unit Flag116 + -- Is_Unchecked_Union Flag117 + -- Is_For_Access_Subtype Flag118 + -- Has_Convention_Pragma Flag119 + -- Has_Primitive_Operations Flag120 + + -- Has_Pragma_Pack Flag121 + -- Is_Bit_Packed_Array Flag122 + -- Has_Unchecked_Union Flag123 + -- Is_Eliminated Flag124 + -- C_Pass_By_Copy Flag125 + -- Is_Instantiated Flag126 + -- Is_Valued_Procedure Flag127 + -- (used for Component_Alignment) Flag128 + -- (used for Component_Alignment) Flag129 + -- Is_Generic_Instance Flag130 + + -- No_Pool_Assigned Flag131 + -- Is_AST_Entry Flag132 + -- Is_VMS_Exception Flag133 + -- Is_Optional_Parameter Flag134 + -- Has_Aliased_Components Flag135 + -- No_Strict_Aliasing Flag136 + -- Is_Machine_Code_Subprogram Flag137 + -- Is_Packed_Array_Type Flag138 + -- Has_Biased_Representation Flag139 + -- Has_Complex_Representation Flag140 + + -- Is_Constr_Subt_For_UN_Aliased Flag141 + -- Has_Missing_Return Flag142 + -- Has_Recursive_Call Flag143 + -- Is_Unsigned_Type Flag144 + -- Strict_Alignment Flag145 + -- Is_Abstract_Type Flag146 + -- Needs_Debug_Info Flag147 + -- Suppress_Elaboration_Warnings Flag148 + -- Is_Compilation_Unit Flag149 + -- Has_Pragma_Elaborate_Body Flag150 + + -- Vax_Float Flag151 + -- Entry_Accepted Flag152 + -- Is_Obsolescent Flag153 + -- Has_Per_Object_Constraint Flag154 + -- Has_Private_Declaration Flag155 + -- Referenced Flag156 + -- Has_Pragma_Inline Flag157 + -- Finalize_Storage_Only Flag158 + -- From_With_Type Flag159 + -- Is_Package_Body_Entity Flag160 + + -- Has_Qualified_Name Flag161 + -- Nonzero_Is_True Flag162 + -- Is_True_Constant Flag163 + -- Reverse_Bit_Order Flag164 + -- Suppress_Style_Checks Flag165 + -- Debug_Info_Off Flag166 + -- Sec_Stack_Needed_For_Return Flag167 + -- Materialize_Entity Flag168 + -- Function_Returns_With_DSP Flag169 + -- Is_Known_Valid Flag170 + + -- Is_Hidden_Open_Scope Flag171 + -- Has_Object_Size_Clause Flag172 + -- Has_Fully_Qualified_Name Flag173 + -- Elaboration_Entity_Required Flag174 + -- Has_Forward_Instantiation Flag175 + -- Is_Discrim_SO_Function Flag176 + -- Size_Depends_On_Discriminant Flag177 + -- Is_Null_Init_Proc Flag178 + -- Has_Pragma_Pure_Function Flag179 + -- Has_Pragma_Unreferenced Flag180 + + -- Has_Contiguous_Rep Flag181 + -- Has_Xref_Entry Flag182 + -- Must_Be_On_Byte_Boundary Flag183 + -- Has_Stream_Size_Clause Flag184 + -- Is_Ada_2005_Only Flag185 + -- Is_Interface Flag186 + -- Has_Constrained_Partial_View Flag187 + -- Has_Persistent_BSS Flag188 + -- Is_Pure_Unit_Access_Type Flag189 + -- Has_Specified_Stream_Input Flag190 + + -- Has_Specified_Stream_Output Flag191 + -- Has_Specified_Stream_Read Flag192 + -- Has_Specified_Stream_Write Flag193 + -- Is_Local_Anonymous_Access Flag194 + -- Is_Primitive_Wrapper Flag195 + -- Was_Hidden Flag196 + -- Is_Limited_Interface Flag197 + -- Is_Protected_Interface Flag198 + -- Is_Synchronized_Interface Flag199 + -- Is_Task_Interface Flag200 + + -- Has_Anon_Block_Suffix Flag201 + -- Itype_Printed Flag202 + -- Has_Pragma_Pure Flag203 + -- Is_Known_Null Flag204 + -- Low_Bound_Known Flag205 + -- Is_Visible_Formal Flag206 + -- Known_To_Have_Preelab_Init Flag207 + -- Must_Have_Preelab_Init Flag208 + -- Is_Return_Object Flag209 + -- Elaborate_Body_Desirable Flag210 + + -- Has_Static_Discriminants Flag211 + -- Has_Pragma_Unreferenced_Objects Flag212 + -- Requires_Overriding Flag213 + -- Has_RACW Flag214 + + -- (unused) Flag215 ----------------------- -- Local subprograms -- @@ -509,12 +509,7 @@ package body Einfo is function Abstract_Interfaces (Id : E) return L is begin - pragma Assert - (Ekind (Id) = E_Record_Type - or else Ekind (Id) = E_Record_Subtype - or else Ekind (Id) = E_Record_Type_With_Private - or else Ekind (Id) = E_Record_Subtype_With_Private - or else Ekind (Id) = E_Class_Wide_Type); + pragma Assert (Is_Record_Type (Id)); return Elist25 (Id); end Abstract_Interfaces; @@ -956,9 +951,10 @@ package body Einfo is function Equivalent_Type (Id : E) return E is begin pragma Assert - (Ekind (Id) = E_Class_Wide_Subtype or else - Ekind (Id) = E_Access_Protected_Subprogram_Type or else - Ekind (Id) = E_Access_Subprogram_Type or else + (Ekind (Id) = E_Class_Wide_Subtype or else + Ekind (Id) = E_Access_Protected_Subprogram_Type or else + Ekind (Id) = E_Anonymous_Access_Protected_Subprogram_Type or else + Ekind (Id) = E_Access_Subprogram_Type or else Ekind (Id) = E_Exception_Type); return Node18 (Id); end Equivalent_Type; @@ -1019,11 +1015,13 @@ package body Einfo is function First_Index (Id : E) return N is begin + pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id)); return Node17 (Id); end First_Index; function First_Literal (Id : E) return E is begin + pragma Assert (Is_Enumeration_Type (Id)); return Node17 (Id); end First_Literal; @@ -1295,6 +1293,12 @@ package body Einfo is return Flag180 (Id); end Has_Pragma_Unreferenced; + function Has_Pragma_Unreferenced_Objects (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag212 (Id); + end Has_Pragma_Unreferenced_Objects; + function Has_Primitive_Operations (Id : E) return B is begin pragma Assert (Is_Type (Id)); @@ -1311,6 +1315,12 @@ package body Einfo is return Flag161 (Id); end Has_Qualified_Name; + function Has_RACW (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Package); + return Flag214 (Id); + end Has_RACW; + function Has_Record_Rep_Clause (Id : E) return B is begin pragma Assert (Is_Record_Type (Id)); @@ -1449,10 +1459,17 @@ package body Einfo is return Node21 (Id); end Interface_Name; - function Is_Abstract (Id : E) return B is + function Is_Abstract_Subprogram (Id : E) return B is begin + pragma Assert (Is_Overloadable (Id)); return Flag19 (Id); - end Is_Abstract; + end Is_Abstract_Subprogram; + + function Is_Abstract_Type (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag146 (Id); + end Is_Abstract_Type; function Is_Local_Anonymous_Access (Id : E) return B is begin @@ -2003,6 +2020,7 @@ package body Einfo is function Master_Id (Id : E) return E is begin + pragma Assert (Is_Access_Type (Id)); return Node17 (Id); end Master_Id; @@ -2084,8 +2102,7 @@ package body Einfo is function Non_Limited_View (Id : E) return E is begin - pragma Assert (False - or else Ekind (Id) in Incomplete_Kind); + pragma Assert (Ekind (Id) in Incomplete_Kind); return Node17 (Id); end Non_Limited_View; @@ -2280,6 +2297,12 @@ package body Einfo is return Uint9 (Id); end Renaming_Map; + function Requires_Overriding (Id : E) return B is + begin + pragma Assert (Is_Overloadable (Id)); + return Flag213 (Id); + end Requires_Overriding; + function Return_Present (Id : E) return B is begin return Flag54 (Id); @@ -2476,6 +2499,11 @@ package body Einfo is return Ekind (Id) in Access_Kind; end Is_Access_Type; + function Is_Access_Protected_Subprogram_Type (Id : E) return B is + begin + return Ekind (Id) in Access_Protected_Kind; + end Is_Access_Protected_Subprogram_Type; + function Is_Array_Type (Id : E) return B is begin return Ekind (Id) in Array_Kind; @@ -2676,12 +2704,7 @@ package body Einfo is procedure Set_Abstract_Interfaces (Id : E; V : L) is begin - pragma Assert - (Ekind (Id) = E_Record_Type - or else Ekind (Id) = E_Record_Subtype - or else Ekind (Id) = E_Record_Type_With_Private - or else Ekind (Id) = E_Record_Subtype_With_Private - or else Ekind (Id) = E_Class_Wide_Type); + pragma Assert (Is_Record_Type (Id)); Set_Elist25 (Id, V); end Set_Abstract_Interfaces; @@ -3130,10 +3153,11 @@ package body Einfo is procedure Set_Equivalent_Type (Id : E; V : E) is begin pragma Assert - (Ekind (Id) = E_Class_Wide_Type or else - Ekind (Id) = E_Class_Wide_Subtype or else - Ekind (Id) = E_Access_Protected_Subprogram_Type or else - Ekind (Id) = E_Access_Subprogram_Type or else + (Ekind (Id) = E_Class_Wide_Type or else + Ekind (Id) = E_Class_Wide_Subtype or else + Ekind (Id) = E_Access_Protected_Subprogram_Type or else + Ekind (Id) = E_Anonymous_Access_Protected_Subprogram_Type or else + Ekind (Id) = E_Access_Subprogram_Type or else Ekind (Id) = E_Exception_Type); Set_Node18 (Id, V); end Set_Equivalent_Type; @@ -3194,11 +3218,13 @@ package body Einfo is procedure Set_First_Index (Id : E; V : N) is begin + pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id)); Set_Node17 (Id, V); end Set_First_Index; procedure Set_First_Literal (Id : E; V : E) is begin + pragma Assert (Is_Enumeration_Type (Id)); Set_Node17 (Id, V); end Set_First_Literal; @@ -3479,6 +3505,12 @@ package body Einfo is Set_Flag180 (Id, V); end Set_Has_Pragma_Unreferenced; + procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag212 (Id, V); + end Set_Has_Pragma_Unreferenced_Objects; + procedure Set_Has_Primitive_Operations (Id : E; V : B := True) is begin pragma Assert (Id = Base_Type (Id)); @@ -3495,6 +3527,12 @@ package body Einfo is Set_Flag161 (Id, V); end Set_Has_Qualified_Name; + procedure Set_Has_RACW (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Package); + Set_Flag214 (Id, V); + end Set_Has_RACW; + procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True) is begin pragma Assert (Id = Base_Type (Id)); @@ -3637,10 +3675,17 @@ package body Einfo is Set_Node21 (Id, V); end Set_Interface_Name; - procedure Set_Is_Abstract (Id : E; V : B := True) is + procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True) is begin + pragma Assert (Is_Overloadable (Id)); Set_Flag19 (Id, V); - end Set_Is_Abstract; + end Set_Is_Abstract_Subprogram; + + procedure Set_Is_Abstract_Type (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag146 (Id, V); + end Set_Is_Abstract_Type; procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True) is begin @@ -4219,6 +4264,7 @@ package body Einfo is procedure Set_Master_Id (Id : E; V : E) is begin + pragma Assert (Is_Access_Type (Id)); Set_Node17 (Id, V); end Set_Master_Id; @@ -4304,8 +4350,7 @@ package body Einfo is procedure Set_Non_Limited_View (Id : E; V : E) is begin - pragma Assert (False - or else Ekind (Id) in Incomplete_Kind); + pragma Assert (Ekind (Id) in Incomplete_Kind); Set_Node17 (Id, V); end Set_Non_Limited_View; @@ -4502,6 +4547,12 @@ package body Einfo is Set_Uint9 (Id, V); end Set_Renaming_Map; + procedure Set_Requires_Overriding (Id : E; V : B := True) is + begin + pragma Assert (Is_Overloadable (Id)); + Set_Flag213 (Id, V); + end Set_Requires_Overriding; + procedure Set_Return_Present (Id : E; V : B := True) is begin Set_Flag54 (Id, V); @@ -5252,7 +5303,7 @@ package body Einfo is end Entry_Index_Type; --------------------- - -- 1 -- + -- First_Component -- --------------------- function First_Component (Id : E) return E is @@ -5271,6 +5322,28 @@ package body Einfo is return Comp_Id; end First_Component; + ------------------------------------- + -- First_Component_Or_Discriminant -- + ------------------------------------- + + function First_Component_Or_Discriminant (Id : E) return E is + Comp_Id : E; + + begin + pragma Assert + (Is_Record_Type (Id) or else Is_Incomplete_Or_Private_Type (Id)); + + Comp_Id := First_Entity (Id); + while Present (Comp_Id) loop + exit when Ekind (Comp_Id) = E_Component + or else + Ekind (Comp_Id) = E_Discriminant; + Comp_Id := Next_Entity (Comp_Id); + end loop; + + return Comp_Id; + end First_Component_Or_Discriminant; + ------------------------ -- First_Discriminant -- ------------------------ @@ -6132,6 +6205,25 @@ package body Einfo is return Comp_Id; end Next_Component; + ------------------------------------ + -- Next_Component_Or_Discriminant -- + ------------------------------------ + + function Next_Component_Or_Discriminant (Id : E) return E is + Comp_Id : E; + + begin + Comp_Id := Next_Entity (Id); + while Present (Comp_Id) loop + exit when Ekind (Comp_Id) = E_Component + or else + Ekind (Comp_Id) = E_Discriminant; + Comp_Id := Next_Entity (Comp_Id); + end loop; + + return Comp_Id; + end Next_Component_Or_Discriminant; + ----------------------- -- Next_Discriminant -- ----------------------- @@ -6182,10 +6274,10 @@ package body Einfo is P : E; begin - -- Follow the chain of declared entities as long as the kind of - -- the entity corresponds to a formal parameter. Skip internal - -- entities that may have been created for implicit subtypes, - -- in the process of analyzing default expressions. + -- Follow the chain of declared entities as long as the kind of the + -- entity corresponds to a formal parameter. Skip internal entities + -- that may have been created for implicit subtypes, in the process + -- of analyzing default expressions. P := Id; @@ -6765,210 +6857,214 @@ package body Einfo is Write_Eol; end if; - W ("Address_Taken", Flag104 (Id)); - W ("Body_Needed_For_SAL", Flag40 (Id)); - W ("C_Pass_By_Copy", Flag125 (Id)); - W ("Can_Never_Be_Null", Flag38 (Id)); - W ("Checks_May_Be_Suppressed", Flag31 (Id)); - W ("Debug_Info_Off", Flag166 (Id)); - W ("Default_Expressions_Processed", Flag108 (Id)); - W ("Delay_Cleanups", Flag114 (Id)); - W ("Delay_Subprogram_Descriptors", Flag50 (Id)); - W ("Depends_On_Private", Flag14 (Id)); - W ("Discard_Names", Flag88 (Id)); - W ("Elaboration_Entity_Required", Flag174 (Id)); - W ("Elaborate_Body_Desirable", Flag210 (Id)); - W ("Entry_Accepted", Flag152 (Id)); - W ("Finalize_Storage_Only", Flag158 (Id)); - W ("From_With_Type", Flag159 (Id)); - W ("Function_Returns_With_DSP", Flag169 (Id)); - W ("Has_Aliased_Components", Flag135 (Id)); - W ("Has_Alignment_Clause", Flag46 (Id)); - W ("Has_All_Calls_Remote", Flag79 (Id)); - W ("Has_Anon_Block_Suffix", Flag201 (Id)); - W ("Has_Atomic_Components", Flag86 (Id)); - W ("Has_Biased_Representation", Flag139 (Id)); - W ("Has_Completion", Flag26 (Id)); - W ("Has_Completion_In_Body", Flag71 (Id)); - W ("Has_Complex_Representation", Flag140 (Id)); - W ("Has_Component_Size_Clause", Flag68 (Id)); - W ("Has_Contiguous_Rep", Flag181 (Id)); - W ("Has_Controlled_Component", Flag43 (Id)); - W ("Has_Controlling_Result", Flag98 (Id)); - W ("Has_Convention_Pragma", Flag119 (Id)); - W ("Has_Delayed_Freeze", Flag18 (Id)); - W ("Has_Discriminants", Flag5 (Id)); - W ("Has_Enumeration_Rep_Clause", Flag66 (Id)); - W ("Has_Exit", Flag47 (Id)); - W ("Has_External_Tag_Rep_Clause", Flag110 (Id)); - W ("Has_Forward_Instantiation", Flag175 (Id)); - W ("Has_Fully_Qualified_Name", Flag173 (Id)); - W ("Has_Gigi_Rep_Item", Flag82 (Id)); - W ("Has_Homonym", Flag56 (Id)); - W ("Has_Machine_Radix_Clause", Flag83 (Id)); - W ("Has_Master_Entity", Flag21 (Id)); - W ("Has_Missing_Return", Flag142 (Id)); - W ("Has_Nested_Block_With_Handler", Flag101 (Id)); - W ("Has_Non_Standard_Rep", Flag75 (Id)); - W ("Has_Object_Size_Clause", Flag172 (Id)); - W ("Has_Per_Object_Constraint", Flag154 (Id)); - W ("Has_Persistent_BSS", Flag188 (Id)); - W ("Has_Pragma_Controlled", Flag27 (Id)); - W ("Has_Pragma_Elaborate_Body", Flag150 (Id)); - W ("Has_Pragma_Inline", Flag157 (Id)); - W ("Has_Pragma_Pack", Flag121 (Id)); - W ("Has_Pragma_Pure", Flag203 (Id)); - W ("Has_Pragma_Pure_Function", Flag179 (Id)); - W ("Has_Pragma_Unreferenced", Flag180 (Id)); - W ("Has_Primitive_Operations", Flag120 (Id)); - W ("Has_Private_Declaration", Flag155 (Id)); - W ("Has_Qualified_Name", Flag161 (Id)); - W ("Has_Record_Rep_Clause", Flag65 (Id)); - W ("Has_Recursive_Call", Flag143 (Id)); - W ("Has_Size_Clause", Flag29 (Id)); - W ("Has_Small_Clause", Flag67 (Id)); - W ("Has_Specified_Layout", Flag100 (Id)); - W ("Has_Specified_Stream_Input", Flag190 (Id)); - W ("Has_Specified_Stream_Output", Flag191 (Id)); - W ("Has_Specified_Stream_Read", Flag192 (Id)); - W ("Has_Specified_Stream_Write", Flag193 (Id)); - W ("Has_Static_Discriminants", Flag211 (Id)); - W ("Has_Storage_Size_Clause", Flag23 (Id)); - W ("Has_Stream_Size_Clause", Flag184 (Id)); - W ("Has_Subprogram_Descriptor", Flag93 (Id)); - W ("Has_Task", Flag30 (Id)); - W ("Has_Unchecked_Union", Flag123 (Id)); - W ("Has_Unknown_Discriminants", Flag72 (Id)); - W ("Has_Volatile_Components", Flag87 (Id)); - W ("Has_Xref_Entry", Flag182 (Id)); - W ("In_Package_Body", Flag48 (Id)); - W ("In_Private_Part", Flag45 (Id)); - W ("In_Use", Flag8 (Id)); - W ("Is_AST_Entry", Flag132 (Id)); - W ("Is_Abstract", Flag19 (Id)); - W ("Is_Local_Anonymous_Access", Flag194 (Id)); - W ("Is_Access_Constant", Flag69 (Id)); - W ("Is_Ada_2005_Only", Flag185 (Id)); - W ("Is_Aliased", Flag15 (Id)); - W ("Is_Asynchronous", Flag81 (Id)); - W ("Is_Atomic", Flag85 (Id)); - W ("Is_Bit_Packed_Array", Flag122 (Id)); - W ("Is_CPP_Class", Flag74 (Id)); - W ("Is_Called", Flag102 (Id)); - W ("Is_Character_Type", Flag63 (Id)); - W ("Is_Child_Unit", Flag73 (Id)); - W ("Is_Class_Wide_Equivalent_Type", Flag35 (Id)); - W ("Is_Compilation_Unit", Flag149 (Id)); - W ("Is_Completely_Hidden", Flag103 (Id)); - W ("Is_Concurrent_Record_Type", Flag20 (Id)); - W ("Is_Constr_Subt_For_UN_Aliased", Flag141 (Id)); - W ("Is_Constr_Subt_For_U_Nominal", Flag80 (Id)); - W ("Is_Constrained", Flag12 (Id)); - W ("Is_Constructor", Flag76 (Id)); - W ("Is_Controlled", Flag42 (Id)); - W ("Is_Controlling_Formal", Flag97 (Id)); - W ("Is_Discrim_SO_Function", Flag176 (Id)); - W ("Is_Dispatching_Operation", Flag6 (Id)); - W ("Is_Eliminated", Flag124 (Id)); - W ("Is_Entry_Formal", Flag52 (Id)); - W ("Is_Exported", Flag99 (Id)); - W ("Is_First_Subtype", Flag70 (Id)); - W ("Is_For_Access_Subtype", Flag118 (Id)); - W ("Is_Formal_Subprogram", Flag111 (Id)); - W ("Is_Frozen", Flag4 (Id)); - W ("Is_Generic_Actual_Type", Flag94 (Id)); - W ("Is_Generic_Instance", Flag130 (Id)); - W ("Is_Generic_Type", Flag13 (Id)); - W ("Is_Hidden", Flag57 (Id)); - W ("Is_Hidden_Open_Scope", Flag171 (Id)); - W ("Is_Immediately_Visible", Flag7 (Id)); - W ("Is_Imported", Flag24 (Id)); - W ("Is_Inlined", Flag11 (Id)); - W ("Is_Instantiated", Flag126 (Id)); - W ("Is_Interface", Flag186 (Id)); - W ("Is_Internal", Flag17 (Id)); - W ("Is_Interrupt_Handler", Flag89 (Id)); - W ("Is_Intrinsic_Subprogram", Flag64 (Id)); - W ("Is_Itype", Flag91 (Id)); - W ("Is_Known_Non_Null", Flag37 (Id)); - W ("Is_Known_Null", Flag204 (Id)); - W ("Is_Known_Valid", Flag170 (Id)); - W ("Is_Limited_Composite", Flag106 (Id)); - W ("Is_Limited_Interface", Flag197 (Id)); - W ("Is_Limited_Record", Flag25 (Id)); - W ("Is_Machine_Code_Subprogram", Flag137 (Id)); - W ("Is_Non_Static_Subtype", Flag109 (Id)); - W ("Is_Null_Init_Proc", Flag178 (Id)); - W ("Is_Obsolescent", Flag153 (Id)); - W ("Is_Optional_Parameter", Flag134 (Id)); - W ("Is_Overriding_Operation", Flag39 (Id)); - W ("Is_Package_Body_Entity", Flag160 (Id)); - W ("Is_Packed", Flag51 (Id)); - W ("Is_Packed_Array_Type", Flag138 (Id)); - W ("Is_Potentially_Use_Visible", Flag9 (Id)); - W ("Is_Preelaborated", Flag59 (Id)); - W ("Is_Primitive_Wrapper", Flag195 (Id)); - W ("Is_Private_Composite", Flag107 (Id)); - W ("Is_Private_Descendant", Flag53 (Id)); - W ("Is_Protected_Interface", Flag198 (Id)); - W ("Is_Public", Flag10 (Id)); - W ("Is_Pure", Flag44 (Id)); - W ("Is_Pure_Unit_Access_Type", Flag189 (Id)); - W ("Is_Remote_Call_Interface", Flag62 (Id)); - W ("Is_Remote_Types", Flag61 (Id)); - W ("Is_Renaming_Of_Object", Flag112 (Id)); - W ("Is_Return_Object", Flag209 (Id)); - W ("Is_Shared_Passive", Flag60 (Id)); - W ("Is_Synchronized_Interface", Flag199 (Id)); - W ("Is_Statically_Allocated", Flag28 (Id)); - W ("Is_Tag", Flag78 (Id)); - W ("Is_Tagged_Type", Flag55 (Id)); - W ("Is_Task_Interface", Flag200 (Id)); - W ("Is_Thread_Body", Flag77 (Id)); - W ("Is_True_Constant", Flag163 (Id)); - W ("Is_Unchecked_Union", Flag117 (Id)); - W ("Is_Unsigned_Type", Flag144 (Id)); - W ("Is_VMS_Exception", Flag133 (Id)); - W ("Is_Valued_Procedure", Flag127 (Id)); - W ("Is_Visible_Child_Unit", Flag116 (Id)); - W ("Is_Visible_Formal", Flag206 (Id)); - W ("Is_Volatile", Flag16 (Id)); - W ("Itype_Printed", Flag202 (Id)); - W ("Kill_Elaboration_Checks", Flag32 (Id)); - W ("Kill_Range_Checks", Flag33 (Id)); - W ("Kill_Tag_Checks", Flag34 (Id)); - W ("Known_To_Have_Preelab_Init", Flag207 (Id)); - W ("Low_Bound_Known", Flag205 (Id)); - W ("Machine_Radix_10", Flag84 (Id)); - W ("Materialize_Entity", Flag168 (Id)); - W ("Must_Be_On_Byte_Boundary", Flag183 (Id)); - W ("Must_Have_Preelab_Init", Flag208 (Id)); - W ("Needs_Debug_Info", Flag147 (Id)); - W ("Needs_No_Actuals", Flag22 (Id)); - W ("Never_Set_In_Source", Flag115 (Id)); - W ("No_Pool_Assigned", Flag131 (Id)); - W ("No_Return", Flag113 (Id)); - W ("No_Strict_Aliasing", Flag136 (Id)); - W ("Non_Binary_Modulus", Flag58 (Id)); - W ("Nonzero_Is_True", Flag162 (Id)); - W ("Reachable", Flag49 (Id)); - W ("Referenced", Flag156 (Id)); - W ("Referenced_As_LHS", Flag36 (Id)); - W ("Return_Present", Flag54 (Id)); - W ("Returns_By_Ref", Flag90 (Id)); - W ("Reverse_Bit_Order", Flag164 (Id)); - W ("Sec_Stack_Needed_For_Return", Flag167 (Id)); - W ("Size_Depends_On_Discriminant", Flag177 (Id)); - W ("Size_Known_At_Compile_Time", Flag92 (Id)); - W ("Strict_Alignment", Flag145 (Id)); - W ("Suppress_Elaboration_Warnings", Flag148 (Id)); - W ("Suppress_Init_Proc", Flag105 (Id)); - W ("Suppress_Style_Checks", Flag165 (Id)); - W ("Treat_As_Volatile", Flag41 (Id)); - W ("Uses_Sec_Stack", Flag95 (Id)); - W ("Vax_Float", Flag151 (Id)); - W ("Warnings_Off", Flag96 (Id)); - W ("Was_Hidden", Flag196 (Id)); + W ("Address_Taken", Flag104 (Id)); + W ("Body_Needed_For_SAL", Flag40 (Id)); + W ("C_Pass_By_Copy", Flag125 (Id)); + W ("Can_Never_Be_Null", Flag38 (Id)); + W ("Checks_May_Be_Suppressed", Flag31 (Id)); + W ("Debug_Info_Off", Flag166 (Id)); + W ("Default_Expressions_Processed", Flag108 (Id)); + W ("Delay_Cleanups", Flag114 (Id)); + W ("Delay_Subprogram_Descriptors", Flag50 (Id)); + W ("Depends_On_Private", Flag14 (Id)); + W ("Discard_Names", Flag88 (Id)); + W ("Elaboration_Entity_Required", Flag174 (Id)); + W ("Elaborate_Body_Desirable", Flag210 (Id)); + W ("Entry_Accepted", Flag152 (Id)); + W ("Finalize_Storage_Only", Flag158 (Id)); + W ("From_With_Type", Flag159 (Id)); + W ("Function_Returns_With_DSP", Flag169 (Id)); + W ("Has_Aliased_Components", Flag135 (Id)); + W ("Has_Alignment_Clause", Flag46 (Id)); + W ("Has_All_Calls_Remote", Flag79 (Id)); + W ("Has_Anon_Block_Suffix", Flag201 (Id)); + W ("Has_Atomic_Components", Flag86 (Id)); + W ("Has_Biased_Representation", Flag139 (Id)); + W ("Has_Completion", Flag26 (Id)); + W ("Has_Completion_In_Body", Flag71 (Id)); + W ("Has_Complex_Representation", Flag140 (Id)); + W ("Has_Component_Size_Clause", Flag68 (Id)); + W ("Has_Contiguous_Rep", Flag181 (Id)); + W ("Has_Controlled_Component", Flag43 (Id)); + W ("Has_Controlling_Result", Flag98 (Id)); + W ("Has_Convention_Pragma", Flag119 (Id)); + W ("Has_Delayed_Freeze", Flag18 (Id)); + W ("Has_Discriminants", Flag5 (Id)); + W ("Has_Enumeration_Rep_Clause", Flag66 (Id)); + W ("Has_Exit", Flag47 (Id)); + W ("Has_External_Tag_Rep_Clause", Flag110 (Id)); + W ("Has_Forward_Instantiation", Flag175 (Id)); + W ("Has_Fully_Qualified_Name", Flag173 (Id)); + W ("Has_Gigi_Rep_Item", Flag82 (Id)); + W ("Has_Homonym", Flag56 (Id)); + W ("Has_Machine_Radix_Clause", Flag83 (Id)); + W ("Has_Master_Entity", Flag21 (Id)); + W ("Has_Missing_Return", Flag142 (Id)); + W ("Has_Nested_Block_With_Handler", Flag101 (Id)); + W ("Has_Non_Standard_Rep", Flag75 (Id)); + W ("Has_Object_Size_Clause", Flag172 (Id)); + W ("Has_Per_Object_Constraint", Flag154 (Id)); + W ("Has_Persistent_BSS", Flag188 (Id)); + W ("Has_Pragma_Controlled", Flag27 (Id)); + W ("Has_Pragma_Elaborate_Body", Flag150 (Id)); + W ("Has_Pragma_Inline", Flag157 (Id)); + W ("Has_Pragma_Pack", Flag121 (Id)); + W ("Has_Pragma_Pure", Flag203 (Id)); + W ("Has_Pragma_Pure_Function", Flag179 (Id)); + W ("Has_Pragma_Unreferenced", Flag180 (Id)); + W ("Has_Pragma_Unreferenced_Objects", Flag212 (Id)); + W ("Has_Primitive_Operations", Flag120 (Id)); + W ("Has_Private_Declaration", Flag155 (Id)); + W ("Has_Qualified_Name", Flag161 (Id)); + W ("Has_RACW", Flag214 (Id)); + W ("Has_Record_Rep_Clause", Flag65 (Id)); + W ("Has_Recursive_Call", Flag143 (Id)); + W ("Has_Size_Clause", Flag29 (Id)); + W ("Has_Small_Clause", Flag67 (Id)); + W ("Has_Specified_Layout", Flag100 (Id)); + W ("Has_Specified_Stream_Input", Flag190 (Id)); + W ("Has_Specified_Stream_Output", Flag191 (Id)); + W ("Has_Specified_Stream_Read", Flag192 (Id)); + W ("Has_Specified_Stream_Write", Flag193 (Id)); + W ("Has_Static_Discriminants", Flag211 (Id)); + W ("Has_Storage_Size_Clause", Flag23 (Id)); + W ("Has_Stream_Size_Clause", Flag184 (Id)); + W ("Has_Subprogram_Descriptor", Flag93 (Id)); + W ("Has_Task", Flag30 (Id)); + W ("Has_Unchecked_Union", Flag123 (Id)); + W ("Has_Unknown_Discriminants", Flag72 (Id)); + W ("Has_Volatile_Components", Flag87 (Id)); + W ("Has_Xref_Entry", Flag182 (Id)); + W ("In_Package_Body", Flag48 (Id)); + W ("In_Private_Part", Flag45 (Id)); + W ("In_Use", Flag8 (Id)); + W ("Is_AST_Entry", Flag132 (Id)); + W ("Is_Abstract_Subprogram", Flag19 (Id)); + W ("Is_Abstract_Type", Flag146 (Id)); + W ("Is_Local_Anonymous_Access", Flag194 (Id)); + W ("Is_Access_Constant", Flag69 (Id)); + W ("Is_Ada_2005_Only", Flag185 (Id)); + W ("Is_Aliased", Flag15 (Id)); + W ("Is_Asynchronous", Flag81 (Id)); + W ("Is_Atomic", Flag85 (Id)); + W ("Is_Bit_Packed_Array", Flag122 (Id)); + W ("Is_CPP_Class", Flag74 (Id)); + W ("Is_Called", Flag102 (Id)); + W ("Is_Character_Type", Flag63 (Id)); + W ("Is_Child_Unit", Flag73 (Id)); + W ("Is_Class_Wide_Equivalent_Type", Flag35 (Id)); + W ("Is_Compilation_Unit", Flag149 (Id)); + W ("Is_Completely_Hidden", Flag103 (Id)); + W ("Is_Concurrent_Record_Type", Flag20 (Id)); + W ("Is_Constr_Subt_For_UN_Aliased", Flag141 (Id)); + W ("Is_Constr_Subt_For_U_Nominal", Flag80 (Id)); + W ("Is_Constrained", Flag12 (Id)); + W ("Is_Constructor", Flag76 (Id)); + W ("Is_Controlled", Flag42 (Id)); + W ("Is_Controlling_Formal", Flag97 (Id)); + W ("Is_Discrim_SO_Function", Flag176 (Id)); + W ("Is_Dispatching_Operation", Flag6 (Id)); + W ("Is_Eliminated", Flag124 (Id)); + W ("Is_Entry_Formal", Flag52 (Id)); + W ("Is_Exported", Flag99 (Id)); + W ("Is_First_Subtype", Flag70 (Id)); + W ("Is_For_Access_Subtype", Flag118 (Id)); + W ("Is_Formal_Subprogram", Flag111 (Id)); + W ("Is_Frozen", Flag4 (Id)); + W ("Is_Generic_Actual_Type", Flag94 (Id)); + W ("Is_Generic_Instance", Flag130 (Id)); + W ("Is_Generic_Type", Flag13 (Id)); + W ("Is_Hidden", Flag57 (Id)); + W ("Is_Hidden_Open_Scope", Flag171 (Id)); + W ("Is_Immediately_Visible", Flag7 (Id)); + W ("Is_Imported", Flag24 (Id)); + W ("Is_Inlined", Flag11 (Id)); + W ("Is_Instantiated", Flag126 (Id)); + W ("Is_Interface", Flag186 (Id)); + W ("Is_Internal", Flag17 (Id)); + W ("Is_Interrupt_Handler", Flag89 (Id)); + W ("Is_Intrinsic_Subprogram", Flag64 (Id)); + W ("Is_Itype", Flag91 (Id)); + W ("Is_Known_Non_Null", Flag37 (Id)); + W ("Is_Known_Null", Flag204 (Id)); + W ("Is_Known_Valid", Flag170 (Id)); + W ("Is_Limited_Composite", Flag106 (Id)); + W ("Is_Limited_Interface", Flag197 (Id)); + W ("Is_Limited_Record", Flag25 (Id)); + W ("Is_Machine_Code_Subprogram", Flag137 (Id)); + W ("Is_Non_Static_Subtype", Flag109 (Id)); + W ("Is_Null_Init_Proc", Flag178 (Id)); + W ("Is_Obsolescent", Flag153 (Id)); + W ("Is_Optional_Parameter", Flag134 (Id)); + W ("Is_Overriding_Operation", Flag39 (Id)); + W ("Is_Package_Body_Entity", Flag160 (Id)); + W ("Is_Packed", Flag51 (Id)); + W ("Is_Packed_Array_Type", Flag138 (Id)); + W ("Is_Potentially_Use_Visible", Flag9 (Id)); + W ("Is_Preelaborated", Flag59 (Id)); + W ("Is_Primitive_Wrapper", Flag195 (Id)); + W ("Is_Private_Composite", Flag107 (Id)); + W ("Is_Private_Descendant", Flag53 (Id)); + W ("Is_Protected_Interface", Flag198 (Id)); + W ("Is_Public", Flag10 (Id)); + W ("Is_Pure", Flag44 (Id)); + W ("Is_Pure_Unit_Access_Type", Flag189 (Id)); + W ("Is_Remote_Call_Interface", Flag62 (Id)); + W ("Is_Remote_Types", Flag61 (Id)); + W ("Is_Renaming_Of_Object", Flag112 (Id)); + W ("Is_Return_Object", Flag209 (Id)); + W ("Is_Shared_Passive", Flag60 (Id)); + W ("Is_Synchronized_Interface", Flag199 (Id)); + W ("Is_Statically_Allocated", Flag28 (Id)); + W ("Is_Tag", Flag78 (Id)); + W ("Is_Tagged_Type", Flag55 (Id)); + W ("Is_Task_Interface", Flag200 (Id)); + W ("Is_Thread_Body", Flag77 (Id)); + W ("Is_True_Constant", Flag163 (Id)); + W ("Is_Unchecked_Union", Flag117 (Id)); + W ("Is_Unsigned_Type", Flag144 (Id)); + W ("Is_VMS_Exception", Flag133 (Id)); + W ("Is_Valued_Procedure", Flag127 (Id)); + W ("Is_Visible_Child_Unit", Flag116 (Id)); + W ("Is_Visible_Formal", Flag206 (Id)); + W ("Is_Volatile", Flag16 (Id)); + W ("Itype_Printed", Flag202 (Id)); + W ("Kill_Elaboration_Checks", Flag32 (Id)); + W ("Kill_Range_Checks", Flag33 (Id)); + W ("Kill_Tag_Checks", Flag34 (Id)); + W ("Known_To_Have_Preelab_Init", Flag207 (Id)); + W ("Low_Bound_Known", Flag205 (Id)); + W ("Machine_Radix_10", Flag84 (Id)); + W ("Materialize_Entity", Flag168 (Id)); + W ("Must_Be_On_Byte_Boundary", Flag183 (Id)); + W ("Must_Have_Preelab_Init", Flag208 (Id)); + W ("Needs_Debug_Info", Flag147 (Id)); + W ("Needs_No_Actuals", Flag22 (Id)); + W ("Never_Set_In_Source", Flag115 (Id)); + W ("No_Pool_Assigned", Flag131 (Id)); + W ("No_Return", Flag113 (Id)); + W ("No_Strict_Aliasing", Flag136 (Id)); + W ("Non_Binary_Modulus", Flag58 (Id)); + W ("Nonzero_Is_True", Flag162 (Id)); + W ("Reachable", Flag49 (Id)); + W ("Referenced", Flag156 (Id)); + W ("Referenced_As_LHS", Flag36 (Id)); + W ("Requires_Overriding", Flag213 (Id)); + W ("Return_Present", Flag54 (Id)); + W ("Returns_By_Ref", Flag90 (Id)); + W ("Reverse_Bit_Order", Flag164 (Id)); + W ("Sec_Stack_Needed_For_Return", Flag167 (Id)); + W ("Size_Depends_On_Discriminant", Flag177 (Id)); + W ("Size_Known_At_Compile_Time", Flag92 (Id)); + W ("Strict_Alignment", Flag145 (Id)); + W ("Suppress_Elaboration_Warnings", Flag148 (Id)); + W ("Suppress_Init_Proc", Flag105 (Id)); + W ("Suppress_Style_Checks", Flag165 (Id)); + W ("Treat_As_Volatile", Flag41 (Id)); + W ("Uses_Sec_Stack", Flag95 (Id)); + W ("Vax_Float", Flag151 (Id)); + W ("Warnings_Off", Flag96 (Id)); + W ("Was_Hidden", Flag196 (Id)); end Write_Entity_Flags; ----------------------- @@ -7126,28 +7222,28 @@ package body Einfo is procedure Write_Field8_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Component | - E_Discriminant => + when E_Component | + E_Discriminant => Write_Str ("Normalized_First_Bit"); - when Formal_Kind | - E_Function | - E_Subprogram_Body => + when Formal_Kind | + E_Function | + E_Subprogram_Body => Write_Str ("Mechanism"); - when Type_Kind => + when Type_Kind => Write_Str ("Associated_Node_For_Itype"); - when E_Package => + when E_Package => Write_Str ("Dependent_Instances"); - when E_Return_Statement => + when E_Return_Statement => Write_Str ("Return_Applies_To"); - when E_Variable => + when E_Variable => Write_Str ("Hiding_Loop_Variable"); - when others => + when others => Write_Str ("Field8??"); end case; end Write_Field8_Name; @@ -7159,21 +7255,21 @@ package body Einfo is procedure Write_Field9_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Type_Kind => + when Type_Kind => Write_Str ("Class_Wide_Type"); - when E_Function | - E_Generic_Function | - E_Generic_Package | - E_Generic_Procedure | - E_Package | - E_Procedure => + when E_Function | + E_Generic_Function | + E_Generic_Package | + E_Generic_Procedure | + E_Package | + E_Procedure => Write_Str ("Renaming_Map"); - when Object_Kind => + when Object_Kind => Write_Str ("Current_Value"); - when others => + when others => Write_Str ("Field9??"); end case; end Write_Field9_Name; @@ -7185,24 +7281,24 @@ package body Einfo is procedure Write_Field10_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Type_Kind => + when Type_Kind => Write_Str ("Referenced_Object"); - when E_In_Parameter | - E_Constant => + when E_In_Parameter | + E_Constant => Write_Str ("Discriminal_Link"); - when E_Function | - E_Package | - E_Package_Body | - E_Procedure => + when E_Function | + E_Package | + E_Package_Body | + E_Procedure => Write_Str ("Handler_Records"); - when E_Component | - E_Discriminant => + when E_Component | + E_Discriminant => Write_Str ("Normalized_Position_Max"); - when others => + when others => Write_Str ("Field10??"); end case; end Write_Field10_Name; @@ -7214,35 +7310,35 @@ package body Einfo is procedure Write_Field11_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Formal_Kind => + when Formal_Kind => Write_Str ("Entry_Component"); - when E_Component | - E_Discriminant => + when E_Component | + E_Discriminant => Write_Str ("Component_Bit_Offset"); - when E_Constant => + when E_Constant => Write_Str ("Full_View"); - when E_Enumeration_Literal => + when E_Enumeration_Literal => Write_Str ("Enumeration_Pos"); - when E_Block => + when E_Block => Write_Str ("Block_Node"); - when E_Function | - E_Procedure | - E_Entry | - E_Entry_Family => + when E_Function | + E_Procedure | + E_Entry | + E_Entry_Family => Write_Str ("Protected_Body_Subprogram"); - when E_Generic_Package => + when E_Generic_Package => Write_Str ("Generic_Homonym"); - when Type_Kind => + when Type_Kind => Write_Str ("Full_View"); - when others => + when others => Write_Str ("Field11??"); end case; end Write_Field11_Name; @@ -7254,31 +7350,31 @@ package body Einfo is procedure Write_Field12_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Entry_Kind => + when Entry_Kind => Write_Str ("Barrier_Function"); - when E_Enumeration_Literal => + when E_Enumeration_Literal => Write_Str ("Enumeration_Rep"); - when Type_Kind | - E_Component | - E_Constant | - E_Discriminant | - E_In_Parameter | - E_In_Out_Parameter | - E_Out_Parameter | - E_Loop_Parameter | - E_Variable => + when Type_Kind | + E_Component | + E_Constant | + E_Discriminant | + E_In_Parameter | + E_In_Out_Parameter | + E_Out_Parameter | + E_Loop_Parameter | + E_Variable => Write_Str ("Esize"); - when E_Function | - E_Procedure => + when E_Function | + E_Procedure => Write_Str ("Next_Inlined_Subprogram"); - when E_Package => + when E_Package => Write_Str ("Associated_Formal_Package"); - when others => + when others => Write_Str ("Field12??"); end case; end Write_Field12_Name; @@ -7290,17 +7386,17 @@ package body Einfo is procedure Write_Field13_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Type_Kind => + when Type_Kind => Write_Str ("RM_Size"); - when E_Component | - E_Discriminant => + when E_Component | + E_Discriminant => Write_Str ("Component_Clause"); - when E_Enumeration_Literal => + when E_Enumeration_Literal => Write_Str ("Debug_Renaming_Link"); - when E_Function => + when E_Function => if not Comes_From_Source (Id) and then Chars (Id) = Name_Op_Ne @@ -7314,16 +7410,16 @@ package body Einfo is Write_Str ("Field13??"); end if; - when Formal_Kind | - E_Variable => + when Formal_Kind | + E_Variable => Write_Str ("Extra_Accessibility"); - when E_Procedure | - E_Package | - Generic_Unit_Kind => + when E_Procedure | + E_Package | + Generic_Unit_Kind => Write_Str ("Elaboration_Entity"); - when others => + when others => Write_Str ("Field13??"); end case; end Write_Field13_Name; @@ -7335,26 +7431,26 @@ package body Einfo is procedure Write_Field14_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Type_Kind | - Formal_Kind | - E_Constant | - E_Variable | - E_Loop_Parameter => + when Type_Kind | + Formal_Kind | + E_Constant | + E_Variable | + E_Loop_Parameter => Write_Str ("Alignment"); - when E_Component | - E_Discriminant => + when E_Component | + E_Discriminant => Write_Str ("Normalized_Position"); - when E_Function | - E_Procedure => + when E_Function | + E_Procedure => Write_Str ("First_Optional_Parameter"); - when E_Package | - E_Generic_Package => + when E_Package | + E_Generic_Package => Write_Str ("Shadow_Entities"); - when others => + when others => Write_Str ("Field14??"); end case; end Write_Field14_Name; @@ -7366,52 +7462,52 @@ package body Einfo is procedure Write_Field15_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Access_Kind | - Task_Kind => + when Access_Kind | + Task_Kind => Write_Str ("Storage_Size_Variable"); - when Class_Wide_Kind | - E_Record_Type | - E_Record_Subtype | - Private_Kind => + when Class_Wide_Kind | + E_Record_Type | + E_Record_Subtype | + Private_Kind => Write_Str ("Primitive_Operations"); - when E_Component => + when E_Component => Write_Str ("DT_Entry_Count"); - when Decimal_Fixed_Point_Kind => + when Decimal_Fixed_Point_Kind => Write_Str ("Scale_Value"); - when E_Discriminant => + when E_Discriminant => Write_Str ("Discriminant_Number"); - when Formal_Kind => + when Formal_Kind => Write_Str ("Extra_Formal"); - when E_Function | - E_Procedure => + when E_Function | + E_Procedure => Write_Str ("DT_Position"); - when Entry_Kind => + when Entry_Kind => Write_Str ("Entry_Parameters_Type"); - when Enumeration_Kind => + when Enumeration_Kind => Write_Str ("Lit_Indexes"); - when E_Package | - E_Package_Body => + when E_Package | + E_Package_Body => Write_Str ("Related_Instance"); - when E_Protected_Type => + when E_Protected_Type => Write_Str ("Entry_Bodies_Array"); - when E_String_Literal_Subtype => + when E_String_Literal_Subtype => Write_Str ("String_Literal_Low_Bound"); - when E_Variable => + when E_Variable => Write_Str ("Shared_Var_Read_Proc"); - when others => + when others => Write_Str ("Field15??"); end case; end Write_Field15_Name; @@ -7423,37 +7519,37 @@ package body Einfo is procedure Write_Field16_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Component => + when E_Component => Write_Str ("Entry_Formal"); - when E_Function | - E_Procedure => + when E_Function | + E_Procedure => Write_Str ("DTC_Entity"); - when E_Package | - E_Generic_Package | - Concurrent_Kind => + when E_Package | + E_Generic_Package | + Concurrent_Kind => Write_Str ("First_Private_Entity"); - when E_Record_Type | - E_Record_Type_With_Private => + when E_Record_Type | + E_Record_Type_With_Private => Write_Str ("Access_Disp_Table"); - when E_String_Literal_Subtype => + when E_String_Literal_Subtype => Write_Str ("String_Literal_Length"); - when Enumeration_Kind => + when Enumeration_Kind => Write_Str ("Lit_Strings"); - when E_Variable | - E_Out_Parameter => + when E_Variable | + E_Out_Parameter => Write_Str ("Unset_Reference"); - when E_Record_Subtype | - E_Class_Wide_Subtype => + when E_Record_Subtype | + E_Class_Wide_Subtype => Write_Str ("Cloned_Subtype"); - when others => + when others => Write_Str ("Field16??"); end case; end Write_Field16_Name; @@ -7465,67 +7561,67 @@ package body Einfo is procedure Write_Field17_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Digits_Kind => + when Digits_Kind => Write_Str ("Digits_Value"); - when E_Component => + when E_Component => Write_Str ("Prival"); - when E_Discriminant => + when E_Discriminant => Write_Str ("Discriminal"); - when E_Block | - Class_Wide_Kind | - Concurrent_Kind | - Private_Kind | - E_Entry | - E_Entry_Family | - E_Function | - E_Generic_Function | - E_Generic_Package | - E_Generic_Procedure | - E_Loop | - E_Operator | - E_Package | - E_Package_Body | - E_Procedure | - E_Record_Type | - E_Record_Subtype | - E_Return_Statement | - E_Subprogram_Body | - E_Subprogram_Type => + when E_Block | + Class_Wide_Kind | + Concurrent_Kind | + Private_Kind | + E_Entry | + E_Entry_Family | + E_Function | + E_Generic_Function | + E_Generic_Package | + E_Generic_Procedure | + E_Loop | + E_Operator | + E_Package | + E_Package_Body | + E_Procedure | + E_Record_Type | + E_Record_Subtype | + E_Return_Statement | + E_Subprogram_Body | + E_Subprogram_Type => Write_Str ("First_Entity"); - when Array_Kind => + when Array_Kind => Write_Str ("First_Index"); - when E_Protected_Body => + when E_Protected_Body => Write_Str ("Object_Ref"); - when Enumeration_Kind => + when Enumeration_Kind => Write_Str ("First_Literal"); - when Access_Kind => + when Access_Kind => Write_Str ("Master_Id"); - when Modular_Integer_Kind => + when Modular_Integer_Kind => Write_Str ("Modulus"); - when Formal_Kind | - E_Constant | - E_Generic_In_Out_Parameter | - E_Variable => + when Formal_Kind | + E_Constant | + E_Generic_In_Out_Parameter | + E_Variable => Write_Str ("Actual_Subtype"); - when E_Incomplete_Type => + when E_Incomplete_Type => Write_Str ("Non_Limited_View"); - when E_Incomplete_Subtype => + when E_Incomplete_Subtype => if From_With_Type (Id) then Write_Str ("Non_Limited_View"); end if; - when others => + when others => Write_Str ("Field17??"); end case; end Write_Field17_Name; @@ -7537,50 +7633,51 @@ package body Einfo is procedure Write_Field18_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Enumeration_Literal | - E_Function | - E_Operator | - E_Procedure => + when E_Enumeration_Literal | + E_Function | + E_Operator | + E_Procedure => Write_Str ("Alias"); - when E_Record_Type => + when E_Record_Type => Write_Str ("Corresponding_Concurrent_Type"); - when E_Entry_Index_Parameter => + when E_Entry_Index_Parameter => Write_Str ("Entry_Index_Constant"); - when E_Class_Wide_Subtype | - E_Access_Protected_Subprogram_Type | - E_Access_Subprogram_Type | - E_Exception_Type => + when E_Class_Wide_Subtype | + E_Access_Protected_Subprogram_Type | + E_Anonymous_Access_Protected_Subprogram_Type | + E_Access_Subprogram_Type | + E_Exception_Type => Write_Str ("Equivalent_Type"); - when Fixed_Point_Kind => + when Fixed_Point_Kind => Write_Str ("Delta_Value"); - when E_Constant | - E_Variable => + when E_Constant | + E_Variable => Write_Str ("Renamed_Object"); - when E_Exception | - E_Package | - E_Generic_Function | - E_Generic_Procedure | - E_Generic_Package => + when E_Exception | + E_Package | + E_Generic_Function | + E_Generic_Procedure | + E_Generic_Package => Write_Str ("Renamed_Entity"); - when Incomplete_Or_Private_Kind => + when Incomplete_Or_Private_Kind => Write_Str ("Private_Dependents"); - when Concurrent_Kind => + when Concurrent_Kind => Write_Str ("Corresponding_Record_Type"); - when E_Label | - E_Loop | - E_Block => + when E_Label | + E_Loop | + E_Block => Write_Str ("Enclosing_Scope"); - when others => + when others => Write_Str ("Field18??"); end case; end Write_Field18_Name; @@ -7592,38 +7689,39 @@ package body Einfo is procedure Write_Field19_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Array_Type | - E_Array_Subtype => + when E_Array_Type | + E_Array_Subtype => Write_Str ("Related_Array_Object"); - when E_Block | - Concurrent_Kind | - E_Function | - E_Procedure | - Entry_Kind => + when E_Block | + Concurrent_Kind | + E_Function | + E_Procedure | + E_Return_Statement | + Entry_Kind => Write_Str ("Finalization_Chain_Entity"); - when E_Constant | E_Variable => + when E_Constant | E_Variable => Write_Str ("Size_Check_Code"); - when E_Discriminant => + when E_Discriminant => Write_Str ("Corresponding_Discriminant"); - when E_Package | - E_Generic_Package => + when E_Package | + E_Generic_Package => Write_Str ("Body_Entity"); - when E_Package_Body | - Formal_Kind => + when E_Package_Body | + Formal_Kind => Write_Str ("Spec_Entity"); - when Private_Kind => + when Private_Kind => Write_Str ("Underlying_Full_View"); - when E_Record_Type => + when E_Record_Type => Write_Str ("Parent_Subtype"); - when others => + when others => Write_Str ("Field19??"); end case; end Write_Field19_Name; @@ -7635,55 +7733,55 @@ package body Einfo is procedure Write_Field20_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Array_Kind => + when Array_Kind => Write_Str ("Component_Type"); - when E_In_Parameter | - E_Generic_In_Parameter => + when E_In_Parameter | + E_Generic_In_Parameter => Write_Str ("Default_Value"); - when Access_Kind => + when Access_Kind => Write_Str ("Directly_Designated_Type"); - when E_Component => + when E_Component => Write_Str ("Discriminant_Checking_Func"); - when E_Discriminant => + when E_Discriminant => Write_Str ("Discriminant_Default_Value"); - when E_Block | - Class_Wide_Kind | - Concurrent_Kind | - Private_Kind | - E_Entry | - E_Entry_Family | - E_Function | - E_Generic_Function | - E_Generic_Package | - E_Generic_Procedure | - E_Loop | - E_Operator | - E_Package | - E_Package_Body | - E_Procedure | - E_Record_Type | - E_Record_Subtype | - E_Return_Statement | - E_Subprogram_Body | - E_Subprogram_Type => + when E_Block | + Class_Wide_Kind | + Concurrent_Kind | + Private_Kind | + E_Entry | + E_Entry_Family | + E_Function | + E_Generic_Function | + E_Generic_Package | + E_Generic_Procedure | + E_Loop | + E_Operator | + E_Package | + E_Package_Body | + E_Procedure | + E_Record_Type | + E_Record_Subtype | + E_Return_Statement | + E_Subprogram_Body | + E_Subprogram_Type => Write_Str ("Last_Entity"); - when Scalar_Kind => + when Scalar_Kind => Write_Str ("Scalar_Range"); - when E_Exception => + when E_Exception => Write_Str ("Register_Exception_Call"); - when E_Variable => + when E_Variable => Write_Str ("Last_Assignment"); - when others => + when others => Write_Str ("Field20??"); end case; end Write_Field20_Name; @@ -7695,40 +7793,40 @@ package body Einfo is procedure Write_Field21_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Constant | - E_Exception | - E_Function | - E_Generic_Function | - E_Procedure | - E_Generic_Procedure | - E_Variable => + when E_Constant | + E_Exception | + E_Function | + E_Generic_Function | + E_Procedure | + E_Generic_Procedure | + E_Variable => Write_Str ("Interface_Name"); - when Concurrent_Kind | - Incomplete_Or_Private_Kind | - Class_Wide_Kind | - E_Record_Type | - E_Record_Subtype => + when Concurrent_Kind | + Incomplete_Or_Private_Kind | + Class_Wide_Kind | + E_Record_Type | + E_Record_Subtype => Write_Str ("Discriminant_Constraint"); - when Entry_Kind => + when Entry_Kind => Write_Str ("Accept_Address"); - when Fixed_Point_Kind => + when Fixed_Point_Kind => Write_Str ("Small_Value"); - when E_In_Parameter => + when E_In_Parameter => Write_Str ("Default_Expr_Function"); - when Array_Kind | - Modular_Integer_Kind => + when Array_Kind | + Modular_Integer_Kind => Write_Str ("Original_Array_Type"); - when E_Access_Subprogram_Type | - E_Access_Protected_Subprogram_Type => + when E_Access_Subprogram_Type | + E_Access_Protected_Subprogram_Type => Write_Str ("Original_Access_Type"); - when others => + when others => Write_Str ("Field21??"); end case; end Write_Field21_Name; @@ -7740,57 +7838,57 @@ package body Einfo is procedure Write_Field22_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Access_Kind => + when Access_Kind => Write_Str ("Associated_Storage_Pool"); - when Array_Kind => + when Array_Kind => Write_Str ("Component_Size"); - when E_Component | - E_Discriminant => + when E_Component | + E_Discriminant => Write_Str ("Original_Record_Component"); - when E_Enumeration_Literal => + when E_Enumeration_Literal => Write_Str ("Enumeration_Rep_Expr"); - when E_Exception => + when E_Exception => Write_Str ("Exception_Code"); - when Formal_Kind => + when Formal_Kind => Write_Str ("Protected_Formal"); - when E_Record_Type => + when E_Record_Type => Write_Str ("Corresponding_Remote_Type"); - when E_Block | - E_Entry | - E_Entry_Family | - E_Function | - E_Loop | - E_Package | - E_Package_Body | - E_Generic_Package | - E_Generic_Function | - E_Generic_Procedure | - E_Procedure | - E_Protected_Type | - E_Return_Statement | - E_Subprogram_Body | - E_Task_Type => + when E_Block | + E_Entry | + E_Entry_Family | + E_Function | + E_Loop | + E_Package | + E_Package_Body | + E_Generic_Package | + E_Generic_Function | + E_Generic_Procedure | + E_Procedure | + E_Protected_Type | + E_Return_Statement | + E_Subprogram_Body | + E_Task_Type => Write_Str ("Scope_Depth_Value"); - when E_Record_Type_With_Private | - E_Record_Subtype_With_Private | - E_Private_Type | - E_Private_Subtype | - E_Limited_Private_Type | - E_Limited_Private_Subtype => + when E_Record_Type_With_Private | + E_Record_Subtype_With_Private | + E_Private_Type | + E_Private_Subtype | + E_Limited_Private_Type | + E_Limited_Private_Subtype => Write_Str ("Private_View"); - when E_Variable => + when E_Variable => Write_Str ("Shared_Var_Assign_Proc"); - when others => + when others => Write_Str ("Field22??"); end case; end Write_Field22_Name; @@ -7802,45 +7900,45 @@ package body Einfo is procedure Write_Field23_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Access_Kind => + when Access_Kind => Write_Str ("Associated_Final_Chain"); - when Array_Kind => + when Array_Kind => Write_Str ("Packed_Array_Type"); - when E_Block => + when E_Block => Write_Str ("Entry_Cancel_Parameter"); - when E_Component => + when E_Component => Write_Str ("Protected_Operation"); - when E_Discriminant => + when E_Discriminant => Write_Str ("CR_Discriminant"); - when E_Enumeration_Type => + when E_Enumeration_Type => Write_Str ("Enum_Pos_To_Rep"); - when Formal_Kind | - E_Variable => + when Formal_Kind | + E_Variable => Write_Str ("Extra_Constrained"); - when E_Generic_Function | - E_Generic_Package | - E_Generic_Procedure => + when E_Generic_Function | + E_Generic_Package | + E_Generic_Procedure => Write_Str ("Inner_Instances"); - when Concurrent_Kind | - Incomplete_Or_Private_Kind | - Class_Wide_Kind | - E_Record_Type | - E_Record_Subtype => + when Concurrent_Kind | + Incomplete_Or_Private_Kind | + Class_Wide_Kind | + E_Record_Type | + E_Record_Subtype => Write_Str ("Stored_Constraint"); - when E_Function | - E_Procedure => + when E_Function | + E_Procedure => Write_Str ("Generic_Renamings"); - when E_Package => + when E_Package => if Is_Generic_Instance (Id) then Write_Str ("Generic_Renamings"); else @@ -7849,10 +7947,10 @@ package body Einfo is -- What about Privals_Chain for protected operations ??? - when Entry_Kind => + when Entry_Kind => Write_Str ("Privals_Chain"); - when others => + when others => Write_Str ("Field23??"); end case; end Write_Field23_Name; @@ -7874,26 +7972,26 @@ package body Einfo is procedure Write_Field25_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Component => + when E_Component => Write_Str ("DT_Offset_To_Top_Func"); - when E_Procedure | - E_Function => + when E_Procedure | + E_Function => Write_Str ("Abstract_Interface_Alias"); - when E_Package => + when E_Package => Write_Str ("Current_Use_Clause"); - when E_Record_Type | - E_Record_Subtype | - E_Record_Type_With_Private | - E_Record_Subtype_With_Private => + when E_Record_Type | + E_Record_Subtype | + E_Record_Type_With_Private | + E_Record_Subtype_With_Private => Write_Str ("Abstract_Interfaces"); - when Task_Kind => + when Task_Kind => Write_Str ("Task_Body_Procedure"); - when others => + when others => Write_Str ("Field25??"); end case; end Write_Field25_Name; @@ -7905,15 +8003,15 @@ package body Einfo is procedure Write_Field26_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Generic_Package | - E_Package => + when E_Generic_Package | + E_Package => Write_Str ("Package_Instantiation"); - when E_Procedure | - E_Function => + when E_Procedure | + E_Function => Write_Str ("Overridden_Operation"); - when others => + when others => Write_Str ("Field26??"); end case; end Write_Field26_Name; @@ -7925,10 +8023,10 @@ package body Einfo is procedure Write_Field27_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Procedure => + when E_Procedure => Write_Str ("Wrapped_Entity"); - when others => + when others => Write_Str ("Field27??"); end case; end Write_Field27_Name; @@ -7940,10 +8038,10 @@ package body Einfo is procedure Write_Field28_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Procedure | E_Function | E_Entry => + when E_Procedure | E_Function | E_Entry => Write_Str ("Extra_Formals"); - when others => + when others => Write_Str ("Field28??"); end case; end Write_Field28_Name; @@ -7952,42 +8050,47 @@ package body Einfo is -- Iterator Procedures -- ------------------------- - procedure Proc_Next_Component (N : in out Node_Id) is + procedure Proc_Next_Component (N : in out Node_Id) is begin N := Next_Component (N); end Proc_Next_Component; - procedure Proc_Next_Discriminant (N : in out Node_Id) is + procedure Proc_Next_Component_Or_Discriminant (N : in out Node_Id) is + begin + N := Next_Component (N); + end Proc_Next_Component_Or_Discriminant; + + procedure Proc_Next_Discriminant (N : in out Node_Id) is begin N := Next_Discriminant (N); end Proc_Next_Discriminant; - procedure Proc_Next_Formal (N : in out Node_Id) is + procedure Proc_Next_Formal (N : in out Node_Id) is begin N := Next_Formal (N); end Proc_Next_Formal; - procedure Proc_Next_Formal_With_Extras (N : in out Node_Id) is + procedure Proc_Next_Formal_With_Extras (N : in out Node_Id) is begin N := Next_Formal_With_Extras (N); end Proc_Next_Formal_With_Extras; - procedure Proc_Next_Index (N : in out Node_Id) is + procedure Proc_Next_Index (N : in out Node_Id) is begin N := Next_Index (N); end Proc_Next_Index; - procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id) is + procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id) is begin N := Next_Inlined_Subprogram (N); end Proc_Next_Inlined_Subprogram; - procedure Proc_Next_Literal (N : in out Node_Id) is + procedure Proc_Next_Literal (N : in out Node_Id) is begin N := Next_Literal (N); end Proc_Next_Literal; - procedure Proc_Next_Stored_Discriminant (N : in out Node_Id) is + procedure Proc_Next_Stored_Discriminant (N : in out Node_Id) is begin N := Next_Stored_Discriminant (N); end Proc_Next_Stored_Discriminant; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 46f03a92d59..f606d4f5ecf 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1045,13 +1045,13 @@ package Einfo is -- entity designed by this field instead of being computed. -- Finalization_Chain_Entity (Node19) --- Present in scopes which can have finalizable entities (blocks, --- functions, procedures, tasks, entries). When this field is empty it --- means that there are no finalization actions to perform on exit of the --- scope. When this field contains 'Error', it means that no --- finalization actions should happen at this level and the --- finalization chain of a parent scope shall be used (??? this is --- an improper use of 'Error' and should be changed). otherwise it +-- Present in scopes that can have finalizable entities (blocks, +-- functions, procedures, tasks, entries, return statements). When this +-- field is empty it means that there are no finalization actions to +-- perform on exit of the scope. When this field contains 'Error', it +-- means that no finalization actions should happen at this level and +-- the finalization chain of a parent scope shall be used (??? this is +-- an improper use of 'Error' and should be changed). Otherwise it -- contains an entity of type Finalizable_Ptr that is the head of the -- list of objects to finalize on exit. See "Finalization Management" -- section in exp_ch7.adb for more details. @@ -1066,16 +1066,20 @@ package Einfo is -- derivation. -- First_Component (synthesized) --- Applies to record types. Returns the first component by following --- the chain of declared entities for the record until a component --- is found (one with an Ekind of E_Component). The discriminants are --- skipped. If the record is null, then Empty is returned. +-- Applies to record types. Returns the first component by following the +-- chain of declared entities for the record until a component is found +-- (one with an Ekind of E_Component). The discriminants are skipped. If +-- the record is null, then Empty is returned. + +-- First_Component_Or_Discriminant (synthesized) +-- Similar to First_Component, but discriminants are not skipped, so will +-- find the first discriminant if discriminants are present. -- First_Discriminant (synthesized) --- Applies to types with discriminants. The discriminants are the --- first entities declared in the type, so normally this is equivalent --- to First_Entity. The exception arises for tagged types, where the --- tag itself is prepended to the front of the entity chain, so the +-- Applies to types with discriminants. The discriminants are the first +-- entities declared in the type, so normally this is equivalent to +-- First_Entity. The exception arises for tagged types, where the tag +-- itself is prepended to the front of the entity chain, so the -- First_Discriminant function steps past the tag if it is present. -- First_Entity (Node17) @@ -1233,6 +1237,8 @@ package Einfo is -- True if Targparm.Functions_Return_By_DSP_On_Target is True and -- the function returns a value of a type whose size is not known -- at compile time. +-- +-- Note: this flag is obsolete, it is always False ??? -- Generic_Homonym (Node11) -- Present in generic packages. The generic homonym is the entity of @@ -1524,7 +1530,15 @@ package Einfo is -- Present in all entities. Set if a valid pragma Unreferenced applies -- to the pragma, indicating that no warning should be given if the -- entity has no references, but a warning should be given if it is --- in fact referenced. +-- in fact referenced. For private types, this flag is set in both the +-- private entity and full entity if the pragma applies to either. + +-- Has_Pragma_Unreferenced_Objects (Flag212) +-- Present in type and subtype entities. Set if a valid pragma +-- Unreferenced_Objects applies to the type, indicating that no warning +-- should be given for objects of such a type for being unreferenced +-- (but unlike the case with pragma Unreferenced, it is ok to reference +-- such an object and no warning is generated. -- Known_To_Have_Preelab_Init (Flag207) -- Present in all type and subtype entities. If set, then the type is @@ -1561,6 +1575,10 @@ package Einfo is -- the flag Has_Fully_Qualified_Name, which is set if the name does -- indeed include the fully qualified name. +-- Has_RACW (Flag214) +-- Present in package spec entities. Set if the spec contains the +-- declaration of a remote access-to-classwide type. + -- Has_Record_Rep_Clause (Flag65) [implementation base type only] -- Present in record types. Set if a record representation clause has -- been given for this record type. Used to prevent more than one such @@ -1635,9 +1653,9 @@ package Einfo is -- Has_Task (Flag30) [base type only] -- Present in all type entities. Set on task types themselves, and also -- (recursively) on any composite type which has a component for which --- Has_Task is set. The meaning is that an allocator of such an object --- must create the required tasks. Note that the flag is not set on --- access types, even if they designate an object that Has_Task. +-- Has_Task is set. The meaning is that an allocator or declaration of +-- such an object must create the required tasks. Note: the flag is not +-- set on access types, even if they designate an object that Has_Task. -- Has_Unchecked_Union (Flag123) [base type only] -- Present in all type entities. Set on unchecked unions themselves @@ -1749,9 +1767,13 @@ package Einfo is -- part. The flag on a type is also used to determine the visibility of -- the primitive operators of the type. --- Is_Abstract (Flag19) --- Present in all types, and also for functions and procedures. Set --- for abstract types and abstract subprograms. +-- Is_Abstract_Subprogram (Flag19) +-- Present in all subprograms and entries. Set for abstract subprograms. +-- Always False for enumeration literals and entries. See also +-- Requires_Overriding. + +-- Is_Abstract_Type (Flag146) +-- Present in all types. Set for abstract types. -- Is_Local_Anonymous_Access (Flag194) -- Present in access types. Set for an anonymous access type to indicate @@ -1765,6 +1787,10 @@ package Einfo is -- Present in access types and subtypes. Indicates that the keyword -- constant was present in the access type definition. +-- Is_Access_Protected_Subprogram_Type (synthesized) +-- Applies to all types, true for named and anonymous access to +-- protected subprograms. + -- Is_Access_Type (synthesized) -- Applies to all entities, true for access types and subtypes @@ -1907,8 +1933,8 @@ package Einfo is -- of dispatching operations. -- Is_CPP_Class (Flag74) --- Present in all type entities, set only for tagged and untagged --- record types to which the pragma CPP_Class has been applied. +-- Present in all type entities, set only for tagged types to which a +-- valid pragma Import (CPP, ...) or pragma CPP_Class has been applied. -- Is_Decimal_Fixed_Point_Type (synthesized) -- Applies to all type entities, true for decimal fixed point @@ -2648,7 +2674,10 @@ package Einfo is -- Master_Id (Node17) -- Present in access types and subtypes. Empty unless Has_Task is -- set for the designated type, in which case it points to the entity --- for the Master_Id for the access type master. +-- for the Master_Id for the access type master. Also set for access-to- +-- limited-class-wide types whose root may be extended with task +-- components, and for access-to-limited-interfaces because they can be +-- used to reference tasks implementing such interface. -- Materialize_Entity (Flag168) -- Present in all entities. Set only for constant or renamed entities @@ -2744,11 +2773,17 @@ package Einfo is -- the renaming possibility. -- Next_Component (synthesized) --- Applies to record components. Returns the next component by --- following the chain of declared entities until one is found which --- corresponds to a component (Ekind is E_Component). Any internal types --- generated from the subtype indications of the record components are --- skipped. Returns Empty if no more components. +-- Applies to record components. Returns the next component by following +-- the chain of declared entities until one is found which corresponds to +-- a component (Ekind is E_Component). Any internal types generated from +-- the subtype indications of the record components are skipped. Returns +-- Empty if no more components. + +-- Next_Component_Or_Discriminant (synthesized) +-- Similar to Next_Component, but includes components and discriminants +-- so the input can have either E_Component or E_Discriminant, and the +-- same is true for the result. Returns Empty if no more components or +-- discriminants in the record. -- Next_Discriminant (synthesized) -- Applies to discriminants returned by First/Next_Discriminant. @@ -3103,6 +3138,12 @@ package Einfo is -- details. The maps for package instances are also used when the -- instance is the actual corresponding to a formal package. +-- Requires_Overriding (Flag213) +-- Present in all subprograms and entries. Set for subprograms that +-- require overriding as defined by RM-2005-3.9.3(6/2). Note that this +-- is True only for implicitly declare subprograms; it is not set on the +-- parent type's subprogram. See also Is_Abstract_Subprogram. + -- Return_Present (Flag54) -- Present in function and generic function entities. Set if the -- function contains a return statement (used for error checking). @@ -3124,10 +3165,11 @@ package Einfo is -- Reverse_Bit_Order (Flag164) [base type only] -- Present in all record type entities. Set if a valid pragma an --- attribute represention clause for Bit_Order has reversed the order --- of bits from the default value. When this flag is set, a component --- clause must specify a set of bits entirely contained in a single --- storage unit. +-- attribute represention clause for Bit_Order has reversed the order of +-- bits from the default value. When this flag is set, a component clause +-- must specify a set of bits entirely contained in a single storage unit +-- (Ada 95) or a single machine scalar (see Ada 2005 AI-133), or must +-- occupy in integral number of storage units. -- RM_Size (Uint13) -- Present in all type and subtype entities. Contains the value of @@ -3406,7 +3448,7 @@ package Einfo is -- Access Kinds -- ------------------ - -- The following three entity kinds are introduced by the corresponding + -- The following five entity kinds are introduced by the corresponding -- type definitions: -- E_Access_Type, @@ -3615,16 +3657,16 @@ package Einfo is -- An access to subprogram type, created by an access to subprogram -- declaration. + E_Anonymous_Access_Subprogram_Type, + -- An anonymous access to subprogram type, created by an access to + -- subprogram declaration. + E_Access_Protected_Subprogram_Type, -- An access to a protected subprogram, created by the corresponding -- declaration. Values of such a type denote both a protected object -- and a protected operation within, and have different compile-time -- and run-time properties than other access to subprograms. - E_Anonymous_Access_Subprogram_Type, - -- An anonymous access to subprogram type, created by an access to - -- subprogram declaration. - E_Anonymous_Access_Protected_Subprogram_Type, -- An anonymous access to protected subprogram type, created by an -- access to subprogram declaration. @@ -3862,11 +3904,15 @@ package Einfo is -- E_Allocator_Type -- E_General_Access_Type -- E_Access_Subprogram_Type - -- E_Access_Protected_Subprogram_Type -- E_Anonymous_Access_Subprogram_Type + -- E_Access_Protected_Subprogram_Type -- E_Anonymous_Access_Protected_Subprogram_Type E_Anonymous_Access_Type; + subtype Access_Protected_Kind is Entity_Kind range + E_Access_Protected_Subprogram_Type .. + E_Anonymous_Access_Protected_Subprogram_Type; + subtype Array_Kind is Entity_Kind range E_Array_Type .. -- E_Array_Subtype @@ -4183,863 +4229,878 @@ package Einfo is -- The following attributes apply to all entities - -- Ekind (Ekind) - - -- Chars (Name1) - -- Next_Entity (Node2) - -- Scope (Node3) - -- Homonym (Node4) - -- Etype (Node5) - -- First_Rep_Item (Node6) - -- Freeze_Node (Node7) - -- Obsolescent_Warning (Node24) - - -- Address_Taken (Flag104) - -- Can_Never_Be_Null (Flag38) - -- Checks_May_Be_Suppressed (Flag31) - -- Debug_Info_Off (Flag166) - -- Has_Anon_Block_Suffix (Flag201) - -- Has_Controlled_Component (Flag43) (base type only) - -- Has_Convention_Pragma (Flag119) - -- Has_Delayed_Freeze (Flag18) - -- Has_Fully_Qualified_Name (Flag173) - -- Has_Gigi_Rep_Item (Flag82) - -- Has_Homonym (Flag56) - -- Has_Persistent_BSS (Flag188) - -- Has_Pragma_Elaborate_Body (Flag150) - -- Has_Pragma_Inline (Flag157) - -- Has_Pragma_Pure (Flag203) - -- Has_Pragma_Pure_Function (Flag179) - -- Has_Pragma_Unreferenced (Flag180) - -- Has_Private_Declaration (Flag155) - -- Has_Qualified_Name (Flag161) - -- Has_Unknown_Discriminants (Flag72) - -- Has_Xref_Entry (Flag182) - -- Is_Ada_2005_Only (Flag185) - -- Is_Bit_Packed_Array (Flag122) (base type only) - -- Is_Child_Unit (Flag73) - -- Is_Compilation_Unit (Flag149) - -- Is_Completely_Hidden (Flag103) - -- Is_Discrim_SO_Function (Flag176) - -- Is_Dispatching_Operation (Flag6) - -- Is_Exported (Flag99) - -- Is_First_Subtype (Flag70) - -- Is_Formal_Subprogram (Flag111) - -- Is_Generic_Instance (Flag130) - -- Is_Hidden (Flag57) - -- Is_Hidden_Open_Scope (Flag171) - -- Is_Immediately_Visible (Flag7) - -- Is_Imported (Flag24) - -- Is_Inlined (Flag11) - -- Is_Internal (Flag17) - -- Is_Itype (Flag91) - -- Is_Known_Non_Null (Flag37) - -- Is_Known_Null (Flag204) - -- Is_Known_Valid (Flag170) - -- Is_Limited_Composite (Flag106) - -- Is_Limited_Record (Flag25) - -- Is_Obsolescent (Flag153) - -- Is_Package_Body_Entity (Flag160) - -- Is_Packed_Array_Type (Flag138) - -- Is_Potentially_Use_Visible (Flag9) - -- Is_Preelaborated (Flag59) - -- Is_Primitive_Wrapper (Flag195) - -- Is_Public (Flag10) - -- Is_Pure (Flag44) - -- Is_Remote_Call_Interface (Flag62) - -- Is_Remote_Types (Flag61) - -- Is_Shared_Passive (Flag60) - -- Is_Statically_Allocated (Flag28) - -- Is_Unchecked_Union (Flag117) - -- Is_Visible_Formal (Flag206) - -- Is_VMS_Exception (Flag133) - -- Kill_Elaboration_Checks (Flag32) - -- Kill_Range_Checks (Flag33) - -- Kill_Tag_Checks (Flag34) - -- Low_Bound_Known (Flag205) - -- Materialize_Entity (Flag168) - -- Needs_Debug_Info (Flag147) - -- No_Return (Flag113) - -- Referenced (Flag156) - -- Referenced_As_LHS (Flag36) - -- Suppress_Elaboration_Warnings (Flag148) - -- Suppress_Style_Checks (Flag165) - -- Was_Hidden (Flag196) - - -- Declaration_Node (synth) - -- Enclosing_Dynamic_Scope (synth) - -- Has_Foreign_Convention (synth) - -- Is_Derived_Type (synth) - -- Is_Dynamic_Scope (synth) - -- Is_Limited_Type (synth) - -- Underlying_Type (synth) - -- all classification attributes (synth) + -- Ekind (Ekind) + + -- Chars (Name1) + -- Next_Entity (Node2) + -- Scope (Node3) + -- Homonym (Node4) + -- Etype (Node5) + -- First_Rep_Item (Node6) + -- Freeze_Node (Node7) + -- Obsolescent_Warning (Node24) + + -- Address_Taken (Flag104) + -- Can_Never_Be_Null (Flag38) + -- Checks_May_Be_Suppressed (Flag31) + -- Debug_Info_Off (Flag166) + -- Has_Anon_Block_Suffix (Flag201) + -- Has_Controlled_Component (Flag43) (base type only) + -- Has_Convention_Pragma (Flag119) + -- Has_Delayed_Freeze (Flag18) + -- Has_Fully_Qualified_Name (Flag173) + -- Has_Gigi_Rep_Item (Flag82) + -- Has_Homonym (Flag56) + -- Has_Persistent_BSS (Flag188) + -- Has_Pragma_Elaborate_Body (Flag150) + -- Has_Pragma_Inline (Flag157) + -- Has_Pragma_Pure (Flag203) + -- Has_Pragma_Pure_Function (Flag179) + -- Has_Pragma_Unreferenced (Flag180) + -- Has_Private_Declaration (Flag155) + -- Has_Qualified_Name (Flag161) + -- Has_Unknown_Discriminants (Flag72) + -- Has_Xref_Entry (Flag182) + -- Is_Ada_2005_Only (Flag185) + -- Is_Bit_Packed_Array (Flag122) (base type only) + -- Is_Child_Unit (Flag73) + -- Is_Compilation_Unit (Flag149) + -- Is_Completely_Hidden (Flag103) + -- Is_Discrim_SO_Function (Flag176) + -- Is_Dispatching_Operation (Flag6) + -- Is_Exported (Flag99) + -- Is_First_Subtype (Flag70) + -- Is_Formal_Subprogram (Flag111) + -- Is_Generic_Instance (Flag130) + -- Is_Hidden (Flag57) + -- Is_Hidden_Open_Scope (Flag171) + -- Is_Immediately_Visible (Flag7) + -- Is_Imported (Flag24) + -- Is_Inlined (Flag11) + -- Is_Internal (Flag17) + -- Is_Itype (Flag91) + -- Is_Known_Non_Null (Flag37) + -- Is_Known_Null (Flag204) + -- Is_Known_Valid (Flag170) + -- Is_Limited_Composite (Flag106) + -- Is_Limited_Record (Flag25) + -- Is_Obsolescent (Flag153) + -- Is_Package_Body_Entity (Flag160) + -- Is_Packed_Array_Type (Flag138) + -- Is_Potentially_Use_Visible (Flag9) + -- Is_Preelaborated (Flag59) + -- Is_Primitive_Wrapper (Flag195) + -- Is_Public (Flag10) + -- Is_Pure (Flag44) + -- Is_Remote_Call_Interface (Flag62) + -- Is_Remote_Types (Flag61) + -- Is_Shared_Passive (Flag60) + -- Is_Statically_Allocated (Flag28) + -- Is_Unchecked_Union (Flag117) + -- Is_Visible_Formal (Flag206) + -- Is_VMS_Exception (Flag133) + -- Kill_Elaboration_Checks (Flag32) + -- Kill_Range_Checks (Flag33) + -- Kill_Tag_Checks (Flag34) + -- Low_Bound_Known (Flag205) + -- Materialize_Entity (Flag168) + -- Needs_Debug_Info (Flag147) + -- No_Return (Flag113) + -- Referenced (Flag156) + -- Referenced_As_LHS (Flag36) + -- Suppress_Elaboration_Warnings (Flag148) + -- Suppress_Style_Checks (Flag165) + -- Was_Hidden (Flag196) + + -- Declaration_Node (synth) + -- Enclosing_Dynamic_Scope (synth) + -- Has_Foreign_Convention (synth) + -- Is_Derived_Type (synth) + -- Is_Dynamic_Scope (synth) + -- Is_Limited_Type (synth) + -- Underlying_Type (synth) + -- all classification attributes (synth) -- The following list of access functions applies to all entities for -- types and subtypes. References to this list appear subsequently as -- as "(plus type attributes)" for each appropriate Entity_Kind. - -- Associated_Node_For_Itype (Node8) - -- Class_Wide_Type (Node9) - -- Referenced_Object (Node10) - -- Full_View (Node11) - -- Esize (Uint12) - -- RM_Size (Uint13) - -- Alignment (Uint14) - - -- Depends_On_Private (Flag14) - -- Discard_Names (Flag88) - -- Finalize_Storage_Only (Flag158) (base type only) - -- From_With_Type (Flag159) - -- Has_Aliased_Components (Flag135) (base type only) - -- Has_Alignment_Clause (Flag46) - -- Has_Atomic_Components (Flag86) (base type only) - -- Has_Completion_In_Body (Flag71) - -- Has_Complex_Representation (Flag140) (base type only) - -- Has_Constrained_Partial_View (Flag187) - -- Has_Discriminants (Flag5) - -- Has_Non_Standard_Rep (Flag75) (base type only) - -- Has_Object_Size_Clause (Flag172) - -- Has_Primitive_Operations (Flag120) (base type only) - -- Has_Size_Clause (Flag29) - -- Has_Specified_Layout (Flag100) (base type only) - -- Has_Specified_Stream_Input (Flag190) - -- Has_Specified_Stream_Output (Flag191) - -- Has_Specified_Stream_Read (Flag192) - -- Has_Specified_Stream_Write (Flag193) - -- Has_Task (Flag30) (base type only) - -- Has_Unchecked_Union (Flag123) (base type only) - -- Has_Volatile_Components (Flag87) (base type only) - -- In_Use (Flag8) - -- Is_Abstract (Flag19) - -- Is_Asynchronous (Flag81) - -- Is_Atomic (Flag85) - -- Is_Constr_Subt_For_U_Nominal (Flag80) - -- Is_Constr_Subt_For_UN_Aliased (Flag141) - -- Is_Controlled (Flag42) (base type only) - -- Is_Eliminated (Flag124) - -- Is_Frozen (Flag4) - -- Is_Generic_Actual_Type (Flag94) - -- Is_Generic_Type (Flag13) - -- Is_Limited_Interface (Flag197) - -- Is_Protected_Interface (Flag198) - -- Is_Synchronized_Interface (Flag199) - -- Is_Task_Interface (Flag200) - -- Is_Non_Static_Subtype (Flag109) - -- Is_Packed (Flag51) (base type only) - -- Is_Private_Composite (Flag107) - -- Is_Renaming_Of_Object (Flag112) - -- Is_Tagged_Type (Flag55) - -- Is_Unsigned_Type (Flag144) - -- Is_Volatile (Flag16) - -- Itype_Printed (Flag202) (itypes only) - -- Known_To_Have_Preelab_Init (Flag207) - -- Must_Be_On_Byte_Boundary (Flag183) - -- Must_Have_Preelab_Init (Flag208) - -- Size_Depends_On_Discriminant (Flag177) - -- Size_Known_At_Compile_Time (Flag92) - -- Strict_Alignment (Flag145) (base type only) - -- Suppress_Init_Proc (Flag105) (base type only) - -- Treat_As_Volatile (Flag41) - - -- Alignment_Clause (synth) - -- Ancestor_Subtype (synth) - -- Base_Type (synth) - -- First_Subtype (synth) - -- Has_Private_Ancestor (synth) - -- Implementation_Base_Type (synth) - -- Is_By_Copy_Type (synth) - -- Is_By_Reference_Type (synth) - -- Is_Inherently_Limited_Type (synth) - -- Root_Type (synth) - -- Size_Clause (synth) + -- Associated_Node_For_Itype (Node8) + -- Class_Wide_Type (Node9) + -- Referenced_Object (Node10) + -- Full_View (Node11) + -- Esize (Uint12) + -- RM_Size (Uint13) + -- Alignment (Uint14) + + -- Depends_On_Private (Flag14) + -- Discard_Names (Flag88) + -- Finalize_Storage_Only (Flag158) (base type only) + -- From_With_Type (Flag159) + -- Has_Aliased_Components (Flag135) (base type only) + -- Has_Alignment_Clause (Flag46) + -- Has_Atomic_Components (Flag86) (base type only) + -- Has_Completion_In_Body (Flag71) + -- Has_Complex_Representation (Flag140) (base type only) + -- Has_Constrained_Partial_View (Flag187) + -- Has_Discriminants (Flag5) + -- Has_Non_Standard_Rep (Flag75) (base type only) + -- Has_Object_Size_Clause (Flag172) + -- Has_Pragma_Unreferenced_Objects (Flag212) + -- Has_Primitive_Operations (Flag120) (base type only) + -- Has_Size_Clause (Flag29) + -- Has_Specified_Layout (Flag100) (base type only) + -- Has_Specified_Stream_Input (Flag190) + -- Has_Specified_Stream_Output (Flag191) + -- Has_Specified_Stream_Read (Flag192) + -- Has_Specified_Stream_Write (Flag193) + -- Has_Task (Flag30) (base type only) + -- Has_Unchecked_Union (Flag123) (base type only) + -- Has_Volatile_Components (Flag87) (base type only) + -- In_Use (Flag8) + -- Is_Abstract_Type (Flag146) + -- Is_Asynchronous (Flag81) + -- Is_Atomic (Flag85) + -- Is_Constr_Subt_For_U_Nominal (Flag80) + -- Is_Constr_Subt_For_UN_Aliased (Flag141) + -- Is_Controlled (Flag42) (base type only) + -- Is_Eliminated (Flag124) + -- Is_Frozen (Flag4) + -- Is_Generic_Actual_Type (Flag94) + -- Is_Generic_Type (Flag13) + -- Is_Limited_Interface (Flag197) + -- Is_Protected_Interface (Flag198) + -- Is_Synchronized_Interface (Flag199) + -- Is_Task_Interface (Flag200) + -- Is_Non_Static_Subtype (Flag109) + -- Is_Packed (Flag51) (base type only) + -- Is_Private_Composite (Flag107) + -- Is_Renaming_Of_Object (Flag112) + -- Is_Tagged_Type (Flag55) + -- Is_Unsigned_Type (Flag144) + -- Is_Volatile (Flag16) + -- Itype_Printed (Flag202) (itypes only) + -- Known_To_Have_Preelab_Init (Flag207) + -- Must_Be_On_Byte_Boundary (Flag183) + -- Must_Have_Preelab_Init (Flag208) + -- Size_Depends_On_Discriminant (Flag177) + -- Size_Known_At_Compile_Time (Flag92) + -- Strict_Alignment (Flag145) (base type only) + -- Suppress_Init_Proc (Flag105) (base type only) + -- Treat_As_Volatile (Flag41) + + -- Alignment_Clause (synth) + -- Ancestor_Subtype (synth) + -- Base_Type (synth) + -- First_Subtype (synth) + -- Has_Private_Ancestor (synth) + -- Implementation_Base_Type (synth) + -- Is_Access_Protected_Subprogram_Type (synth) + -- Is_By_Copy_Type (synth) + -- Is_By_Reference_Type (synth) + -- Is_Inherently_Limited_Type (synth) + -- Root_Type (synth) + -- Size_Clause (synth) ------------------------------------------ -- Applicable attributes by entity kind -- ------------------------------------------ -- E_Access_Protected_Subprogram_Type - -- Equivalent_Type (Node18) - -- Directly_Designated_Type (Node20) - -- Original_Access_Type (Node21) - -- Needs_No_Actuals (Flag22) - -- (plus type attributes) + -- Equivalent_Type (Node18) + -- Directly_Designated_Type (Node20) + -- Original_Access_Type (Node21) + -- Needs_No_Actuals (Flag22) + -- (plus type attributes) -- E_Access_Subprogram_Type - -- Equivalent_Type (Node18) (remote types only) - -- Directly_Designated_Type (Node20) - -- Original_Access_Type (Node21) - -- Needs_No_Actuals (Flag22) - -- (plus type attributes) + -- Equivalent_Type (Node18) (remote types only) + -- Directly_Designated_Type (Node20) + -- Original_Access_Type (Node21) + -- Needs_No_Actuals (Flag22) + -- (plus type attributes) -- E_Access_Type -- E_Access_Subtype - -- Storage_Size_Variable (Node15) (base type only) - -- Master_Id (Node17) - -- Directly_Designated_Type (Node20) - -- Associated_Storage_Pool (Node22) (base type only) - -- Associated_Final_Chain (Node23) - -- Has_Pragma_Controlled (Flag27) (base type only) - -- Has_Storage_Size_Clause (Flag23) (base type only) - -- Is_Local_Anonymous_Access (Flag194) - -- Is_Access_Constant (Flag69) - -- Is_Pure_Unit_Access_Type (Flag189) - -- No_Pool_Assigned (Flag131) (base type only) - -- No_Strict_Aliasing (Flag136) (base type only) + -- Storage_Size_Variable (Node15) (base type only) + -- Master_Id (Node17) + -- Directly_Designated_Type (Node20) + -- Associated_Storage_Pool (Node22) (base type only) + -- Associated_Final_Chain (Node23) + -- Has_Pragma_Controlled (Flag27) (base type only) + -- Has_Storage_Size_Clause (Flag23) (base type only) + -- Is_Local_Anonymous_Access (Flag194) + -- Is_Access_Constant (Flag69) + -- Is_Pure_Unit_Access_Type (Flag189) + -- No_Pool_Assigned (Flag131) (base type only) + -- No_Strict_Aliasing (Flag136) (base type only) -- (plus type attributes) -- E_Access_Attribute_Type - -- Directly_Designated_Type (Node20) + -- Directly_Designated_Type (Node20) -- (plus type attributes) -- E_Allocator_Type - -- Directly_Designated_Type (Node20) + -- Directly_Designated_Type (Node20) -- (plus type attributes) -- E_Anonymous_Access_Subprogram_Type -- E_Anonymous_Access_Protected_Subprogram_Type -- E_Anonymous_Access_Type - -- Storage_Size_Variable (Node15) ??? is this needed ??? - -- Directly_Designated_Type (Node20) + -- Storage_Size_Variable (Node15) ??? is this needed ??? + -- Directly_Designated_Type (Node20) -- (plus type attributes) -- E_Array_Type -- E_Array_Subtype - -- First_Index (Node17) - -- Related_Array_Object (Node19) - -- Component_Type (Node20) (base type only) - -- Original_Array_Type (Node21) - -- Component_Size (Uint22) (base type only) - -- Packed_Array_Type (Node23) - -- Component_Alignment (special) (base type only) - -- Has_Component_Size_Clause (Flag68) (base type only) - -- Has_Pragma_Pack (Flag121) (base type only) - -- Is_Aliased (Flag15) - -- Is_Constrained (Flag12) - -- Next_Index (synth) - -- Number_Dimensions (synth) - -- (plus type attributes) + -- First_Index (Node17) + -- Related_Array_Object (Node19) + -- Component_Type (Node20) (base type only) + -- Original_Array_Type (Node21) + -- Component_Size (Uint22) (base type only) + -- Packed_Array_Type (Node23) + -- Component_Alignment (special) (base type only) + -- Has_Component_Size_Clause (Flag68) (base type only) + -- Has_Pragma_Pack (Flag121) (base type only) + -- Is_Aliased (Flag15) + -- Is_Constrained (Flag12) + -- Next_Index (synth) + -- Number_Dimensions (synth) + -- (plus type attributes) -- E_Block - -- Block_Node (Node11) - -- First_Entity (Node17) - -- Last_Entity (Node20) - -- Delay_Cleanups (Flag114) - -- Discard_Names (Flag88) - -- Finalization_Chain_Entity (Node19) - -- Scope_Depth_Value (Uint22) - -- Entry_Cancel_Parameter (Node23) - -- Has_Master_Entity (Flag21) - -- Has_Nested_Block_With_Handler (Flag101) - -- Sec_Stack_Needed_For_Return (Flag167) - -- Uses_Sec_Stack (Flag95) - -- Scope_Depth (synth) + -- Block_Node (Node11) + -- First_Entity (Node17) + -- Last_Entity (Node20) + -- Finalization_Chain_Entity (Node19) + -- Scope_Depth_Value (Uint22) + -- Entry_Cancel_Parameter (Node23) + -- Delay_Cleanups (Flag114) + -- Discard_Names (Flag88) + -- Has_Master_Entity (Flag21) + -- Has_Nested_Block_With_Handler (Flag101) + -- Sec_Stack_Needed_For_Return (Flag167) + -- Uses_Sec_Stack (Flag95) + -- Scope_Depth (synth) -- E_Class_Wide_Type -- E_Class_Wide_Subtype - -- Cloned_Subtype (Node16) (subtype case only) - -- First_Entity (Node17) - -- Equivalent_Type (Node18) (always Empty in type case) - -- Last_Entity (Node20) - -- First_Component (synth) - -- (plus type attributes) + -- Cloned_Subtype (Node16) (subtype case only) + -- First_Entity (Node17) + -- Equivalent_Type (Node18) (always Empty for type) + -- Last_Entity (Node20) + -- First_Component (synth) + -- First_Component_Or_Discriminant (synth) + -- First_Discriminant (synth) + -- (plus type attributes) -- E_Component - -- Normalized_First_Bit (Uint8) - -- Current_Value (Node9) (always Empty) - -- Normalized_Position_Max (Uint10) - -- Component_Bit_Offset (Uint11) - -- Esize (Uint12) - -- Component_Clause (Node13) - -- Normalized_Position (Uint14) - -- DT_Entry_Count (Uint15) - -- Entry_Formal (Node16) - -- Prival (Node17) - -- Renamed_Object (Node18) (always Empty) - -- Discriminant_Checking_Func (Node20) - -- Interface_Name (Node21) (JGNAT usage only) - -- Original_Record_Component (Node22) - -- Protected_Operation (Node23) - -- DT_Offset_To_Top_Func (Node25) - -- Has_Biased_Representation (Flag139) - -- Has_Per_Object_Constraint (Flag154) - -- Is_Atomic (Flag85) - -- Is_Tag (Flag78) - -- Is_Volatile (Flag16) - -- Treat_As_Volatile (Flag41) - -- Is_Return_Object (Flag209) - -- Is_Protected_Private (synth) - -- Next_Component (synth) - -- Next_Tag_Component (synth) + -- Normalized_First_Bit (Uint8) + -- Current_Value (Node9) (always Empty) + -- Normalized_Position_Max (Uint10) + -- Component_Bit_Offset (Uint11) + -- Esize (Uint12) + -- Component_Clause (Node13) + -- Normalized_Position (Uint14) + -- DT_Entry_Count (Uint15) + -- Entry_Formal (Node16) + -- Prival (Node17) + -- Renamed_Object (Node18) (always Empty) + -- Discriminant_Checking_Func (Node20) + -- Interface_Name (Node21) (JGNAT usage only) + -- Original_Record_Component (Node22) + -- Protected_Operation (Node23) + -- DT_Offset_To_Top_Func (Node25) + -- Has_Biased_Representation (Flag139) + -- Has_Per_Object_Constraint (Flag154) + -- Is_Atomic (Flag85) + -- Is_Tag (Flag78) + -- Is_Volatile (Flag16) + -- Treat_As_Volatile (Flag41) + -- Is_Return_Object (Flag209) + -- Is_Protected_Private (synth) + -- Next_Component (synth) + -- Next_Component_Or_Discriminant (synth) + -- Next_Tag_Component (synth) -- E_Constant -- E_Loop_Parameter - -- Current_Value (Node9) (always Empty) - -- Discriminal_Link (Node10) (discriminals only) - -- Full_View (Node11) - -- Esize (Uint12) - -- Alignment (Uint14) - -- Actual_Subtype (Node17) - -- Renamed_Object (Node18) - -- Size_Check_Code (Node19) (constants only) - -- In_Private_Part (Flag45) - -- Interface_Name (Node21) - -- Has_Alignment_Clause (Flag46) - -- Has_Atomic_Components (Flag86) - -- Has_Biased_Representation (Flag139) - -- Has_Completion (Flag26) (constants only) - -- Has_Size_Clause (Flag29) - -- Has_Volatile_Components (Flag87) - -- Is_Atomic (Flag85) - -- Is_Eliminated (Flag124) - -- Is_True_Constant (Flag163) - -- Is_Volatile (Flag16) - -- Never_Set_In_Source (Flag115) - -- Treat_As_Volatile (Flag41) - -- Is_Return_Object (Flag209) - -- Address_Clause (synth) - -- Alignment_Clause (synth) - -- Constant_Value (synth) - -- Size_Clause (synth) + -- Current_Value (Node9) (always Empty) + -- Discriminal_Link (Node10) (discriminals only) + -- Full_View (Node11) + -- Esize (Uint12) + -- Alignment (Uint14) + -- Actual_Subtype (Node17) + -- Renamed_Object (Node18) + -- Size_Check_Code (Node19) (constants only) + -- In_Private_Part (Flag45) + -- Interface_Name (Node21) + -- Has_Alignment_Clause (Flag46) + -- Has_Atomic_Components (Flag86) + -- Has_Biased_Representation (Flag139) + -- Has_Completion (Flag26) (constants only) + -- Has_Size_Clause (Flag29) + -- Has_Volatile_Components (Flag87) + -- Is_Atomic (Flag85) + -- Is_Eliminated (Flag124) + -- Is_True_Constant (Flag163) + -- Is_Volatile (Flag16) + -- Never_Set_In_Source (Flag115) + -- Treat_As_Volatile (Flag41) + -- Is_Return_Object (Flag209) + -- Address_Clause (synth) + -- Alignment_Clause (synth) + -- Constant_Value (synth) + -- Size_Clause (synth) -- E_Decimal_Fixed_Point_Type -- E_Decimal_Fixed_Subtype - -- Scale_Value (Uint15) - -- Digits_Value (Uint17) - -- Scalar_Range (Node20) - -- Delta_Value (Ureal18) - -- Small_Value (Ureal21) - -- Has_Machine_Radix_Clause (Flag83) - -- Machine_Radix_10 (Flag84) - -- Type_Low_Bound (synth) - -- Type_High_Bound (synth) - -- (plus type attributes) + -- Scale_Value (Uint15) + -- Digits_Value (Uint17) + -- Scalar_Range (Node20) + -- Delta_Value (Ureal18) + -- Small_Value (Ureal21) + -- Has_Machine_Radix_Clause (Flag83) + -- Machine_Radix_10 (Flag84) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) + -- (plus type attributes) -- E_Discriminant - -- Normalized_First_Bit (Uint8) - -- Current_Value (Node9) (always Empty) - -- Normalized_Position_Max (Uint10) - -- Component_Bit_Offset (Uint11) - -- Esize (Uint12) - -- Component_Clause (Node13) - -- Normalized_Position (Uint14) - -- Discriminant_Number (Uint15) - -- Discriminal (Node17) - -- Renamed_Object (Node18) (always Empty) - -- Corresponding_Discriminant (Node19) - -- Discriminant_Default_Value (Node20) - -- Interface_Name (Node21) (JGNAT usage only) - -- Original_Record_Component (Node22) - -- CR_Discriminant (Node23) - -- Is_Return_Object (Flag209) - -- Next_Discriminant (synth) - -- Next_Stored_Discriminant (synth) + -- Normalized_First_Bit (Uint8) + -- Current_Value (Node9) (always Empty) + -- Normalized_Position_Max (Uint10) + -- Component_Bit_Offset (Uint11) + -- Esize (Uint12) + -- Component_Clause (Node13) + -- Normalized_Position (Uint14) + -- Discriminant_Number (Uint15) + -- Discriminal (Node17) + -- Renamed_Object (Node18) (always Empty) + -- Corresponding_Discriminant (Node19) + -- Discriminant_Default_Value (Node20) + -- Interface_Name (Node21) (JGNAT usage only) + -- Original_Record_Component (Node22) + -- CR_Discriminant (Node23) + -- Is_Return_Object (Flag209) + -- Next_Component_Or_Discriminant (synth) + -- Next_Discriminant (synth) + -- Next_Stored_Discriminant (synth) -- E_Entry -- E_Entry_Family - -- Protected_Body_Subprogram (Node11) - -- Barrier_Function (Node12) - -- Entry_Parameters_Type (Node15) - -- First_Entity (Node17) - -- Alias (Node18) (Entry only. Always empty) - -- Finalization_Chain_Entity (Node19) - -- Last_Entity (Node20) - -- Accept_Address (Elist21) - -- Scope_Depth_Value (Uint22) - -- Privals_Chain (Elist23) (for a protected entry) - -- Default_Expressions_Processed (Flag108) - -- Entry_Accepted (Flag152) - -- Is_AST_Entry (Flag132) (for entry only) - -- Needs_No_Actuals (Flag22) - -- Sec_Stack_Needed_For_Return (Flag167) - -- Uses_Sec_Stack (Flag95) - -- Address_Clause (synth) - -- First_Formal (synth) - -- First_Formal_With_Extras (synth) - -- Entry_Index_Type (synth) - -- Number_Formals (synth) - -- Scope_Depth (synth) + -- Protected_Body_Subprogram (Node11) + -- Barrier_Function (Node12) + -- Entry_Parameters_Type (Node15) + -- First_Entity (Node17) + -- Alias (Node18) (for entry only. Empty) + -- Finalization_Chain_Entity (Node19) + -- Last_Entity (Node20) + -- Accept_Address (Elist21) + -- Scope_Depth_Value (Uint22) + -- Privals_Chain (Elist23) (for a protected entry) + -- Default_Expressions_Processed (Flag108) + -- Entry_Accepted (Flag152) + -- Is_AST_Entry (Flag132) (for entry only) + -- Needs_No_Actuals (Flag22) + -- Sec_Stack_Needed_For_Return (Flag167) + -- Uses_Sec_Stack (Flag95) + -- Address_Clause (synth) + -- First_Formal (synth) + -- First_Formal_With_Extras (synth) + -- Entry_Index_Type (synth) + -- Number_Formals (synth) + -- Scope_Depth (synth) -- E_Entry_Index_Parameter - -- Entry_Index_Constant (Node18) + -- Entry_Index_Constant (Node18) -- E_Enumeration_Literal - -- Enumeration_Pos (Uint11) - -- Enumeration_Rep (Uint12) - -- Debug_Renaming_Link (Node13) - -- Alias (Node18) - -- Enumeration_Rep_Expr (Node22) - -- Next_Literal (synth) + -- Enumeration_Pos (Uint11) + -- Enumeration_Rep (Uint12) + -- Debug_Renaming_Link (Node13) + -- Alias (Node18) + -- Enumeration_Rep_Expr (Node22) + -- Next_Literal (synth) -- E_Enumeration_Type -- E_Enumeration_Subtype - -- Lit_Indexes (Node15) (root type only) - -- Lit_Strings (Node16) (root type only) - -- First_Literal (Node17) - -- Scalar_Range (Node20) - -- Enum_Pos_To_Rep (Node23) (type only, not subtype) - -- Has_Biased_Representation (Flag139) - -- Has_Contiguous_Rep (Flag181) - -- Has_Enumeration_Rep_Clause (Flag66) - -- Nonzero_Is_True (Flag162) (base type only) - -- Type_Low_Bound (synth) - -- Type_High_Bound (synth) - -- (plus type attributes) + -- Lit_Indexes (Node15) (root type only) + -- Lit_Strings (Node16) (root type only) + -- First_Literal (Node17) + -- Scalar_Range (Node20) + -- Enum_Pos_To_Rep (Node23) (type only) + -- Has_Biased_Representation (Flag139) + -- Has_Contiguous_Rep (Flag181) + -- Has_Enumeration_Rep_Clause (Flag66) + -- Nonzero_Is_True (Flag162) (base type only) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) + -- (plus type attributes) -- E_Exception - -- Alignment (Uint14) - -- Renamed_Entity (Node18) - -- Register_Exception_Call (Node20) - -- Interface_Name (Node21) - -- Exception_Code (Uint22) - -- Discard_Names (Flag88) - -- Is_VMS_Exception (Flag133) + -- Alignment (Uint14) + -- Renamed_Entity (Node18) + -- Register_Exception_Call (Node20) + -- Interface_Name (Node21) + -- Exception_Code (Uint22) + -- Discard_Names (Flag88) + -- Is_VMS_Exception (Flag133) -- E_Exception_Type - -- Equivalent_Type (Node18) - -- (plus type attributes) + -- Equivalent_Type (Node18) + -- (plus type attributes) -- E_Floating_Point_Type -- E_Floating_Point_Subtype - -- Digits_Value (Uint17) - -- Scalar_Range (Node20) - -- Type_Low_Bound (synth) - -- Type_High_Bound (synth) - -- (plus type attributes) + -- Digits_Value (Uint17) + -- Scalar_Range (Node20) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) + -- (plus type attributes) -- E_Function -- E_Generic_Function - -- Mechanism (Uint8) (returns Mechanism_Type) - -- Renaming_Map (Uint9) - -- Handler_Records (List10) (non-generic case only) - -- Protected_Body_Subprogram (Node11) - -- Next_Inlined_Subprogram (Node12) - -- Corresponding_Equality (Node13) (implicit /= only) - -- Elaboration_Entity (Node13) (all other cases) - -- First_Optional_Parameter (Node14) (non-generic case only) - -- DT_Position (Uint15) - -- DTC_Entity (Node16) - -- First_Entity (Node17) - -- Alias (Node18) (non-generic case only) - -- Renamed_Entity (Node18) (generic case only) - -- Finalization_Chain_Entity (Node19) - -- Last_Entity (Node20) - -- Interface_Name (Node21) - -- Scope_Depth_Value (Uint22) - -- Generic_Renamings (Elist23) (for an instance) - -- Inner_Instances (Elist23) (for a generic function) - -- Privals_Chain (Elist23) (for a protected function) - -- Abstract_Interface_Alias (Node25) - -- Overridden_Operation (Node26) - -- Extra_Formals (Node28) - -- Body_Needed_For_SAL (Flag40) - -- Elaboration_Entity_Required (Flag174) - -- Function_Returns_With_DSP (Flag169) - -- Default_Expressions_Processed (Flag108) - -- Delay_Cleanups (Flag114) - -- Delay_Subprogram_Descriptors (Flag50) - -- Discard_Names (Flag88) - -- Has_Completion (Flag26) - -- Has_Controlling_Result (Flag98) - -- Has_Master_Entity (Flag21) - -- Has_Missing_Return (Flag142) - -- Has_Nested_Block_With_Handler (Flag101) - -- Has_Recursive_Call (Flag143) - -- Has_Subprogram_Descriptor (Flag93) - -- Is_Abstract (Flag19) - -- Is_Called (Flag102) (non-generic case only) - -- Is_Constructor (Flag76) - -- Is_Discrim_SO_Function (Flag176) - -- Is_Eliminated (Flag124) - -- Is_Instantiated (Flag126) (generic case only) - -- Is_Intrinsic_Subprogram (Flag64) - -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) - -- Is_Overriding_Operation (Flag39) (non-generic case only) - -- Is_Private_Descendant (Flag53) - -- Is_Pure (Flag44) - -- Is_Thread_Body (Flag77) (non-generic case only) - -- Is_Visible_Child_Unit (Flag116) - -- Needs_No_Actuals (Flag22) - -- Return_Present (Flag54) - -- Returns_By_Ref (Flag90) - -- Sec_Stack_Needed_For_Return (Flag167) - -- Uses_Sec_Stack (Flag95) - -- Address_Clause (synth) - -- First_Formal (synth) - -- First_Formal_With_Extras (synth) - -- Number_Formals (synth) - -- Scope_Depth (synth) + -- Mechanism (Uint8) (Mechanism_Type) + -- Renaming_Map (Uint9) + -- Handler_Records (List10) (non-generic case only) + -- Protected_Body_Subprogram (Node11) + -- Next_Inlined_Subprogram (Node12) + -- Corresponding_Equality (Node13) (implicit /= only) + -- Elaboration_Entity (Node13) (all other cases) + -- First_Optional_Parameter (Node14) (non-generic case only) + -- DT_Position (Uint15) + -- DTC_Entity (Node16) + -- First_Entity (Node17) + -- Alias (Node18) (non-generic case only) + -- Renamed_Entity (Node18) (generic case only) + -- Finalization_Chain_Entity (Node19) + -- Last_Entity (Node20) + -- Interface_Name (Node21) + -- Scope_Depth_Value (Uint22) + -- Generic_Renamings (Elist23) (for an instance) + -- Inner_Instances (Elist23) (generic function only) + -- Privals_Chain (Elist23) (protected func only) + -- Abstract_Interface_Alias (Node25) + -- Overridden_Operation (Node26) + -- Extra_Formals (Node28) + -- Body_Needed_For_SAL (Flag40) + -- Elaboration_Entity_Required (Flag174) + -- Function_Returns_With_DSP (Flag169) + -- Default_Expressions_Processed (Flag108) + -- Delay_Cleanups (Flag114) + -- Delay_Subprogram_Descriptors (Flag50) + -- Discard_Names (Flag88) + -- Has_Completion (Flag26) + -- Has_Controlling_Result (Flag98) + -- Has_Master_Entity (Flag21) + -- Has_Missing_Return (Flag142) + -- Has_Nested_Block_With_Handler (Flag101) + -- Has_Recursive_Call (Flag143) + -- Has_Subprogram_Descriptor (Flag93) + -- Is_Abstract_Subprogram (Flag19) (non-generic case only) + -- Is_Called (Flag102) (non-generic case only) + -- Is_Constructor (Flag76) + -- Is_Discrim_SO_Function (Flag176) + -- Is_Eliminated (Flag124) + -- Is_Instantiated (Flag126) (generic case only) + -- Is_Intrinsic_Subprogram (Flag64) + -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) + -- Is_Overriding_Operation (Flag39) (non-generic case only) + -- Is_Private_Descendant (Flag53) + -- Is_Pure (Flag44) + -- Is_Thread_Body (Flag77) (non-generic case only) + -- Is_Visible_Child_Unit (Flag116) + -- Needs_No_Actuals (Flag22) + -- Requires_Overriding (Flag213) (non-generic case only) + -- Return_Present (Flag54) + -- Returns_By_Ref (Flag90) + -- Sec_Stack_Needed_For_Return (Flag167) + -- Uses_Sec_Stack (Flag95) + -- Address_Clause (synth) + -- First_Formal (synth) + -- First_Formal_With_Extras (synth) + -- Number_Formals (synth) + -- Scope_Depth (synth) -- E_General_Access_Type - -- Storage_Size_Variable (Node15) (base type only) - -- Master_Id (Node17) - -- Directly_Designated_Type (Node20) - -- Associated_Storage_Pool (Node22) (base type only) - -- Associated_Final_Chain (Node23) + -- Storage_Size_Variable (Node15) (base type only) + -- Master_Id (Node17) + -- Directly_Designated_Type (Node20) + -- Associated_Storage_Pool (Node22) (base type only) + -- Associated_Final_Chain (Node23) -- (plus type attributes) -- E_Generic_In_Parameter -- E_Generic_In_Out_Parameter - -- Current_Value (Node9) (always Empty) - -- Entry_Component (Node11) - -- Actual_Subtype (Node17) - -- Renamed_Object (Node18) (always Empty) - -- Default_Value (Node20) - -- Protected_Formal (Node22) - -- Is_Controlling_Formal (Flag97) - -- Is_Entry_Formal (Flag52) - -- Is_Return_Object (Flag209) - -- Parameter_Mode (synth) + -- Current_Value (Node9) (always Empty) + -- Entry_Component (Node11) + -- Actual_Subtype (Node17) + -- Renamed_Object (Node18) (always Empty) + -- Default_Value (Node20) + -- Protected_Formal (Node22) + -- Is_Controlling_Formal (Flag97) + -- Is_Entry_Formal (Flag52) + -- Is_Return_Object (Flag209) + -- Parameter_Mode (synth) -- E_Incomplete_Type -- E_Incomplete_Subtype - -- Non_Limited_View (Node17) - -- Private_Dependents (Elist18) - -- Discriminant_Constraint (Elist21) - -- Stored_Constraint (Elist23) - -- First_Discriminant (synth) - -- First_Stored_Discriminant (synth) + -- Non_Limited_View (Node17) + -- Private_Dependents (Elist18) + -- Discriminant_Constraint (Elist21) + -- Stored_Constraint (Elist23) + -- First_Discriminant (synth) + -- First_Stored_Discriminant (synth) -- (plus type attributes) -- E_In_Parameter -- E_In_Out_Parameter -- E_Out_Parameter - -- Mechanism (Uint8) (returns Mechanism_Type) - -- Current_Value (Node9) - -- Discriminal_Link (Node10) (discriminals only) - -- Entry_Component (Node11) - -- Esize (Uint12) - -- Extra_Accessibility (Node13) - -- Alignment (Uint14) - -- Extra_Formal (Node15) - -- Unset_Reference (Node16) - -- Actual_Subtype (Node17) - -- Renamed_Object (Node18) - -- Spec_Entity (Node19) - -- Default_Value (Node20) - -- Default_Expr_Function (Node21) - -- Protected_Formal (Node22) - -- Extra_Constrained (Node23) - -- Is_Controlling_Formal (Flag97) - -- Is_Entry_Formal (Flag52) - -- Is_Optional_Parameter (Flag134) - -- Low_Bound_Known (Flag205) - -- Never_Set_In_Source (Flag115) - -- Is_Return_Object (Flag209) - -- Parameter_Mode (synth) + -- Mechanism (Uint8) (Mechanism_Type) + -- Current_Value (Node9) + -- Discriminal_Link (Node10) (discriminals only) + -- Entry_Component (Node11) + -- Esize (Uint12) + -- Extra_Accessibility (Node13) + -- Alignment (Uint14) + -- Extra_Formal (Node15) + -- Unset_Reference (Node16) + -- Actual_Subtype (Node17) + -- Renamed_Object (Node18) + -- Spec_Entity (Node19) + -- Default_Value (Node20) + -- Default_Expr_Function (Node21) + -- Protected_Formal (Node22) + -- Extra_Constrained (Node23) + -- Is_Controlling_Formal (Flag97) + -- Is_Entry_Formal (Flag52) + -- Is_Optional_Parameter (Flag134) + -- Low_Bound_Known (Flag205) + -- Never_Set_In_Source (Flag115) + -- Is_Return_Object (Flag209) + -- Parameter_Mode (synth) -- E_Label - -- Enclosing_Scope (Node18) - -- Reachable (Flag49) + -- Enclosing_Scope (Node18) + -- Reachable (Flag49) -- E_Limited_Private_Type -- E_Limited_Private_Subtype - -- First_Entity (Node17) - -- Private_Dependents (Elist18) - -- Underlying_Full_View (Node19) - -- Last_Entity (Node20) - -- Discriminant_Constraint (Elist21) - -- Private_View (Node22) - -- Stored_Constraint (Elist23) - -- Has_Completion (Flag26) - -- First_Discriminant (synth) - -- First_Stored_Discriminant (synth) + -- First_Entity (Node17) + -- Private_Dependents (Elist18) + -- Underlying_Full_View (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Private_View (Node22) + -- Stored_Constraint (Elist23) + -- Has_Completion (Flag26) + -- First_Discriminant (synth) + -- First_Stored_Discriminant (synth) -- (plus type attributes) -- E_Loop - -- Has_Exit (Flag47) - -- Has_Master_Entity (Flag21) - -- Has_Nested_Block_With_Handler (Flag101) + -- Has_Exit (Flag47) + -- Has_Master_Entity (Flag21) + -- Has_Nested_Block_With_Handler (Flag101) -- E_Modular_Integer_Type -- E_Modular_Integer_Subtype - -- Modulus (Uint17) (base type only) - -- Original_Array_Type (Node21) - -- Scalar_Range (Node20) - -- Non_Binary_Modulus (Flag58) (base type only) - -- Has_Biased_Representation (Flag139) - -- Type_Low_Bound (synth) - -- Type_High_Bound (synth) + -- Modulus (Uint17) (base type only) + -- Original_Array_Type (Node21) + -- Scalar_Range (Node20) + -- Non_Binary_Modulus (Flag58) (base type only) + -- Has_Biased_Representation (Flag139) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) -- (plus type attributes) -- E_Named_Integer - -- Constant_Value (synth) + -- Constant_Value (synth) -- E_Named_Real - -- Constant_Value (synth) + -- Constant_Value (synth) -- E_Operator - -- First_Entity (Node17) - -- Alias (Node18) - -- Last_Entity (Node20) - -- Is_Machine_Code_Subprogram (Flag137) - -- Is_Pure (Flag44) - -- Is_Intrinsic_Subprogram (Flag64) - -- Is_Overriding_Operation (Flag39) - -- Default_Expressions_Processed (Flag108) + -- First_Entity (Node17) + -- Alias (Node18) + -- Last_Entity (Node20) + -- Is_Machine_Code_Subprogram (Flag137) + -- Is_Pure (Flag44) + -- Is_Intrinsic_Subprogram (Flag64) + -- Is_Overriding_Operation (Flag39) + -- Default_Expressions_Processed (Flag108) -- E_Ordinary_Fixed_Point_Type -- E_Ordinary_Fixed_Point_Subtype - -- Delta_Value (Ureal18) - -- Scalar_Range (Node20) - -- Small_Value (Ureal21) - -- Has_Small_Clause (Flag67) - -- Type_Low_Bound (synth) - -- Type_High_Bound (synth) - -- (plus type attributes) + -- Delta_Value (Ureal18) + -- Scalar_Range (Node20) + -- Small_Value (Ureal21) + -- Has_Small_Clause (Flag67) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) + -- (plus type attributes) -- E_Package -- E_Generic_Package - -- Dependent_Instances (Elist8) (for an instance) - -- Renaming_Map (Uint9) - -- Handler_Records (List10) (non-generic case only) - -- Generic_Homonym (Node11) (generic case only) - -- Associated_Formal_Package (Node12) - -- Elaboration_Entity (Node13) - -- Shadow_Entities (List14) - -- Related_Instance (Node15) (non-generic case only) - -- First_Private_Entity (Node16) - -- First_Entity (Node17) - -- Renamed_Entity (Node18) - -- Body_Entity (Node19) - -- Last_Entity (Node20) - -- Interface_Name (Node21) - -- Scope_Depth_Value (Uint22) - -- Generic_Renamings (Elist23) (for an instance) - -- Inner_Instances (Elist23) (generic case only) - -- Limited_View (Node23) (non-generic, not instance) - -- Current_Use_Clause (Node25) - -- Package_Instantiation (Node26) - -- Delay_Subprogram_Descriptors (Flag50) - -- Body_Needed_For_SAL (Flag40) - -- Discard_Names (Flag88) - -- Elaboration_Entity_Required (Flag174) - -- Elaborate_Body_Desirable (Flag210) (non-generic case only) - -- From_With_Type (Flag159) - -- Has_All_Calls_Remote (Flag79) - -- Has_Completion (Flag26) - -- Has_Forward_Instantiation (Flag175) - -- Has_Master_Entity (Flag21) - -- Has_Subprogram_Descriptor (Flag93) - -- In_Package_Body (Flag48) - -- In_Private_Part (Flag45) - -- In_Use (Flag8) - -- Is_Instantiated (Flag126) - -- Is_Private_Descendant (Flag53) - -- Is_Visible_Child_Unit (Flag116) - -- Is_Wrapper_Package (synth) (non-generic case only) - -- Scope_Depth (synth) + -- Dependent_Instances (Elist8) (for an instance) + -- Renaming_Map (Uint9) + -- Handler_Records (List10) (non-generic case only) + -- Generic_Homonym (Node11) (generic case only) + -- Associated_Formal_Package (Node12) + -- Elaboration_Entity (Node13) + -- Shadow_Entities (List14) + -- Related_Instance (Node15) (non-generic case only) + -- First_Private_Entity (Node16) + -- First_Entity (Node17) + -- Renamed_Entity (Node18) + -- Body_Entity (Node19) + -- Last_Entity (Node20) + -- Interface_Name (Node21) + -- Scope_Depth_Value (Uint22) + -- Generic_Renamings (Elist23) (for an instance) + -- Inner_Instances (Elist23) (generic case only) + -- Limited_View (Node23) (non-generic/instance) + -- Current_Use_Clause (Node25) + -- Package_Instantiation (Node26) + -- Delay_Subprogram_Descriptors (Flag50) + -- Body_Needed_For_SAL (Flag40) + -- Discard_Names (Flag88) + -- Elaboration_Entity_Required (Flag174) + -- Elaborate_Body_Desirable (Flag210) (non-generic case only) + -- From_With_Type (Flag159) + -- Has_All_Calls_Remote (Flag79) + -- Has_Completion (Flag26) + -- Has_Forward_Instantiation (Flag175) + -- Has_Master_Entity (Flag21) + -- Has_RACW (Flag214) (non-generic case only) + -- Has_Subprogram_Descriptor (Flag93) + -- In_Package_Body (Flag48) + -- In_Private_Part (Flag45) + -- In_Use (Flag8) + -- Is_Instantiated (Flag126) + -- Is_Private_Descendant (Flag53) + -- Is_Visible_Child_Unit (Flag116) + -- Is_Wrapper_Package (synth) (non-generic case only) + -- Scope_Depth (synth) -- E_Package_Body - -- Handler_Records (List10) (non-generic case only) - -- Related_Instance (Node15) (non-generic case only) - -- First_Entity (Node17) - -- Spec_Entity (Node19) - -- Last_Entity (Node20) - -- Scope_Depth_Value (Uint22) - -- Scope_Depth (synth) - -- Delay_Subprogram_Descriptors (Flag50) - -- Has_Subprogram_Descriptor (Flag93) + -- Handler_Records (List10) (non-generic case only) + -- Related_Instance (Node15) (non-generic case only) + -- First_Entity (Node17) + -- Spec_Entity (Node19) + -- Last_Entity (Node20) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + -- Delay_Subprogram_Descriptors (Flag50) + -- Has_Subprogram_Descriptor (Flag93) -- E_Private_Type -- E_Private_Subtype - -- Primitive_Operations (Elist15) - -- First_Entity (Node17) - -- Private_Dependents (Elist18) - -- Underlying_Full_View (Node19) - -- Last_Entity (Node20) - -- Discriminant_Constraint (Elist21) - -- Private_View (Node22) - -- Stored_Constraint (Elist23) - -- Has_Completion (Flag26) - -- Is_Controlled (Flag42) (base type only) - -- Is_For_Access_Subtype (Flag118) (subtype only) - -- First_Discriminant (synth) - -- First_Stored_Discriminant (synth) + -- Primitive_Operations (Elist15) + -- First_Entity (Node17) + -- Private_Dependents (Elist18) + -- Underlying_Full_View (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Private_View (Node22) + -- Stored_Constraint (Elist23) + -- Has_Completion (Flag26) + -- Is_Controlled (Flag42) (base type only) + -- Is_For_Access_Subtype (Flag118) (subtype only) + -- First_Discriminant (synth) + -- First_Stored_Discriminant (synth) -- (plus type attributes) -- E_Procedure -- E_Generic_Procedure - -- Renaming_Map (Uint9) - -- Handler_Records (List10) (non-generic case only) - -- Protected_Body_Subprogram (Node11) - -- Next_Inlined_Subprogram (Node12) - -- Elaboration_Entity (Node13) - -- First_Optional_Parameter (Node14) (non-generic case only) - -- DT_Position (Uint15) - -- DTC_Entity (Node16) - -- First_Entity (Node17) - -- Alias (Node18) (non-generic case only) - -- Renamed_Entity (Node18) (generic case only) - -- Finalization_Chain_Entity (Node19) - -- Last_Entity (Node20) - -- Interface_Name (Node21) - -- Scope_Depth_Value (Uint22) - -- Scope_Depth (synth) - -- Generic_Renamings (Elist23) (for an instance) - -- Inner_Instances (Elist23) (for a generic procedure) - -- Privals_Chain (Elist23) (for a protected procedure) - -- Abstract_Interface_Alias (Node25) - -- Overridden_Operation (Node26) - -- Wrapped_Entity (Node27) (non-generic case only) - -- Extra_Formals (Node28) - -- Body_Needed_For_SAL (Flag40) - -- Elaboration_Entity_Required (Flag174) - -- Function_Returns_With_DSP (Flag169) (always False for procedure) - -- Default_Expressions_Processed (Flag108) - -- Delay_Cleanups (Flag114) - -- Delay_Subprogram_Descriptors (Flag50) - -- Discard_Names (Flag88) - -- Has_Completion (Flag26) - -- Has_Master_Entity (Flag21) - -- Has_Nested_Block_With_Handler (Flag101) - -- Has_Subprogram_Descriptor (Flag93) - -- Is_Visible_Child_Unit (Flag116) - -- Is_Abstract (Flag19) - -- Is_Asynchronous (Flag81) - -- Is_Called (Flag102) (non-generic subprogram) - -- Is_Constructor (Flag76) - -- Is_Eliminated (Flag124) - -- Is_Instantiated (Flag126) (generic case only) - -- Is_Interrupt_Handler (Flag89) - -- Is_Intrinsic_Subprogram (Flag64) - -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) - -- Is_Null_Init_Proc (Flag178) - -- Is_Overriding_Operation (Flag39) (non-generic case only) - -- Is_Primitive_Wrapper (Flag195) (non-generic case only) - -- Is_Private_Descendant (Flag53) - -- Is_Pure (Flag44) - -- Is_Thread_Body (Flag77) (non-generic case only) - -- Is_Valued_Procedure (Flag127) - -- Is_Visible_Child_Unit (Flag116) - -- Needs_No_Actuals (Flag22) - -- No_Return (Flag113) - -- Sec_Stack_Needed_For_Return (Flag167) - -- Address_Clause (synth) - -- First_Formal (synth) - -- First_Formal_With_Extras (synth) - -- Number_Formals (synth) + -- Renaming_Map (Uint9) + -- Handler_Records (List10) (non-generic case only) + -- Protected_Body_Subprogram (Node11) + -- Next_Inlined_Subprogram (Node12) + -- Elaboration_Entity (Node13) + -- First_Optional_Parameter (Node14) (non-generic case only) + -- DT_Position (Uint15) + -- DTC_Entity (Node16) + -- First_Entity (Node17) + -- Alias (Node18) (non-generic case only) + -- Renamed_Entity (Node18) (generic case only) + -- Finalization_Chain_Entity (Node19) + -- Last_Entity (Node20) + -- Interface_Name (Node21) + -- Scope_Depth_Value (Uint22) + -- Generic_Renamings (Elist23) (for instance) + -- Inner_Instances (Elist23) (for generic proc) + -- Privals_Chain (Elist23) (for protected proc) + -- Abstract_Interface_Alias (Node25) + -- Overridden_Operation (Node26) + -- Wrapped_Entity (Node27) (non-generic case only) + -- Extra_Formals (Node28) + -- Body_Needed_For_SAL (Flag40) + -- Delay_Cleanups (Flag114) + -- Discard_Names (Flag88) + -- Elaboration_Entity_Required (Flag174) + -- Function_Returns_With_DSP (Flag169) (false for procedure) + -- Default_Expressions_Processed (Flag108) + -- Delay_Cleanups (Flag114) + -- Delay_Subprogram_Descriptors (Flag50) + -- Discard_Names (Flag88) + -- Has_Completion (Flag26) + -- Has_Master_Entity (Flag21) + -- Has_Nested_Block_With_Handler (Flag101) + -- Has_Subprogram_Descriptor (Flag93) + -- Is_Visible_Child_Unit (Flag116) + -- Is_Abstract_Subprogram (Flag19) (non-generic case only) + -- Is_Asynchronous (Flag81) + -- Is_Called (Flag102) (non-generic subprog) + -- Is_Constructor (Flag76) + -- Is_Eliminated (Flag124) + -- Is_Instantiated (Flag126) (generic case only) + -- Is_Interrupt_Handler (Flag89) + -- Is_Intrinsic_Subprogram (Flag64) + -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) + -- Is_Null_Init_Proc (Flag178) + -- Is_Overriding_Operation (Flag39) (non-generic case only) + -- Is_Primitive_Wrapper (Flag195) (non-generic case only) + -- Is_Private_Descendant (Flag53) + -- Is_Pure (Flag44) + -- Is_Thread_Body (Flag77) (non-generic case only) + -- Is_Valued_Procedure (Flag127) + -- Is_Visible_Child_Unit (Flag116) + -- Needs_No_Actuals (Flag22) + -- No_Return (Flag113) + -- Requires_Overriding (Flag213) (non-generic case only) + -- Sec_Stack_Needed_For_Return (Flag167) + -- Address_Clause (synth) + -- First_Formal (synth) + -- First_Formal_With_Extras (synth) + -- Number_Formals (synth) + -- Delay_Cleanups (Flag114) + -- Discard_Names (Flag88) -- E_Protected_Body - -- Object_Ref (Node17) + -- Object_Ref (Node17) -- (any others??? First/Last Entity, Scope_Depth???) -- E_Protected_Object -- E_Protected_Type -- E_Protected_Subtype - -- Entry_Bodies_Array (Node15) - -- First_Private_Entity (Node16) - -- First_Entity (Node17) - -- Corresponding_Record_Type (Node18) - -- Finalization_Chain_Entity (Node19) - -- Last_Entity (Node20) - -- Discriminant_Constraint (Elist21) - -- Scope_Depth_Value (Uint22) - -- Scope_Depth (synth) - -- Stored_Constraint (Elist23) - -- Has_Interrupt_Handler (synth) - -- Sec_Stack_Needed_For_Return (Flag167) ??? - -- Uses_Sec_Stack (Flag95) ??? - -- Has_Entries (synth) - -- Number_Entries (synth) + -- Entry_Bodies_Array (Node15) + -- First_Private_Entity (Node16) + -- First_Entity (Node17) + -- Corresponding_Record_Type (Node18) + -- Finalization_Chain_Entity (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + -- Stored_Constraint (Elist23) + -- Has_Interrupt_Handler (synth) + -- Sec_Stack_Needed_For_Return (Flag167) ??? + -- Uses_Sec_Stack (Flag95) ??? + -- Has_Entries (synth) + -- Number_Entries (synth) -- E_Record_Type -- E_Record_Subtype - -- Primitive_Operations (Elist15) - -- Access_Disp_Table (Elist16) (base type only) - -- Cloned_Subtype (Node16) (subtype case only) - -- First_Entity (Node17) - -- Corresponding_Concurrent_Type (Node18) - -- Parent_Subtype (Node19) - -- Last_Entity (Node20) - -- Discriminant_Constraint (Elist21) - -- Corresponding_Remote_Type (Node22) - -- Stored_Constraint (Elist23) - -- Abstract_Interfaces (Elist25) - -- Component_Alignment (special) (base type only) - -- C_Pass_By_Copy (Flag125) (base type only) - -- Has_External_Tag_Rep_Clause (Flag110) - -- Has_Record_Rep_Clause (Flag65) (base type only) - -- Has_Static_Discriminants (Flag211) (subtype only) - -- Is_Class_Wide_Equivalent_Type (Flag35) - -- Is_Concurrent_Record_Type (Flag20) - -- Is_Constrained (Flag12) - -- Is_Controlled (Flag42) (base type only) - -- Is_Interface (Flag186) - -- Reverse_Bit_Order (Flag164) (base type only) - -- First_Component (synth) - -- First_Discriminant (synth) - -- First_Stored_Discriminant (synth) - -- First_Tag_Component (synth) + -- Primitive_Operations (Elist15) + -- Access_Disp_Table (Elist16) (base type only) + -- Cloned_Subtype (Node16) (subtype case only) + -- First_Entity (Node17) + -- Corresponding_Concurrent_Type (Node18) + -- Parent_Subtype (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Corresponding_Remote_Type (Node22) + -- Stored_Constraint (Elist23) + -- Abstract_Interfaces (Elist25) + -- Component_Alignment (special) (base type only) + -- C_Pass_By_Copy (Flag125) (base type only) + -- Has_External_Tag_Rep_Clause (Flag110) + -- Has_Record_Rep_Clause (Flag65) (base type only) + -- Has_Static_Discriminants (Flag211) (subtype only) + -- Is_Class_Wide_Equivalent_Type (Flag35) + -- Is_Concurrent_Record_Type (Flag20) + -- Is_Constrained (Flag12) + -- Is_Controlled (Flag42) (base type only) + -- Is_Interface (Flag186) + -- Reverse_Bit_Order (Flag164) (base type only) + -- First_Component (synth) + -- First_Component_Or_Discriminant (synth) + -- First_Discriminant (synth) + -- First_Stored_Discriminant (synth) + -- First_Tag_Component (synth) -- (plus type attributes) -- E_Record_Type_With_Private -- E_Record_Subtype_With_Private - -- Primitive_Operations (Elist15) - -- Access_Disp_Table (Elist16) (base type only) - -- First_Entity (Node17) - -- Private_Dependents (Elist18) - -- Underlying_Full_View (Node19) - -- Last_Entity (Node20) - -- Discriminant_Constraint (Elist21) - -- Private_View (Node22) - -- Stored_Constraint (Elist23) - -- Abstract_Interfaces (Elist25) - -- Has_Completion (Flag26) - -- Has_Record_Rep_Clause (Flag65) (base type only) - -- Has_External_Tag_Rep_Clause (Flag110) - -- Is_Concurrent_Record_Type (Flag20) - -- Is_Constrained (Flag12) - -- Is_Controlled (Flag42) (base type only) - -- Is_Interface (Flag186) - -- Reverse_Bit_Order (Flag164) (base type only) - -- First_Component (synth) - -- First_Discriminant (synth) - -- First_Stored_Discriminant (synth) - -- First_Tag_Component (synth) + -- Primitive_Operations (Elist15) + -- Access_Disp_Table (Elist16) (base type only) + -- First_Entity (Node17) + -- Private_Dependents (Elist18) + -- Underlying_Full_View (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Private_View (Node22) + -- Stored_Constraint (Elist23) + -- Abstract_Interfaces (Elist25) + -- Has_Completion (Flag26) + -- Has_Record_Rep_Clause (Flag65) (base type only) + -- Has_External_Tag_Rep_Clause (Flag110) + -- Is_Concurrent_Record_Type (Flag20) + -- Is_Constrained (Flag12) + -- Is_Controlled (Flag42) (base type only) + -- Is_Interface (Flag186) + -- Reverse_Bit_Order (Flag164) (base type only) + -- First_Component (synth) + -- First_Component_Or_Discriminant (synth) + -- First_Discriminant (synth) + -- First_Stored_Discriminant (synth) + -- First_Tag_Component (synth) -- (plus type attributes) -- E_Return_Statement - -- Return_Applies_To (Node8) + -- Return_Applies_To (Node8) + -- Finalization_Chain_Entity (Node19) -- E_Signed_Integer_Type -- E_Signed_Integer_Subtype - -- Scalar_Range (Node20) - -- Has_Biased_Representation (Flag139) - -- Type_Low_Bound (synth) - -- Type_High_Bound (synth) + -- Scalar_Range (Node20) + -- Has_Biased_Representation (Flag139) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) -- (plus type attributes) -- E_String_Type -- E_String_Subtype - -- First_Index (Node17) - -- Component_Type (Node20) (base type only) - -- Is_Constrained (Flag12) - -- Next_Index (synth) - -- Number_Dimensions (synth) + -- First_Index (Node17) + -- Component_Type (Node20) (base type only) + -- Is_Constrained (Flag12) + -- Next_Index (synth) + -- Number_Dimensions (synth) -- (plus type attributes) -- E_String_Literal_Subtype - -- String_Literal_Low_Bound (Node15) - -- String_Literal_Length (Uint16) - -- First_Index (Node17) (always Empty) - -- Packed_Array_Type (Node23) + -- String_Literal_Low_Bound (Node15) + -- String_Literal_Length (Uint16) + -- First_Index (Node17) (always Empty) + -- Packed_Array_Type (Node23) -- (plus type attributes) -- E_Subprogram_Body - -- Mechanism (Uint8) - -- First_Entity (Node17) - -- Last_Entity (Node20) - -- Scope_Depth_Value (Uint22) - -- Scope_Depth (synth) + -- Mechanism (Uint8) + -- First_Entity (Node17) + -- Last_Entity (Node20) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) -- E_Subprogram_Type - -- Directly_Designated_Type (Node20) - -- First_Formal (synth) - -- First_Formal_With_Extras (synth) - -- Number_Formals (synth) - -- Function_Returns_With_DSP (Flag169) + -- Directly_Designated_Type (Node20) + -- First_Formal (synth) + -- First_Formal_With_Extras (synth) + -- Number_Formals (synth) + -- Function_Returns_With_DSP (Flag169) -- (plus type attributes) -- E_Task_Body @@ -5047,59 +5108,59 @@ package Einfo is -- E_Task_Type -- E_Task_Subtype - -- Storage_Size_Variable (Node15) (base type only) - -- First_Private_Entity (Node16) - -- First_Entity (Node17) - -- Corresponding_Record_Type (Node18) - -- Finalization_Chain_Entity (Node19) - -- Last_Entity (Node20) - -- Discriminant_Constraint (Elist21) - -- Scope_Depth_Value (Uint22) - -- Scope_Depth (synth) - -- Stored_Constraint (Elist23) - -- Task_Body_Procedure (Node25) - -- Delay_Cleanups (Flag114) - -- Has_Master_Entity (Flag21) - -- Has_Storage_Size_Clause (Flag23) (base type only) - -- Uses_Sec_Stack (Flag95) ??? - -- Sec_Stack_Needed_For_Return (Flag167) ??? - -- Has_Entries (synth) - -- Number_Entries (synth) + -- Storage_Size_Variable (Node15) (base type only) + -- First_Private_Entity (Node16) + -- First_Entity (Node17) + -- Corresponding_Record_Type (Node18) + -- Finalization_Chain_Entity (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + -- Stored_Constraint (Elist23) + -- Task_Body_Procedure (Node25) + -- Delay_Cleanups (Flag114) + -- Has_Master_Entity (Flag21) + -- Has_Storage_Size_Clause (Flag23) (base type only) + -- Uses_Sec_Stack (Flag95) ??? + -- Sec_Stack_Needed_For_Return (Flag167) ??? + -- Has_Entries (synth) + -- Number_Entries (synth) -- (plus type attributes) -- E_Variable - -- Hiding_Loop_Variable (Node8) - -- Current_Value (Node9) - -- Esize (Uint12) - -- Extra_Accessibility (Node13) - -- Alignment (Uint14) - -- Shared_Var_Read_Proc (Node15) - -- Unset_Reference (Node16) - -- Actual_Subtype (Node17) - -- Renamed_Object (Node18) - -- Size_Check_Code (Node19) - -- Last_Assignment (Node20) - -- Interface_Name (Node21) - -- Shared_Var_Assign_Proc (Node22) - -- Extra_Constrained (Node23) - -- Has_Alignment_Clause (Flag46) - -- Has_Atomic_Components (Flag86) - -- Has_Biased_Representation (Flag139) - -- Has_Size_Clause (Flag29) - -- Has_Volatile_Components (Flag87) - -- In_Private_Part (Flag45) - -- Is_Atomic (Flag85) - -- Is_Eliminated (Flag124) - -- Is_Shared_Passive (Flag60) - -- Is_True_Constant (Flag163) - -- Is_Volatile (Flag16) - -- Never_Set_In_Source (Flag115) - -- Treat_As_Volatile (Flag41) - -- Is_Return_Object (Flag209) - -- Address_Clause (synth) - -- Alignment_Clause (synth) - -- Constant_Value (synth) - -- Size_Clause (synth) + -- Hiding_Loop_Variable (Node8) + -- Current_Value (Node9) + -- Esize (Uint12) + -- Extra_Accessibility (Node13) + -- Alignment (Uint14) + -- Shared_Var_Read_Proc (Node15) + -- Unset_Reference (Node16) + -- Actual_Subtype (Node17) + -- Renamed_Object (Node18) + -- Size_Check_Code (Node19) + -- Last_Assignment (Node20) + -- Interface_Name (Node21) + -- Shared_Var_Assign_Proc (Node22) + -- Extra_Constrained (Node23) + -- Has_Alignment_Clause (Flag46) + -- Has_Atomic_Components (Flag86) + -- Has_Biased_Representation (Flag139) + -- Has_Size_Clause (Flag29) + -- Has_Volatile_Components (Flag87) + -- In_Private_Part (Flag45) + -- Is_Atomic (Flag85) + -- Is_Eliminated (Flag124) + -- Is_Shared_Passive (Flag60) + -- Is_True_Constant (Flag163) + -- Is_Volatile (Flag16) + -- Never_Set_In_Source (Flag115) + -- Treat_As_Volatile (Flag41) + -- Is_Return_Object (Flag209) + -- Address_Clause (synth) + -- Alignment_Clause (synth) + -- Constant_Value (synth) + -- Size_Clause (synth) -- E_Void -- Since E_Void is the initial Ekind value of an entity when it is first @@ -5330,343 +5391,347 @@ package Einfo is -- section contains the functions used to obtain attribute values which -- correspond to values in fields or flags in the entity itself. - function Abstract_Interfaces (Id : E) return L; - function Accept_Address (Id : E) return L; - function Access_Disp_Table (Id : E) return L; - function Actual_Subtype (Id : E) return E; - function Address_Taken (Id : E) return B; - function Alias (Id : E) return E; - function Abstract_Interface_Alias (Id : E) return E; - function Alignment (Id : E) return U; - function Associated_Final_Chain (Id : E) return E; - function Associated_Formal_Package (Id : E) return E; - function Associated_Node_For_Itype (Id : E) return N; - function Associated_Storage_Pool (Id : E) return E; - function Barrier_Function (Id : E) return N; - function Block_Node (Id : E) return N; - function Body_Entity (Id : E) return E; - function Body_Needed_For_SAL (Id : E) return B; - function CR_Discriminant (Id : E) return E; - function C_Pass_By_Copy (Id : E) return B; - function Can_Never_Be_Null (Id : E) return B; - function Checks_May_Be_Suppressed (Id : E) return B; - function Class_Wide_Type (Id : E) return E; - function Cloned_Subtype (Id : E) return E; - function Component_Alignment (Id : E) return C; - function Component_Clause (Id : E) return N; - function Component_Bit_Offset (Id : E) return U; - function Component_Size (Id : E) return U; - function Component_Type (Id : E) return E; - function Corresponding_Concurrent_Type (Id : E) return E; - function Corresponding_Discriminant (Id : E) return E; - function Corresponding_Equality (Id : E) return E; - function Corresponding_Record_Type (Id : E) return E; - function Corresponding_Remote_Type (Id : E) return E; - function Current_Use_Clause (Id : E) return E; - function Current_Value (Id : E) return N; - function Debug_Info_Off (Id : E) return B; - function Debug_Renaming_Link (Id : E) return E; - function DTC_Entity (Id : E) return E; - function DT_Entry_Count (Id : E) return U; - function DT_Offset_To_Top_Func (Id : E) return E; - function DT_Position (Id : E) return U; - function Default_Expr_Function (Id : E) return E; - function Default_Expressions_Processed (Id : E) return B; - function Default_Value (Id : E) return N; - function Delay_Cleanups (Id : E) return B; - function Delay_Subprogram_Descriptors (Id : E) return B; - function Delta_Value (Id : E) return R; - function Dependent_Instances (Id : E) return L; - function Depends_On_Private (Id : E) return B; - function Digits_Value (Id : E) return U; - function Directly_Designated_Type (Id : E) return E; - function Discard_Names (Id : E) return B; - function Discriminal (Id : E) return E; - function Discriminal_Link (Id : E) return E; - function Discriminant_Checking_Func (Id : E) return E; - function Discriminant_Constraint (Id : E) return L; - function Discriminant_Default_Value (Id : E) return N; - function Discriminant_Number (Id : E) return U; - function Elaborate_Body_Desirable (Id : E) return B; - function Elaboration_Entity (Id : E) return E; - function Elaboration_Entity_Required (Id : E) return B; - function Enclosing_Scope (Id : E) return E; - function Entry_Accepted (Id : E) return B; - function Entry_Bodies_Array (Id : E) return E; - function Entry_Cancel_Parameter (Id : E) return E; - function Entry_Component (Id : E) return E; - function Entry_Formal (Id : E) return E; - function Entry_Index_Constant (Id : E) return E; - function Entry_Index_Type (Id : E) return E; - function Entry_Parameters_Type (Id : E) return E; - function Enum_Pos_To_Rep (Id : E) return E; - function Enumeration_Pos (Id : E) return U; - function Enumeration_Rep (Id : E) return U; - function Enumeration_Rep_Expr (Id : E) return N; - function Equivalent_Type (Id : E) return E; - function Esize (Id : E) return U; - function Exception_Code (Id : E) return U; - function Extra_Accessibility (Id : E) return E; - function Extra_Constrained (Id : E) return E; - function Extra_Formal (Id : E) return E; - function Extra_Formals (Id : E) return E; - function Finalization_Chain_Entity (Id : E) return E; - function Finalize_Storage_Only (Id : E) return B; - function First_Entity (Id : E) return E; - function First_Index (Id : E) return N; - function First_Literal (Id : E) return E; - function First_Optional_Parameter (Id : E) return E; - function First_Private_Entity (Id : E) return E; - function First_Rep_Item (Id : E) return N; - function Freeze_Node (Id : E) return N; - function From_With_Type (Id : E) return B; - function Full_View (Id : E) return E; - function Function_Returns_With_DSP (Id : E) return B; - function Generic_Homonym (Id : E) return E; - function Generic_Renamings (Id : E) return L; - function Handler_Records (Id : E) return S; - function Has_Aliased_Components (Id : E) return B; - function Has_Alignment_Clause (Id : E) return B; - function Has_All_Calls_Remote (Id : E) return B; - function Has_Anon_Block_Suffix (Id : E) return B; - function Has_Atomic_Components (Id : E) return B; - function Has_Biased_Representation (Id : E) return B; - function Has_Completion (Id : E) return B; - function Has_Completion_In_Body (Id : E) return B; - function Has_Complex_Representation (Id : E) return B; - function Has_Component_Size_Clause (Id : E) return B; - function Has_Constrained_Partial_View (Id : E) return B; - function Has_Contiguous_Rep (Id : E) return B; - function Has_Controlled_Component (Id : E) return B; - function Has_Controlling_Result (Id : E) return B; - function Has_Convention_Pragma (Id : E) return B; - function Has_Delayed_Freeze (Id : E) return B; - function Has_Discriminants (Id : E) return B; - function Has_Enumeration_Rep_Clause (Id : E) return B; - function Has_Exit (Id : E) return B; - function Has_External_Tag_Rep_Clause (Id : E) return B; - function Has_Fully_Qualified_Name (Id : E) return B; - function Has_Gigi_Rep_Item (Id : E) return B; - function Has_Homonym (Id : E) return B; - function Has_Interrupt_Handler (Id : E) return B; - function Has_Machine_Radix_Clause (Id : E) return B; - function Has_Master_Entity (Id : E) return B; - function Has_Missing_Return (Id : E) return B; - function Has_Nested_Block_With_Handler (Id : E) return B; - function Has_Forward_Instantiation (Id : E) return B; - function Has_Non_Standard_Rep (Id : E) return B; - function Has_Object_Size_Clause (Id : E) return B; - function Has_Per_Object_Constraint (Id : E) return B; - function Has_Persistent_BSS (Id : E) return B; - function Has_Pragma_Controlled (Id : E) return B; - function Has_Pragma_Elaborate_Body (Id : E) return B; - function Has_Pragma_Inline (Id : E) return B; - function Has_Pragma_Pack (Id : E) return B; - function Has_Pragma_Pure (Id : E) return B; - function Has_Pragma_Pure_Function (Id : E) return B; - function Has_Pragma_Unreferenced (Id : E) return B; - function Has_Primitive_Operations (Id : E) return B; - function Has_Qualified_Name (Id : E) return B; - function Has_Record_Rep_Clause (Id : E) return B; - function Has_Recursive_Call (Id : E) return B; - function Has_Size_Clause (Id : E) return B; - function Has_Small_Clause (Id : E) return B; - function Has_Specified_Layout (Id : E) return B; - function Has_Specified_Stream_Input (Id : E) return B; - function Has_Specified_Stream_Output (Id : E) return B; - function Has_Specified_Stream_Read (Id : E) return B; - function Has_Specified_Stream_Write (Id : E) return B; - function Has_Static_Discriminants (Id : E) return B; - function Has_Storage_Size_Clause (Id : E) return B; - function Has_Stream_Size_Clause (Id : E) return B; - function Has_Subprogram_Descriptor (Id : E) return B; - function Has_Task (Id : E) return B; - function Has_Unchecked_Union (Id : E) return B; - function Has_Unknown_Discriminants (Id : E) return B; - function Has_Volatile_Components (Id : E) return B; - function Has_Xref_Entry (Id : E) return B; - function Hiding_Loop_Variable (Id : E) return E; - function Homonym (Id : E) return E; - function In_Package_Body (Id : E) return B; - function In_Private_Part (Id : E) return B; - function In_Use (Id : E) return B; - function Inner_Instances (Id : E) return L; - function Interface_Name (Id : E) return N; - function Is_AST_Entry (Id : E) return B; - function Is_Abstract (Id : E) return B; - function Is_Local_Anonymous_Access (Id : E) return B; - function Is_Access_Constant (Id : E) return B; - function Is_Ada_2005_Only (Id : E) return B; - function Is_Aliased (Id : E) return B; - function Is_Asynchronous (Id : E) return B; - function Is_Atomic (Id : E) return B; - function Is_Bit_Packed_Array (Id : E) return B; - function Is_CPP_Class (Id : E) return B; - function Is_Called (Id : E) return B; - function Is_Character_Type (Id : E) return B; - function Is_Child_Unit (Id : E) return B; - function Is_Class_Wide_Equivalent_Type (Id : E) return B; - function Is_Compilation_Unit (Id : E) return B; - function Is_Completely_Hidden (Id : E) return B; - function Is_Constr_Subt_For_UN_Aliased (Id : E) return B; - function Is_Constr_Subt_For_U_Nominal (Id : E) return B; - function Is_Constrained (Id : E) return B; - function Is_Constructor (Id : E) return B; - function Is_Controlled (Id : E) return B; - function Is_Controlling_Formal (Id : E) return B; - function Is_Discrim_SO_Function (Id : E) return B; - function Is_Dispatching_Operation (Id : E) return B; - function Is_Eliminated (Id : E) return B; - function Is_Entry_Formal (Id : E) return B; - function Is_Exported (Id : E) return B; - function Is_First_Subtype (Id : E) return B; - function Is_For_Access_Subtype (Id : E) return B; - function Is_Frozen (Id : E) return B; - function Is_Generic_Instance (Id : E) return B; - function Is_Hidden (Id : E) return B; - function Is_Hidden_Open_Scope (Id : E) return B; - function Is_Immediately_Visible (Id : E) return B; - function Is_Imported (Id : E) return B; - function Is_Inlined (Id : E) return B; - function Is_Interface (Id : E) return B; - function Is_Instantiated (Id : E) return B; - function Is_Internal (Id : E) return B; - function Is_Interrupt_Handler (Id : E) return B; - function Is_Intrinsic_Subprogram (Id : E) return B; - function Is_Itype (Id : E) return B; - function Is_Known_Non_Null (Id : E) return B; - function Is_Known_Null (Id : E) return B; - function Is_Known_Valid (Id : E) return B; - function Is_Limited_Composite (Id : E) return B; - function Is_Limited_Interface (Id : E) return B; - function Is_Machine_Code_Subprogram (Id : E) return B; - function Is_Non_Static_Subtype (Id : E) return B; - function Is_Null_Init_Proc (Id : E) return B; - function Is_Obsolescent (Id : E) return B; - function Is_Optional_Parameter (Id : E) return B; - function Is_Package_Body_Entity (Id : E) return B; - function Is_Packed (Id : E) return B; - function Is_Packed_Array_Type (Id : E) return B; - function Is_Potentially_Use_Visible (Id : E) return B; - function Is_Preelaborated (Id : E) return B; - function Is_Primitive_Wrapper (Id : E) return B; - function Is_Private_Composite (Id : E) return B; - function Is_Private_Descendant (Id : E) return B; - function Is_Protected_Interface (Id : E) return B; - function Is_Public (Id : E) return B; - function Is_Pure (Id : E) return B; - function Is_Pure_Unit_Access_Type (Id : E) return B; - function Is_Remote_Call_Interface (Id : E) return B; - function Is_Remote_Types (Id : E) return B; - function Is_Renaming_Of_Object (Id : E) return B; - function Is_Return_Object (Id : E) return B; - function Is_Shared_Passive (Id : E) return B; - function Is_Statically_Allocated (Id : E) return B; - function Is_Synchronized_Interface (Id : E) return B; - function Is_Tag (Id : E) return B; - function Is_Tagged_Type (Id : E) return B; - function Is_Task_Interface (Id : E) return B; - function Is_Thread_Body (Id : E) return B; - function Is_True_Constant (Id : E) return B; - function Is_Unchecked_Union (Id : E) return B; - function Is_Unsigned_Type (Id : E) return B; - function Is_VMS_Exception (Id : E) return B; - function Is_Valued_Procedure (Id : E) return B; - function Is_Visible_Child_Unit (Id : E) return B; - function Is_Visible_Formal (Id : E) return B; - function Is_Volatile (Id : E) return B; - function Itype_Printed (Id : E) return B; - function Kill_Elaboration_Checks (Id : E) return B; - function Kill_Range_Checks (Id : E) return B; - function Kill_Tag_Checks (Id : E) return B; - function Known_To_Have_Preelab_Init (Id : E) return B; - function Last_Assignment (Id : E) return N; - function Last_Entity (Id : E) return E; - function Limited_View (Id : E) return E; - function Lit_Indexes (Id : E) return E; - function Lit_Strings (Id : E) return E; - function Low_Bound_Known (Id : E) return B; - function Machine_Radix_10 (Id : E) return B; - function Master_Id (Id : E) return E; - function Materialize_Entity (Id : E) return B; - function Mechanism (Id : E) return M; - function Modulus (Id : E) return U; - function Must_Be_On_Byte_Boundary (Id : E) return B; - function Must_Have_Preelab_Init (Id : E) return B; - function Needs_Debug_Info (Id : E) return B; - function Needs_No_Actuals (Id : E) return B; - function Never_Set_In_Source (Id : E) return B; - function Next_Inlined_Subprogram (Id : E) return E; - function No_Pool_Assigned (Id : E) return B; - function No_Return (Id : E) return B; - function No_Strict_Aliasing (Id : E) return B; - function Non_Binary_Modulus (Id : E) return B; - function Non_Limited_View (Id : E) return E; - function Nonzero_Is_True (Id : E) return B; - function Normalized_First_Bit (Id : E) return U; - function Normalized_Position (Id : E) return U; - function Normalized_Position_Max (Id : E) return U; - function Object_Ref (Id : E) return E; - function Obsolescent_Warning (Id : E) return N; - function Original_Access_Type (Id : E) return E; - function Original_Array_Type (Id : E) return E; - function Original_Record_Component (Id : E) return E; - function Overridden_Operation (Id : E) return E; - function Package_Instantiation (Id : E) return N; - function Packed_Array_Type (Id : E) return E; - function Parent_Subtype (Id : E) return E; - function Primitive_Operations (Id : E) return L; - function Prival (Id : E) return E; - function Privals_Chain (Id : E) return L; - function Private_Dependents (Id : E) return L; - function Private_View (Id : E) return N; - function Protected_Body_Subprogram (Id : E) return E; - function Protected_Formal (Id : E) return E; - function Protected_Operation (Id : E) return E; - function RM_Size (Id : E) return U; - function Reachable (Id : E) return B; - function Referenced (Id : E) return B; - function Referenced_As_LHS (Id : E) return B; - function Referenced_Object (Id : E) return N; - function Register_Exception_Call (Id : E) return N; - function Related_Array_Object (Id : E) return E; - function Related_Instance (Id : E) return E; - function Renamed_Entity (Id : E) return N; - function Renamed_Object (Id : E) return N; - function Renaming_Map (Id : E) return U; - function Return_Present (Id : E) return B; - function Return_Applies_To (Id : E) return N; - function Returns_By_Ref (Id : E) return B; - function Reverse_Bit_Order (Id : E) return B; - function Scalar_Range (Id : E) return N; - function Scale_Value (Id : E) return U; - function Scope_Depth_Value (Id : E) return U; - function Sec_Stack_Needed_For_Return (Id : E) return B; - function Shadow_Entities (Id : E) return S; - function Shared_Var_Assign_Proc (Id : E) return E; - function Shared_Var_Read_Proc (Id : E) return E; - function Size_Check_Code (Id : E) return N; - function Size_Known_At_Compile_Time (Id : E) return B; - function Size_Depends_On_Discriminant (Id : E) return B; - function Small_Value (Id : E) return R; - function Spec_Entity (Id : E) return E; - function Storage_Size_Variable (Id : E) return E; - function Stored_Constraint (Id : E) return L; - 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 Suppress_Elaboration_Warnings (Id : E) return B; - function Suppress_Init_Proc (Id : E) return B; - function Suppress_Style_Checks (Id : E) return B; - function Task_Body_Procedure (Id : E) return N; - function Treat_As_Volatile (Id : E) return B; - function Underlying_Full_View (Id : E) return E; - function Unset_Reference (Id : E) return N; - function Uses_Sec_Stack (Id : E) return B; - function Vax_Float (Id : E) return B; - function Warnings_Off (Id : E) return B; - function Was_Hidden (Id : E) return B; - function Wrapped_Entity (Id : E) return E; + function Abstract_Interfaces (Id : E) return L; + function Accept_Address (Id : E) return L; + function Access_Disp_Table (Id : E) return L; + function Actual_Subtype (Id : E) return E; + function Address_Taken (Id : E) return B; + function Alias (Id : E) return E; + function Abstract_Interface_Alias (Id : E) return E; + function Alignment (Id : E) return U; + function Associated_Final_Chain (Id : E) return E; + function Associated_Formal_Package (Id : E) return E; + function Associated_Node_For_Itype (Id : E) return N; + function Associated_Storage_Pool (Id : E) return E; + function Barrier_Function (Id : E) return N; + function Block_Node (Id : E) return N; + function Body_Entity (Id : E) return E; + function Body_Needed_For_SAL (Id : E) return B; + function CR_Discriminant (Id : E) return E; + function C_Pass_By_Copy (Id : E) return B; + function Can_Never_Be_Null (Id : E) return B; + function Checks_May_Be_Suppressed (Id : E) return B; + function Class_Wide_Type (Id : E) return E; + function Cloned_Subtype (Id : E) return E; + function Component_Alignment (Id : E) return C; + function Component_Clause (Id : E) return N; + function Component_Bit_Offset (Id : E) return U; + function Component_Size (Id : E) return U; + function Component_Type (Id : E) return E; + function Corresponding_Concurrent_Type (Id : E) return E; + function Corresponding_Discriminant (Id : E) return E; + function Corresponding_Equality (Id : E) return E; + function Corresponding_Record_Type (Id : E) return E; + function Corresponding_Remote_Type (Id : E) return E; + function Current_Use_Clause (Id : E) return E; + function Current_Value (Id : E) return N; + function Debug_Info_Off (Id : E) return B; + function Debug_Renaming_Link (Id : E) return E; + function DTC_Entity (Id : E) return E; + function DT_Entry_Count (Id : E) return U; + function DT_Offset_To_Top_Func (Id : E) return E; + function DT_Position (Id : E) return U; + function Default_Expr_Function (Id : E) return E; + function Default_Expressions_Processed (Id : E) return B; + function Default_Value (Id : E) return N; + function Delay_Cleanups (Id : E) return B; + function Delay_Subprogram_Descriptors (Id : E) return B; + function Delta_Value (Id : E) return R; + function Dependent_Instances (Id : E) return L; + function Depends_On_Private (Id : E) return B; + function Digits_Value (Id : E) return U; + function Directly_Designated_Type (Id : E) return E; + function Discard_Names (Id : E) return B; + function Discriminal (Id : E) return E; + function Discriminal_Link (Id : E) return E; + function Discriminant_Checking_Func (Id : E) return E; + function Discriminant_Constraint (Id : E) return L; + function Discriminant_Default_Value (Id : E) return N; + function Discriminant_Number (Id : E) return U; + function Elaborate_Body_Desirable (Id : E) return B; + function Elaboration_Entity (Id : E) return E; + function Elaboration_Entity_Required (Id : E) return B; + function Enclosing_Scope (Id : E) return E; + function Entry_Accepted (Id : E) return B; + function Entry_Bodies_Array (Id : E) return E; + function Entry_Cancel_Parameter (Id : E) return E; + function Entry_Component (Id : E) return E; + function Entry_Formal (Id : E) return E; + function Entry_Index_Constant (Id : E) return E; + function Entry_Index_Type (Id : E) return E; + function Entry_Parameters_Type (Id : E) return E; + function Enum_Pos_To_Rep (Id : E) return E; + function Enumeration_Pos (Id : E) return U; + function Enumeration_Rep (Id : E) return U; + function Enumeration_Rep_Expr (Id : E) return N; + function Equivalent_Type (Id : E) return E; + function Esize (Id : E) return U; + function Exception_Code (Id : E) return U; + function Extra_Accessibility (Id : E) return E; + function Extra_Constrained (Id : E) return E; + function Extra_Formal (Id : E) return E; + function Extra_Formals (Id : E) return E; + function Finalization_Chain_Entity (Id : E) return E; + function Finalize_Storage_Only (Id : E) return B; + function First_Entity (Id : E) return E; + function First_Index (Id : E) return N; + function First_Literal (Id : E) return E; + function First_Optional_Parameter (Id : E) return E; + function First_Private_Entity (Id : E) return E; + function First_Rep_Item (Id : E) return N; + function Freeze_Node (Id : E) return N; + function From_With_Type (Id : E) return B; + function Full_View (Id : E) return E; + function Function_Returns_With_DSP (Id : E) return B; + function Generic_Homonym (Id : E) return E; + function Generic_Renamings (Id : E) return L; + function Handler_Records (Id : E) return S; + function Has_Aliased_Components (Id : E) return B; + function Has_Alignment_Clause (Id : E) return B; + function Has_All_Calls_Remote (Id : E) return B; + function Has_Anon_Block_Suffix (Id : E) return B; + function Has_Atomic_Components (Id : E) return B; + function Has_Biased_Representation (Id : E) return B; + function Has_Completion (Id : E) return B; + function Has_Completion_In_Body (Id : E) return B; + function Has_Complex_Representation (Id : E) return B; + function Has_Component_Size_Clause (Id : E) return B; + function Has_Constrained_Partial_View (Id : E) return B; + function Has_Contiguous_Rep (Id : E) return B; + function Has_Controlled_Component (Id : E) return B; + function Has_Controlling_Result (Id : E) return B; + function Has_Convention_Pragma (Id : E) return B; + function Has_Delayed_Freeze (Id : E) return B; + function Has_Discriminants (Id : E) return B; + function Has_Enumeration_Rep_Clause (Id : E) return B; + function Has_Exit (Id : E) return B; + function Has_External_Tag_Rep_Clause (Id : E) return B; + function Has_Fully_Qualified_Name (Id : E) return B; + function Has_Gigi_Rep_Item (Id : E) return B; + function Has_Homonym (Id : E) return B; + function Has_Interrupt_Handler (Id : E) return B; + function Has_Machine_Radix_Clause (Id : E) return B; + function Has_Master_Entity (Id : E) return B; + function Has_Missing_Return (Id : E) return B; + function Has_Nested_Block_With_Handler (Id : E) return B; + function Has_Forward_Instantiation (Id : E) return B; + function Has_Non_Standard_Rep (Id : E) return B; + function Has_Object_Size_Clause (Id : E) return B; + function Has_Per_Object_Constraint (Id : E) return B; + function Has_Persistent_BSS (Id : E) return B; + function Has_Pragma_Controlled (Id : E) return B; + function Has_Pragma_Elaborate_Body (Id : E) return B; + function Has_Pragma_Inline (Id : E) return B; + function Has_Pragma_Pack (Id : E) return B; + function Has_Pragma_Pure (Id : E) return B; + function Has_Pragma_Pure_Function (Id : E) return B; + function Has_Pragma_Unreferenced (Id : E) return B; + function Has_Pragma_Unreferenced_Objects (Id : E) return B; + function Has_Primitive_Operations (Id : E) return B; + function Has_Qualified_Name (Id : E) return B; + function Has_RACW (Id : E) return B; + function Has_Record_Rep_Clause (Id : E) return B; + function Has_Recursive_Call (Id : E) return B; + function Has_Size_Clause (Id : E) return B; + function Has_Small_Clause (Id : E) return B; + function Has_Specified_Layout (Id : E) return B; + function Has_Specified_Stream_Input (Id : E) return B; + function Has_Specified_Stream_Output (Id : E) return B; + function Has_Specified_Stream_Read (Id : E) return B; + function Has_Specified_Stream_Write (Id : E) return B; + function Has_Static_Discriminants (Id : E) return B; + function Has_Storage_Size_Clause (Id : E) return B; + function Has_Stream_Size_Clause (Id : E) return B; + function Has_Subprogram_Descriptor (Id : E) return B; + function Has_Task (Id : E) return B; + function Has_Unchecked_Union (Id : E) return B; + function Has_Unknown_Discriminants (Id : E) return B; + function Has_Volatile_Components (Id : E) return B; + function Has_Xref_Entry (Id : E) return B; + function Hiding_Loop_Variable (Id : E) return E; + function Homonym (Id : E) return E; + function In_Package_Body (Id : E) return B; + function In_Private_Part (Id : E) return B; + function In_Use (Id : E) return B; + function Inner_Instances (Id : E) return L; + function Interface_Name (Id : E) return N; + function Is_AST_Entry (Id : E) return B; + function Is_Abstract_Subprogram (Id : E) return B; + function Is_Abstract_Type (Id : E) return B; + function Is_Local_Anonymous_Access (Id : E) return B; + function Is_Access_Constant (Id : E) return B; + function Is_Ada_2005_Only (Id : E) return B; + function Is_Aliased (Id : E) return B; + function Is_Asynchronous (Id : E) return B; + function Is_Atomic (Id : E) return B; + function Is_Bit_Packed_Array (Id : E) return B; + function Is_CPP_Class (Id : E) return B; + function Is_Called (Id : E) return B; + function Is_Character_Type (Id : E) return B; + function Is_Child_Unit (Id : E) return B; + function Is_Class_Wide_Equivalent_Type (Id : E) return B; + function Is_Compilation_Unit (Id : E) return B; + function Is_Completely_Hidden (Id : E) return B; + function Is_Constr_Subt_For_UN_Aliased (Id : E) return B; + function Is_Constr_Subt_For_U_Nominal (Id : E) return B; + function Is_Constrained (Id : E) return B; + function Is_Constructor (Id : E) return B; + function Is_Controlled (Id : E) return B; + function Is_Controlling_Formal (Id : E) return B; + function Is_Discrim_SO_Function (Id : E) return B; + function Is_Dispatching_Operation (Id : E) return B; + function Is_Eliminated (Id : E) return B; + function Is_Entry_Formal (Id : E) return B; + function Is_Exported (Id : E) return B; + function Is_First_Subtype (Id : E) return B; + function Is_For_Access_Subtype (Id : E) return B; + function Is_Frozen (Id : E) return B; + function Is_Generic_Instance (Id : E) return B; + function Is_Hidden (Id : E) return B; + function Is_Hidden_Open_Scope (Id : E) return B; + function Is_Immediately_Visible (Id : E) return B; + function Is_Imported (Id : E) return B; + function Is_Inlined (Id : E) return B; + function Is_Interface (Id : E) return B; + function Is_Instantiated (Id : E) return B; + function Is_Internal (Id : E) return B; + function Is_Interrupt_Handler (Id : E) return B; + function Is_Intrinsic_Subprogram (Id : E) return B; + function Is_Itype (Id : E) return B; + function Is_Known_Non_Null (Id : E) return B; + function Is_Known_Null (Id : E) return B; + function Is_Known_Valid (Id : E) return B; + function Is_Limited_Composite (Id : E) return B; + function Is_Limited_Interface (Id : E) return B; + function Is_Machine_Code_Subprogram (Id : E) return B; + function Is_Non_Static_Subtype (Id : E) return B; + function Is_Null_Init_Proc (Id : E) return B; + function Is_Obsolescent (Id : E) return B; + function Is_Optional_Parameter (Id : E) return B; + function Is_Package_Body_Entity (Id : E) return B; + function Is_Packed (Id : E) return B; + function Is_Packed_Array_Type (Id : E) return B; + function Is_Potentially_Use_Visible (Id : E) return B; + function Is_Preelaborated (Id : E) return B; + function Is_Primitive_Wrapper (Id : E) return B; + function Is_Private_Composite (Id : E) return B; + function Is_Private_Descendant (Id : E) return B; + function Is_Protected_Interface (Id : E) return B; + function Is_Public (Id : E) return B; + function Is_Pure (Id : E) return B; + function Is_Pure_Unit_Access_Type (Id : E) return B; + function Is_Remote_Call_Interface (Id : E) return B; + function Is_Remote_Types (Id : E) return B; + function Is_Renaming_Of_Object (Id : E) return B; + function Is_Return_Object (Id : E) return B; + function Is_Shared_Passive (Id : E) return B; + function Is_Statically_Allocated (Id : E) return B; + function Is_Synchronized_Interface (Id : E) return B; + function Is_Tag (Id : E) return B; + function Is_Tagged_Type (Id : E) return B; + function Is_Task_Interface (Id : E) return B; + function Is_Thread_Body (Id : E) return B; + function Is_True_Constant (Id : E) return B; + function Is_Unchecked_Union (Id : E) return B; + function Is_Unsigned_Type (Id : E) return B; + function Is_VMS_Exception (Id : E) return B; + function Is_Valued_Procedure (Id : E) return B; + function Is_Visible_Child_Unit (Id : E) return B; + function Is_Visible_Formal (Id : E) return B; + function Is_Volatile (Id : E) return B; + function Itype_Printed (Id : E) return B; + function Kill_Elaboration_Checks (Id : E) return B; + function Kill_Range_Checks (Id : E) return B; + function Kill_Tag_Checks (Id : E) return B; + function Known_To_Have_Preelab_Init (Id : E) return B; + function Last_Assignment (Id : E) return N; + function Last_Entity (Id : E) return E; + function Limited_View (Id : E) return E; + function Lit_Indexes (Id : E) return E; + function Lit_Strings (Id : E) return E; + function Low_Bound_Known (Id : E) return B; + function Machine_Radix_10 (Id : E) return B; + function Master_Id (Id : E) return E; + function Materialize_Entity (Id : E) return B; + function Mechanism (Id : E) return M; + function Modulus (Id : E) return U; + function Must_Be_On_Byte_Boundary (Id : E) return B; + function Must_Have_Preelab_Init (Id : E) return B; + function Needs_Debug_Info (Id : E) return B; + function Needs_No_Actuals (Id : E) return B; + function Never_Set_In_Source (Id : E) return B; + function Next_Inlined_Subprogram (Id : E) return E; + function No_Pool_Assigned (Id : E) return B; + function No_Return (Id : E) return B; + function No_Strict_Aliasing (Id : E) return B; + function Non_Binary_Modulus (Id : E) return B; + function Non_Limited_View (Id : E) return E; + function Nonzero_Is_True (Id : E) return B; + function Normalized_First_Bit (Id : E) return U; + function Normalized_Position (Id : E) return U; + function Normalized_Position_Max (Id : E) return U; + function Object_Ref (Id : E) return E; + function Obsolescent_Warning (Id : E) return N; + function Original_Access_Type (Id : E) return E; + function Original_Array_Type (Id : E) return E; + function Original_Record_Component (Id : E) return E; + function Overridden_Operation (Id : E) return E; + function Package_Instantiation (Id : E) return N; + function Packed_Array_Type (Id : E) return E; + function Parent_Subtype (Id : E) return E; + function Primitive_Operations (Id : E) return L; + function Prival (Id : E) return E; + function Privals_Chain (Id : E) return L; + function Private_Dependents (Id : E) return L; + function Private_View (Id : E) return N; + function Protected_Body_Subprogram (Id : E) return E; + function Protected_Formal (Id : E) return E; + function Protected_Operation (Id : E) return E; + function RM_Size (Id : E) return U; + function Reachable (Id : E) return B; + function Referenced (Id : E) return B; + function Referenced_As_LHS (Id : E) return B; + function Referenced_Object (Id : E) return N; + function Register_Exception_Call (Id : E) return N; + function Related_Array_Object (Id : E) return E; + function Related_Instance (Id : E) return E; + function Renamed_Entity (Id : E) return N; + function Renamed_Object (Id : E) return N; + function Renaming_Map (Id : E) return U; + function Requires_Overriding (Id : E) return B; + function Return_Present (Id : E) return B; + function Return_Applies_To (Id : E) return N; + function Returns_By_Ref (Id : E) return B; + function Reverse_Bit_Order (Id : E) return B; + function Scalar_Range (Id : E) return N; + function Scale_Value (Id : E) return U; + function Scope_Depth_Value (Id : E) return U; + function Sec_Stack_Needed_For_Return (Id : E) return B; + function Shadow_Entities (Id : E) return S; + function Shared_Var_Assign_Proc (Id : E) return E; + function Shared_Var_Read_Proc (Id : E) return E; + function Size_Check_Code (Id : E) return N; + function Size_Known_At_Compile_Time (Id : E) return B; + function Size_Depends_On_Discriminant (Id : E) return B; + function Small_Value (Id : E) return R; + function Spec_Entity (Id : E) return E; + function Storage_Size_Variable (Id : E) return E; + function Stored_Constraint (Id : E) return L; + 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 Suppress_Elaboration_Warnings (Id : E) return B; + function Suppress_Init_Proc (Id : E) return B; + function Suppress_Style_Checks (Id : E) return B; + function Task_Body_Procedure (Id : E) return N; + function Treat_As_Volatile (Id : E) return B; + function Underlying_Full_View (Id : E) return E; + function Unset_Reference (Id : E) return N; + function Uses_Sec_Stack (Id : E) return B; + function Vax_Float (Id : E) return B; + function Warnings_Off (Id : E) return B; + function Was_Hidden (Id : E) return B; + function Wrapped_Entity (Id : E) return E; ------------------------------- -- Classification Attributes -- @@ -5678,49 +5743,50 @@ package Einfo is -- In some cases, the test is of an entity attribute (e.g. in the case of -- Is_Generic_Type where the Ekind does not provide the needed information) - function Is_Access_Type (Id : E) return B; - function Is_Array_Type (Id : E) return B; - function Is_Class_Wide_Type (Id : E) return B; - function Is_Composite_Type (Id : E) return B; - function Is_Concurrent_Body (Id : E) return B; - function Is_Concurrent_Record_Type (Id : E) return B; - function Is_Concurrent_Type (Id : E) return B; - function Is_Decimal_Fixed_Point_Type (Id : E) return B; - function Is_Digits_Type (Id : E) return B; - function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B; - function Is_Discrete_Type (Id : E) return B; - function Is_Elementary_Type (Id : E) return B; - function Is_Entry (Id : E) return B; - function Is_Enumeration_Type (Id : E) return B; - function Is_Fixed_Point_Type (Id : E) return B; - function Is_Floating_Point_Type (Id : E) return B; - function Is_Formal (Id : E) return B; - function Is_Formal_Object (Id : E) return B; - function Is_Formal_Subprogram (Id : E) return B; - function Is_Generic_Actual_Type (Id : E) return B; - function Is_Generic_Unit (Id : E) return B; - function Is_Generic_Type (Id : E) return B; - function Is_Generic_Subprogram (Id : E) return B; - function Is_Incomplete_Or_Private_Type (Id : E) return B; - function Is_Incomplete_Type (Id : E) return B; - function Is_Integer_Type (Id : E) return B; - function Is_Limited_Record (Id : E) return B; - function Is_Modular_Integer_Type (Id : E) return B; - function Is_Named_Number (Id : E) return B; - function Is_Numeric_Type (Id : E) return B; - function Is_Object (Id : E) return B; - function Is_Ordinary_Fixed_Point_Type (Id : E) return B; - function Is_Overloadable (Id : E) return B; - function Is_Overriding_Operation (Id : E) return B; - function Is_Private_Type (Id : E) return B; - function Is_Protected_Type (Id : E) return B; - function Is_Real_Type (Id : E) return B; - function Is_Record_Type (Id : E) return B; - function Is_Scalar_Type (Id : E) return B; - function Is_Signed_Integer_Type (Id : E) return B; - function Is_Subprogram (Id : E) return B; - function Is_Task_Type (Id : E) return B; - function Is_Type (Id : E) return B; + function Is_Access_Type (Id : E) return B; + function Is_Access_Protected_Subprogram_Type (Id : E) return B; + function Is_Array_Type (Id : E) return B; + function Is_Class_Wide_Type (Id : E) return B; + function Is_Composite_Type (Id : E) return B; + function Is_Concurrent_Body (Id : E) return B; + function Is_Concurrent_Record_Type (Id : E) return B; + function Is_Concurrent_Type (Id : E) return B; + function Is_Decimal_Fixed_Point_Type (Id : E) return B; + function Is_Digits_Type (Id : E) return B; + function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B; + function Is_Discrete_Type (Id : E) return B; + function Is_Elementary_Type (Id : E) return B; + function Is_Entry (Id : E) return B; + function Is_Enumeration_Type (Id : E) return B; + function Is_Fixed_Point_Type (Id : E) return B; + function Is_Floating_Point_Type (Id : E) return B; + function Is_Formal (Id : E) return B; + function Is_Formal_Object (Id : E) return B; + function Is_Formal_Subprogram (Id : E) return B; + function Is_Generic_Actual_Type (Id : E) return B; + function Is_Generic_Unit (Id : E) return B; + function Is_Generic_Type (Id : E) return B; + function Is_Generic_Subprogram (Id : E) return B; + function Is_Incomplete_Or_Private_Type (Id : E) return B; + function Is_Incomplete_Type (Id : E) return B; + function Is_Integer_Type (Id : E) return B; + function Is_Limited_Record (Id : E) return B; + function Is_Modular_Integer_Type (Id : E) return B; + function Is_Named_Number (Id : E) return B; + function Is_Numeric_Type (Id : E) return B; + function Is_Object (Id : E) return B; + function Is_Ordinary_Fixed_Point_Type (Id : E) return B; + function Is_Overloadable (Id : E) return B; + function Is_Overriding_Operation (Id : E) return B; + function Is_Private_Type (Id : E) return B; + function Is_Protected_Type (Id : E) return B; + function Is_Real_Type (Id : E) return B; + function Is_Record_Type (Id : E) return B; + function Is_Scalar_Type (Id : E) return B; + function Is_Signed_Integer_Type (Id : E) return B; + function Is_Subprogram (Id : E) return B; + function Is_Task_Type (Id : E) return B; + function Is_Type (Id : E) return B; ------------------------------------- -- Synthesized Attribute Functions -- @@ -5729,74 +5795,76 @@ package Einfo is -- The functions in this section synthesize attributes from the tree, -- so they do not correspond to defined fields in the entity itself. - function Address_Clause (Id : E) return N; - function Alignment_Clause (Id : E) return N; - function Ancestor_Subtype (Id : E) return E; - function Base_Type (Id : E) return E; - function Constant_Value (Id : E) return N; - function Declaration_Node (Id : E) return N; - function Designated_Type (Id : E) return E; - function Enclosing_Dynamic_Scope (Id : E) return E; - function First_Component (Id : E) return E; - function First_Discriminant (Id : E) return E; - function First_Formal (Id : E) return E; - function First_Formal_With_Extras (Id : E) return E; - function First_Stored_Discriminant (Id : E) return E; - function First_Subtype (Id : E) return E; - function Has_Attach_Handler (Id : E) return B; - function Has_Entries (Id : E) return B; - function Has_Foreign_Convention (Id : E) return B; - function Has_Private_Ancestor (Id : E) return B; - function Has_Private_Declaration (Id : E) return B; - function Implementation_Base_Type (Id : E) return E; - function Is_Always_Inlined (Id : E) return B; - function Is_Boolean_Type (Id : E) return B; - function Is_By_Copy_Type (Id : E) return B; - function Is_By_Reference_Type (Id : E) return B; - function Is_Derived_Type (Id : E) return B; - function Is_Dynamic_Scope (Id : E) return B; - function Is_Indefinite_Subtype (Id : E) return B; - function Is_Limited_Type (Id : E) return B; - function Is_Package_Or_Generic_Package (Id : E) return B; - function Is_Protected_Private (Id : E) return B; - function Is_Protected_Record_Type (Id : E) return B; - function Is_Inherently_Limited_Type (Id : E) return B; - function Is_String_Type (Id : E) return B; - function Is_Task_Record_Type (Id : E) return B; - function Is_Wrapper_Package (Id : E) return B; - function Next_Component (Id : E) return E; - function Next_Discriminant (Id : E) return E; - function Next_Formal (Id : E) return E; - function Next_Formal_With_Extras (Id : E) return E; - function Next_Literal (Id : E) return E; - function Next_Stored_Discriminant (Id : E) return E; - function Number_Dimensions (Id : E) return Pos; - function Number_Discriminants (Id : E) return Pos; - function Number_Entries (Id : E) return Nat; - function Number_Formals (Id : E) return Pos; - function Parameter_Mode (Id : E) return Formal_Kind; - function Root_Type (Id : E) return E; - function Scope_Depth_Set (Id : E) return B; - function Size_Clause (Id : E) return N; - function Stream_Size_Clause (Id : E) return N; - function First_Tag_Component (Id : E) return E; - function Next_Tag_Component (Id : E) return E; - function Type_High_Bound (Id : E) return N; - function Type_Low_Bound (Id : E) return N; - function Underlying_Type (Id : E) return E; + function Address_Clause (Id : E) return N; + function Alignment_Clause (Id : E) return N; + function Ancestor_Subtype (Id : E) return E; + function Base_Type (Id : E) return E; + function Constant_Value (Id : E) return N; + function Declaration_Node (Id : E) return N; + function Designated_Type (Id : E) return E; + function Enclosing_Dynamic_Scope (Id : E) return E; + function First_Component (Id : E) return E; + function First_Component_Or_Discriminant (Id : E) return E; + function First_Discriminant (Id : E) return E; + function First_Formal (Id : E) return E; + function First_Formal_With_Extras (Id : E) return E; + function First_Stored_Discriminant (Id : E) return E; + function First_Subtype (Id : E) return E; + function Has_Attach_Handler (Id : E) return B; + function Has_Entries (Id : E) return B; + function Has_Foreign_Convention (Id : E) return B; + function Has_Private_Ancestor (Id : E) return B; + function Has_Private_Declaration (Id : E) return B; + function Implementation_Base_Type (Id : E) return E; + function Is_Always_Inlined (Id : E) return B; + function Is_Boolean_Type (Id : E) return B; + function Is_By_Copy_Type (Id : E) return B; + function Is_By_Reference_Type (Id : E) return B; + function Is_Derived_Type (Id : E) return B; + function Is_Dynamic_Scope (Id : E) return B; + function Is_Indefinite_Subtype (Id : E) return B; + function Is_Limited_Type (Id : E) return B; + function Is_Package_Or_Generic_Package (Id : E) return B; + function Is_Protected_Private (Id : E) return B; + function Is_Protected_Record_Type (Id : E) return B; + function Is_Inherently_Limited_Type (Id : E) return B; + function Is_String_Type (Id : E) return B; + function Is_Task_Record_Type (Id : E) return B; + function Is_Wrapper_Package (Id : E) return B; + function Next_Component (Id : E) return E; + function Next_Component_Or_Discriminant (Id : E) return E; + function Next_Discriminant (Id : E) return E; + function Next_Formal (Id : E) return E; + function Next_Formal_With_Extras (Id : E) return E; + function Next_Literal (Id : E) return E; + function Next_Stored_Discriminant (Id : E) return E; + function Number_Dimensions (Id : E) return Pos; + function Number_Discriminants (Id : E) return Pos; + function Number_Entries (Id : E) return Nat; + function Number_Formals (Id : E) return Pos; + function Parameter_Mode (Id : E) return Formal_Kind; + function Root_Type (Id : E) return E; + function Scope_Depth_Set (Id : E) return B; + function Size_Clause (Id : E) return N; + function Stream_Size_Clause (Id : E) return N; + function First_Tag_Component (Id : E) return E; + function Next_Tag_Component (Id : E) return E; + function Type_High_Bound (Id : E) return N; + function Type_Low_Bound (Id : E) return N; + function Underlying_Type (Id : E) return E; ---------------------------------------------- -- Type Representation Attribute Predicates -- ---------------------------------------------- - -- These predicates test the setting of the indicated attribute. If - -- the value has been set, then Known is True, and Unknown is False. - -- If no value is set, then Known is False and Unknown is True. The - -- Known_Static predicate is true only if the value is set (Known) - -- and is set to a compile time known value. Note that in the case - -- of Alignment and Normalized_First_Bit, dynamic values are not - -- possible, so we do not need a separate Known_Static calls in - -- these cases. The not set (unknown values are as follows: + -- These predicates test the setting of the indicated attribute. If the + -- value has been set, then Known is True, and Unknown is False. If no + -- value is set, then Known is False and Unknown is True. The Known_Static + -- predicate is true only if the value is set (Known) and is set to a + -- compile time known value. Note that in the case of Alignment and + -- Normalized_First_Bit, dynamic values are not possible, so we do not + -- need a separate Known_Static calls in these cases. The not set (unknown + -- values are as follows: -- Alignment Uint_0 or No_Uint -- Component_Size Uint_0 or No_Uint @@ -5845,348 +5913,352 @@ package Einfo is -- Attribute Set Procedures -- ------------------------------ - procedure Set_Abstract_Interfaces (Id : E; V : L); - procedure Set_Accept_Address (Id : E; V : L); - procedure Set_Access_Disp_Table (Id : E; V : L); - procedure Set_Actual_Subtype (Id : E; V : E); - procedure Set_Address_Taken (Id : E; V : B := True); - procedure Set_Alias (Id : E; V : E); - procedure Set_Abstract_Interface_Alias (Id : E; V : E); - procedure Set_Alignment (Id : E; V : U); - procedure Set_Associated_Final_Chain (Id : E; V : E); - procedure Set_Associated_Formal_Package (Id : E; V : E); - procedure Set_Associated_Node_For_Itype (Id : E; V : N); - procedure Set_Associated_Storage_Pool (Id : E; V : E); - procedure Set_Barrier_Function (Id : E; V : N); - procedure Set_Block_Node (Id : E; V : N); - procedure Set_Body_Entity (Id : E; V : E); - procedure Set_Body_Needed_For_SAL (Id : E; V : B := True); - procedure Set_CR_Discriminant (Id : E; V : E); - procedure Set_C_Pass_By_Copy (Id : E; V : B := True); - procedure Set_Can_Never_Be_Null (Id : E; V : B := True); - procedure Set_Checks_May_Be_Suppressed (Id : E; V : B := True); - procedure Set_Class_Wide_Type (Id : E; V : E); - procedure Set_Cloned_Subtype (Id : E; V : E); - procedure Set_Component_Alignment (Id : E; V : C); - procedure Set_Component_Bit_Offset (Id : E; V : U); - procedure Set_Component_Clause (Id : E; V : N); - procedure Set_Component_Size (Id : E; V : U); - procedure Set_Component_Type (Id : E; V : E); - procedure Set_Corresponding_Concurrent_Type (Id : E; V : E); - procedure Set_Corresponding_Discriminant (Id : E; V : E); - procedure Set_Corresponding_Equality (Id : E; V : E); - procedure Set_Corresponding_Record_Type (Id : E; V : E); - procedure Set_Corresponding_Remote_Type (Id : E; V : E); - procedure Set_Current_Use_Clause (Id : E; V : E); - procedure Set_Current_Value (Id : E; V : N); - procedure Set_Debug_Info_Off (Id : E; V : B := True); - procedure Set_Debug_Renaming_Link (Id : E; V : E); - procedure Set_DTC_Entity (Id : E; V : E); - procedure Set_DT_Entry_Count (Id : E; V : U); - procedure Set_DT_Offset_To_Top_Func (Id : E; V : E); - procedure Set_DT_Position (Id : E; V : U); - procedure Set_Default_Expr_Function (Id : E; V : E); - procedure Set_Default_Expressions_Processed (Id : E; V : B := True); - procedure Set_Default_Value (Id : E; V : N); - procedure Set_Delay_Cleanups (Id : E; V : B := True); - procedure Set_Delay_Subprogram_Descriptors (Id : E; V : B := True); - procedure Set_Delta_Value (Id : E; V : R); - procedure Set_Dependent_Instances (Id : E; V : L); - procedure Set_Depends_On_Private (Id : E; V : B := True); - procedure Set_Digits_Value (Id : E; V : U); - procedure Set_Directly_Designated_Type (Id : E; V : E); - procedure Set_Discard_Names (Id : E; V : B := True); - procedure Set_Discriminal (Id : E; V : E); - procedure Set_Discriminal_Link (Id : E; V : E); - procedure Set_Discriminant_Checking_Func (Id : E; V : E); - procedure Set_Discriminant_Constraint (Id : E; V : L); - procedure Set_Discriminant_Default_Value (Id : E; V : N); - procedure Set_Discriminant_Number (Id : E; V : U); - procedure Set_Elaborate_Body_Desirable (Id : E; V : B := True); - procedure Set_Elaboration_Entity (Id : E; V : E); - procedure Set_Elaboration_Entity_Required (Id : E; V : B := True); - procedure Set_Enclosing_Scope (Id : E; V : E); - procedure Set_Entry_Accepted (Id : E; V : B := True); - procedure Set_Entry_Bodies_Array (Id : E; V : E); - procedure Set_Entry_Cancel_Parameter (Id : E; V : E); - procedure Set_Entry_Component (Id : E; V : E); - procedure Set_Entry_Formal (Id : E; V : E); - procedure Set_Entry_Index_Constant (Id : E; V : E); - procedure Set_Entry_Parameters_Type (Id : E; V : E); - procedure Set_Enum_Pos_To_Rep (Id : E; V : E); - procedure Set_Enumeration_Pos (Id : E; V : U); - procedure Set_Enumeration_Rep (Id : E; V : U); - procedure Set_Enumeration_Rep_Expr (Id : E; V : N); - procedure Set_Equivalent_Type (Id : E; V : E); - procedure Set_Esize (Id : E; V : U); - procedure Set_Exception_Code (Id : E; V : U); - procedure Set_Extra_Accessibility (Id : E; V : E); - procedure Set_Extra_Constrained (Id : E; V : E); - procedure Set_Extra_Formal (Id : E; V : E); - procedure Set_Extra_Formals (Id : E; V : E); - procedure Set_Finalization_Chain_Entity (Id : E; V : E); - procedure Set_Finalize_Storage_Only (Id : E; V : B := True); - procedure Set_First_Entity (Id : E; V : E); - procedure Set_First_Index (Id : E; V : N); - procedure Set_First_Literal (Id : E; V : E); - procedure Set_First_Optional_Parameter (Id : E; V : E); - procedure Set_First_Private_Entity (Id : E; V : E); - procedure Set_First_Rep_Item (Id : E; V : N); - procedure Set_Freeze_Node (Id : E; V : N); - procedure Set_From_With_Type (Id : E; V : B := True); - procedure Set_Full_View (Id : E; V : E); - procedure Set_Function_Returns_With_DSP (Id : E; V : B := True); - procedure Set_Generic_Homonym (Id : E; V : E); - procedure Set_Generic_Renamings (Id : E; V : L); - procedure Set_Handler_Records (Id : E; V : S); - procedure Set_Has_Aliased_Components (Id : E; V : B := True); - procedure Set_Has_Alignment_Clause (Id : E; V : B := True); - procedure Set_Has_All_Calls_Remote (Id : E; V : B := True); - procedure Set_Has_Anon_Block_Suffix (Id : E; V : B := True); - procedure Set_Has_Atomic_Components (Id : E; V : B := True); - procedure Set_Has_Biased_Representation (Id : E; V : B := True); - procedure Set_Has_Completion (Id : E; V : B := True); - procedure Set_Has_Completion_In_Body (Id : E; V : B := True); - procedure Set_Has_Complex_Representation (Id : E; V : B := True); - procedure Set_Has_Component_Size_Clause (Id : E; V : B := True); - procedure Set_Has_Constrained_Partial_View (Id : E; V : B := True); - procedure Set_Has_Contiguous_Rep (Id : E; V : B := True); - procedure Set_Has_Controlled_Component (Id : E; V : B := True); - procedure Set_Has_Controlling_Result (Id : E; V : B := True); - procedure Set_Has_Convention_Pragma (Id : E; V : B := True); - procedure Set_Has_Delayed_Freeze (Id : E; V : B := True); - procedure Set_Has_Discriminants (Id : E; V : B := True); - procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True); - procedure Set_Has_Exit (Id : E; V : B := True); - procedure Set_Has_External_Tag_Rep_Clause (Id : E; V : B := True); - procedure Set_Has_Fully_Qualified_Name (Id : E; V : B := True); - procedure Set_Has_Gigi_Rep_Item (Id : E; V : B := True); - procedure Set_Has_Homonym (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); - procedure Set_Has_Missing_Return (Id : E; V : B := True); - procedure Set_Has_Nested_Block_With_Handler (Id : E; V : B := True); - procedure Set_Has_Forward_Instantiation (Id : E; V : B := True); - 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_Per_Object_Constraint (Id : E; V : B := True); - procedure Set_Has_Persistent_BSS (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); - procedure Set_Has_Pragma_Inline (Id : E; V : B := True); - procedure Set_Has_Pragma_Pack (Id : E; V : B := True); - procedure Set_Has_Pragma_Pure (Id : E; V : B := True); - procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True); - procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True); - procedure Set_Has_Primitive_Operations (Id : E; V : B := True); - procedure Set_Has_Private_Declaration (Id : E; V : B := True); - procedure Set_Has_Qualified_Name (Id : E; V : B := True); - procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True); - procedure Set_Has_Recursive_Call (Id : E; V : B := True); - procedure Set_Has_Size_Clause (Id : E; V : B := True); - procedure Set_Has_Small_Clause (Id : E; V : B := True); - procedure Set_Has_Specified_Layout (Id : E; V : B := True); - procedure Set_Has_Specified_Stream_Input (Id : E; V : B := True); - procedure Set_Has_Specified_Stream_Output (Id : E; V : B := True); - procedure Set_Has_Specified_Stream_Read (Id : E; V : B := True); - procedure Set_Has_Specified_Stream_Write (Id : E; V : B := True); - procedure Set_Has_Static_Discriminants (Id : E; V : B := True); - procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True); - procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True); - procedure Set_Has_Subprogram_Descriptor (Id : E; V : B := True); - procedure Set_Has_Task (Id : E; V : B := True); - procedure Set_Has_Unchecked_Union (Id : E; V : B := True); - procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True); - procedure Set_Has_Volatile_Components (Id : E; V : B := True); - procedure Set_Has_Xref_Entry (Id : E; V : B := True); - procedure Set_Hiding_Loop_Variable (Id : E; V : E); - procedure Set_Homonym (Id : E; V : E); - procedure Set_In_Package_Body (Id : E; V : B := True); - procedure Set_In_Private_Part (Id : E; V : B := True); - procedure Set_In_Use (Id : E; V : B := True); - procedure Set_Inner_Instances (Id : E; V : L); - procedure Set_Interface_Name (Id : E; V : N); - procedure Set_Is_AST_Entry (Id : E; V : B := True); - procedure Set_Is_Abstract (Id : E; V : B := True); - procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True); - procedure Set_Is_Access_Constant (Id : E; V : B := True); - procedure Set_Is_Ada_2005_Only (Id : E; V : B := True); - procedure Set_Is_Aliased (Id : E; V : B := True); - procedure Set_Is_Asynchronous (Id : E; V : B := True); - procedure Set_Is_Atomic (Id : E; V : B := True); - procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True); - procedure Set_Is_CPP_Class (Id : E; V : B := True); - procedure Set_Is_Called (Id : E; V : B := True); - procedure Set_Is_Character_Type (Id : E; V : B := True); - procedure Set_Is_Child_Unit (Id : E; V : B := True); - procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True); - procedure Set_Is_Compilation_Unit (Id : E; V : B := True); - procedure Set_Is_Completely_Hidden (Id : E; V : B := True); - procedure Set_Is_Concurrent_Record_Type (Id : E; V : B := True); - procedure Set_Is_Constr_Subt_For_UN_Aliased (Id : E; V : B := True); - procedure Set_Is_Constr_Subt_For_U_Nominal (Id : E; V : B := True); - procedure Set_Is_Constrained (Id : E; V : B := True); - procedure Set_Is_Constructor (Id : E; V : B := True); - procedure Set_Is_Controlled (Id : E; V : B := True); - procedure Set_Is_Controlling_Formal (Id : E; V : B := True); - procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True); - procedure Set_Is_Dispatching_Operation (Id : E; V : B := True); - procedure Set_Is_Eliminated (Id : E; V : B := True); - procedure Set_Is_Entry_Formal (Id : E; V : B := True); - procedure Set_Is_Exported (Id : E; V : B := True); - procedure Set_Is_First_Subtype (Id : E; V : B := True); - procedure Set_Is_For_Access_Subtype (Id : E; V : B := True); - procedure Set_Is_Formal_Subprogram (Id : E; V : B := True); - procedure Set_Is_Frozen (Id : E; V : B := True); - procedure Set_Is_Generic_Actual_Type (Id : E; V : B := True); - procedure Set_Is_Generic_Instance (Id : E; V : B := True); - procedure Set_Is_Generic_Type (Id : E; V : B := True); - procedure Set_Is_Hidden (Id : E; V : B := True); - procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True); - procedure Set_Is_Immediately_Visible (Id : E; V : B := True); - procedure Set_Is_Imported (Id : E; V : B := True); - procedure Set_Is_Inlined (Id : E; V : B := True); - procedure Set_Is_Interface (Id : E; V : B := True); - procedure Set_Is_Instantiated (Id : E; V : B := True); - procedure Set_Is_Internal (Id : E; V : B := True); - procedure Set_Is_Interrupt_Handler (Id : E; V : B := True); - procedure Set_Is_Intrinsic_Subprogram (Id : E; V : B := True); - procedure Set_Is_Itype (Id : E; V : B := True); - procedure Set_Is_Known_Non_Null (Id : E; V : B := True); - procedure Set_Is_Known_Null (Id : E; V : B := True); - procedure Set_Is_Known_Valid (Id : E; V : B := True); - procedure Set_Is_Limited_Composite (Id : E; V : B := True); - procedure Set_Is_Limited_Interface (Id : E; V : B := True); - procedure Set_Is_Limited_Record (Id : E; V : B := True); - procedure Set_Is_Machine_Code_Subprogram (Id : E; V : B := True); - procedure Set_Is_Non_Static_Subtype (Id : E; V : B := True); - procedure Set_Is_Null_Init_Proc (Id : E; V : B := True); - procedure Set_Is_Obsolescent (Id : E; V : B := True); - procedure Set_Is_Optional_Parameter (Id : E; V : B := True); - procedure Set_Is_Overriding_Operation (Id : E; V : B := True); - procedure Set_Is_Package_Body_Entity (Id : E; V : B := True); - procedure Set_Is_Packed (Id : E; V : B := True); - procedure Set_Is_Packed_Array_Type (Id : E; V : B := True); - procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True); - procedure Set_Is_Preelaborated (Id : E; V : B := True); - procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True); - procedure Set_Is_Private_Composite (Id : E; V : B := True); - procedure Set_Is_Private_Descendant (Id : E; V : B := True); - procedure Set_Is_Protected_Interface (Id : E; V : B := True); - procedure Set_Is_Public (Id : E; V : B := True); - procedure Set_Is_Pure (Id : E; V : B := True); - procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True); - procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True); - procedure Set_Is_Remote_Types (Id : E; V : B := True); - procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True); - procedure Set_Is_Return_Object (Id : E; V : B := True); - procedure Set_Is_Shared_Passive (Id : E; V : B := True); - procedure Set_Is_Statically_Allocated (Id : E; V : B := True); - procedure Set_Is_Synchronized_Interface (Id : E; V : B := True); - procedure Set_Is_Tag (Id : E; V : B := True); - procedure Set_Is_Tagged_Type (Id : E; V : B := True); - procedure Set_Is_Task_Interface (Id : E; V : B := True); - procedure Set_Is_Thread_Body (Id : E; V : B := True); - procedure Set_Is_True_Constant (Id : E; V : B := True); - procedure Set_Is_Unchecked_Union (Id : E; V : B := True); - procedure Set_Is_Unsigned_Type (Id : E; V : B := True); - procedure Set_Is_VMS_Exception (Id : E; V : B := True); - procedure Set_Is_Valued_Procedure (Id : E; V : B := True); - procedure Set_Is_Visible_Child_Unit (Id : E; V : B := True); - procedure Set_Is_Visible_Formal (Id : E; V : B := True); - procedure Set_Is_Volatile (Id : E; V : B := True); - procedure Set_Itype_Printed (Id : E; V : B := True); - procedure Set_Kill_Elaboration_Checks (Id : E; V : B := True); - procedure Set_Kill_Range_Checks (Id : E; V : B := True); - procedure Set_Kill_Tag_Checks (Id : E; V : B := True); - procedure Set_Known_To_Have_Preelab_Init (Id : E; V : B := True); - procedure Set_Last_Assignment (Id : E; V : N); - procedure Set_Last_Entity (Id : E; V : E); - procedure Set_Limited_View (Id : E; V : E); - procedure Set_Lit_Indexes (Id : E; V : E); - procedure Set_Lit_Strings (Id : E; V : E); - procedure Set_Low_Bound_Known (Id : E; V : B := True); - procedure Set_Machine_Radix_10 (Id : E; V : B := True); - procedure Set_Master_Id (Id : E; V : E); - procedure Set_Materialize_Entity (Id : E; V : B := True); - procedure Set_Mechanism (Id : E; V : M); - procedure Set_Modulus (Id : E; V : U); - procedure Set_Must_Be_On_Byte_Boundary (Id : E; V : B := True); - procedure Set_Must_Have_Preelab_Init (Id : E; V : B := True); - procedure Set_Needs_Debug_Info (Id : E; V : B := True); - procedure Set_Needs_No_Actuals (Id : E; V : B := True); - procedure Set_Never_Set_In_Source (Id : E; V : B := True); - procedure Set_Next_Inlined_Subprogram (Id : E; V : E); - procedure Set_No_Pool_Assigned (Id : E; V : B := True); - procedure Set_No_Return (Id : E; V : B := True); - procedure Set_No_Strict_Aliasing (Id : E; V : B := True); - procedure Set_Non_Binary_Modulus (Id : E; V : B := True); - procedure Set_Non_Limited_View (Id : E; V : E); - procedure Set_Nonzero_Is_True (Id : E; V : B := True); - procedure Set_Normalized_First_Bit (Id : E; V : U); - procedure Set_Normalized_Position (Id : E; V : U); - procedure Set_Normalized_Position_Max (Id : E; V : U); - procedure Set_Object_Ref (Id : E; V : E); - procedure Set_Obsolescent_Warning (Id : E; V : N); - procedure Set_Original_Access_Type (Id : E; V : E); - procedure Set_Original_Array_Type (Id : E; V : E); - procedure Set_Original_Record_Component (Id : E; V : E); - procedure Set_Overridden_Operation (Id : E; V : E); - procedure Set_Package_Instantiation (Id : E; V : N); - procedure Set_Packed_Array_Type (Id : E; V : E); - procedure Set_Parent_Subtype (Id : E; V : E); - procedure Set_Primitive_Operations (Id : E; V : L); - procedure Set_Prival (Id : E; V : E); - procedure Set_Privals_Chain (Id : E; V : L); - procedure Set_Private_Dependents (Id : E; V : L); - procedure Set_Private_View (Id : E; V : N); - procedure Set_Protected_Body_Subprogram (Id : E; V : E); - procedure Set_Protected_Formal (Id : E; V : E); - procedure Set_Protected_Operation (Id : E; V : N); - procedure Set_RM_Size (Id : E; V : U); - procedure Set_Reachable (Id : E; V : B := True); - procedure Set_Referenced (Id : E; V : B := True); - procedure Set_Referenced_As_LHS (Id : E; V : B := True); - procedure Set_Referenced_Object (Id : E; V : N); - procedure Set_Register_Exception_Call (Id : E; V : N); - procedure Set_Related_Array_Object (Id : E; V : E); - procedure Set_Related_Instance (Id : E; V : E); - procedure Set_Renamed_Entity (Id : E; V : N); - procedure Set_Renamed_Object (Id : E; V : N); - procedure Set_Renaming_Map (Id : E; V : U); - procedure Set_Return_Present (Id : E; V : B := True); - procedure Set_Return_Applies_To (Id : E; V : N); - procedure Set_Returns_By_Ref (Id : E; V : B := True); - procedure Set_Reverse_Bit_Order (Id : E; V : B := True); - procedure Set_Scalar_Range (Id : E; V : N); - procedure Set_Scale_Value (Id : E; V : U); - procedure Set_Scope_Depth_Value (Id : E; V : U); - procedure Set_Sec_Stack_Needed_For_Return (Id : E; V : B := True); - procedure Set_Shadow_Entities (Id : E; V : S); - procedure Set_Shared_Var_Assign_Proc (Id : E; V : E); - procedure Set_Shared_Var_Read_Proc (Id : E; V : E); - procedure Set_Size_Check_Code (Id : E; V : N); - procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True); - procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True); - procedure Set_Small_Value (Id : E; V : R); - procedure Set_Spec_Entity (Id : E; V : E); - procedure Set_Storage_Size_Variable (Id : E; V : E); - procedure Set_Stored_Constraint (Id : E; V : L); - 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_Suppress_Elaboration_Warnings (Id : E; V : B := True); - procedure Set_Suppress_Init_Proc (Id : E; V : B := True); - procedure Set_Suppress_Style_Checks (Id : E; V : B := True); - procedure Set_Task_Body_Procedure (Id : E; V : N); - procedure Set_Treat_As_Volatile (Id : E; V : B := True); - procedure Set_Underlying_Full_View (Id : E; V : E); - procedure Set_Unset_Reference (Id : E; V : N); - procedure Set_Uses_Sec_Stack (Id : E; V : B := True); - procedure Set_Vax_Float (Id : E; V : B := True); - procedure Set_Warnings_Off (Id : E; V : B := True); - procedure Set_Was_Hidden (Id : E; V : B := True); - procedure Set_Wrapped_Entity (Id : E; V : E); + procedure Set_Abstract_Interfaces (Id : E; V : L); + procedure Set_Accept_Address (Id : E; V : L); + procedure Set_Access_Disp_Table (Id : E; V : L); + procedure Set_Actual_Subtype (Id : E; V : E); + procedure Set_Address_Taken (Id : E; V : B := True); + procedure Set_Alias (Id : E; V : E); + procedure Set_Abstract_Interface_Alias (Id : E; V : E); + procedure Set_Alignment (Id : E; V : U); + procedure Set_Associated_Final_Chain (Id : E; V : E); + procedure Set_Associated_Formal_Package (Id : E; V : E); + procedure Set_Associated_Node_For_Itype (Id : E; V : N); + procedure Set_Associated_Storage_Pool (Id : E; V : E); + procedure Set_Barrier_Function (Id : E; V : N); + procedure Set_Block_Node (Id : E; V : N); + procedure Set_Body_Entity (Id : E; V : E); + procedure Set_Body_Needed_For_SAL (Id : E; V : B := True); + procedure Set_CR_Discriminant (Id : E; V : E); + procedure Set_C_Pass_By_Copy (Id : E; V : B := True); + procedure Set_Can_Never_Be_Null (Id : E; V : B := True); + procedure Set_Checks_May_Be_Suppressed (Id : E; V : B := True); + procedure Set_Class_Wide_Type (Id : E; V : E); + procedure Set_Cloned_Subtype (Id : E; V : E); + procedure Set_Component_Alignment (Id : E; V : C); + procedure Set_Component_Bit_Offset (Id : E; V : U); + procedure Set_Component_Clause (Id : E; V : N); + procedure Set_Component_Size (Id : E; V : U); + procedure Set_Component_Type (Id : E; V : E); + procedure Set_Corresponding_Concurrent_Type (Id : E; V : E); + procedure Set_Corresponding_Discriminant (Id : E; V : E); + procedure Set_Corresponding_Equality (Id : E; V : E); + procedure Set_Corresponding_Record_Type (Id : E; V : E); + procedure Set_Corresponding_Remote_Type (Id : E; V : E); + procedure Set_Current_Use_Clause (Id : E; V : E); + procedure Set_Current_Value (Id : E; V : N); + procedure Set_Debug_Info_Off (Id : E; V : B := True); + procedure Set_Debug_Renaming_Link (Id : E; V : E); + procedure Set_DTC_Entity (Id : E; V : E); + procedure Set_DT_Entry_Count (Id : E; V : U); + procedure Set_DT_Offset_To_Top_Func (Id : E; V : E); + procedure Set_DT_Position (Id : E; V : U); + procedure Set_Default_Expr_Function (Id : E; V : E); + procedure Set_Default_Expressions_Processed (Id : E; V : B := True); + procedure Set_Default_Value (Id : E; V : N); + procedure Set_Delay_Cleanups (Id : E; V : B := True); + procedure Set_Delay_Subprogram_Descriptors (Id : E; V : B := True); + procedure Set_Delta_Value (Id : E; V : R); + procedure Set_Dependent_Instances (Id : E; V : L); + procedure Set_Depends_On_Private (Id : E; V : B := True); + procedure Set_Digits_Value (Id : E; V : U); + procedure Set_Directly_Designated_Type (Id : E; V : E); + procedure Set_Discard_Names (Id : E; V : B := True); + procedure Set_Discriminal (Id : E; V : E); + procedure Set_Discriminal_Link (Id : E; V : E); + procedure Set_Discriminant_Checking_Func (Id : E; V : E); + procedure Set_Discriminant_Constraint (Id : E; V : L); + procedure Set_Discriminant_Default_Value (Id : E; V : N); + procedure Set_Discriminant_Number (Id : E; V : U); + procedure Set_Elaborate_Body_Desirable (Id : E; V : B := True); + procedure Set_Elaboration_Entity (Id : E; V : E); + procedure Set_Elaboration_Entity_Required (Id : E; V : B := True); + procedure Set_Enclosing_Scope (Id : E; V : E); + procedure Set_Entry_Accepted (Id : E; V : B := True); + procedure Set_Entry_Bodies_Array (Id : E; V : E); + procedure Set_Entry_Cancel_Parameter (Id : E; V : E); + procedure Set_Entry_Component (Id : E; V : E); + procedure Set_Entry_Formal (Id : E; V : E); + procedure Set_Entry_Index_Constant (Id : E; V : E); + procedure Set_Entry_Parameters_Type (Id : E; V : E); + procedure Set_Enum_Pos_To_Rep (Id : E; V : E); + procedure Set_Enumeration_Pos (Id : E; V : U); + procedure Set_Enumeration_Rep (Id : E; V : U); + procedure Set_Enumeration_Rep_Expr (Id : E; V : N); + procedure Set_Equivalent_Type (Id : E; V : E); + procedure Set_Esize (Id : E; V : U); + procedure Set_Exception_Code (Id : E; V : U); + procedure Set_Extra_Accessibility (Id : E; V : E); + procedure Set_Extra_Constrained (Id : E; V : E); + procedure Set_Extra_Formal (Id : E; V : E); + procedure Set_Extra_Formals (Id : E; V : E); + procedure Set_Finalization_Chain_Entity (Id : E; V : E); + procedure Set_Finalize_Storage_Only (Id : E; V : B := True); + procedure Set_First_Entity (Id : E; V : E); + procedure Set_First_Index (Id : E; V : N); + procedure Set_First_Literal (Id : E; V : E); + procedure Set_First_Optional_Parameter (Id : E; V : E); + procedure Set_First_Private_Entity (Id : E; V : E); + procedure Set_First_Rep_Item (Id : E; V : N); + procedure Set_Freeze_Node (Id : E; V : N); + procedure Set_From_With_Type (Id : E; V : B := True); + procedure Set_Full_View (Id : E; V : E); + procedure Set_Function_Returns_With_DSP (Id : E; V : B := True); + procedure Set_Generic_Homonym (Id : E; V : E); + procedure Set_Generic_Renamings (Id : E; V : L); + procedure Set_Handler_Records (Id : E; V : S); + procedure Set_Has_Aliased_Components (Id : E; V : B := True); + procedure Set_Has_Alignment_Clause (Id : E; V : B := True); + procedure Set_Has_All_Calls_Remote (Id : E; V : B := True); + procedure Set_Has_Anon_Block_Suffix (Id : E; V : B := True); + procedure Set_Has_Atomic_Components (Id : E; V : B := True); + procedure Set_Has_Biased_Representation (Id : E; V : B := True); + procedure Set_Has_Completion (Id : E; V : B := True); + procedure Set_Has_Completion_In_Body (Id : E; V : B := True); + procedure Set_Has_Complex_Representation (Id : E; V : B := True); + procedure Set_Has_Component_Size_Clause (Id : E; V : B := True); + procedure Set_Has_Constrained_Partial_View (Id : E; V : B := True); + procedure Set_Has_Contiguous_Rep (Id : E; V : B := True); + procedure Set_Has_Controlled_Component (Id : E; V : B := True); + procedure Set_Has_Controlling_Result (Id : E; V : B := True); + procedure Set_Has_Convention_Pragma (Id : E; V : B := True); + procedure Set_Has_Delayed_Freeze (Id : E; V : B := True); + procedure Set_Has_Discriminants (Id : E; V : B := True); + procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True); + procedure Set_Has_Exit (Id : E; V : B := True); + procedure Set_Has_External_Tag_Rep_Clause (Id : E; V : B := True); + procedure Set_Has_Fully_Qualified_Name (Id : E; V : B := True); + procedure Set_Has_Gigi_Rep_Item (Id : E; V : B := True); + procedure Set_Has_Homonym (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); + procedure Set_Has_Missing_Return (Id : E; V : B := True); + procedure Set_Has_Nested_Block_With_Handler (Id : E; V : B := True); + procedure Set_Has_Forward_Instantiation (Id : E; V : B := True); + 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_Per_Object_Constraint (Id : E; V : B := True); + procedure Set_Has_Persistent_BSS (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); + procedure Set_Has_Pragma_Inline (Id : E; V : B := True); + procedure Set_Has_Pragma_Pack (Id : E; V : B := True); + procedure Set_Has_Pragma_Pure (Id : E; V : B := True); + procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True); + procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True); + procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True); + procedure Set_Has_Primitive_Operations (Id : E; V : B := True); + procedure Set_Has_Private_Declaration (Id : E; V : B := True); + procedure Set_Has_Qualified_Name (Id : E; V : B := True); + procedure Set_Has_RACW (Id : E; V : B := True); + procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True); + procedure Set_Has_Recursive_Call (Id : E; V : B := True); + procedure Set_Has_Size_Clause (Id : E; V : B := True); + procedure Set_Has_Small_Clause (Id : E; V : B := True); + procedure Set_Has_Specified_Layout (Id : E; V : B := True); + procedure Set_Has_Specified_Stream_Input (Id : E; V : B := True); + procedure Set_Has_Specified_Stream_Output (Id : E; V : B := True); + procedure Set_Has_Specified_Stream_Read (Id : E; V : B := True); + procedure Set_Has_Specified_Stream_Write (Id : E; V : B := True); + procedure Set_Has_Static_Discriminants (Id : E; V : B := True); + procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True); + procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True); + procedure Set_Has_Subprogram_Descriptor (Id : E; V : B := True); + procedure Set_Has_Task (Id : E; V : B := True); + procedure Set_Has_Unchecked_Union (Id : E; V : B := True); + procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True); + procedure Set_Has_Volatile_Components (Id : E; V : B := True); + procedure Set_Has_Xref_Entry (Id : E; V : B := True); + procedure Set_Hiding_Loop_Variable (Id : E; V : E); + procedure Set_Homonym (Id : E; V : E); + procedure Set_In_Package_Body (Id : E; V : B := True); + procedure Set_In_Private_Part (Id : E; V : B := True); + procedure Set_In_Use (Id : E; V : B := True); + procedure Set_Inner_Instances (Id : E; V : L); + procedure Set_Interface_Name (Id : E; V : N); + procedure Set_Is_AST_Entry (Id : E; V : B := True); + procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True); + procedure Set_Is_Abstract_Type (Id : E; V : B := True); + procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True); + procedure Set_Is_Access_Constant (Id : E; V : B := True); + procedure Set_Is_Ada_2005_Only (Id : E; V : B := True); + procedure Set_Is_Aliased (Id : E; V : B := True); + procedure Set_Is_Asynchronous (Id : E; V : B := True); + procedure Set_Is_Atomic (Id : E; V : B := True); + procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True); + procedure Set_Is_CPP_Class (Id : E; V : B := True); + procedure Set_Is_Called (Id : E; V : B := True); + procedure Set_Is_Character_Type (Id : E; V : B := True); + procedure Set_Is_Child_Unit (Id : E; V : B := True); + procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True); + procedure Set_Is_Compilation_Unit (Id : E; V : B := True); + procedure Set_Is_Completely_Hidden (Id : E; V : B := True); + procedure Set_Is_Concurrent_Record_Type (Id : E; V : B := True); + procedure Set_Is_Constr_Subt_For_UN_Aliased (Id : E; V : B := True); + procedure Set_Is_Constr_Subt_For_U_Nominal (Id : E; V : B := True); + procedure Set_Is_Constrained (Id : E; V : B := True); + procedure Set_Is_Constructor (Id : E; V : B := True); + procedure Set_Is_Controlled (Id : E; V : B := True); + procedure Set_Is_Controlling_Formal (Id : E; V : B := True); + procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True); + procedure Set_Is_Dispatching_Operation (Id : E; V : B := True); + procedure Set_Is_Eliminated (Id : E; V : B := True); + procedure Set_Is_Entry_Formal (Id : E; V : B := True); + procedure Set_Is_Exported (Id : E; V : B := True); + procedure Set_Is_First_Subtype (Id : E; V : B := True); + procedure Set_Is_For_Access_Subtype (Id : E; V : B := True); + procedure Set_Is_Formal_Subprogram (Id : E; V : B := True); + procedure Set_Is_Frozen (Id : E; V : B := True); + procedure Set_Is_Generic_Actual_Type (Id : E; V : B := True); + procedure Set_Is_Generic_Instance (Id : E; V : B := True); + procedure Set_Is_Generic_Type (Id : E; V : B := True); + procedure Set_Is_Hidden (Id : E; V : B := True); + procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True); + procedure Set_Is_Immediately_Visible (Id : E; V : B := True); + procedure Set_Is_Imported (Id : E; V : B := True); + procedure Set_Is_Inlined (Id : E; V : B := True); + procedure Set_Is_Interface (Id : E; V : B := True); + procedure Set_Is_Instantiated (Id : E; V : B := True); + procedure Set_Is_Internal (Id : E; V : B := True); + procedure Set_Is_Interrupt_Handler (Id : E; V : B := True); + procedure Set_Is_Intrinsic_Subprogram (Id : E; V : B := True); + procedure Set_Is_Itype (Id : E; V : B := True); + procedure Set_Is_Known_Non_Null (Id : E; V : B := True); + procedure Set_Is_Known_Null (Id : E; V : B := True); + procedure Set_Is_Known_Valid (Id : E; V : B := True); + procedure Set_Is_Limited_Composite (Id : E; V : B := True); + procedure Set_Is_Limited_Interface (Id : E; V : B := True); + procedure Set_Is_Limited_Record (Id : E; V : B := True); + procedure Set_Is_Machine_Code_Subprogram (Id : E; V : B := True); + procedure Set_Is_Non_Static_Subtype (Id : E; V : B := True); + procedure Set_Is_Null_Init_Proc (Id : E; V : B := True); + procedure Set_Is_Obsolescent (Id : E; V : B := True); + procedure Set_Is_Optional_Parameter (Id : E; V : B := True); + procedure Set_Is_Overriding_Operation (Id : E; V : B := True); + procedure Set_Is_Package_Body_Entity (Id : E; V : B := True); + procedure Set_Is_Packed (Id : E; V : B := True); + procedure Set_Is_Packed_Array_Type (Id : E; V : B := True); + procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True); + procedure Set_Is_Preelaborated (Id : E; V : B := True); + procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True); + procedure Set_Is_Private_Composite (Id : E; V : B := True); + procedure Set_Is_Private_Descendant (Id : E; V : B := True); + procedure Set_Is_Protected_Interface (Id : E; V : B := True); + procedure Set_Is_Public (Id : E; V : B := True); + procedure Set_Is_Pure (Id : E; V : B := True); + procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True); + procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True); + procedure Set_Is_Remote_Types (Id : E; V : B := True); + procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True); + procedure Set_Is_Return_Object (Id : E; V : B := True); + procedure Set_Is_Shared_Passive (Id : E; V : B := True); + procedure Set_Is_Statically_Allocated (Id : E; V : B := True); + procedure Set_Is_Synchronized_Interface (Id : E; V : B := True); + procedure Set_Is_Tag (Id : E; V : B := True); + procedure Set_Is_Tagged_Type (Id : E; V : B := True); + procedure Set_Is_Task_Interface (Id : E; V : B := True); + procedure Set_Is_Thread_Body (Id : E; V : B := True); + procedure Set_Is_True_Constant (Id : E; V : B := True); + procedure Set_Is_Unchecked_Union (Id : E; V : B := True); + procedure Set_Is_Unsigned_Type (Id : E; V : B := True); + procedure Set_Is_VMS_Exception (Id : E; V : B := True); + procedure Set_Is_Valued_Procedure (Id : E; V : B := True); + procedure Set_Is_Visible_Child_Unit (Id : E; V : B := True); + procedure Set_Is_Visible_Formal (Id : E; V : B := True); + procedure Set_Is_Volatile (Id : E; V : B := True); + procedure Set_Itype_Printed (Id : E; V : B := True); + procedure Set_Kill_Elaboration_Checks (Id : E; V : B := True); + procedure Set_Kill_Range_Checks (Id : E; V : B := True); + procedure Set_Kill_Tag_Checks (Id : E; V : B := True); + procedure Set_Known_To_Have_Preelab_Init (Id : E; V : B := True); + procedure Set_Last_Assignment (Id : E; V : N); + procedure Set_Last_Entity (Id : E; V : E); + procedure Set_Limited_View (Id : E; V : E); + procedure Set_Lit_Indexes (Id : E; V : E); + procedure Set_Lit_Strings (Id : E; V : E); + procedure Set_Low_Bound_Known (Id : E; V : B := True); + procedure Set_Machine_Radix_10 (Id : E; V : B := True); + procedure Set_Master_Id (Id : E; V : E); + procedure Set_Materialize_Entity (Id : E; V : B := True); + procedure Set_Mechanism (Id : E; V : M); + procedure Set_Modulus (Id : E; V : U); + procedure Set_Must_Be_On_Byte_Boundary (Id : E; V : B := True); + procedure Set_Must_Have_Preelab_Init (Id : E; V : B := True); + procedure Set_Needs_Debug_Info (Id : E; V : B := True); + procedure Set_Needs_No_Actuals (Id : E; V : B := True); + procedure Set_Never_Set_In_Source (Id : E; V : B := True); + procedure Set_Next_Inlined_Subprogram (Id : E; V : E); + procedure Set_No_Pool_Assigned (Id : E; V : B := True); + procedure Set_No_Return (Id : E; V : B := True); + procedure Set_No_Strict_Aliasing (Id : E; V : B := True); + procedure Set_Non_Binary_Modulus (Id : E; V : B := True); + procedure Set_Non_Limited_View (Id : E; V : E); + procedure Set_Nonzero_Is_True (Id : E; V : B := True); + procedure Set_Normalized_First_Bit (Id : E; V : U); + procedure Set_Normalized_Position (Id : E; V : U); + procedure Set_Normalized_Position_Max (Id : E; V : U); + procedure Set_Object_Ref (Id : E; V : E); + procedure Set_Obsolescent_Warning (Id : E; V : N); + procedure Set_Original_Access_Type (Id : E; V : E); + procedure Set_Original_Array_Type (Id : E; V : E); + procedure Set_Original_Record_Component (Id : E; V : E); + procedure Set_Overridden_Operation (Id : E; V : E); + procedure Set_Package_Instantiation (Id : E; V : N); + procedure Set_Packed_Array_Type (Id : E; V : E); + procedure Set_Parent_Subtype (Id : E; V : E); + procedure Set_Primitive_Operations (Id : E; V : L); + procedure Set_Prival (Id : E; V : E); + procedure Set_Privals_Chain (Id : E; V : L); + procedure Set_Private_Dependents (Id : E; V : L); + procedure Set_Private_View (Id : E; V : N); + procedure Set_Protected_Body_Subprogram (Id : E; V : E); + procedure Set_Protected_Formal (Id : E; V : E); + procedure Set_Protected_Operation (Id : E; V : N); + procedure Set_RM_Size (Id : E; V : U); + procedure Set_Reachable (Id : E; V : B := True); + procedure Set_Referenced (Id : E; V : B := True); + procedure Set_Referenced_As_LHS (Id : E; V : B := True); + procedure Set_Referenced_Object (Id : E; V : N); + procedure Set_Register_Exception_Call (Id : E; V : N); + procedure Set_Related_Array_Object (Id : E; V : E); + procedure Set_Related_Instance (Id : E; V : E); + procedure Set_Renamed_Entity (Id : E; V : N); + procedure Set_Renamed_Object (Id : E; V : N); + procedure Set_Renaming_Map (Id : E; V : U); + procedure Set_Requires_Overriding (Id : E; V : B := True); + procedure Set_Return_Present (Id : E; V : B := True); + procedure Set_Return_Applies_To (Id : E; V : N); + procedure Set_Returns_By_Ref (Id : E; V : B := True); + procedure Set_Reverse_Bit_Order (Id : E; V : B := True); + procedure Set_Scalar_Range (Id : E; V : N); + procedure Set_Scale_Value (Id : E; V : U); + procedure Set_Scope_Depth_Value (Id : E; V : U); + procedure Set_Sec_Stack_Needed_For_Return (Id : E; V : B := True); + procedure Set_Shadow_Entities (Id : E; V : S); + procedure Set_Shared_Var_Assign_Proc (Id : E; V : E); + procedure Set_Shared_Var_Read_Proc (Id : E; V : E); + procedure Set_Size_Check_Code (Id : E; V : N); + procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True); + procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True); + procedure Set_Small_Value (Id : E; V : R); + procedure Set_Spec_Entity (Id : E; V : E); + procedure Set_Storage_Size_Variable (Id : E; V : E); + procedure Set_Stored_Constraint (Id : E; V : L); + 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_Suppress_Elaboration_Warnings (Id : E; V : B := True); + procedure Set_Suppress_Init_Proc (Id : E; V : B := True); + procedure Set_Suppress_Style_Checks (Id : E; V : B := True); + procedure Set_Task_Body_Procedure (Id : E; V : N); + procedure Set_Treat_As_Volatile (Id : E; V : B := True); + procedure Set_Underlying_Full_View (Id : E; V : E); + procedure Set_Unset_Reference (Id : E; V : N); + procedure Set_Uses_Sec_Stack (Id : E; V : B := True); + procedure Set_Vax_Float (Id : E; V : B := True); + procedure Set_Warnings_Off (Id : E; V : B := True); + procedure Set_Was_Hidden (Id : E; V : B := True); + procedure Set_Wrapped_Entity (Id : E; V : E); ----------------------------------- -- Field Initialization Routines -- @@ -6253,16 +6325,18 @@ package Einfo is -- We define the set of Proc_Next_xxx routines simply for the purposes -- of inlining them without necessarily inlining the function. - procedure Proc_Next_Component (N : in out Node_Id); - procedure Proc_Next_Discriminant (N : in out Node_Id); - procedure Proc_Next_Formal (N : in out Node_Id); - procedure Proc_Next_Formal_With_Extras (N : in out Node_Id); - procedure Proc_Next_Index (N : in out Node_Id); - procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id); - procedure Proc_Next_Literal (N : in out Node_Id); - procedure Proc_Next_Stored_Discriminant (N : in out Node_Id); + procedure Proc_Next_Component (N : in out Node_Id); + procedure Proc_Next_Component_Or_Discriminant (N : in out Node_Id); + procedure Proc_Next_Discriminant (N : in out Node_Id); + procedure Proc_Next_Formal (N : in out Node_Id); + procedure Proc_Next_Formal_With_Extras (N : in out Node_Id); + procedure Proc_Next_Index (N : in out Node_Id); + procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id); + procedure Proc_Next_Literal (N : in out Node_Id); + procedure Proc_Next_Stored_Discriminant (N : in out Node_Id); pragma Inline (Proc_Next_Component); + pragma Inline (Proc_Next_Component_Or_Discriminant); pragma Inline (Proc_Next_Discriminant); pragma Inline (Proc_Next_Formal); pragma Inline (Proc_Next_Formal_With_Extras); @@ -6271,28 +6345,31 @@ package Einfo is pragma Inline (Proc_Next_Literal); pragma Inline (Proc_Next_Stored_Discriminant); - procedure Next_Component (N : in out Node_Id) + procedure Next_Component (N : in out Node_Id) renames Proc_Next_Component; - procedure Next_Discriminant (N : in out Node_Id) + procedure Next_Component_Or_Discriminant (N : in out Node_Id) + renames Proc_Next_Component; + + procedure Next_Discriminant (N : in out Node_Id) renames Proc_Next_Discriminant; - procedure Next_Formal (N : in out Node_Id) + procedure Next_Formal (N : in out Node_Id) renames Proc_Next_Formal; - procedure Next_Formal_With_Extras (N : in out Node_Id) + procedure Next_Formal_With_Extras (N : in out Node_Id) renames Proc_Next_Formal_With_Extras; - procedure Next_Index (N : in out Node_Id) + procedure Next_Index (N : in out Node_Id) renames Proc_Next_Index; - procedure Next_Inlined_Subprogram (N : in out Node_Id) + procedure Next_Inlined_Subprogram (N : in out Node_Id) renames Proc_Next_Inlined_Subprogram; - procedure Next_Literal (N : in out Node_Id) + procedure Next_Literal (N : in out Node_Id) renames Proc_Next_Literal; - procedure Next_Stored_Discriminant (N : in out Node_Id) + procedure Next_Stored_Discriminant (N : in out Node_Id) renames Proc_Next_Stored_Discriminant; ---------------------------------------------- @@ -6300,26 +6377,25 @@ package Einfo is ---------------------------------------------- -- The First_Rep_Item field of every entity points to a linked list - -- (linked through Next_Rep_Item) of representation pragmas and - -- attribute definition clauses that apply to the item. Note that - -- in the case of types, it is assumed that any such rep items for - -- a base type also apply to all subtypes. This is implemented by - -- having the chain for subtypes link onto the chain for the base - -- type, so that any new entries for the subtype are added at the - -- start of the chain. + -- (linked through Next_Rep_Item) of representation pragmas and attribute + -- definition clauses that apply to the item. Note that in the case of + -- types, it is assumed that any such rep items for a base type also apply + -- to all subtypes. This is implemented by having the chain for subtypes + -- link onto the chain for the base type, so that any new entries for the + -- subtype are added at the start of the chain. function Get_Attribute_Definition_Clause (E : Entity_Id; Id : Attribute_Id) return Node_Id; - -- Searches the Rep_Item chain for a given entity E, for an instance - -- of an attribute definition clause with the given attribute Id. If - -- found, the value returned is the N_Attribute_Definition_Clause node, - -- otherwise Empty is returned. + -- Searches the Rep_Item chain for a given entity E, for an instance of an + -- attribute definition clause with the given attribute Id. If found, the + -- value returned is the N_Attribute_Definition_Clause node, otherwise + -- Empty is returned. function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id; -- Searches the Rep_Item chain for the given entity E, for an instance - -- of a representation pragma with the given name Nam. If found then - -- the value returned is the N_Pragma node, otherwise Empty is returned. + -- a representation pragma with the given name Nam. If found then the + -- value returned is the N_Pragma node, otherwise Empty is returned. function Has_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Boolean; -- Searches the Rep_Item chain for the given entity E, for an instance @@ -6329,10 +6405,9 @@ package Einfo is function Has_Attribute_Definition_Clause (E : Entity_Id; Id : Attribute_Id) return Boolean; - -- Searches the Rep_Item chain for a given entity E, for an instance - -- of an attribute definition clause with the given attribute Id. If - -- found, True is returned, otherwise False indicates that no matching - -- entry was found. + -- Searches the Rep_Item chain for a given entity E, for an instance of an + -- attribute definition clause with the given attribute Id. If found, True + -- is returned, otherwise False indicates that no matching entry was found. procedure Record_Rep_Item (E : Entity_Id; N : Node_Id); -- N is the node for either a representation pragma or an attribute @@ -6545,9 +6620,11 @@ package Einfo is pragma Inline (Has_Pragma_Pure); pragma Inline (Has_Pragma_Pure_Function); pragma Inline (Has_Pragma_Unreferenced); + pragma Inline (Has_Pragma_Unreferenced_Objects); pragma Inline (Has_Primitive_Operations); pragma Inline (Has_Private_Declaration); pragma Inline (Has_Qualified_Name); + pragma Inline (Has_RACW); pragma Inline (Has_Record_Rep_Clause); pragma Inline (Has_Recursive_Call); pragma Inline (Has_Size_Clause); @@ -6574,11 +6651,13 @@ package Einfo is pragma Inline (Inner_Instances); pragma Inline (Interface_Name); pragma Inline (Is_AST_Entry); - pragma Inline (Is_Abstract); + pragma Inline (Is_Abstract_Subprogram); + pragma Inline (Is_Abstract_Type); pragma Inline (Is_Local_Anonymous_Access); pragma Inline (Is_Access_Constant); pragma Inline (Is_Ada_2005_Only); pragma Inline (Is_Access_Type); + pragma Inline (Is_Access_Protected_Subprogram_Type); pragma Inline (Is_Aliased); pragma Inline (Is_Array_Type); pragma Inline (Is_Asynchronous); @@ -6760,6 +6839,7 @@ package Einfo is pragma Inline (Renamed_Entity); pragma Inline (Renamed_Object); pragma Inline (Renaming_Map); + pragma Inline (Requires_Overriding); pragma Inline (Return_Present); pragma Inline (Return_Applies_To); pragma Inline (Returns_By_Ref); @@ -6931,10 +7011,12 @@ package Einfo is pragma Inline (Set_Has_Pragma_Pure); pragma Inline (Set_Has_Pragma_Pure_Function); pragma Inline (Set_Has_Pragma_Unreferenced); + pragma Inline (Set_Has_Pragma_Unreferenced_Objects); pragma Inline (Set_Known_To_Have_Preelab_Init); pragma Inline (Set_Has_Primitive_Operations); pragma Inline (Set_Has_Private_Declaration); pragma Inline (Set_Has_Qualified_Name); + pragma Inline (Set_Has_RACW); pragma Inline (Set_Has_Record_Rep_Clause); pragma Inline (Set_Has_Recursive_Call); pragma Inline (Set_Has_Size_Clause); @@ -6960,7 +7042,8 @@ package Einfo is pragma Inline (Set_Inner_Instances); pragma Inline (Set_Interface_Name); pragma Inline (Set_Is_AST_Entry); - pragma Inline (Set_Is_Abstract); + pragma Inline (Set_Is_Abstract_Subprogram); + pragma Inline (Set_Is_Abstract_Type); pragma Inline (Set_Is_Local_Anonymous_Access); pragma Inline (Set_Is_Access_Constant); pragma Inline (Set_Is_Ada_2005_Only); @@ -7106,6 +7189,7 @@ package Einfo is pragma Inline (Set_Renamed_Entity); pragma Inline (Set_Renamed_Object); pragma Inline (Set_Renaming_Map); + pragma Inline (Set_Requires_Overriding); pragma Inline (Set_Return_Present); pragma Inline (Set_Return_Applies_To); pragma Inline (Set_Returns_By_Ref); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 7410db22552..d3db4afceb3 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -29,6 +29,7 @@ with Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; +with Exp_Atag; use Exp_Atag; with Exp_Aggr; use Exp_Aggr; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; @@ -127,10 +128,6 @@ package body Exp_Ch5 is -- pointers which are not 'part of the value' and must not be changed -- upon assignment. N is the original Assignment node. - procedure No_Secondary_Stack_Case (N : Node_Id); - -- Obsolete code to deal with functions for which - -- Function_Returns_With_DSP is True. - function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean; -- This function is used in processing the assignment of a record or -- indexed component. The argument N is either the left hand or right @@ -1401,7 +1398,7 @@ package body Exp_Ch5 is begin -- Ada 2005 (AI-327): Handle assignment to priority of protected object - -- Rewrite an assignment to X'Priority into a run-time call. + -- Rewrite an assignment to X'Priority into a run-time call -- For example: X'Priority := New_Prio_Expr; -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr); @@ -1759,7 +1756,7 @@ package body Exp_Ch5 is -- Build-in-place function call case. Note that we're not yet doing -- build-in-place for user-written assignment statements; the - -- assignment here came from can aggregate. + -- assignment here came from an aggregate. elsif Ada_Version >= Ada_05 and then Is_Build_In_Place_Function_Call (Rhs) @@ -1830,7 +1827,7 @@ package body Exp_Ch5 is -- In case of assignment to a class-wide tagged type, before -- the assignment we generate run-time check to ensure that - -- the tag of the Target is covered by the tag of the source + -- the tags of source and target match. if Is_Class_Wide_Type (Typ) and then Is_Tagged_Type (Typ) @@ -1839,21 +1836,19 @@ package body Exp_Ch5 is Append_To (L, Make_Raise_Constraint_Error (Loc, Condition => - Make_Op_Not (Loc, - Make_Function_Call (Loc, - Name => New_Reference_To - (RTE (RE_CW_Membership), Loc), - Parameter_Associations => New_List ( + Make_Op_Ne (Loc, + Left_Opnd => Make_Selected_Component (Loc, - Prefix => - Duplicate_Subexpr (Lhs), + Prefix => Duplicate_Subexpr (Lhs), Selector_Name => - Make_Identifier (Loc, Name_uTag)), + Make_Identifier (Loc, + Chars => Name_uTag)), + Right_Opnd => Make_Selected_Component (Loc, - Prefix => - Duplicate_Subexpr (Rhs), + Prefix => Duplicate_Subexpr (Rhs), Selector_Name => - Make_Identifier (Loc, Name_uTag))))), + Make_Identifier (Loc, + Chars => Name_uTag))), Reason => CE_Tag_Check_Failed)); end if; @@ -1861,7 +1856,8 @@ package body Exp_Ch5 is Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (Op, Loc), Parameter_Associations => New_List ( - Unchecked_Convert_To (F_Typ, Duplicate_Subexpr (Lhs)), + Unchecked_Convert_To (F_Typ, + Duplicate_Subexpr (Lhs)), Unchecked_Convert_To (F_Typ, Duplicate_Subexpr (Rhs))))); end; @@ -1872,8 +1868,8 @@ package body Exp_Ch5 is -- We can't afford to have destructive Finalization Actions -- in the Self assignment case, so if the target and the -- source are not obviously different, code is generated to - -- avoid the self assignment case - -- + -- avoid the self assignment case: + -- if lhs'address /= rhs'address then -- <code for controlled and/or tagged assignment> -- end if; @@ -1901,7 +1897,7 @@ package body Exp_Ch5 is -- We need to set up an exception handler for implementing -- 7.6.1 (18). The remaining adjustments are tackled by the -- implementation of adjust for record_controllers (see - -- s-finimp.adb) + -- s-finimp.adb). -- This is skipped if we have no finalization @@ -1914,7 +1910,7 @@ package body Exp_Ch5 is Make_Handled_Sequence_Of_Statements (Loc, Statements => L, Exception_Handlers => New_List ( - Make_Exception_Handler (Loc, + Make_Implicit_Exception_Handler (Loc, Exception_Choices => New_List (Make_Others_Choice (Loc)), Statements => New_List ( @@ -1931,7 +1927,7 @@ package body Exp_Ch5 is Make_Handled_Sequence_Of_Statements (Loc, Statements => L))); -- If no restrictions on aborts, protect the whole assignement - -- for controlled objects as per 9.8(11) + -- for controlled objects as per 9.8(11). if Controlled_Type (Typ) and then Expand_Ctrl_Actions @@ -2366,61 +2362,6 @@ package body Exp_Ch5 is -- initial values might need to be set). procedure Expand_N_Extended_Return_Statement (N : Node_Id) is - - function Is_Build_In_Place_Function (Fun : Entity_Id) return Boolean; - -- F must be of type E_Function or E_Generic_Function. Return True if it - -- uses build-in-place for the result object. In Ada 95, this must be - -- False for inherently limited result type. In Ada 2005, this must be - -- True for inherently limited result type. For other types, we have a - -- choice -- build-in-place is usually more efficient for large things, - -- and less efficient for small things. However, we had better not use - -- build-in-place if the Convention is other than Ada, because that - -- would disturb mixed-language programs. - -- - -- Note that for the non-inherently-limited cases, we must make the same - -- decision for Ada 95 and 2005, so that mixed-dialect programs work. - -- - -- ???This function will be needed when compiling the call sites; - -- we will have to move it to a more global place. - - -------------------------------- - -- Is_Build_In_Place_Function -- - -------------------------------- - - function Is_Build_In_Place_Function (Fun : Entity_Id) return Boolean is - R_Type : constant Entity_Id := Underlying_Type (Etype (Fun)); - - begin - -- First, the cases that matter for correctness - - if Is_Inherently_Limited_Type (R_Type) then - return Ada_Version >= Ada_05 and then not Debug_Flag_Dot_L; - - -- Note: If you have Convention (C) on an inherently limited - -- type, you're on your own. That is, the C code will have to be - -- carefully written to know about the Ada conventions. - - elsif - Has_Foreign_Convention (R_Type) - or else - Has_Foreign_Convention (Fun) - then - return False; - - -- Second, the efficiency-related decisions. It would be obnoxiously - -- inefficient to use build-in-place for elementary types. For - -- composites, we could return False if the subtype is known to be - -- small (<= one or two words?) but we don't bother with that yet. - - else - return Is_Composite_Type (R_Type); - end if; - end Is_Build_In_Place_Function; - - ------------------------ - -- Local Declarations -- - ------------------------ - Loc : constant Source_Ptr := Sloc (N); Return_Object_Entity : constant Entity_Id := @@ -2433,10 +2374,83 @@ package body Exp_Ch5 is Is_Build_In_Place_Function (Parent_Function); Return_Stm : Node_Id; + Statements : List_Id; Handled_Stm_Seq : Node_Id; Result : Node_Id; Exp : Node_Id; + function Move_Activation_Chain return Node_Id; + -- Construct a call to System.Tasking.Stages.Move_Activation_Chain + -- with parameters: + -- From current activation chain + -- To activation chain passed in by the caller + -- New_Master master passed in by the caller + + function Move_Final_List return Node_Id; + -- Construct call to System.Finalization_Implementation.Move_Final_List + -- with parameters: + -- From finalization list of the return statement + -- To finalization list passed in by the caller + + --------------------- + -- Move_Activation_Chain -- + --------------------- + + function Move_Activation_Chain return Node_Id is + Activation_Chain_Formal : constant Entity_Id := + Build_In_Place_Formal (Parent_Function, BIP_Activation_Chain); + To : constant Node_Id := + New_Reference_To (Activation_Chain_Formal, Loc); + Master_Formal : constant Entity_Id := + Build_In_Place_Formal (Parent_Function, BIP_Master); + New_Master : constant Node_Id := + New_Reference_To (Master_Formal, Loc); + + Chain_Entity : Entity_Id; + From : Node_Id; + begin + Chain_Entity := First_Entity (Return_Statement_Entity (N)); + while Chars (Chain_Entity) /= Name_uChain loop + Chain_Entity := Next_Entity (Chain_Entity); + end loop; + + From := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Chain_Entity, Loc), + Attribute_Name => Name_Unrestricted_Access); + -- ??? I'm not sure why "Make_Identifier (Loc, Name_uChain)" doesn't + -- work, instead of "New_Reference_To (Chain_Entity, Loc)" above. + + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Move_Activation_Chain), Loc), + Parameter_Associations => New_List (From, To, New_Master)); + end Move_Activation_Chain; + + --------------------- + -- Move_Final_List -- + --------------------- + + function Move_Final_List return Node_Id is + Flist : constant Entity_Id := + Finalization_Chain_Entity (Return_Statement_Entity (N)); + + From : constant Node_Id := New_Reference_To (Flist, Loc); + + Caller_Final_List : constant Entity_Id := + Build_In_Place_Formal + (Parent_Function, BIP_Final_List); + + To : constant Node_Id := + New_Reference_To (Caller_Final_List, Loc); + + begin + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Move_Final_List), Loc), + Parameter_Associations => New_List (From, To)); + end Move_Final_List; + -- Start of processing for Expand_N_Extended_Return_Statement begin @@ -2448,27 +2462,63 @@ package body Exp_Ch5 is Handled_Stm_Seq := Handled_Statement_Sequence (N); + -- Build a simple_return_statement that returns the return object when + -- there is a statement sequence, or no expression, or the result will + -- be built in place. Note however that we currently do this for all + -- composite cases, even though nonlimited composite results are not yet + -- built in place (though we plan to do so eventually). + if Present (Handled_Stm_Seq) - or else Is_Build_In_Place + or else Is_Composite_Type (Etype (Parent_Function)) or else No (Exp) then - -- Build simple_return_statement that returns the return object + Statements := New_List; + + if Present (Handled_Stm_Seq) then + Append_To (Statements, Handled_Stm_Seq); + end if; + + -- If control gets past the above Statements, we have successfully + -- completed the return statement. If the result type has controlled + -- parts, we call Move_Final_List to transfer responsibility for + -- finalization of the return object to the caller. An alternative + -- would be to declare a Success flag in the function, initialize it + -- to False, and set it to True here. Then move the Move_Final_List + -- call into the cleanup code, and check Success. If Success then + -- Move_Final_List else do finalization. Then we can remove the + -- abort-deferral and the nulling-out of the From parameter from + -- Move_Final_List. Note that the current method is not quite + -- correct in the rather obscure case of a select-then-abort + -- statement whose abortable part contains the return statement. + + if Is_Controlled (Etype (Parent_Function)) + or else Has_Controlled_Component (Etype (Parent_Function)) + then + Append_To (Statements, Move_Final_List); + end if; + + -- Similarly to the above Move_Final_List, if the result type + -- contains tasks, we call Move_Activation_Chain. Later, the cleanup + -- code will call Complete_Master, which will terminate any + -- unactivated tasks belonging to the return statement master. But + -- Move_Activation_Chain updates their master to be that of the + -- caller, so they will not be terminated unless the return + -- statement completes unsuccessfully due to exception, abort, goto, + -- or exit. + + if Has_Task (Etype (Parent_Function)) then + Append_To (Statements, Move_Activation_Chain); + end if; + + -- Build a simple_return_statement that returns the return object Return_Stm := Make_Return_Statement (Loc, Expression => New_Occurrence_Of (Return_Object_Entity, Loc)); + Append_To (Statements, Return_Stm); - if Present (Handled_Stm_Seq) then - Handled_Stm_Seq := - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Handled_Stm_Seq, Return_Stm)); - else - Handled_Stm_Seq := - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Return_Stm)); - end if; - - pragma Assert (Present (Handled_Stm_Seq)); + Handled_Stm_Seq := + Make_Handled_Sequence_Of_Statements (Loc, Statements); end if; -- Case where we build a block @@ -2479,7 +2529,29 @@ package body Exp_Ch5 is Declarations => Return_Object_Declarations (N), Handled_Statement_Sequence => Handled_Stm_Seq); - if Is_Build_In_Place then + -- We set the entity of the new block statement to be that of the + -- return statement. This is necessary so that various fields, such + -- as Finalization_Chain_Entity carry over from the return statement + -- to the block. Note that this block is unusual, in that its entity + -- is an E_Return_Statement rather than an E_Block. + + Set_Identifier + (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc)); + + -- If the object decl was already rewritten as a renaming, then + -- we don't want to do the object allocation and transformation of + -- of the return object declaration to a renaming. This case occurs + -- when the return object is initialized by a call to another + -- build-in-place function, and that function is responsible for the + -- allocation of the return object. + + if Is_Build_In_Place + and then + Nkind (Return_Object_Decl) = N_Object_Renaming_Declaration + then + Set_By_Ref (Return_Stm); -- Return build-in-place results by ref + + elsif Is_Build_In_Place then -- Locate the implicit access parameter associated with the -- the caller-supplied return object and convert the return @@ -2503,84 +2575,282 @@ package body Exp_Ch5 is -- ... declare - Return_Obj_Id : constant Entity_Id := - Defining_Identifier (Return_Object_Decl); - Return_Obj_Typ : constant Entity_Id := Etype (Return_Obj_Id); - Return_Obj_Expr : constant Node_Id := - Expression (Return_Object_Decl); - Obj_Acc_Formal : Entity_Id := Extra_Formals (Parent_Function); - Obj_Acc_Deref : Node_Id; - Init_Assignment : Node_Id; + Return_Obj_Id : constant Entity_Id := + Defining_Identifier (Return_Object_Decl); + Return_Obj_Typ : constant Entity_Id := Etype (Return_Obj_Id); + Return_Obj_Expr : constant Node_Id := + Expression (Return_Object_Decl); + Result_Subt : constant Entity_Id := + Etype (Parent_Function); + Constr_Result : constant Boolean := + Is_Constrained (Result_Subt); + Obj_Alloc_Formal : Entity_Id; + Object_Access : Entity_Id; + Obj_Acc_Deref : Node_Id; + Init_Assignment : Node_Id := Empty; begin -- Build-in-place results must be returned by reference Set_By_Ref (Return_Stm); - -- Locate the implicit access parameter passed by the caller. - -- It might be better to search for that with a symbol table - -- lookup, but for now we traverse the extra actuals to find - -- the access parameter (currently there can only be one). + -- Retrieve the implicit access parameter passed by the caller - while Present (Obj_Acc_Formal) loop - exit when - Ekind (Etype (Obj_Acc_Formal)) = E_Anonymous_Access_Type; - Next_Formal_With_Extras (Obj_Acc_Formal); - end loop; + Object_Access := + Build_In_Place_Formal (Parent_Function, BIP_Object_Access); - -- ??? pragma Assert (Present (Obj_Acc_Formal)); + -- If the return object's declaration includes an expression + -- and the declaration isn't marked as No_Initialization, then + -- we need to generate an assignment to the object and insert + -- it after the declaration before rewriting it as a renaming + -- (otherwise we'll lose the initialization). - -- For now we only rewrite the object if we can locate the - -- implicit access parameter. Normally there should be one - -- if Build_In_Place is true, but at the moment it's only - -- created in the more restrictive case of constrained - -- inherently limited result subtypes. ??? + if Present (Return_Obj_Expr) + and then not No_Initialization (Return_Object_Decl) + then + Init_Assignment := + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Return_Obj_Id, Loc), + Expression => Relocate_Node (Return_Obj_Expr)); + Set_Assignment_OK (Name (Init_Assignment)); + Set_No_Ctrl_Actions (Init_Assignment); - if Present (Obj_Acc_Formal) then + Set_Parent (Expression (Init_Assignment), Init_Assignment); - -- If the return object's declaration includes an expression - -- and the declaration isn't marked as No_Initialization, - -- then we need to generate an assignment to the object and - -- insert it after the declaration before rewriting it as - -- a renaming (otherwise we'll lose the initialization). + Set_Expression (Return_Object_Decl, Empty); - if Present (Return_Obj_Expr) - and then not No_Initialization (Return_Object_Decl) + if Is_Class_Wide_Type (Etype (Return_Obj_Id)) + and then not Is_Class_Wide_Type + (Etype (Expression (Init_Assignment))) then - Init_Assignment := - Make_Assignment_Statement (Loc, - Name => New_Reference_To (Return_Obj_Id, Loc), - Expression => Relocate_Node (Return_Obj_Expr)); - Set_Assignment_OK (Name (Init_Assignment)); - Set_No_Ctrl_Actions (Init_Assignment); - - -- ??? Should we be setting the parent of the expression - -- here? - -- Set_Parent - -- (Expression (Init_Assignment), Init_Assignment); - - Set_Expression (Return_Object_Decl, Empty); + Rewrite (Expression (Init_Assignment), + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of + (Etype (Return_Obj_Id), Loc), + Expression => + Relocate_Node (Expression (Init_Assignment)))); + end if; + if Constr_Result then Insert_After (Return_Object_Decl, Init_Assignment); end if; + end if; - -- Replace the return object declaration with a renaming - -- of a dereference of the implicit access formal. + -- When the function's subtype is unconstrained, a run-time + -- test is needed to determine the form of allocation to use + -- for the return object. The function has an implicit formal + -- parameter that indicates this. If the BIP_Alloc_Form formal + -- has the value one, then the caller has passed access to an + -- existing object for use as the return object. If the value + -- is two, then the return object must be allocated on the + -- secondary stack. Otherwise, the object must be allocated in + -- a storage pool. Currently the last case is only supported + -- for the global heap (user-defined storage pools TBD ???). We + -- generate an if statement to test the implicit allocation + -- formal and initialize a local access value appropriately, + -- creating allocators in the secondary stack and global heap + -- cases. + + if not Constr_Result then + Obj_Alloc_Formal := + Build_In_Place_Formal (Parent_Function, BIP_Alloc_Form); + + declare + Ref_Type : Entity_Id; + Ptr_Type_Decl : Node_Id; + Alloc_Obj_Id : Entity_Id; + Alloc_Obj_Decl : Node_Id; + Alloc_If_Stmt : Node_Id; + SS_Allocator : Node_Id; + Heap_Allocator : Node_Id; + + begin + -- Reuse the itype created for the function's implicit + -- access formal. This avoids the need to create a new + -- access type here, plus it allows assigning the access + -- formal directly without applying a conversion. + + -- Ref_Type := Etype (Object_Access); + + -- Create an access type designating the function's + -- result subtype. + + Ref_Type := + Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + + Ptr_Type_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ref_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Reference_To (Return_Obj_Typ, Loc))); + + Insert_Before_And_Analyze + (Return_Object_Decl, Ptr_Type_Decl); + + -- Create an access object that will be initialized to an + -- access value denoting the return object, either coming + -- from an implicit access value passed in by the caller + -- or from the result of an allocator. + + Alloc_Obj_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('R')); + Set_Etype (Alloc_Obj_Id, Ref_Type); + + Alloc_Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Alloc_Obj_Id, + Object_Definition => New_Reference_To + (Ref_Type, Loc)); + + Insert_Before_And_Analyze + (Return_Object_Decl, Alloc_Obj_Decl); + + -- Create allocators for both the secondary stack and + -- global heap. If there's an initialization expression, + -- then create these as initialized allocators. + + if Present (Return_Obj_Expr) + and then not No_Initialization (Return_Object_Decl) + then + Heap_Allocator := + Make_Allocator (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Reference_To (Return_Obj_Typ, Loc), + Expression => + New_Copy_Tree (Return_Obj_Expr))); + + SS_Allocator := New_Copy_Tree (Heap_Allocator); + + else + Heap_Allocator := + Make_Allocator (Loc, + New_Reference_To (Return_Obj_Typ, Loc)); - Obj_Acc_Deref := - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Obj_Acc_Formal, Loc)); + -- If the object requires default initialization then + -- that will happen later following the elaboration of + -- the object renaming. If we don't turn it off here + -- then the object will be default initialized twice. - Rewrite (Return_Object_Decl, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Return_Obj_Id, - Access_Definition => Empty, - Subtype_Mark => New_Occurrence_Of - (Return_Obj_Typ, Loc), - Name => Obj_Acc_Deref)); + Set_No_Initialization (Heap_Allocator); - Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref); + SS_Allocator := New_Copy_Tree (Heap_Allocator); + end if; + + Set_Storage_Pool + (SS_Allocator, RTE (RE_SS_Pool)); + Set_Procedure_To_Call + (SS_Allocator, RTE (RE_SS_Allocate)); + + -- Create an if statement to test the BIP_Alloc_Form + -- formal and initialize the access object to either the + -- BIP_Object_Access formal (BIP_Alloc_Form = 0), the + -- result of allocaing the object in the secondary stack + -- (BIP_Alloc_Form = 1), or else an allocator to create + -- the return object in the heap (BIP_Alloc_Form = 2). + + -- ??? An unchecked type conversion must be made in the + -- case of assigning the access object formal to the + -- local access object, because a normal conversion would + -- be illegal in some cases (such as converting access- + -- to-unconstrained to access-to-constrained), but the + -- the unchecked conversion will presumably fail to work + -- right in just such cases. It's not clear at all how to + -- handle this. ??? + + Alloc_If_Stmt := + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (Obj_Alloc_Formal, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, + UI_From_Int (BIP_Allocation_Form'Pos + (Caller_Allocation)))), + Then_Statements => + New_List (Make_Assignment_Statement (Loc, + Name => + New_Reference_To + (Alloc_Obj_Id, Loc), + Expression => + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To (Ref_Type, Loc), + Expression => + New_Reference_To + (Object_Access, Loc)))), + Elsif_Parts => + New_List (Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To + (Obj_Alloc_Formal, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, + UI_From_Int ( + BIP_Allocation_Form'Pos + (Secondary_Stack)))), + Then_Statements => + New_List + (Make_Assignment_Statement (Loc, + Name => + New_Reference_To + (Alloc_Obj_Id, Loc), + Expression => + SS_Allocator)))), + Else_Statements => + New_List (Make_Assignment_Statement (Loc, + Name => + New_Reference_To + (Alloc_Obj_Id, Loc), + Expression => + Heap_Allocator))); + + -- If a separate initialization assignment was created + -- earlier, append that following the assignment of the + -- implicit access formal to the access object, to ensure + -- that the return object is initialized in that case. + + if Present (Init_Assignment) then + Append_To + (Then_Statements (Alloc_If_Stmt), + Init_Assignment); + end if; + + Insert_After_And_Analyze (Alloc_Obj_Decl, Alloc_If_Stmt); + + -- Remember the local access object for use in the + -- dereference of the renaming created below. + + Object_Access := Alloc_Obj_Id; + end; end if; + + -- Replace the return object declaration with a renaming of a + -- dereference of the access value designating the return + -- object. + + Obj_Acc_Deref := + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Object_Access, Loc)); + + Rewrite (Return_Object_Decl, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Return_Obj_Id, + Access_Definition => Empty, + Subtype_Mark => New_Occurrence_Of + (Return_Obj_Typ, Loc), + Name => Obj_Acc_Deref)); + + Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref); end; end if; @@ -2622,8 +2892,8 @@ package body Exp_Ch5 is -- Expand_N_If_Statement -- --------------------------- - -- First we deal with the case of C and Fortran convention boolean - -- values, with zero/non-zero semantics. + -- First we deal with the case of C and Fortran convention boolean values, + -- with zero/non-zero semantics. -- Second, we deal with the obvious rewriting for the cases where the -- condition of the IF is known at compile time to be True or False. @@ -2647,8 +2917,8 @@ package body Exp_Ch5 is -- end if; -- This rewriting is needed if at least one elsif part has a non-empty - -- Condition_Actions list. We also do the same processing if there is - -- a constant condition in an elsif part (in conjunction with the first + -- Condition_Actions list. We also do the same processing if there is a + -- constant condition in an elsif part (in conjunction with the first -- processing step mentioned above, for the recursive call made to deal -- with the created inner if, this deals with properly optimizing the -- cases of constant elsif conditions). @@ -2668,8 +2938,8 @@ package body Exp_Ch5 is while Compile_Time_Known_Value (Condition (N)) loop - -- If condition is True, we can simply rewrite the if statement - -- now by replacing it by the series of then statements. + -- If condition is True, we can simply rewrite the if statement now + -- by replacing it by the series of then statements. if Is_True (Expr_Value (Condition (N))) then @@ -2687,10 +2957,10 @@ package body Exp_Ch5 is -- the Then statements else - -- We do not delete the condition if constant condition - -- warnings are enabled, since otherwise we end up deleting - -- the desired warning. Of course the backend will get rid - -- of this True/False test anyway, so nothing is lost here. + -- We do not delete the condition if constant condition warnings + -- are enabled, since otherwise we end up deleting the desired + -- warning. Of course the backend will get rid of this True/False + -- test anyway, so nothing is lost here. if not Constant_Condition_Warnings then Kill_Dead_Code (Condition (N)); @@ -2698,8 +2968,8 @@ package body Exp_Ch5 is Kill_Dead_Code (Then_Statements (N), Warn_On_Deleted_Code); - -- If there are no elsif statements, then we simply replace - -- the entire if statement by the sequence of else statements. + -- If there are no elsif statements, then we simply replace the + -- entire if statement by the sequence of else statements. if No (Elsif_Parts (N)) then if No (Else_Statements (N)) @@ -2715,9 +2985,9 @@ package body Exp_Ch5 is return; - -- If there are elsif statements, the first of them becomes - -- the if/then section of the rebuilt if statement This is - -- the case where we loop to reprocess this copied condition. + -- If there are elsif statements, the first of them becomes the + -- if/then section of the rebuilt if statement This is the case + -- where we loop to reprocess this copied condition. else Hed := Remove_Head (Elsif_Parts (N)); @@ -2747,18 +3017,18 @@ package body Exp_Ch5 is while Present (E) loop Adjust_Condition (Condition (E)); - -- If there are condition actions, then we rewrite the if - -- statement as indicated above. We also do the same rewrite - -- if the condition is True or False. The further processing - -- of this constant condition is then done by the recursive - -- call to expand the newly created if statement + -- If there are condition actions, then rewrite the if statement + -- as indicated above. We also do the same rewrite for a True or + -- False condition. The further processing of this constant + -- condition is then done by the recursive call to expand the + -- newly created if statement if Present (Condition_Actions (E)) or else Compile_Time_Known_Value (Condition (E)) then - -- Note this is not an implicit if statement, since it is - -- part of an explicit if statement in the source (or of an - -- implicit if statement that has already been tested). + -- Note this is not an implicit if statement, since it is part + -- of an explicit if statement in the source (or of an implicit + -- if statement that has already been tested). New_If := Make_If_Statement (Sloc (E), @@ -2913,9 +3183,9 @@ package body Exp_Ch5 is -- range bounds here, since they were frozen with constant declarations -- and it is during that process that the validity checking is done. - -- Handle the case where we have a for loop with the range type being - -- an enumeration type with non-standard representation. In this case - -- we expand: + -- Handle the case where we have a for loop with the range type being an + -- enumeration type with non-standard representation. In this case we + -- expand: -- for x in [reverse] a .. b loop -- ... @@ -2952,8 +3222,8 @@ package body Exp_Ch5 is Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Loop_Id), 'P')); - -- If the type has a contiguous representation, successive - -- values can be generated as offsets from the first literal. + -- If the type has a contiguous representation, successive values + -- can be generated as offsets from the first literal. if Has_Contiguous_Rep (Btype) then Expr := @@ -3033,8 +3303,8 @@ package body Exp_Ch5 is Analyze (N); end; - -- Second case, if we have a while loop with Condition_Actions set, - -- then we change it into a plain loop: + -- Second case, if we have a while loop with Condition_Actions set, then + -- we change it into a plain loop: -- while C loop -- ... @@ -3064,10 +3334,10 @@ package body Exp_Ch5 is Prepend (ES, Statements (N)); Insert_List_Before (ES, Condition_Actions (Isc)); - -- This is not an implicit loop, since it is generated in - -- response to the loop statement being processed. If this - -- is itself implicit, the restriction has already been - -- checked. If not, it is an explicit loop. + -- This is not an implicit loop, since it is generated in response + -- to the loop statement being processed. If this is itself + -- implicit, the restriction has already been checked. If not, + -- it is an explicit loop. Rewrite (N, Make_Loop_Statement (Sloc (N), @@ -3167,8 +3437,8 @@ package body Exp_Ch5 is pragma Assert (Is_Entry (Scope_Id)); - -- Look at the enclosing block to see whether the return is from - -- an accept statement or an entry body. + -- Look at the enclosing block to see whether the return is from an + -- accept statement or an entry body. for J in reverse 0 .. Cur_Idx loop Scope_Id := Scope_Stack.Table (J).Entity; @@ -3249,9 +3519,9 @@ package body Exp_Ch5 is -- Deal with returning variable length objects and controlled types - -- Nothing to do if we are returning by reference, or this is not a - -- type that requires special processing (indicated by the fact that - -- it requires a cleanup scope for the secondary stack case). + -- Nothing to do if we are returning by reference, or this is not type + -- that requires special processing (indicated by the fact that it + -- requires a cleanup scope for the secondary stack case). if Is_Inherently_Limited_Type (T) then null; @@ -3282,158 +3552,6 @@ package body Exp_Ch5 is end if; end; - -- Case of secondary stack not used - - elsif Function_Returns_With_DSP (Scope_Id) then - - -- The DSP method is no longer in use. We would like to ignore DSP - -- while implementing AI-318; hence the raise below. - - if True then - raise Program_Error; - end if; - - -- Here what we need to do is to always return by reference, since - -- we will return with the stack pointer depressed. We may need to - -- do a copy to a local temporary before doing this return. - - No_Secondary_Stack_Case : declare - Local_Copy_Required : Boolean := False; - -- Set to True if a local copy is required - - Copy_Ent : Entity_Id; - -- Used for the target entity if a copy is required - - Decl : Node_Id; - -- Declaration used to create copy if needed - - procedure Test_Copy_Required (Expr : Node_Id); - -- Determines if Expr represents a return value for which a - -- copy is required. More specifically, a copy is not required - -- if Expr represents an object or component of an object that - -- is either in the local subprogram frame, or is constant. - -- If a copy is required, then Local_Copy_Required is set True. - - ------------------------ - -- Test_Copy_Required -- - ------------------------ - - procedure Test_Copy_Required (Expr : Node_Id) is - Ent : Entity_Id; - - begin - -- If component, test prefix (object containing component) - - if Nkind (Expr) = N_Indexed_Component - or else - Nkind (Expr) = N_Selected_Component - then - Test_Copy_Required (Prefix (Expr)); - return; - - -- See if we have an entity name - - elsif Is_Entity_Name (Expr) then - Ent := Entity (Expr); - - -- Constant entity is always OK, no copy required - - if Ekind (Ent) = E_Constant then - return; - - -- No copy required for local variable - - elsif Ekind (Ent) = E_Variable - and then Scope (Ent) = Current_Subprogram - then - return; - end if; - end if; - - -- All other cases require a copy - - Local_Copy_Required := True; - end Test_Copy_Required; - - -- Start of processing for No_Secondary_Stack_Case - - begin - -- No copy needed if result is from a function call. - -- In this case the result is already being returned by - -- reference with the stack pointer depressed. - - -- To make up for a gcc 2.8.1 deficiency (???), we perform - -- the copy for array types if the constrained status of the - -- target type is different from that of the expression. - - if Requires_Transient_Scope (T) - and then - (not Is_Array_Type (T) - or else Is_Constrained (T) = Is_Constrained (Return_Type) - or else Controlled_Type (T)) - and then Nkind (Exp) = N_Function_Call - then - Set_By_Ref (N); - - -- We always need a local copy for a controlled type, since - -- we are required to finalize the local value before return. - -- The copy will automatically include the required finalize. - -- Moreover, gigi cannot make this copy, since we need special - -- processing to ensure proper behavior for finalization. - - -- Note: the reason we are returning with a depressed stack - -- pointer in the controlled case (even if the type involved - -- is constrained) is that we must make a local copy to deal - -- properly with the requirement that the local result be - -- finalized. - - elsif Controlled_Type (Utyp) then - Copy_Ent := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); - - -- Build declaration to do the copy, and insert it, setting - -- Assignment_OK, because we may be copying a limited type. - -- In addition we set the special flag to inhibit finalize - -- attachment if this is a controlled type (since this attach - -- must be done by the caller, otherwise if we attach it here - -- we will finalize the returned result prematurely). - - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Copy_Ent, - Object_Definition => New_Occurrence_Of (Return_Type, Loc), - Expression => Relocate_Node (Exp)); - - Set_Assignment_OK (Decl); - Set_Delay_Finalize_Attach (Decl); - Insert_Action (N, Decl); - - -- Now the actual return uses the copied value - - Rewrite (Exp, New_Occurrence_Of (Copy_Ent, Loc)); - Analyze_And_Resolve (Exp, Return_Type); - - -- Since we have made the copy, gigi does not have to, so - -- we set the By_Ref flag to prevent another copy being made. - - Set_By_Ref (N); - - -- Non-controlled cases - - else - Test_Copy_Required (Exp); - - -- If a local copy is required, then gigi will make the - -- copy, otherwise, we can return the result directly, - -- so set By_Ref to suppress the gigi copy. - - if not Local_Copy_Required then - Set_By_Ref (N); - end if; - end if; - end No_Secondary_Stack_Case; - -- Here if secondary stack is used else @@ -3457,12 +3575,12 @@ package body Exp_Ch5 is -- case either the result is already on the secondary stack, or is -- already being returned with the stack pointer depressed and no -- further processing is required except to set the By_Ref flag to - -- ensure that gigi does not attempt an extra unnecessary copy. - -- (actually not just unnecessary but harmfully wrong in the case - -- of a controlled type, where gigi does not know how to do a copy). - -- To make up for a gcc 2.8.1 deficiency (???), we perform - -- the copy for array types if the constrained status of the - -- target type is different from that of the expression. + -- ensure that gigi does not attempt an extra unnecessary copy + -- (actually not just unnecessary but harmfully wrong in the case of + -- a controlled type, where gigi does not know how to do a copy). To + -- make up for a gcc 2.8.1 deficiency (???), we perform the copy for + -- array types if the constrained status of the target type is + -- different from that of the expression. if Requires_Transient_Scope (T) and then @@ -3474,25 +3592,25 @@ package body Exp_Ch5 is then Set_By_Ref (N); - -- Remove side effects from the expression now so that - -- other part of the expander do not have to reanalyze - -- this node without this optimization + -- Remove side effects from the expression now so that other parts + -- of the expander do not have to reanalyze the node without this + -- optimization. Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp)); -- For controlled types, do the allocation on the secondary stack -- manually in order to call adjust at the right time: + -- type Anon1 is access Return_Type; -- for Anon1'Storage_pool use ss_pool; -- Anon2 : anon1 := new Return_Type'(expr); -- return Anon2.all; + -- We do the same for classwide types that are not potentially -- controlled (by the virtue of restriction No_Finalization) because -- gigi is not able to properly allocate class-wide types. - elsif Is_Class_Wide_Type (Utyp) - or else Controlled_Type (Utyp) - then + elsif CW_Or_Controlled_Type (Utyp) then declare Loc : constant Source_Ptr := Sloc (N); Temp : constant Entity_Id := @@ -3550,13 +3668,12 @@ package body Exp_Ch5 is end if; end if; - -- Implement the rules of 6.5(8-10), which require a tag check in - -- the case of a limited tagged return type, and tag reassignment - -- for nonlimited tagged results. These actions are needed when - -- the return type is a specific tagged type and the result - -- expression is a conversion or a formal parameter, because in - -- that case the tag of the expression might differ from the tag - -- of the specific result type. + -- Implement the rules of 6.5(8-10), which require a tag check in the + -- case of a limited tagged return type, and tag reassignment for + -- nonlimited tagged results. These actions are needed when the return + -- type is a specific tagged type and the result expression is a + -- conversion or a formal parameter, because in that case the tag of the + -- expression might differ from the tag of the specific result type. if Is_Tagged_Type (Utyp) and then not Is_Class_Wide_Type (Utyp) @@ -3565,8 +3682,8 @@ package body Exp_Ch5 is or else (Is_Entity_Name (Exp) and then Ekind (Entity (Exp)) in Formal_Kind)) then - -- When the return type is limited, perform a check that the - -- tag of the result is the same as the tag of the return type. + -- When the return type is limited, perform a check that the tag of + -- the result is the same as the tag of the return type. if Is_Limited_Type (Return_Type) then Insert_Action (Exp, @@ -3586,14 +3703,13 @@ package body Exp_Ch5 is Loc))), Reason => CE_Tag_Check_Failed)); - -- If the result type is a specific nonlimited tagged type, - -- then we have to ensure that the tag of the result is that - -- of the result type. This is handled by making a copy of the - -- expression in the case where it might have a different tag, - -- namely when the expression is a conversion or a formal - -- parameter. We create a new object of the result type and - -- initialize it from the expression, which will implicitly - -- force the tag to be set appropriately. + -- If the result type is a specific nonlimited tagged type, then we + -- have to ensure that the tag of the result is that of the result + -- type. This is handled by making a copy of the expression in the + -- case where it might have a different tag, namely when the + -- expression is a conversion or a formal parameter. We create a new + -- object of the result type and initialize it from the expression, + -- which will implicitly force the tag to be set appropriately. else Result_Id := @@ -3640,16 +3756,10 @@ package body Exp_Ch5 is Condition => Make_Op_Gt (Loc, Left_Opnd => - Make_Function_Call (Loc, - Name => - New_Reference_To - (RTE (RE_Get_Access_Level), Loc), - Parameter_Associations => - New_List (Make_Attribute_Reference (Loc, - Prefix => - Duplicate_Subexpr (Exp), - Attribute_Name => - Name_Tag))), + Build_Get_Access_Level (Loc, + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Exp), + Attribute_Name => Name_Tag)), Right_Opnd => Make_Integer_Literal (Loc, Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), @@ -3683,8 +3793,8 @@ package body Exp_Ch5 is if Kind = E_Procedure or else Kind = E_Generic_Procedure then return; - -- If it is a nested return within an extended one, replace it - -- with a return of the previously declared return object. + -- If it is a nested return within an extended one, replace it with a + -- return of the previously declared return object. elsif Kind = E_Return_Statement then Rewrite (N, @@ -3699,8 +3809,8 @@ package body Exp_Ch5 is pragma Assert (Is_Entry (Scope_Id)); - -- Look at the enclosing block to see whether the return is from - -- an accept statement or an entry body. + -- Look at the enclosing block to see whether the return is from an + -- accept statement or an entry body. for J in reverse 0 .. Scope_Stack.Last loop Scope_Id := Scope_Stack.Table (J).Entity; @@ -3740,8 +3850,8 @@ package body Exp_Ch5 is Rewrite (N, Goto_Stat); Analyze (N); - -- If it is a return from an entry body, put a Complete_Entry_Body - -- call in front of the return. + -- If it is a return from an entry body, put a Complete_Entry_Body call + -- in front of the return. elsif Is_Protected_Type (Scope_Id) then Call := @@ -3818,25 +3928,20 @@ package body Exp_Ch5 is -- The type of the expression (not necessarily the same as R_Type) begin - -- The DSP method is no longer in use - - pragma Assert (not Function_Returns_With_DSP (Scope_Id)); - -- We rewrite "return <expression>;" to be: -- return _anon_ : <return_subtype> := <expression> -- The expansion produced by Expand_N_Extended_Return_Statement will - -- contain simple return statements (for example, a block containing a + -- contain simple return statements (for example, a block containing -- simple return of the return object), which brings us back here with -- Comes_From_Extended_Return_Statement set. To avoid infinite -- recursion, we do not transform into an extended return if -- Comes_From_Extended_Return_Statement is True. -- The reason for this design is that for Ada 2005 limited returns, we - -- need to reify the return object, so we can build it "in place", - -- and we need a block statement to hang finalization and tasking stuff - -- off of. + -- need to reify the return object, so we can build it "in place", and + -- we need a block statement to hang finalization and tasking stuff. -- ??? In order to avoid disruption, we avoid translating to extended -- return except in the cases where we really need to (Ada 2005 @@ -3878,11 +3983,11 @@ package body Exp_Ch5 is -- of an extended return statement (either written by the user, or -- generated by the above code). - -- Always normalize C/Fortran boolean result. This is not always - -- necessary, but it seems a good idea to minimize the passing - -- around of non-normalized values, and in any case this handles - -- the processing of barrier functions for protected types, which - -- turn the condition into a return statement. + -- Always normalize C/Fortran boolean result. This is not always needed, + -- but it seems a good idea to minimize the passing around of non- + -- normalized values, and in any case this handles the processing of + -- barrier functions for protected types, which turn the condition into + -- a return statement. if Is_Boolean_Type (Exptyp) and then Nonzero_Is_True (Exptyp) @@ -3943,18 +4048,6 @@ package body Exp_Ch5 is end if; end; - -- Case of secondary stack not used - - elsif Function_Returns_With_DSP (Scope_Id) then - - -- The DSP method is no longer in use. We would like to ignore DSP - -- while implementing AI-318; hence the following assertion. Keep the - -- old code around in case DSP is revived someday. - - pragma Assert (False); - - No_Secondary_Stack_Case (N); - -- Here if secondary stack is used else @@ -3989,15 +4082,14 @@ package body Exp_Ch5 is and then (not Is_Array_Type (Exptyp) or else Is_Constrained (Exptyp) = Is_Constrained (R_Type) - or else Is_Class_Wide_Type (Utyp) - or else Controlled_Type (Exptyp)) + or else CW_Or_Controlled_Type (Utyp)) and then Nkind (Exp) = N_Function_Call then Set_By_Ref (N); - -- Remove side effects from the expression now so that - -- other part of the expander do not have to reanalyze - -- this node without this optimization + -- Remove side effects from the expression now so that other parts + -- of the expander do not have to reanalyze this node without this + -- optimization Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp)); @@ -4013,9 +4105,7 @@ package body Exp_Ch5 is -- controlled (by the virtue of restriction No_Finalization) because -- gigi is not able to properly allocate class-wide types. - elsif Is_Class_Wide_Type (Utyp) - or else Controlled_Type (Utyp) - then + elsif CW_Or_Controlled_Type (Utyp) then declare Loc : constant Source_Ptr := Sloc (N); Temp : constant Entity_Id := @@ -4073,13 +4163,12 @@ package body Exp_Ch5 is end if; end if; - -- Implement the rules of 6.5(8-10), which require a tag check in - -- the case of a limited tagged return type, and tag reassignment - -- for nonlimited tagged results. These actions are needed when - -- the return type is a specific tagged type and the result - -- expression is a conversion or a formal parameter, because in - -- that case the tag of the expression might differ from the tag - -- of the specific result type. + -- Implement the rules of 6.5(8-10), which require a tag check in the + -- case of a limited tagged return type, and tag reassignment for + -- nonlimited tagged results. These actions are needed when the return + -- type is a specific tagged type and the result expression is a + -- conversion or a formal parameter, because in that case the tag of the + -- expression might differ from the tag of the specific result type. if Is_Tagged_Type (Utyp) and then not Is_Class_Wide_Type (Utyp) @@ -4109,14 +4198,13 @@ package body Exp_Ch5 is Loc))), Reason => CE_Tag_Check_Failed)); - -- If the result type is a specific nonlimited tagged type, - -- then we have to ensure that the tag of the result is that - -- of the result type. This is handled by making a copy of the - -- expression in the case where it might have a different tag, - -- namely when the expression is a conversion or a formal - -- parameter. We create a new object of the result type and - -- initialize it from the expression, which will implicitly - -- force the tag to be set appropriately. + -- If the result type is a specific nonlimited tagged type, then we + -- have to ensure that the tag of the result is that of the result + -- type. This is handled by making a copy of the expression in the + -- case where it might have a different tag, namely when the + -- expression is a conversion or a formal parameter. We create a new + -- object of the result type and initialize it from the expression, + -- which will implicitly force the tag to be set appropriately. else declare @@ -4168,16 +4256,10 @@ package body Exp_Ch5 is Condition => Make_Op_Gt (Loc, Left_Opnd => - Make_Function_Call (Loc, - Name => - New_Reference_To - (RTE (RE_Get_Access_Level), Loc), - Parameter_Associations => - New_List (Make_Attribute_Reference (Loc, - Prefix => - Duplicate_Subexpr (Exp), - Attribute_Name => - Name_Tag))), + Build_Get_Access_Level (Loc, + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Exp), + Attribute_Name => Name_Tag)), Right_Opnd => Make_Integer_Literal (Loc, Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), @@ -4200,8 +4282,8 @@ package body Exp_Ch5 is Save_Tag : constant Boolean := Is_Tagged_Type (T) and then not No_Ctrl_Actions (N) and then not Java_VM; - -- Tags are not saved and restored when Java_VM because JVM tags - -- are represented implicitly in objects. + -- Tags are not saved and restored when Java_VM because JVM tags are + -- represented implicitly in objects. Res : List_Id; Tag_Tmp : Entity_Id; @@ -4271,8 +4353,8 @@ package body Exp_Ch5 is -- specific to each object of the type, not to the value being assigned. -- Thus they need to be left intact during the assignment. We achieve -- this by constructing a Storage_Array subtype, and by overlaying - -- objects of this type on the source and target of the assignment. - -- The assignment is then rewritten to assignments of slices of these + -- objects of this type on the source and target of the assignment. The + -- assignment is then rewritten to assignments of slices of these -- arrays, copying the user data, and leaving the pointers untouched. if Ctrl_Act then @@ -4306,10 +4388,9 @@ package body Exp_Ch5 is (Rec : Entity_Id; Lo : Node_Id; Hi : Node_Id) return Node_Id; - -- Build and return a slice of an array of type S overlaid - -- on object Rec, with bounds specified by Lo and Hi. If either - -- bound is empty, a default of S'First (respectively S'Last) - -- is used. + -- Build and return a slice of an array of type S overlaid on + -- object Rec, with bounds specified by Lo and Hi. If either bound + -- is empty, a default of S'First (respectively S'Last) is used. ----------------- -- Build_Slice -- @@ -4328,12 +4409,12 @@ package body Exp_Ch5 is Make_Attribute_Reference (Loc, Prefix => Rec, Attribute_Name => Name_Address)); - -- Access value designating an opaque storage array of - -- type S overlaid on record Rec. + -- Access value designating an opaque storage array of type S + -- overlaid on record Rec. begin - -- Compute slice bounds using S'First (1) and S'Last - -- as default values when not specified by the caller. + -- Compute slice bounds using S'First (1) and S'Last as default + -- values when not specified by the caller. if No (Lo) then Lo_Bound := Make_Integer_Literal (Loc, 1); @@ -4613,161 +4694,6 @@ package body Exp_Ch5 is return Empty_List; end Make_Tag_Ctrl_Assignment; - ----------------------------- - -- No_Secondary_Stack_Case -- - ----------------------------- - - procedure No_Secondary_Stack_Case (N : Node_Id) is - pragma Assert (False); -- DSP method no longer in use - - Loc : constant Source_Ptr := Sloc (N); - Exp : constant Node_Id := Expression (N); - T : constant Entity_Id := Etype (Exp); - Scope_Id : constant Entity_Id := - Return_Applies_To (Return_Statement_Entity (N)); - Return_Type : constant Entity_Id := Etype (Scope_Id); - Utyp : constant Entity_Id := Underlying_Type (Return_Type); - - -- Here what we need to do is to always return by reference, since - -- we will return with the stack pointer depressed. We may need to - -- do a copy to a local temporary before doing this return. - - Local_Copy_Required : Boolean := False; - -- Set to True if a local copy is required - - Copy_Ent : Entity_Id; - -- Used for the target entity if a copy is required - - Decl : Node_Id; - -- Declaration used to create copy if needed - - procedure Test_Copy_Required (Expr : Node_Id); - -- Determines if Expr represents a return value for which a - -- copy is required. More specifically, a copy is not required - -- if Expr represents an object or component of an object that - -- is either in the local subprogram frame, or is constant. - -- If a copy is required, then Local_Copy_Required is set True. - - ------------------------ - -- Test_Copy_Required -- - ------------------------ - - procedure Test_Copy_Required (Expr : Node_Id) is - Ent : Entity_Id; - - begin - -- If component, test prefix (object containing component) - - if Nkind (Expr) = N_Indexed_Component - or else - Nkind (Expr) = N_Selected_Component - then - Test_Copy_Required (Prefix (Expr)); - return; - - -- See if we have an entity name - - elsif Is_Entity_Name (Expr) then - Ent := Entity (Expr); - - -- Constant entity is always OK, no copy required - - if Ekind (Ent) = E_Constant then - return; - - -- No copy required for local variable - - elsif Ekind (Ent) = E_Variable - and then Scope (Ent) = Current_Subprogram - then - return; - end if; - end if; - - -- All other cases require a copy - - Local_Copy_Required := True; - end Test_Copy_Required; - - -- Start of processing for No_Secondary_Stack_Case - - begin - -- No copy needed if result is from a function call. - -- In this case the result is already being returned by - -- reference with the stack pointer depressed. - - -- To make up for a gcc 2.8.1 deficiency (???), we perform - -- the copy for array types if the constrained status of the - -- target type is different from that of the expression. - - if Requires_Transient_Scope (T) - and then - (not Is_Array_Type (T) - or else Is_Constrained (T) = Is_Constrained (Return_Type) - or else Controlled_Type (T)) - and then Nkind (Exp) = N_Function_Call - then - Set_By_Ref (N); - - -- We always need a local copy for a controlled type, since - -- we are required to finalize the local value before return. - -- The copy will automatically include the required finalize. - -- Moreover, gigi cannot make this copy, since we need special - -- processing to ensure proper behavior for finalization. - - -- Note: the reason we are returning with a depressed stack - -- pointer in the controlled case (even if the type involved - -- is constrained) is that we must make a local copy to deal - -- properly with the requirement that the local result be - -- finalized. - - elsif Controlled_Type (Utyp) then - Copy_Ent := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); - - -- Build declaration to do the copy, and insert it, setting - -- Assignment_OK, because we may be copying a limited type. - -- In addition we set the special flag to inhibit finalize - -- attachment if this is a controlled type (since this attach - -- must be done by the caller, otherwise if we attach it here - -- we will finalize the returned result prematurely). - - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Copy_Ent, - Object_Definition => New_Occurrence_Of (Return_Type, Loc), - Expression => Relocate_Node (Exp)); - - Set_Assignment_OK (Decl); - Set_Delay_Finalize_Attach (Decl); - Insert_Action (N, Decl); - - -- Now the actual return uses the copied value - - Rewrite (Exp, New_Occurrence_Of (Copy_Ent, Loc)); - Analyze_And_Resolve (Exp, Return_Type); - - -- Since we have made the copy, gigi does not have to, so - -- we set the By_Ref flag to prevent another copy being made. - - Set_By_Ref (N); - - -- Non-controlled cases - - else - Test_Copy_Required (Exp); - - -- If a local copy is required, then gigi will make the - -- copy, otherwise, we can return the result directly, - -- so set By_Ref to suppress the gigi copy. - - if not Local_Copy_Required then - Set_By_Ref (N); - end if; - end if; - end No_Secondary_Stack_Case; - ------------------------------------ -- Possible_Bit_Aligned_Component -- ------------------------------------ @@ -4821,9 +4747,9 @@ package body Exp_Ch5 is end if; end; - -- If we have neither a record nor array component, it means that - -- we have fallen off the top testing prefixes recursively, and - -- we now have a stand alone object, where we don't have a problem + -- If we have neither a record nor array component, it means that we + -- have fallen off the top testing prefixes recursively, and we now + -- have a stand alone object, where we don't have a problem. when others => return False; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 90684120fcc..e1d245b7108 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -30,6 +30,7 @@ with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Elists; use Elists; +with Exp_Atag; use Exp_Atag; with Exp_Ch2; use Exp_Ch2; with Exp_Ch3; use Exp_Ch3; with Exp_Ch7; use Exp_Ch7; @@ -62,7 +63,6 @@ with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; -with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; @@ -81,11 +81,53 @@ package body Exp_Ch6 is procedure Add_Access_Actual_To_Build_In_Place_Call (Function_Call : Node_Id; Function_Id : Entity_Id; - Return_Object : Node_Id); + Return_Object : Node_Id; + Is_Access : Boolean := False); -- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the -- object name given by Return_Object and add the attribute to the end of -- the actual parameter list associated with the build-in-place function - -- call denoted by Function_Call. + -- call denoted by Function_Call. However, if Is_Access is True, then + -- Return_Object is already an access expression, in which case it's passed + -- along directly to the build-in-place function. Finally, if Return_Object + -- is empty, then pass a null literal as the actual. + + procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Function_Call : Node_Id; + Function_Id : Entity_Id; + Alloc_Form : BIP_Allocation_Form := Unspecified; + Alloc_Form_Exp : Node_Id := Empty); + -- Ada 2005 (AI-318-02): Add an actual indicating the form of allocation, + -- if any, to be done by a build-in-place function. If Alloc_Form_Exp is + -- present, then use it, otherwise pass a literal corresponding to the + -- Alloc_Form parameter (which must not be Unspecified in that case). + + procedure Add_Extra_Actual_To_Call + (Subprogram_Call : Node_Id; + Extra_Formal : Entity_Id; + Extra_Actual : Node_Id); + -- Adds Extra_Actual as a named parameter association for the formal + -- Extra_Formal in Subprogram_Call. + + procedure Add_Final_List_Actual_To_Build_In_Place_Call + (Function_Call : Node_Id; + Function_Id : Entity_Id); + -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has + -- controlled parts, add an actual parameter that is a pointer to caller's + -- finalization list. + + procedure Add_Task_Actuals_To_Build_In_Place_Call + (Function_Call : Node_Id; + Function_Id : Entity_Id; + Master_Actual : Node_Id); + -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type + -- contains tasks, add two actual parameters: the master, and a pointer to + -- the caller's activation chain. Master_Actual is the actual parameter + -- expression to pass for the master. In most cases, this is the current + -- master (_master). The two exceptions are: If the function call is the + -- initialization expression for an allocator, we pass the master of the + -- access type. If the function call is the initialization expression for + -- a return object, we pass along the master passed in by the caller. The + -- activation chain to pass is always the local one. procedure Check_Overriding_Operation (Subp : Entity_Id); -- Subp is a dispatching operation. Check whether it may override an @@ -172,66 +214,296 @@ package body Exp_Ch6 is procedure Add_Access_Actual_To_Build_In_Place_Call (Function_Call : Node_Id; Function_Id : Entity_Id; - Return_Object : Node_Id) + Return_Object : Node_Id; + Is_Access : Boolean := False) is Loc : constant Source_Ptr := Sloc (Function_Call); Obj_Address : Node_Id; - Obj_Acc_Formal : Node_Id; - Param_Assoc : Node_Id; + Obj_Acc_Formal : Entity_Id; begin - -- Locate the implicit access parameter in the called function. Maybe - -- we should be testing for the name of the access parameter (or perhaps - -- better, each implicit formal for build-in-place could have an - -- identifying flag, or a Uint attribute to identify it). ??? + -- Locate the implicit access parameter in the called function - Obj_Acc_Formal := Extra_Formals (Function_Id); + Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access); - while Present (Obj_Acc_Formal) loop - exit when Ekind (Etype (Obj_Acc_Formal)) = E_Anonymous_Access_Type; - Next_Formal_With_Extras (Obj_Acc_Formal); - end loop; + -- If no return object is provided, then pass null + + if not Present (Return_Object) then + Obj_Address := Make_Null (Loc); - pragma Assert (Present (Obj_Acc_Formal)); + -- If Return_Object is already an expression of an access type, then use + -- it directly, since it must be an access value denoting the return + -- object, and couldn't possibly be the return object itself. + + elsif Is_Access then + Obj_Address := Return_Object; -- Apply Unrestricted_Access to caller's return object - Obj_Address := - Make_Attribute_Reference (Loc, - Prefix => Return_Object, - Attribute_Name => Name_Unrestricted_Access); + else + Obj_Address := + Make_Attribute_Reference (Loc, + Prefix => Return_Object, + Attribute_Name => Name_Unrestricted_Access); + end if; Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal)); -- Build the parameter association for the new actual and add it to the -- end of the function's actuals. + Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address); + end Add_Access_Actual_To_Build_In_Place_Call; + + -------------------------------------------------- + -- Add_Alloc_Form_Actual_To_Build_In_Place_Call -- + -------------------------------------------------- + + procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Function_Call : Node_Id; + Function_Id : Entity_Id; + Alloc_Form : BIP_Allocation_Form := Unspecified; + Alloc_Form_Exp : Node_Id := Empty) + is + Loc : constant Source_Ptr := Sloc (Function_Call); + Alloc_Form_Actual : Node_Id; + Alloc_Form_Formal : Node_Id; + + begin + -- Locate the implicit allocation form parameter in the called function. + -- Maybe it would be better for each implicit formal of a build-in-place + -- function to have a flag or a Uint attribute to identify it. ??? + + Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form); + + if Present (Alloc_Form_Exp) then + pragma Assert (Alloc_Form = Unspecified); + + Alloc_Form_Actual := Alloc_Form_Exp; + + else + pragma Assert (Alloc_Form /= Unspecified); + + Alloc_Form_Actual := + Make_Integer_Literal (Loc, + Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form))); + end if; + + Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal)); + + -- Build the parameter association for the new actual and add it to the + -- end of the function's actuals. + + Add_Extra_Actual_To_Call + (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual); + end Add_Alloc_Form_Actual_To_Build_In_Place_Call; + + ------------------------------ + -- Add_Extra_Actual_To_Call -- + ------------------------------ + + procedure Add_Extra_Actual_To_Call + (Subprogram_Call : Node_Id; + Extra_Formal : Entity_Id; + Extra_Actual : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Subprogram_Call); + Param_Assoc : Node_Id; + + begin Param_Assoc := Make_Parameter_Association (Loc, - Selector_Name => New_Occurrence_Of (Obj_Acc_Formal, Loc), - Explicit_Actual_Parameter => Obj_Address); + Selector_Name => New_Occurrence_Of (Extra_Formal, Loc), + Explicit_Actual_Parameter => Extra_Actual); - Set_Parent (Param_Assoc, Function_Call); - Set_Parent (Obj_Address, Param_Assoc); + Set_Parent (Param_Assoc, Subprogram_Call); + Set_Parent (Extra_Actual, Param_Assoc); - if Present (Parameter_Associations (Function_Call)) then - if Nkind (Last (Parameter_Associations (Function_Call))) = + if Present (Parameter_Associations (Subprogram_Call)) then + if Nkind (Last (Parameter_Associations (Subprogram_Call))) = N_Parameter_Association then - Set_Next_Named_Actual - (Last (Parameter_Associations (Function_Call)), - Obj_Address); + + -- Find last named actual, and append + + declare + L : Node_Id; + begin + L := First_Actual (Subprogram_Call); + while Present (L) loop + if No (Next_Actual (L)) then + Set_Next_Named_Actual (Parent (L), Extra_Actual); + exit; + end if; + Next_Actual (L); + end loop; + end; + else - Set_First_Named_Actual (Function_Call, Obj_Address); + Set_First_Named_Actual (Subprogram_Call, Extra_Actual); end if; - Append (Param_Assoc, To => Parameter_Associations (Function_Call)); + Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call)); else - Set_Parameter_Associations (Function_Call, New_List (Param_Assoc)); - Set_First_Named_Actual (Function_Call, Obj_Address); + Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc)); + Set_First_Named_Actual (Subprogram_Call, Extra_Actual); end if; - end Add_Access_Actual_To_Build_In_Place_Call; + end Add_Extra_Actual_To_Call; + + -------------------------------------------------- + -- Add_Final_List_Actual_To_Build_In_Place_Call -- + -------------------------------------------------- + + procedure Add_Final_List_Actual_To_Build_In_Place_Call + (Function_Call : Node_Id; + Function_Id : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Function_Call); + Final_List : Node_Id; + Final_List_Actual : Node_Id; + Final_List_Formal : Node_Id; + + begin + -- No such extra parameter is needed if there are no controlled parts + + if not (Is_Controlled (Etype (Function_Id)) + or else Has_Controlled_Component (Etype (Function_Id))) then + return; + end if; + + -- Locate implicit finalization list parameter in the called function + + Final_List_Formal := Build_In_Place_Formal (Function_Id, BIP_Final_List); + + -- Create the actual which is a pointer to the current finalization list + + Final_List := Find_Final_List (Current_Scope); + Final_List_Actual := + Make_Attribute_Reference (Loc, + Prefix => Final_List, + Attribute_Name => Name_Unrestricted_Access); + + Analyze_And_Resolve (Final_List_Actual, Etype (Final_List_Formal)); + + -- Build the parameter association for the new actual and add it to the + -- end of the function's actuals. + + Add_Extra_Actual_To_Call + (Function_Call, Final_List_Formal, Final_List_Actual); + end Add_Final_List_Actual_To_Build_In_Place_Call; + + --------------------------------------------- + -- Add_Task_Actuals_To_Build_In_Place_Call -- + --------------------------------------------- + + procedure Add_Task_Actuals_To_Build_In_Place_Call + (Function_Call : Node_Id; + Function_Id : Entity_Id; + Master_Actual : Node_Id) + -- Note: Master_Actual can be Empty, but only if there are no tasks + is + Loc : constant Source_Ptr := Sloc (Function_Call); + + begin + -- No such extra parameters are needed if there are no tasks + + if not Has_Task (Etype (Function_Id)) then + return; + end if; + + -- The master + + declare + Master_Formal : Node_Id; + begin + -- Locate implicit master parameter in the called function + + Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Master); + + Analyze_And_Resolve (Master_Actual, Etype (Master_Formal)); + + -- Build the parameter association for the new actual and add it to + -- the end of the function's actuals. + + Add_Extra_Actual_To_Call + (Function_Call, Master_Formal, Master_Actual); + end; + + -- The activation chain + + declare + Activation_Chain_Actual : Node_Id; + Activation_Chain_Formal : Node_Id; + begin + -- Locate implicit activation chain parameter in the called function + + Activation_Chain_Formal := Build_In_Place_Formal + (Function_Id, BIP_Activation_Chain); + + -- Create the actual which is a pointer to the current activation + -- chain + + Activation_Chain_Actual := + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uChain), + Attribute_Name => Name_Unrestricted_Access); + + Analyze_And_Resolve + (Activation_Chain_Actual, Etype (Activation_Chain_Formal)); + + -- Build the parameter association for the new actual and add it to + -- the end of the function's actuals. + + Add_Extra_Actual_To_Call + (Function_Call, Activation_Chain_Formal, Activation_Chain_Actual); + end; + end Add_Task_Actuals_To_Build_In_Place_Call; + + ----------------------- + -- BIP_Formal_Suffix -- + ----------------------- + + function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is + begin + case Kind is + when BIP_Alloc_Form => + return "BIPalloc"; + when BIP_Final_List => + return "BIPfinallist"; + when BIP_Master => + return "BIPmaster"; + when BIP_Activation_Chain => + return "BIPactivationchain"; + when BIP_Object_Access => + return "BIPaccess"; + end case; + end BIP_Formal_Suffix; + + --------------------------- + -- Build_In_Place_Formal -- + --------------------------- + + function Build_In_Place_Formal + (Func : Entity_Id; + Kind : BIP_Formal_Kind) return Entity_Id + is + Extra_Formal : Entity_Id := Extra_Formals (Func); + + begin + -- Maybe it would be better for each implicit formal of a build-in-place + -- function to have a flag or a Uint attribute to identify it. ??? + + loop + exit when + Chars (Extra_Formal) = + New_External_Name (Chars (Func), BIP_Formal_Suffix (Kind)); + Next_Formal_With_Extras (Extra_Formal); + end loop; + + pragma Assert (Present (Extra_Formal)); + return Extra_Formal; + end Build_In_Place_Formal; -------------------------------- -- Check_Overriding_Operation -- @@ -1088,10 +1360,10 @@ package body Exp_Ch6 is -- Ada 2005 (AI-318-02): If the actual parameter is a call to a -- build-in-place function, then a temporary return object needs -- to be created and access to it must be passed to the function. - -- Currently we limit such functions to those with constrained - -- inherently limited result subtypes, but eventually we plan to - -- expand the allowed forms of funtions that are treated as - -- build-in-place. + -- Currently we limit such functions to those with inherently + -- limited result subtypes, but eventually we plan to expand the + -- functions that are treated as build-in-place to include other + -- composite result types. if Ada_Version >= Ada_05 and then Is_Build_In_Place_Function_Call (Actual) @@ -2001,8 +2273,11 @@ package body Exp_Ch6 is Make_Implicit_If_Statement (N, Condition => Make_Op_Not (Loc, - Get_Remotely_Callable - (Duplicate_Subexpr_Move_Checks (Actual))), + Build_Get_Remotely_Callable (Loc, + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr_Move_Checks (Actual), + Selector_Name => + Make_Identifier (Loc, Name_uTag)))), Then_Statements => New_List ( Make_Raise_Program_Error (Loc, Reason => PE_Illegal_RACW_E_4_18)))); @@ -2161,7 +2436,7 @@ package body Exp_Ch6 is Set_Entity (Name (N), Parent_Subp); - if Is_Abstract (Parent_Subp) + if Is_Abstract_Subprogram (Parent_Subp) and then not In_Instance then Error_Msg_NE @@ -2270,8 +2545,8 @@ package body Exp_Ch6 is -- Handle case of access to protected subprogram type - if Ekind (Base_Type (Etype (Prefix (Name (N))))) = - E_Access_Protected_Subprogram_Type + if Is_Access_Protected_Subprogram_Type + (Base_Type (Etype (Prefix (Name (N))))) then -- If this is a call through an access to protected operation, -- the prefix has the form (object'address, operation'access). @@ -2717,6 +2992,10 @@ package body Exp_Ch6 is -- If the type returned by the function is unconstrained and the -- call can be inlined, special processing is required. + function Is_Null_Procedure return Boolean; + -- Predicate to recognize stubbed procedures and null procedures, for + -- which there is no need for the full inlining mechanism. + procedure Make_Exit_Label; -- Build declaration for exit label to be used in Return statements @@ -2743,6 +3022,50 @@ package body Exp_Ch6 is function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean; -- Determine whether a formal parameter is used only once in Orig_Bod + ----------------------- + -- Is_Null_Procedure -- + ----------------------- + + function Is_Null_Procedure return Boolean is + Decl : constant Node_Id := Unit_Declaration_Node (Subp); + + begin + if Ekind (Subp) /= E_Procedure then + return False; + + elsif Nkind (Orig_Bod) /= N_Subprogram_Body then + return False; + + -- Check if this is an ada 2005 null procedure + + elsif Nkind (Decl) = N_Subprogram_Declaration + and then Null_Present (Specification (Decl)) + then + return True; + + -- Check if the body contains only a null statement, followed by the + -- return statement added during expansion. + + else + declare + Stat : constant Node_Id := + First + (Statements (Handled_Statement_Sequence (Orig_Bod))); + + Stat2 : constant Node_Id := Next (Stat); + + begin + return + Nkind (Stat) = N_Null_Statement + and then + (No (Stat2) + or else + (Nkind (Stat2) = N_Return_Statement + and then No (Next (Stat2)))); + end; + end if; + end Is_Null_Procedure; + --------------------- -- Make_Exit_Label -- --------------------- @@ -3076,6 +3399,10 @@ package body Exp_Ch6 is (RTE (RE_Address), Relocate_Node (First_Actual (N)))); return; + + elsif Is_Null_Procedure then + Rewrite (N, Make_Null_Statement (Loc)); + return; end if; -- Check for an illegal attempt to inline a recursive procedure. If the @@ -3786,7 +4113,7 @@ package body Exp_Ch6 is Chars => Name_uE); Excep_Handlers := New_List ( - Make_Exception_Handler (Loc, + Make_Implicit_Exception_Handler (Loc, Choice_Parameter => Ent_EO, Exception_Choices => New_List ( Make_Others_Choice (Loc)), @@ -4003,9 +4330,7 @@ package body Exp_Ch6 is elsif Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (Spec_Id); - elsif Present (Utyp) - and then (Is_Class_Wide_Type (Utyp) or else Controlled_Type (Utyp)) - then + elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then Set_Returns_By_Ref (Spec_Id); end if; end; @@ -4403,16 +4728,20 @@ package body Exp_Ch6 is function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is begin -- For now we test whether E denotes a function or access-to-function - -- type whose result subtype is constrained and inherently limited. - -- Later this test will be revised to include unconstrained limited - -- types and composite nonlimited types in general. Functions with - -- a foreign convention or whose result type has a foreign convention + -- type whose result subtype is inherently limited. Later this test may + -- be revised to allow composite nonlimited types. Functions with a + -- foreign convention or whose result type has a foreign convention -- never qualify. if Ekind (E) = E_Function + or else Ekind (E) = E_Generic_Function or else (Ekind (E) = E_Subprogram_Type and then Etype (E) /= Standard_Void_Type) then + -- Note: If you have Convention (C) on an inherently limited type, + -- you're on your own. That is, the C code will have to be carefully + -- written to know about the Ada conventions. + if Has_Foreign_Convention (E) or else Has_Foreign_Convention (Etype (E)) then @@ -4420,7 +4749,8 @@ package body Exp_Ch6 is else return Is_Inherently_Limited_Type (Etype (E)) - and then Is_Constrained (Etype (E)); + and then Ada_Version >= Ada_05 + and then not Debug_Flag_Dot_L; end if; else @@ -4456,6 +4786,22 @@ package body Exp_Ch6 is end if; end Is_Build_In_Place_Function_Call; + --------------------------------------- + -- Is_Build_In_Place_Function_Return -- + --------------------------------------- + + function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean is + begin + if Nkind (N) = N_Return_Statement + or else Nkind (N) = N_Extended_Return_Statement + then + return Is_Build_In_Place_Function + (Return_Applies_To (Return_Statement_Entity (N))); + else + return False; + end if; + end Is_Build_In_Place_Function_Return; + ----------------------- -- Freeze_Subprogram -- ----------------------- @@ -4474,8 +4820,6 @@ package body Exp_Ch6 is procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is Iface_DT_Ptr : Elmt_Id; - Iface_Typ : Entity_Id; - Iface_Elmt : Elmt_Id; Tagged_Typ : Entity_Id; Thunk_Id : Entity_Id; @@ -4483,8 +4827,9 @@ package body Exp_Ch6 is Tagged_Typ := Find_Dispatching_Type (Prim); if No (Access_Disp_Table (Tagged_Typ)) - or else No (Abstract_Interfaces (Tagged_Typ)) + or else not Has_Abstract_Interfaces (Tagged_Typ) or else not RTE_Available (RE_Interface_Tag) + or else Restriction_Active (No_Dispatching_Calls) then return; end if; @@ -4497,36 +4842,29 @@ package body Exp_Ch6 is Iface_DT_Ptr := Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))); - Iface_Elmt := First_Elmt (Abstract_Interfaces (Tagged_Typ)); - while Present (Iface_DT_Ptr) and then Present (Iface_Elmt) loop - Iface_Typ := Node (Iface_Elmt); - - if not Is_Ancestor (Iface_Typ, Tagged_Typ) then - Thunk_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); - - Insert_Actions (N, New_List ( - Expand_Interface_Thunk - (N => Prim, - Thunk_Alias => Prim, - Thunk_Id => Thunk_Id), - - Make_DT_Access_Action (Iface_Typ, - Action => Set_Predefined_Prim_Op_Address, - Args => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (Node (Iface_DT_Ptr), Loc)), - - Make_Integer_Literal (Loc, DT_Position (Prim)), - - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Thunk_Id, Loc), - Attribute_Name => Name_Address))))); - end if; + + while Present (Iface_DT_Ptr) loop + Thunk_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + + Insert_Actions (N, New_List ( + Expand_Interface_Thunk + (N => Prim, + Thunk_Alias => Prim, + Thunk_Id => Thunk_Id), + + Build_Set_Predefined_Prim_Op_Address (Loc, + Tag_Node => + New_Reference_To (Node (Iface_DT_Ptr), Loc), + Position_Node => + Make_Integer_Literal (Loc, DT_Position (Prim)), + Address_Node => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Address)))); Next_Elmt (Iface_DT_Ptr); - Next_Elmt (Iface_Elmt); end loop; end Register_Predefined_DT_Entry; @@ -4537,8 +4875,7 @@ package body Exp_Ch6 is -- whose constructor is in the CPP side (and therefore we don't need -- to generate code to register them in the dispatch table). - if not Debug_Flag_QQ - and then Is_Imported (E) + if Is_Imported (E) and then Convention (E) = Convention_CPP then return; @@ -4551,7 +4888,7 @@ package body Exp_Ch6 is -- the dispatching mechanism is handled internally by the JVM. if Is_Dispatching_Operation (E) - and then not Is_Abstract (E) + and then not Is_Abstract_Subprogram (E) and then Present (DTC_Entity (E)) and then not Java_VM and then not Is_CPP_Class (Scope (DTC_Entity (E))) @@ -4560,43 +4897,48 @@ package body Exp_Ch6 is -- Ada 95 case: Register the subprogram in the primary dispatch table - if Ada_Version < Ada_05 then + -- Do not register the subprogram in the dispatch table if we are + -- compiling under No_Dispatching_Calls restriction. - -- Do not register the subprogram in the dispatch table if we - -- are compiling with the No_Dispatching_Calls restriction. + if not Restriction_Active (No_Dispatching_Calls) then - if not Restriction_Active (No_Dispatching_Calls) then + if Ada_Version < Ada_05 then Insert_After (N, Fill_DT_Entry (Sloc (N), Prim => E)); - end if; - -- Ada 2005 case: Register the subprogram in the secondary dispatch - -- tables associated with abstract interfaces. + -- Ada 2005 case: Register the subprogram in all the dispatch + -- tables associated with the type - else - declare - Typ : constant Entity_Id := Scope (DTC_Entity (E)); + else + declare + Typ : constant Entity_Id := Scope (DTC_Entity (E)); - begin - -- There is no dispatch table associated with abstract - -- interface types. Each type implementing interfaces will - -- fill the associated secondary DT entries. + begin + if not Is_Interface (Typ) + and then Is_Predefined_Dispatching_Operation (E) + then + Register_Predefined_DT_Entry (E); + Insert_After (N, Fill_DT_Entry (Sloc (N), Prim => E)); - if not Is_Interface (Typ) - or else Present (Alias (E)) - then - -- Ada 2005 (AI-251): Check if this entry corresponds with - -- a subprogram that covers an abstract interface type. + -- There is no dispatch table associated with abstract + -- interface types. Each type implementing interfaces will + -- fill the associated secondary DT entries. - if Present (Abstract_Interface_Alias (E)) then - Register_Interface_DT_Entry (N, E); + elsif not Is_Interface (Typ) + or else Present (Alias (E)) + then + -- Ada 2005 (AI-251): Check if this entry corresponds + -- with a subprogram that covers an abstract interface + -- type. - -- Common case: Primitive subprogram + if Present (Abstract_Interface_Alias (E)) then + Register_Interface_DT_Entry (N, E); - else - -- Generate thunks for all the predefined operations + -- Common case: Primitive subprogram + + else + -- Generate thunks for all the predefined operations - if not Restriction_Active (No_Dispatching_Calls) then if Is_Predefined_Dispatching_Operation (E) then Register_Predefined_DT_Entry (E); end if; @@ -4605,8 +4947,8 @@ package body Exp_Ch6 is Fill_DT_Entry (Sloc (N), Prim => E)); end if; end if; - end if; - end; + end; + end if; end if; end if; @@ -4622,9 +4964,7 @@ package body Exp_Ch6 is if Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (E); - elsif Present (Utyp) - and then (Is_Class_Wide_Type (Utyp) or else Controlled_Type (Utyp)) - then + elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then Set_Returns_By_Ref (E); end if; end; @@ -4665,43 +5005,79 @@ package body Exp_Ch6 is Result_Subt := Etype (Function_Id); - -- Replace the initialized allocator of form "new T'(Func (...))" with - -- an uninitialized allocator of form "new T", where T is the result - -- subtype of the called function. The call to the function is handled - -- separately further below. + -- When the result subtype is constrained, the return object must be + -- allocated on the caller side, and access to it is passed to the + -- function. - New_Allocator := - Make_Allocator (Loc, New_Reference_To (Result_Subt, Loc)); - Set_No_Initialization (New_Allocator); + if Is_Constrained (Result_Subt) then - Rewrite (Allocator, New_Allocator); + -- Replace the initialized allocator of form "new T'(Func (...))" + -- with an uninitialized allocator of form "new T", where T is the + -- result subtype of the called function. The call to the function + -- is handled separately further below. - -- Create a new access object and initialize it to the result of the new - -- uninitialized allocator. + New_Allocator := + Make_Allocator (Loc, New_Reference_To (Result_Subt, Loc)); - Return_Obj_Access := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - Set_Etype (Return_Obj_Access, Acc_Type); + Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator)); + Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator)); + Set_No_Initialization (New_Allocator); - Insert_Action (Allocator, - Make_Object_Declaration (Loc, - Defining_Identifier => Return_Obj_Access, - Object_Definition => New_Reference_To (Acc_Type, Loc), - Expression => Relocate_Node (Allocator))); + Rewrite (Allocator, New_Allocator); - -- Add an implicit actual to the function call that provides access to - -- the allocated object. An unchecked conversion to the (specific) - -- result subtype of the function is inserted to handle the case where - -- the access type of the allocator has a class-wide designated type. + -- Create a new access object and initialize it to the result of the + -- new uninitialized allocator. - Add_Access_Actual_To_Build_In_Place_Call - (Func_Call, - Function_Id, - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => New_Reference_To (Result_Subt, Loc), - Expression => - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Return_Obj_Access, Loc)))); + Return_Obj_Access := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Set_Etype (Return_Obj_Access, Acc_Type); + + Insert_Action (Allocator, + Make_Object_Declaration (Loc, + Defining_Identifier => Return_Obj_Access, + Object_Definition => New_Reference_To (Acc_Type, Loc), + Expression => Relocate_Node (Allocator))); + + -- Add an implicit actual to the function call that provides access + -- to the allocated object. An unchecked conversion to the (specific) + -- result subtype of the function is inserted to handle cases where + -- the access type of the allocator has a class-wide designated type. + + Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id); + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type)); + Add_Access_Actual_To_Build_In_Place_Call + (Func_Call, + Function_Id, + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Result_Subt, Loc), + Expression => + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Return_Obj_Access, Loc)))); + + -- When the result subtype is unconstrained, the function itself must + -- perform the allocation of the return object, so we pass parameters + -- indicating that. We don't yet handle the case where the allocation + -- must be done in a user-defined storage pool, which will require + -- passing another actual or two to provide allocation/deallocation + -- operations. ??? + + else + -- Pass an allocation parameter indicating that the function should + -- allocate its result on the heap. + + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Global_Heap); + + -- The caller does not provide the return object in this case, so we + -- have to pass null for the object access actual. + + Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id); + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type)); + Add_Access_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Return_Object => Empty); + end if; -- Finally, replace the allocator node with a reference to the result -- of the function call itself (which will effectively be an access @@ -4744,28 +5120,60 @@ package body Exp_Ch6 is Result_Subt := Etype (Function_Id); - -- Create a temporary object to hold the function result + -- When the result subtype is constrained, an object of the subtype is + -- declared and an access value designating it is passed as an actual. - Return_Obj_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); - Set_Etype (Return_Obj_Id, Result_Subt); + if Is_Constrained (Result_Subt) then - Return_Obj_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Return_Obj_Id, - Aliased_Present => True, - Object_Definition => New_Reference_To (Result_Subt, Loc)); + -- Create a temporary object to hold the function result + + Return_Obj_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('R')); + Set_Etype (Return_Obj_Id, Result_Subt); - Set_No_Initialization (Return_Obj_Decl); + Return_Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Return_Obj_Id, + Aliased_Present => True, + Object_Definition => New_Reference_To (Result_Subt, Loc)); - Insert_Action (Func_Call, Return_Obj_Decl); + Set_No_Initialization (Return_Obj_Decl); - -- Add an implicit actual to the function call that provides access to - -- the caller's return object. + Insert_Action (Func_Call, Return_Obj_Decl); - Add_Access_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, New_Reference_To (Return_Obj_Id, Loc)); + -- Add an implicit actual to the function call that provides access + -- to the caller's return object. + + Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id); + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); + Add_Access_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, New_Reference_To (Return_Obj_Id, Loc)); + + -- When the result subtype is unconstrained, the function must allocate + -- the return object in the secondary stack, so appropriate implicit + -- parameters are added to the call to indicate that. A transient + -- scope is established to ensure eventual cleanup of the result. + + else + -- Pass an allocation parameter indicating that the function should + -- allocate its result on the secondary stack. + + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); + + -- Pass a null value to the function since no return object is + -- available on the caller side. + + Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id); + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); + Add_Access_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Empty); + + Establish_Transient_Scope (Func_Call, Sec_Stack => True); + end if; end Make_Build_In_Place_Call_In_Anonymous_Context; --------------------------------------------------- @@ -4805,9 +5213,20 @@ package body Exp_Ch6 is Result_Subt := Etype (Function_Id); + -- When the result subtype is unconstrained, an additional actual must + -- be passed to indicate that the caller is providing the return object. + + if not Is_Constrained (Result_Subt) then + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); + end if; + -- Add an implicit actual to the function call that provides access to -- the caller's return object. + Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id); + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); Add_Access_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, @@ -4860,14 +5279,20 @@ package body Exp_Ch6 is (Object_Decl : Node_Id; Function_Call : Node_Id) is - Loc : Source_Ptr; - Func_Call : Node_Id := Function_Call; - Function_Id : Entity_Id; - Result_Subt : Entity_Id; - Ref_Type : Entity_Id; - Ptr_Typ_Decl : Node_Id; - Def_Id : Entity_Id; - New_Expr : Node_Id; + Loc : Source_Ptr; + Obj_Def_Id : constant Entity_Id := + Defining_Identifier (Object_Decl); + Func_Call : Node_Id := Function_Call; + Function_Id : Entity_Id; + Result_Subt : Entity_Id; + Caller_Object : Node_Id; + Call_Deref : Node_Id; + Ref_Type : Entity_Id; + Ptr_Typ_Decl : Node_Id; + Def_Id : Entity_Id; + New_Expr : Node_Id; + Enclosing_Func : Entity_Id; + Pass_Caller_Acc : Boolean := False; begin if Nkind (Func_Call) = N_Qualified_Expression then @@ -4888,18 +5313,96 @@ package body Exp_Ch6 is Result_Subt := Etype (Function_Id); - -- Add an implicit actual to the function call that provides access to - -- the declared object. An unchecked conversion to the (specific) result - -- type of the function is inserted to handle the case where the object - -- is declared with a class-wide type. + -- In the constrained case, add an implicit actual to the function call + -- that provides access to the declared object. An unchecked conversion + -- to the (specific) result type of the function is inserted to handle + -- the case where the object is declared with a class-wide type. + + if Is_Constrained (Result_Subt) then + Caller_Object := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Result_Subt, Loc), + Expression => New_Reference_To (Obj_Def_Id, Loc)); + -- If the function's result subtype is unconstrained and the object is + -- a return object of an enclosing build-in-place function, then the + -- implicit build-in-place parameters of the enclosing function must be + -- passed along to the called function. + + elsif Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement then + Pass_Caller_Acc := True; + + Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id); + + -- If the enclosing function has a constrained result type, then + -- caller allocation will be used. + + if Is_Constrained (Etype (Enclosing_Func)) then + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); + + -- Otherwise, when the enclosing function has an unconstrained result + -- type, the BIP_Alloc_Form formal of the enclosing function must be + -- passed long to the callee. + + else + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, + Function_Id, + Alloc_Form_Exp => + New_Reference_To + (Build_In_Place_Formal (Enclosing_Func, BIP_Alloc_Form), + Loc)); + end if; + + -- Retrieve the BIPacc formal from the enclosing function and convert + -- it to the access type of the callee's BIP_Object_Access formal. + + Caller_Object := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To + (Etype + (Build_In_Place_Formal (Function_Id, BIP_Object_Access)), + Loc), + Expression => + New_Reference_To + (Build_In_Place_Formal (Enclosing_Func, BIP_Object_Access), + Loc)); + + -- In other unconstrained cases, pass an indication to do the allocation + -- on the secondary stack and set Caller_Object to Empty so that a null + -- value will be passed for the caller's object address. A transient + -- scope is established to ensure eventual cleanup of the result. + + else + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, + Function_Id, + Alloc_Form => Secondary_Stack); + Caller_Object := Empty; + + Establish_Transient_Scope (Object_Decl, Sec_Stack => True); + end if; + + Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id); + if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement + and then Has_Task (Result_Subt) + then + Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id); + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, + Master_Actual => + New_Reference_To + (Build_In_Place_Formal (Enclosing_Func, BIP_Master), Loc)); + -- Here we're passing along the master that was passed in to this + -- function. + else + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); + end if; Add_Access_Actual_To_Build_In_Place_Call - (Func_Call, - Function_Id, - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => New_Reference_To (Result_Subt, Loc), - Expression => New_Reference_To - (Defining_Identifier (Object_Decl), Loc))); + (Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc); -- Create an access type designating the function's result subtype @@ -4915,7 +5418,18 @@ package body Exp_Ch6 is Subtype_Indication => New_Reference_To (Result_Subt, Loc))); - Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl); + -- The access type and its accompanying object must be inserted after + -- the object declaration in the constrained case, so that the function + -- call can be passed access to the object. In the unconstrained case, + -- the access type and object must be inserted before the object, since + -- the object declaration is rewritten to be a renaming of a dereference + -- of the access object. + + if Is_Constrained (Result_Subt) then + Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl); + else + Insert_Before_And_Analyze (Object_Decl, Ptr_Typ_Decl); + end if; -- Finally, create an access object initialized to a reference to the -- function call. @@ -4935,8 +5449,44 @@ package body Exp_Ch6 is Object_Definition => New_Reference_To (Ref_Type, Loc), Expression => New_Expr)); - Set_Expression (Object_Decl, Empty); - Set_No_Initialization (Object_Decl); + if Is_Constrained (Result_Subt) then + Set_Expression (Object_Decl, Empty); + Set_No_Initialization (Object_Decl); + + -- In case of an unconstrained result subtype, rewrite the object + -- declaration as an object renaming where the renamed object is a + -- dereference of <function_Call>'reference: + -- + -- Obj : Subt renames <function_call>'Ref.all; + + else + Call_Deref := + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Def_Id, Loc)); + + Rewrite (Object_Decl, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Access_Definition => Empty, + Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), + Name => Call_Deref)); + + Set_Renamed_Object (Defining_Identifier (Object_Decl), Call_Deref); + + Analyze (Object_Decl); + + -- Replace the internal identifier of the renaming declaration's + -- entity with identifier of the original object entity. We also have + -- to exchange the entities containing their defining identifiers to + -- ensure the correct replacement of the object declaration by the + -- object renaming declaration to avoid homograph conflicts (since + -- the object declaration's defining identifier was already entered + -- in current scope). + + Set_Chars (Defining_Identifier (Object_Decl), Chars (Obj_Def_Id)); + Exchange_Entities (Defining_Identifier (Object_Decl), Obj_Def_Id); + end if; -- If the object entity has a class-wide Etype, then we need to change -- it to the result subtype of the function call, because otherwise the @@ -4980,7 +5530,7 @@ package body Exp_Ch6 is pragma Assert (Is_Interface (Iface_Typ)); - if not Is_Ancestor (Iface_Typ, Tagged_Typ) then + if not Is_Parent (Iface_Typ, Tagged_Typ) then Thunk_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('T')); diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 219ce70abdb..436654c4c1b 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -40,21 +40,83 @@ package Exp_Ch6 is -- This procedure contains common processing for Expand_N_Function_Call, -- Expand_N_Procedure_Statement, and Expand_N_Entry_Call. + procedure Freeze_Subprogram (N : Node_Id); + -- generate the appropriate expansions related to Subprogram freeze + -- nodes (e. g. the filling of the corresponding Dispatch Table for + -- Primitive Operations) + + -- The following type defines the various forms of allocation used for the + -- results of build-in-place function calls. + + type BIP_Allocation_Form is + (Unspecified, + Caller_Allocation, + Secondary_Stack, + Global_Heap, + User_Storage_Pool); + + type BIP_Formal_Kind is + -- Ada 2005 (AI-318-02): This type defines the kinds of implicit extra + -- formals created for build-in-place functions. The order of the above + -- enumeration literals matches the order in which the formals are + -- declared. See Sem_Ch6.Create_Extra_Formals. + (BIP_Alloc_Form, + -- Present if result subtype is unconstrained. Indicates whether the + -- return object is allocated by the caller or callee, and if the + -- callee, whether to use the secondary stack or the heap. See + -- Create_Extra_Formals. + BIP_Final_List, + -- Present if result type has controlled parts. Pointer to caller's + -- finalization list. + BIP_Master, + -- Present if result type contains tasks. Master associated with + -- calling context. + BIP_Activation_Chain, + -- Present if result type contains tasks. Caller's activation chain. + BIP_Object_Access); + -- Present for all build-in-place functions. Address at which to place + -- the return object, or null if BIP_Alloc_Form indicates + -- allocated by callee. + -- ??? We also need to be able to pass in some way to access a + -- user-defined storage pool at some point. And perhaps a constrained + -- flag. + + function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String; + -- Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names + -- for build-in-place formal parameters of the given kind. + + function Build_In_Place_Formal + (Func : Entity_Id; + Kind : BIP_Formal_Kind) return Entity_Id; + -- Ada 2005 (AI-318-02): Locates and returns the entity for the implicit + -- build-in-place formal parameter of the given kind associated with the + -- function Func, and returns its Entity_Id. It is a bug if not found; the + -- caller should ensure this is called only when the extra formal exists. + function Is_Build_In_Place_Function (E : Entity_Id) return Boolean; - -- Ada 2005 (AI-318-02): Returns True if E denotes a function or an - -- access-to-function type whose result must be built in place; otherwise - -- returns False. Currently this is restricted to the subset of functions - -- whose result subtype is a constrained inherently limited type. + -- Ada 2005 (AI-318-02): Returns True if E denotes a function, generic + -- function, or access-to-function type whose result must be built in + -- place; otherwise returns False. For Ada 2005, this is currently + -- restricted to the set of functions whose result subtype is an inherently + -- limited type. In Ada 95, this must be False for inherently limited + -- result types (but currently returns False for all Ada 95 functions). + -- Eventually we plan to support build-in-place for nonlimited types. + -- Build-in-place is usually more efficient for large things, and less + -- efficient for small things. However, we never use build-in-place if the + -- convention is other than Ada, because that would disturb mixed-language + -- programs. Note that for the non-inherently-limited cases, we must make + -- the same decision for Ada 95 and 2005, so that mixed-dialect programs + -- will work. function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean; -- Ada 2005 (AI-318-02): Returns True if N denotes a call to a function -- that requires handling as a build-in-place call or is a qualified -- expression applied to such a call; otherwise returns False. - procedure Freeze_Subprogram (N : Node_Id); - -- generate the appropriate expansions related to Subprogram freeze - -- nodes (e. g. the filling of the corresponding Dispatch Table for - -- Primitive Operations) + function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean; + -- Ada 2005 (AI-318-02): Returns True if N is an N_Return_Statement or + -- N_Extended_Return_Statement and it applies to a build-in-place function + -- or generic function. procedure Make_Build_In_Place_Call_In_Allocator (Allocator : Node_Id; @@ -84,7 +146,7 @@ package Exp_Ch6 is Function_Call : Node_Id); -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that -- occurs as the right-hand side of an assignment statement by passing - -- access to the left-hand sid as an additional parameter of the function + -- access to the left-hand side as an additional parameter of the function -- call. Assign must denote a N_Assignment_Statement. Function_Call must -- denote either an N_Function_Call node for which Is_Build_In_Place_Call -- is True, or an N_Qualified_Expression node applied to such a function diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index 846b10d41a0..03408a77c07 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -26,10 +26,12 @@ with Atree; use Atree; with Einfo; use Einfo; +with Exp_Ch6; use Exp_Ch6; with Exp_Dbug; use Exp_Dbug; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Nlists; use Nlists; +with Opt; use Opt; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; with Sinfo; use Sinfo; @@ -268,6 +270,19 @@ package body Exp_Ch8 is end if; end if; + -- Ada 2005 (AI-318-02): If the renamed object is a call to a build-in- + -- place function, then a temporary return object needs to be created + -- and access to it must be passed to the function. Currently we limit + -- such functions to those with inherently limited result subtypes, but + -- eventually we plan to expand the functions that are treated as + -- build-in-place to include other composite result types. + + if Ada_Version >= Ada_05 + and then Is_Build_In_Place_Function_Call (Nam) + then + Make_Build_In_Place_Call_In_Anonymous_Context (Nam); + end if; + -- Create renaming entry for debug information Decl := Debug_Renaming_Declaration (N); diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 2ab53d4ecf7..9f8993b2961 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -54,8 +54,10 @@ with Uname; use Uname; package body Rtsfind is RTE_Available_Call : Boolean := False; - -- Set True during call to RTE from RTE_Available. Tells RTE to set - -- RTE_Is_Available to False rather than generating an error message. + -- Set True during call to RTE from RTE_Available (or from call to + -- RTE_Record_Component from RTE_Record_Component_Available). Tells + -- the called subprogram to set RTE_Is_Available to False rather than + -- generating an error message. RTE_Is_Available : Boolean; -- Set True by RTE_Available on entry. When RTE_Available_Call is set @@ -97,6 +99,11 @@ package body Rtsfind is -- first time, its ID is stored in this array, so that subsequent calls -- for the same entity can be satisfied immediately. + -- NOTE: In order to avoid conflicts between record components and subprgs + -- that have the same name (ie. subprogram External_Tag and component + -- External_Tag of package Ada.Tags) this table is not used with + -- Record_Components. + RE_Table : array (RE_Id) of Entity_Id; -------------------------- @@ -123,11 +130,20 @@ package body Rtsfind is -- Local Subprograms -- ----------------------- + function Check_CRT (E : RE_Id; Eid : Entity_Id) return Entity_Id; + -- Check entity Eid to ensure that configurable run-time restrictions + -- are met. May generate an error message and raise RE_Not_Available + -- if the entity E does not exist (i.e. Eid is Empty) + procedure Entity_Not_Defined (Id : RE_Id); -- Outputs error messages for an entity that is not defined in the -- run-time library (the form of the error message is tailored for -- no run time/configurable run time mode as required). + function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type; + -- Retrieves the Unit Name given a unit id represented by its + -- enumeration value in RTU_Id. + procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id); -- Internal procedure called if we can't sucessfully locate or -- process a run-time unit. The parameters give information about @@ -144,10 +160,6 @@ package body Rtsfind is -- a normal situation in configurable run-time mode (and the message in -- this case is suppressed unless we are operating in All_Errors_Mode). - function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type; - -- Retrieves the Unit Name given a unit id represented by its - -- enumeration value in RTU_Id. - procedure Load_RTU (U_Id : RTU_Id; Id : RE_Id := RE_Null; @@ -165,6 +177,10 @@ package body Rtsfind is -- Id is used only for error message detail, and if it is RE_Null, then -- the attempt to output the entity name is ignored. + function Make_Unit_Name (E : RE_Id; N : Node_Id) return Node_Id; + -- If the unit is a child unit, build fully qualified name for use in + -- With_Clause. + procedure Output_Entity_Name (Id : RE_Id; Msg : String); -- Output continuation error message giving qualified name of entity -- corresponding to Id, appending the string given by Msg. This call @@ -181,6 +197,37 @@ package body Rtsfind is -- used if you are sure that the message comes directly or indirectly from -- a call to the RTE function. + --------------- + -- Check_CRT -- + --------------- + + function Check_CRT (E : RE_Id; Eid : Entity_Id) return Entity_Id is + U_Id : constant RTU_Id := RE_Unit_Table (E); + + begin + if No (Eid) then + Entity_Not_Defined (E); + raise RE_Not_Available; + + -- Entity is available + + else + -- If in No_Run_Time mode and entity is not in one of the + -- specially permitted units, raise the exception. + + if No_Run_Time_Mode + and then not OK_No_Run_Time_Unit (U_Id) + then + Entity_Not_Defined (E); + raise RE_Not_Available; + end if; + + -- Otherwise entity is accessible + + return Eid; + end if; + end Check_CRT; + ------------------------ -- Entity_Not_Defined -- ------------------------ @@ -658,6 +705,36 @@ package body Rtsfind is end if; end Load_RTU; + -------------------- + -- Make_Unit_Name -- + -------------------- + + function Make_Unit_Name (E : RE_Id; N : Node_Id) return Node_Id is + U_Id : constant RTU_Id := RE_Unit_Table (E); + U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); + Nam : Node_Id; + Scop : Entity_Id; + + begin + Nam := New_Reference_To (U.Entity, Standard_Location); + Scop := Scope (U.Entity); + + if Nkind (N) = N_Defining_Program_Unit_Name then + while Scop /= Standard_Standard loop + Nam := + Make_Expanded_Name (Standard_Location, + Chars => Chars (U.Entity), + Prefix => New_Reference_To (Scop, Standard_Location), + Selector_Name => Nam); + Set_Entity (Nam, U.Entity); + + Scop := Scope (Scop); + end loop; + end if; + + return Nam; + end Make_Unit_Name; + ----------------------- -- Output_Entity_Name -- ------------------------ @@ -763,11 +840,6 @@ package body Rtsfind is Save_Front_End_Inlining : Boolean; - function Check_CRT (Eid : Entity_Id) return Entity_Id; - -- Check entity Eid to ensure that configurable run-time restrictions - -- are met. May generate an error message and raise RE_Not_Available - -- if the entity E does not exist (i.e. Eid is Empty) - procedure Check_RPC; -- Reject programs that make use of distribution features not supported -- on the current target. On such targets (VMS, Vxworks, others?) we @@ -778,39 +850,6 @@ package body Rtsfind is -- This function is used when entity E is in this compilation's main -- unit. It gets the value from the already compiled declaration. - function Make_Unit_Name (N : Node_Id) return Node_Id; - -- If the unit is a child unit, build fully qualified name for use - -- in With_Clause. - - --------------- - -- Check_CRT -- - --------------- - - function Check_CRT (Eid : Entity_Id) return Entity_Id is - begin - if No (Eid) then - Entity_Not_Defined (E); - raise RE_Not_Available; - - -- Entity is available - - else - -- If in No_Run_Time mode and entity is not in one of the - -- specially permitted units, raise the exception. - - if No_Run_Time_Mode - and then not OK_No_Run_Time_Unit (U_Id) - then - Entity_Not_Defined (E); - raise RE_Not_Available; - end if; - - -- Otherwise entity is accessible - - return Eid; - end if; - end Check_CRT; - --------------- -- Check_RPC -- --------------- @@ -847,9 +886,9 @@ package body Rtsfind is end if; end Check_RPC; - ------------------------ - -- Find_System_Entity -- - ------------------------ + ----------------------- + -- Find_Local_Entity -- + ----------------------- function Find_Local_Entity (E : RE_Id) return Entity_Id is RE_Str : String renames RE_Id'Image (E); @@ -871,34 +910,6 @@ package body Rtsfind is return Ent; end Find_Local_Entity; - -------------------- - -- Make_Unit_Name -- - -------------------- - - function Make_Unit_Name (N : Node_Id) return Node_Id is - Nam : Node_Id; - Scop : Entity_Id; - - begin - Nam := New_Reference_To (U.Entity, Standard_Location); - Scop := Scope (U.Entity); - - if Nkind (N) = N_Defining_Program_Unit_Name then - while Scop /= Standard_Standard loop - Nam := - Make_Expanded_Name (Standard_Location, - Chars => Chars (U.Entity), - Prefix => New_Reference_To (Scop, Standard_Location), - Selector_Name => Nam); - Set_Entity (Nam, U.Entity); - - Scop := Scope (Scop); - end loop; - end if; - - return Nam; - end Make_Unit_Name; - -- Start of processing for RTE begin @@ -917,7 +928,7 @@ package body Rtsfind is and then Analyzed (Main_Unit_Entity) and then not Is_Child_Unit (Main_Unit_Entity) then - return Check_CRT (Find_Local_Entity (E)); + return Check_CRT (E, Find_Local_Entity (E)); end if; Save_Front_End_Inlining := Front_End_Inlining; @@ -947,16 +958,16 @@ package body Rtsfind is -- First we search the package entity chain - Pkg_Ent := First_Entity (U.Entity); - while Present (Pkg_Ent) loop - if Ename = Chars (Pkg_Ent) then - RE_Table (E) := Pkg_Ent; - Check_RPC; - goto Found; - end if; + Pkg_Ent := First_Entity (U.Entity); + while Present (Pkg_Ent) loop + if Ename = Chars (Pkg_Ent) then + RE_Table (E) := Pkg_Ent; + Check_RPC; + goto Found; + end if; - Next_Entity (Pkg_Ent); - end loop; + Next_Entity (Pkg_Ent); + end loop; -- If we did not find the entity in the package entity chain, -- then check if the package entity itself matches. Note that @@ -979,7 +990,7 @@ package body Rtsfind is -- a WITH if the current unit is part of the extended main code -- unit, and if we have not already added the with. The WITH is -- added to the appropriate unit (the current one). We do not need - -- to generate a WITH for an ???? + -- to generate a WITH for a call issued from RTE_Available. <<Found>> if (not U.Withed) @@ -999,7 +1010,7 @@ package body Rtsfind is Make_With_Clause (Standard_Location, Name => Make_Unit_Name - (Defining_Unit_Name (Specification (Lib_Unit)))); + (E, Defining_Unit_Name (Specification (Lib_Unit)))); Set_Library_Unit (Withn, Cunit (U.Unum)); Set_Corresponding_Spec (Withn, U.Entity); Set_First_Name (Withn, True); @@ -1012,7 +1023,7 @@ package body Rtsfind is end if; Front_End_Inlining := Save_Front_End_Inlining; - return Check_CRT (RE_Table (E)); + return Check_CRT (E, RE_Table (E)); end RTE; ------------------- @@ -1047,6 +1058,140 @@ package body Rtsfind is return False; end RTE_Available; + -------------------------- + -- RTE_Record_Component -- + -------------------------- + + function RTE_Record_Component (E : RE_Id) return Entity_Id is + U_Id : constant RTU_Id := RE_Unit_Table (E); + U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); + E1 : Entity_Id; + Ename : Name_Id; + Lib_Unit : Node_Id; + Pkg_Ent : Entity_Id; + + -- The following flag is used to disable front-end inlining when + -- RTE_Record_Component is invoked. This prevents the analysis of other + -- runtime bodies when a particular spec is loaded through Rtsfind. This + -- is both efficient, and it prevents spurious visibility conflicts + -- between use-visible user entities, and entities in run-time packages. + + -- In configurable run-time mode, subprograms marked Inlined_Always must + -- be inlined, so in the case we retain the Front_End_Inlining mode. + + Save_Front_End_Inlining : Boolean; + + begin + -- Note: Contrary to subprogram RTE, there is no need to do any special + -- management with package system.ads because it has no record type + -- declarations. + + Save_Front_End_Inlining := Front_End_Inlining; + Front_End_Inlining := Configurable_Run_Time_Mode; + + -- Load unit if unit not previously loaded + + if not Present (U.Entity) then + Load_RTU (U_Id, Id => E); + end if; + + Lib_Unit := Unit (Cunit (U.Unum)); + + pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration); + Ename := RE_Chars (E); + + -- Search the entity in the components of record type declarations + -- found in the package entity chain. + + Pkg_Ent := First_Entity (U.Entity); + Search : while Present (Pkg_Ent) loop + if Is_Record_Type (Pkg_Ent) then + E1 := First_Entity (Pkg_Ent); + while Present (E1) loop + if Ename = Chars (E1) then + exit Search; + end if; + + Next_Entity (E1); + end loop; + end if; + + Next_Entity (Pkg_Ent); + end loop Search; + + -- If we didn't find the entity we want, something is wrong. The + -- appropriate action will be taken by Check_CRT when we exit. + + -- Cenerate a with-clause if the current unit is part of the extended + -- main code unit, and if we have not already added the with. The clause + -- is added to the appropriate unit (the current one). We do not need to + -- generate it for a call issued from RTE_Component_Available. + + if (not U.Withed) + and then + In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit)) + and then not RTE_Available_Call + then + U.Withed := True; + + declare + Withn : Node_Id; + Lib_Unit : Node_Id; + + begin + Lib_Unit := Unit (Cunit (U.Unum)); + Withn := + Make_With_Clause (Standard_Location, + Name => + Make_Unit_Name + (E, Defining_Unit_Name (Specification (Lib_Unit)))); + Set_Library_Unit (Withn, Cunit (U.Unum)); + Set_Corresponding_Spec (Withn, U.Entity); + Set_First_Name (Withn, True); + Set_Implicit_With (Withn, True); + + Mark_Rewrite_Insertion (Withn); + Append (Withn, Context_Items (Cunit (Current_Sem_Unit))); + Check_Restriction_No_Dependence (Name (Withn), Current_Error_Node); + end; + end if; + + Front_End_Inlining := Save_Front_End_Inlining; + return Check_CRT (E, E1); + end RTE_Record_Component; + + ------------------------------------ + -- RTE_Record_Component_Available -- + ------------------------------------ + + function RTE_Record_Component_Available (E : RE_Id) return Boolean is + Dummy : Entity_Id; + pragma Warnings (Off, Dummy); + + Result : Boolean; + + Save_RTE_Available_Call : constant Boolean := RTE_Available_Call; + Save_RTE_Is_Available : constant Boolean := RTE_Is_Available; + -- These are saved recursively because the call to load a unit + -- caused by an upper level call may perform a recursive call + -- to this routine during analysis of the corresponding unit. + + begin + RTE_Available_Call := True; + RTE_Is_Available := True; + Dummy := RTE_Record_Component (E); + Result := RTE_Is_Available; + RTE_Available_Call := Save_RTE_Available_Call; + RTE_Is_Available := Save_RTE_Is_Available; + return Result; + + exception + when RE_Not_Available => + RTE_Available_Call := Save_RTE_Available_Call; + RTE_Is_Available := Save_RTE_Is_Available; + return False; + end RTE_Record_Component_Available; + ------------------- -- RTE_Error_Msg -- ------------------- @@ -1069,6 +1214,15 @@ package body Rtsfind is end RTE_Error_Msg; ---------------- + -- RTU_Entity -- + ---------------- + + function RTU_Entity (U : RTU_Id) return Entity_Id is + begin + return RT_Unit_Table (U).Entity; + end RTU_Entity; + + ---------------- -- RTU_Loaded -- ---------------- diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb index 518c9984900..4047436e89b 100644 --- a/gcc/ada/s-finimp.adb +++ b/gcc/ada/s-finimp.adb @@ -168,7 +168,7 @@ package body System.Finalization_Implementation is Nb_Link : Short_Short_Integer) is begin - -- Simple case: attachement to a one way list + -- Simple case: attachment to a one way list if Nb_Link = 1 then Obj.Next := L; @@ -176,7 +176,7 @@ package body System.Finalization_Implementation is -- Dynamically allocated objects: they are attached to a doubly linked -- list, so that an element can be finalized at any moment by means of - -- an unchecked deallocation. Attachement is protected against + -- an unchecked deallocation. Attachment is protected against -- multi-threaded access. elsif Nb_Link = 2 then @@ -203,7 +203,7 @@ package body System.Finalization_Implementation is raise; end Locked_Processing; - -- Attachement of arrays to the final list (used only for objects + -- Attachment of arrays to the final list (used only for objects -- returned by function). Obj, in this case is the last element, -- but all other elements are already threaded after it. We just -- attach the rest of the final list at the end of the array list. @@ -231,32 +231,6 @@ package body System.Finalization_Implementation is end Attach_To_Final_List; --------------------- - -- Deep_Tag_Adjust -- - --------------------- - - procedure Deep_Tag_Adjust - (L : in out SFR.Finalizable_Ptr; - A : System.Address; - B : Short_Short_Integer) - is - V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A); - Controller : constant RC_Ptr := Get_Deep_Controller (A); - - begin - if Controller /= null then - Adjust (Controller.all); - Attach_To_Final_List (L, Controller.all, B); - end if; - - -- Is controlled - - if V.all in Finalizable then - Adjust (V.all); - Attach_To_Final_List (L, Finalizable (V.all), 1); - end if; - end Deep_Tag_Adjust; - - --------------------- -- Deep_Tag_Attach -- ---------------------- @@ -280,74 +254,6 @@ package body System.Finalization_Implementation is end if; end Deep_Tag_Attach; - ----------------------- - -- Deep_Tag_Finalize -- - ----------------------- - - procedure Deep_Tag_Finalize - (L : in out SFR.Finalizable_Ptr; - A : System.Address; - B : Boolean) - is - pragma Warnings (Off, L); - - V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A); - Controller : constant RC_Ptr := Get_Deep_Controller (A); - - begin - if Controller /= null then - if B then - Finalize_One (Controller.all); - else - Finalize (Controller.all); - end if; - end if; - - -- Is controlled - - if V.all in Finalizable then - if B then - Finalize_One (V.all); - else - Finalize (V.all); - end if; - end if; - end Deep_Tag_Finalize; - - ------------------------- - -- Deep_Tag_Initialize -- - ------------------------- - - procedure Deep_Tag_Initialize - (L : in out SFR.Finalizable_Ptr; - A : System.Address; - B : Short_Short_Integer) - is - V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A); - Controller : constant RC_Ptr := Get_Deep_Controller (A); - - begin - -- This procedure should not be called if the object has no - -- controlled components - - if Controller = null then - raise Program_Error; - - -- Has controlled components - - else - Initialize (Controller.all); - Attach_To_Final_List (L, Controller.all, B); - end if; - - -- Is controlled - - if V.all in Finalizable then - Initialize (V.all); - Attach_To_Final_List (Controller.F, Finalizable (Controller.all), 1); - end if; - end Deep_Tag_Initialize; - ----------------------------- -- Detach_From_Final_List -- ----------------------------- @@ -441,7 +347,7 @@ package body System.Finalization_Implementation is -- programs using controlled types heavily. if System.Restrictions.Abort_Allowed then - X := To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id; + X := To_Ptr (SSL.Get_Current_Excep.all).Id; end if; while P /= null loop @@ -554,6 +460,34 @@ package body System.Finalization_Implementation is Object.My_Address := Object'Address; end Initialize; + --------------------- + -- Move_Final_List -- + --------------------- + + procedure Move_Final_List + (From : in out SFR.Finalizable_Ptr; + To : Finalizable_Ptr_Ptr) + is + begin + -- This is currently called at the end of the return statement, and the + -- caller does NOT defer aborts. We need to defer aborts to prevent + -- mangling the finalization lists. + + SSL.Abort_Defer.all; + + -- Put the return statement's finalization list onto the caller's one, + -- thus transferring responsibility for finalization of the return + -- object to the caller. + + Attach_To_Final_List (To.all, From.all, Nb_Link => 3); + + -- Empty the return statement's finalization list, so that when the + -- cleanup code executes, there will be nothing to finalize. + From := null; + + SSL.Abort_Undefer.all; + end Move_Final_List; + ------------------------- -- Raise_From_Finalize -- ------------------------- diff --git a/gcc/ada/s-finimp.ads b/gcc/ada/s-finimp.ads index 8366e956c99..f5bb1d27d32 100644 --- a/gcc/ada/s-finimp.ads +++ b/gcc/ada/s-finimp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -51,15 +51,15 @@ package System.Finalization_Implementation is Collection_Finalization_Started : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (SSE.To_Address (1)); - -- This is used to implement the rule in RM-4.8(10.2/2) that requires an + -- This is used to implement the rule in RM 4.8(10.2/2) that requires an -- allocator to raise Program_Error if the collection finalization has -- already started. See also Ada.Finalization.List_Controller. Finalize on -- List_Controller first sets the list to Collection_Finalization_Started, -- to indicate that finalization has started. An allocator will call -- Attach_To_Final_List, which checks for the special value and raises - -- Program_Error if appropriate. The value of - -- Collection_Finalization_Started must be different from 'Access of any - -- finalizable object, and different from null. See AI-280. + -- Program_Error if appropriate. The Collection_Finalization_Started value + -- must be different from 'Access of any finalizable object, and different + -- from null. See AI-280. Global_Final_List : SFR.Finalizable_Ptr; -- This list stores the controlled objects defined in library-level @@ -72,60 +72,52 @@ package System.Finalization_Implementation is (L : in out SFR.Finalizable_Ptr; Obj : in out SFR.Finalizable; Nb_Link : Short_Short_Integer); - -- Attach finalizable object Obj to the linked list L. Nb_Link controls - -- the number of link of the linked_list, and can be either 0 for no - -- attachement, 1 for simple linked lists or 2 for doubly linked lists - -- or even 3 for a simple attachement of a whole array of elements. - -- Attachement to a simply linked list is not protected against - -- concurrent access and should only be used in contexts where it - -- doesn't matter, such as for objects allocated on the stack. In the - -- case of an attachment on a doubly linked list, L must not be null - -- and Obj will be inserted AFTER the first element and the attachment - -- is protected against concurrent call. Typically used to attach to - -- a dynamically allocated object to a List_Controller (whose first - -- element is always a dummy element) + -- Attach finalizable object Obj to the linked list L. Nb_Link controls the + -- number of link of the linked_list, and is one of: 0 for no attachment, 1 + -- for simple linked lists or 2 for doubly linked lists or even 3 for a + -- simple attachment of a whole array of elements. Attachment to a simply + -- linked list is not protected against concurrent access and should only + -- be used in contexts where it doesn't matter, such as for objects + -- allocated on the stack. In the case of an attachment on a doubly linked + -- list, L must not be null and Obj will be inserted AFTER the first + -- element and the attachment is protected against concurrent call. + -- Typically used to attach to a dynamically allocated object to a + -- List_Controller (whose first element is always a dummy element) + + type Finalizable_Ptr_Ptr is access all SFR.Finalizable_Ptr; + -- A pointer to a finalization list. This is used as the type of the extra + -- implicit formal which are passed to build-in-place functions that return + -- controlled types (see Sem_Ch6). That extra formal is then passed on to + -- Move_Final_List (below). + + procedure Move_Final_List + (From : in out SFR.Finalizable_Ptr; + To : Finalizable_Ptr_Ptr); + -- Move all objects on From list to To list. This is used to implement + -- build-in-place function returns. The return object is initially placed + -- on a finalization list local to the return statement, in case the + -- return statement is left prematurely (due to raising an exception, + -- being aborted, or a goto or exit statement). Once the return statement + -- has completed successfully, Move_Final_List is called to move the + -- return object to the caller's finalization list. procedure Finalize_List (L : SFR.Finalizable_Ptr); -- Call Finalize on each element of the list L; procedure Finalize_One (Obj : in out SFR.Finalizable); - -- Call Finalize on Obj and remove its final list. + -- Call Finalize on Obj and remove its final list --------------------- -- Deep Procedures -- --------------------- - procedure Deep_Tag_Initialize - (L : in out SFR.Finalizable_Ptr; - A : System.Address; - B : Short_Short_Integer); - -- Generic initialize for tagged objects with controlled components. - -- A is the address of the object, L the finalization list when it needs - -- to be attached and B the attachement level (see Attach_To_Final_List). - - procedure Deep_Tag_Adjust - (L : in out SFR.Finalizable_Ptr; - A : System.Address; - B : Short_Short_Integer); - -- Generic adjust for tagged objects with controlled components. - -- A is the address of the object, L the finalization list when it needs - -- to be attached and B the attachement level (see Attach_To_Final_List). - - procedure Deep_Tag_Finalize - (L : in out SFR.Finalizable_Ptr; - A : System.Address; - B : Boolean); - -- Generic finalize for tagged objects with controlled components. - -- A is the address of the object, L the finalization list when it needs - -- to be attached and B the attachement level (see Attach_To_Final_List). - procedure Deep_Tag_Attach (L : in out SFR.Finalizable_Ptr; A : System.Address; B : Short_Short_Integer); - -- Generic attachement for tagged objects with controlled components. + -- Generic attachment for tagged objects with controlled components. -- A is the address of the object, L the finalization list when it needs - -- to be attached and B the attachement level (see Attach_To_Final_List). + -- to be attached and B the attachment level (see Attach_To_Final_List). ----------------------------- -- Record Controller Types -- @@ -141,11 +133,11 @@ package System.Finalization_Implementation is end record; procedure Initialize (Object : in out Limited_Record_Controller); - -- Does nothing. + -- Does nothing currently. procedure Finalize (Object : in out Limited_Record_Controller); - -- Finalize the controlled components of the enclosing record by - -- following the list starting at Object.F. + -- Finalize the controlled components of the enclosing record by following + -- the list starting at Object.F. type Record_Controller is new Limited_Record_Controller with record @@ -156,13 +148,13 @@ package System.Finalization_Implementation is -- Initialize the field My_Address to the Object'Address procedure Adjust (Object : in out Record_Controller); - -- Adjust the components and their finalization pointers by subtracting - -- by the offset of the target and the source addresses of the assignment. + -- Adjust the components and their finalization pointers by subtracting by + -- the offset of the target and the source addresses of the assignment. -- Inherit Finalize from Limited_Record_Controller procedure Detach_From_Final_List (Obj : in out SFR.Finalizable); - -- Remove the specified object from its Final list, which must be a - -- doubly linked list. + -- Remove the specified object from its Final list, which must be a doubly + -- linked list. end System.Finalization_Implementation; diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index a9b1812b7dc..ae6908dac49 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -364,10 +364,12 @@ package System.Tasking is ------------------------------------ type Activation_Chain is limited private; - -- Comment required ??? + -- Linked list of to-be-activated tasks, linked through + -- Activation_Link. The order of tasks on the list is irrelevant, because + -- the priority rules will ensure that they actually start activating in + -- priority order. type Activation_Chain_Access is access all Activation_Chain; - -- Comment required ??? type Task_Procedure_Access is access procedure (Arg : System.Address); @@ -651,11 +653,14 @@ package System.Tasking is -- Normally, a task starts out with internal master nesting level one -- larger than external master nesting level. It is incremented to one by -- Enter_Master, which is called in the task body only if the compiler - -- thinks the task may have dependent tasks. It is set to for the + -- thinks the task may have dependent tasks. It is set to 1 for the -- environment task, the level 2 is reserved for server tasks of the -- run-time system (the so called "independent tasks"), and the level 3 is - -- for the library level tasks. + -- for the library level tasks. Foreign threads which are detected by + -- the run-time have a level of 0, allowing these tasks to be easily + -- distinguished if needed. + Foreign_Task_Level : constant Master_Level := 0; Environment_Task_Level : constant Master_Level := 1; Independent_Task_Level : constant Master_Level := 2; Library_Task_Level : constant Master_Level := 3; @@ -1062,14 +1067,14 @@ package System.Tasking is private Null_Task : constant Task_Id := null; - type Activation_Chain is record + type Activation_Chain is limited record T_ID : Task_Id; end record; - pragma Volatile (Activation_Chain); - -- Activation_chain is an in-out parameter of initialization procedures - -- and it must be passed by reference because the init proc may terminate + -- Activation_Chain is an in-out parameter of initialization procedures and + -- it must be passed by reference because the init proc may terminate -- abnormally after creating task components, and these must be properly - -- registered for removal (Expunge_Unactivated_Tasks). + -- registered for removal (Expunge_Unactivated_Tasks). The "limited" forces + -- Activation_Chain to be a by-reference type; see RM-6.2(4). end System.Tasking; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index e0a6c946348..d6fe66c1f4e 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -149,6 +149,9 @@ package body System.Tasking.Stages is -- trigger an automatic stack alignment suitable for GCC's assumptions if -- need be. + -- "Vulnerable_..." in the procedure names below means they must be called + -- with abort deferred. + procedure Vulnerable_Complete_Task (Self_ID : Task_Id); -- Complete the calling task. This procedure must be called with -- abort deferred. It should only be called by Complete_Task and @@ -520,9 +523,11 @@ package body System.Tasking.Stages is begin -- If Master is greater than the current master, it means that Master -- has already awaited its dependent tasks. This raises Program_Error, - -- by 4.8(10.3/2). See AI-280. + -- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads. - if Master > Self_ID.Master_Within then + if Self_ID.Master_of_Task /= Foreign_Task_Level + and then Master > Self_ID.Master_Within + then raise Program_Error with "create task after awaiting termination"; end if; @@ -877,6 +882,53 @@ package body System.Tasking.Stages is end if; end Free_Task; + --------------------------- + -- Move_Activation_Chain -- + --------------------------- + + procedure Move_Activation_Chain + (From, To : Activation_Chain_Access; + New_Master : Master_ID) + is + Self_ID : constant Task_Id := STPO.Self; + C : Task_Id; + + begin + pragma Debug + (Debug.Trace (Self_ID, "Move_Activation_Chain", 'C')); + + -- Nothing to do if From is empty, and we can check that without + -- deferring aborts. + + C := From.all.T_ID; + + if C = null then + return; + end if; + + Initialization.Defer_Abort (Self_ID); + + -- Loop through the From chain, changing their Master_of_Task + -- fields, and to find the end of the chain. + + loop + C.Master_of_Task := New_Master; + exit when C.Common.Activation_Link = null; + C := C.Common.Activation_Link; + end loop; + + -- Hook From in at the start of To + + C.Common.Activation_Link := To.all.T_ID; + To.all.T_ID := From.all.T_ID; + + -- Set From to empty + + From.all.T_ID := null; + + Initialization.Undefer_Abort (Self_ID); + end Move_Activation_Chain; + ------------------ -- Task_Wrapper -- ------------------ @@ -1407,7 +1459,7 @@ package body System.Tasking.Stages is C := All_Tasks_List; while C /= null loop - if C.Common.Activator = Self_ID then + if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then return False; end if; @@ -1449,13 +1501,24 @@ package body System.Tasking.Stages is -- zero for new tasks, and the task should not exit the -- sleep-loops that use this count until the count reaches zero. + -- While we're counting, if we run across any unactivated tasks that + -- belong to this master, we summarily terminate them as required by + -- RM-9.2(6). + Lock_RTS; Write_Lock (Self_ID); C := All_Tasks_List; while C /= null loop - if C.Common.Activator = Self_ID then + + -- Terminate unactivated (never-to-be activated) tasks + + if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then pragma Assert (C.Common.State = Unactivated); + -- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task + -- = CM. The only case where C is pending activation by this + -- task, but the master of C is not CM is in Ada 2005, when C is + -- part of a return object of a build-in-place function. Write_Lock (C); C.Common.Activator := null; @@ -1465,6 +1528,8 @@ package body System.Tasking.Stages is Unlock (C); end if; + -- Count it if dependent on this master + if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then Write_Lock (C); @@ -1733,9 +1798,9 @@ package body System.Tasking.Stages is -- Complete the calling task - -- This procedure must be called with abort deferred. (That's why the - -- name has "Vulnerable" in it.) It should only be called by Complete_Task - -- and Finalize_Global_Tasks (for the environment task). + -- This procedure must be called with abort deferred. It should only be + -- called by Complete_Task and Finalize_Global_Tasks (for the environment + -- task). -- The effect is similar to that of Complete_Master. Differences include -- the closing of entries here, and computation of the number of active diff --git a/gcc/ada/s-tassta.ads b/gcc/ada/s-tassta.ads index 6fc8c8ccc9e..03abca42d8b 100644 --- a/gcc/ada/s-tassta.ads +++ b/gcc/ada/s-tassta.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -143,6 +143,8 @@ package System.Tasking.Stages is -- it is not needed if priority-based scheduling is supported, since all -- the activated tasks synchronize on the activators lock before they -- start activating and so they should start activating in priority order. + -- ??? Actually, the body of this package DOES reverse the chain, so I + -- don't understand the above comment. procedure Complete_Activation; -- Compiler interface only. Do not call from within the RTS. @@ -255,6 +257,22 @@ package System.Tasking.Stages is -- if T has terminated. Do nothing in the other case. It is called from -- Unchecked_Deallocation, for objects that are or contain tasks. + procedure Move_Activation_Chain + (From, To : Activation_Chain_Access; + New_Master : Master_ID); + -- Compiler interface only. Do not call from within the RTS. + -- Move all tasks on From list to To list, and change their Master_of_Task + -- to be New_Master. This is used to implement build-in-place function + -- returns. Tasks that are part of the return object are initially placed + -- on an activation chain local to the return statement, and their master + -- is the return statement, in case the return statement is left + -- prematurely (due to raising an exception, being aborted, or a goto or + -- exit statement). Once the return statement has completed successfully, + -- Move_Activation_Chain is called to move them to the caller's activation + -- chain, and change their master to the one passed in by the caller. If + -- that doesn't happen, they will never be activated, and will become + -- terminated on leaving the return statement. + function Terminated (T : Task_Id) return Boolean; -- This is called by the compiler to implement the 'Terminated attribute. -- Though is not required to be so by the ARM, we choose to synchronize diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 4d8fdb2aa4c..8fc23c2b3e1 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -124,11 +124,6 @@ package body Sem_Ch6 is -- If proper warnings are enabled and the subprogram contains a construct -- that cannot be inlined, the offending construct is flagged accordingly. - type Conformance_Type is - (Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant); - -- Conformance type used for following call, meaning matches the - -- RM definitions of the corresponding terms. - procedure Check_Conformance (New_Id : Entity_Id; Old_Id : Entity_Id; @@ -177,15 +172,6 @@ package body Sem_Ch6 is -- True otherwise. Proc is the entity for the procedure case and is used -- in posting the warning message. - function Conforming_Types - (T1 : Entity_Id; - T2 : Entity_Id; - Ctype : Conformance_Type; - Get_Inst : Boolean := False) return Boolean; - -- Check that two formal parameter types conform, checking both for - -- equality of base types, and where required statically matching - -- subtypes, depending on the setting of Ctype. - procedure Enter_Overloaded_Entity (S : Entity_Id); -- This procedure makes S, a new overloaded entity, into the first visible -- entity with that name. @@ -367,7 +353,7 @@ package body Sem_Ch6 is begin Generate_Definition (Designator); - Set_Is_Abstract (Designator); + Set_Is_Abstract_Subprogram (Designator); New_Overloaded_Entity (Designator); Check_Delayed_Subprogram (Designator); @@ -638,41 +624,6 @@ package body Sem_Ch6 is end; end if; - -- ???Check for not-yet-implemented cases of AI-318. Currently we - -- warn, because that's convenient for our own use. We might want to - -- change these warnings to errors at some point. This will go away - -- once AI-318 is fully implemented. - -- - -- In the first version, we plan not to implement limited function - -- returns when the result type contains tasks or protected objects, - -- and when the result subtype is unconstrained. - - if Ada_Version >= Ada_05 - and then not Debug_Flag_Dot_L - and then Is_Inherently_Limited_Type (R_Type) - then - if Has_Task (R_Type) then - Error_Msg_N ("(Ada 2005) return of task objects" & - " is not yet implemented", N); - end if; - - if Is_Controlled (R_Type) - or else Has_Controlled_Component (R_Type) - then - Error_Msg_N - ("(Ada 2005) return of limited controlled objects" & - " is not yet implemented", N); - end if; - - if - Is_Composite_Type (R_Type) and then not Is_Constrained (R_Type) - then - Error_Msg_N - ("(Ada 2005) return of unconstrained limited composite objects" & - " is not yet implemented", N); - end if; - end if; - if Present (Expr) and then Present (Etype (Expr)) -- Could be False in case of errors. then @@ -1373,7 +1324,9 @@ package body Sem_Ch6 is -- subprogram declaration for it, in order to attach the body to inline. procedure Copy_Parameter_List (Plist : List_Id); - -- Comment required ??? + -- Utility to create a parameter profile for a new subprogram spec, + -- when the subprogram has a body that acts as spec. This is done for + -- some cases of inlining, and for private protected ops. procedure Verify_Overriding_Indicator; -- If there was a previous spec, the entity has been entered in the @@ -1767,7 +1720,7 @@ package body Sem_Ch6 is Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id)); - if Is_Abstract (Spec_Id) then + if Is_Abstract_Subprogram (Spec_Id) then Error_Msg_N ("an abstract subprogram cannot have a body", N); return; else @@ -1843,36 +1796,6 @@ package body Sem_Ch6 is (Etype (First_Entity (Spec_Id)))); end if; - -- Ada 2005: A formal that is an access parameter may have a - -- designated type imported through a limited_with clause, while - -- the body has a regular with clause. Update the types of the - -- formals accordingly, so that the non-limited view of each type - -- is available in the body. We have already verified that the - -- declarations are type-conformant. - - if Ada_Version >= Ada_05 then - declare - F_Spec : Entity_Id; - F_Body : Entity_Id; - - begin - F_Spec := First_Formal (Spec_Id); - F_Body := First_Formal (Body_Id); - - while Present (F_Spec) loop - if Ekind (Etype (F_Spec)) = E_Anonymous_Access_Type - and then - From_With_Type (Designated_Type (Etype (F_Spec))) - then - Set_Etype (F_Spec, Etype (F_Body)); - end if; - - Next_Formal (F_Spec); - Next_Formal (F_Body); - end loop; - end; - end if; - -- Now make the formals visible, and place subprogram -- on scope stack. @@ -2296,7 +2219,7 @@ package body Sem_Ch6 is end if; if Is_Interface (Etyp) - and then not Is_Abstract (Designator) + and then not Is_Abstract_Subprogram (Designator) and then not (Ekind (Designator) = E_Procedure and then Null_Present (Specification (N))) then @@ -2441,7 +2364,7 @@ package body Sem_Ch6 is -- interface types the following error message will be reported later -- (see Analyze_Subprogram_Declaration). - if Is_Abstract (Etype (Designator)) + if Is_Abstract_Type (Etype (Designator)) and then not Is_Interface (Etype (Designator)) and then Nkind (Parent (N)) /= N_Abstract_Subprogram_Declaration @@ -2449,7 +2372,8 @@ package body Sem_Ch6 is /= N_Formal_Abstract_Subprogram_Declaration and then (Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration or else not Is_Entity_Name (Name (Parent (N))) - or else not Is_Abstract (Entity (Name (Parent (N))))) + or else not Is_Abstract_Subprogram + (Entity (Name (Parent (N))))) then Error_Msg_N ("function that returns abstract type must be abstract", N); @@ -2464,7 +2388,7 @@ package body Sem_Ch6 is -------------------------- procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is - Decl : constant Node_Id := Unit_Declaration_Node (Subp); + Decl : constant Node_Id := Unit_Declaration_Node (Subp); Original_Body : Node_Id; Body_To_Analyze : Node_Id; Max_Size : constant := 10; @@ -2479,24 +2403,24 @@ package body Sem_Ch6 is -- elementary statements, as a measure of acceptable size. function Has_Pending_Instantiation return Boolean; - -- If some enclosing body contains instantiations that appear before - -- the corresponding generic body, the enclosing body has a freeze node - -- so that it can be elaborated after the generic itself. This might + -- If some enclosing body contains instantiations that appear before the + -- corresponding generic body, the enclosing body has a freeze node so + -- that it can be elaborated after the generic itself. This might -- conflict with subsequent inlinings, so that it is unsafe to try to -- inline in such a case. function Has_Single_Return return Boolean; - -- In general we cannot inline functions that return unconstrained - -- type. However, we can handle such functions if all return statements - -- return a local variable that is the only declaration in the body - -- of the function. In that case the call can be replaced by that - -- local variable as is done for other inlined calls. + -- In general we cannot inline functions that return unconstrained type. + -- However, we can handle such functions if all return statements return + -- a local variable that is the only declaration in the body of the + -- function. In that case the call can be replaced by that local + -- variable as is done for other inlined calls. procedure Remove_Pragmas; - -- A pragma Unreferenced that mentions a formal parameter has no - -- meaning when the body is inlined and the formals are rewritten. - -- Remove it from body to inline. The analysis of the non-inlined body - -- will handle the pragma properly. + -- A pragma Unreferenced that mentions a formal parameter has no meaning + -- when the body is inlined and the formals are rewritten. Remove it + -- from body to inline. The analysis of the non-inlined body will handle + -- the pragma properly. function Uses_Secondary_Stack (Bod : Node_Id) return Boolean; -- If the body of the subprogram includes a call that returns an @@ -3462,7 +3386,7 @@ package body Sem_Ch6 is -- are left by an erroneous overriding. if not Is_Predefined_Dispatching_Operation (Prim_Op) - and then not Is_Abstract (Prim_Op) + and then not Is_Abstract_Subprogram (Prim_Op) and then Chars (Prim_Op) = Chars (Op) and then Type_Conformant (Prim_Op, Op) and then Convention (Prim_Op) /= Convention (Op) @@ -3503,7 +3427,7 @@ package body Sem_Ch6 is -- of abstract primitives left from an erroneous overriding. if not Is_Predefined_Dispatching_Operation (Prim_Op) - and then not Is_Abstract (Prim_Op) + and then not Is_Abstract_Subprogram (Prim_Op) then Check_Convention (Op => Prim_Op, @@ -3550,7 +3474,9 @@ package body Sem_Ch6 is begin -- Never need to freeze abstract subprogram - if Is_Abstract (Designator) then + if Ekind (Designator) /= E_Subprogram_Type + and then Is_Abstract_Subprogram (Designator) + then null; else -- Need delayed freeze if return type itself needs a delayed @@ -3585,7 +3511,7 @@ package body Sem_Ch6 is if Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (Designator); - elsif Present (Utyp) and then Controlled_Type (Utyp) then + elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then Set_Returns_By_Ref (Designator); end if; end; @@ -3801,6 +3727,7 @@ package body Sem_Ch6 is if Nkind (Decl) = N_Subprogram_Body or else Nkind (Decl) = N_Subprogram_Body_Stub or else Nkind (Decl) = N_Subprogram_Declaration + or else Nkind (Decl) = N_Abstract_Subprogram_Declaration or else Nkind (Decl) = N_Subprogram_Renaming_Declaration then Spec := Specification (Decl); @@ -3819,15 +3746,41 @@ package body Sem_Ch6 is if Ekind (Subp) = E_Entry then Error_Msg_NE ("entry & overrides inherited operation #", Spec, Subp); + else Error_Msg_NE ("subprogram & overrides inherited operation #", Spec, Subp); end if; end if; + + -- If Subp is an operator, it may override a predefined operation. + -- In that case overridden_subp is empty because of our implicit + -- representation for predefined operators. We have to check whether + -- the signature of Subp matches that of a predefined operator. + -- Note that first argument provides the name of the operator, and + -- the second argument the signature that may match that of a standard + -- operation. + + elsif Nkind (Subp) = N_Defining_Operator_Symbol + and then Must_Not_Override (Spec) + then + if Operator_Matches_Spec (Subp, Subp) then + Error_Msg_NE + ("subprogram & overrides predefined operation ", + Spec, Subp); + end if; + else if Must_Override (Spec) then if Ekind (Subp) = E_Entry then Error_Msg_NE ("entry & is not overriding", Spec, Subp); + + elsif Nkind (Subp) = N_Defining_Operator_Symbol then + if not Operator_Matches_Spec (Subp, Subp) then + Error_Msg_NE + ("subprogram & is not overriding", Spec, Subp); + end if; + else Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); end if; @@ -3936,7 +3889,6 @@ package body Sem_Ch6 is declare Arg : constant Node_Id := Original_Node (First_Actual (Last_Stm)); - begin if Nkind (Arg) = N_Attribute_Reference and then Attribute_Name (Arg) = Name_Identity @@ -4379,28 +4331,11 @@ package body Sem_Ch6 is -- treated recursively because they carry a signature. Are_Anonymous_Access_To_Subprogram_Types := - - -- Case 1: Anonymous access to subprogram types - - (Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type - and then Ekind (Type_2) = E_Anonymous_Access_Subprogram_Type) - - -- Case 2: Anonymous access to PROTECTED subprogram types. In this - -- case the anonymous type_declaration has been replaced by an - -- occurrence of an internal access to subprogram type declaration - -- available through the Original_Access_Type attribute - - or else - (Ekind (Type_1) = E_Access_Protected_Subprogram_Type - and then Ekind (Type_2) = E_Access_Protected_Subprogram_Type - and then not Comes_From_Source (Type_1) - and then not Comes_From_Source (Type_2) - and then Present (Original_Access_Type (Type_1)) - and then Present (Original_Access_Type (Type_2)) - and then Ekind (Original_Access_Type (Type_1)) = - E_Anonymous_Access_Protected_Subprogram_Type - and then Ekind (Original_Access_Type (Type_2)) = - E_Anonymous_Access_Protected_Subprogram_Type); + Ekind (Type_1) = Ekind (Type_2) + and then + (Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type + or else + Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type); -- Test anonymous access type case. For this case, static subtype -- matching is required for mode conformance (RM 6.3.1(15)) @@ -4544,16 +4479,9 @@ package body Sem_Ch6 is EF : constant Entity_Id := Make_Defining_Identifier (Sloc (Assoc_Entity), Chars => New_External_Name (Chars (Assoc_Entity), - Suffix => Suffix)); + Suffix => Suffix)); begin - -- We never generate extra formals if expansion is not active - -- because we don't need them unless we are generating code. - - if not Expander_Active then - return Empty; - end if; - -- A little optimization. Never generate an extra formal for the -- _init operand of an initialization procedure, since it could -- never be used. @@ -4586,6 +4514,13 @@ package body Sem_Ch6 is -- Start of processing for Create_Extra_Formals begin + -- We never generate extra formals if expansion is not active + -- because we don't need them unless we are generating code. + + if not Expander_Active then + return; + end if; + -- If this is a derived subprogram then the subtypes of the parent -- subprogram's formal parameters will be used to to determine the need -- for extra formals. @@ -4601,7 +4536,7 @@ package body Sem_Ch6 is Next_Formal (Formal); end loop; - -- If Extra_formals where already created, don't do it again. This + -- If Extra_formals were already created, don't do it again. This -- situation may arise for subprogram types created as part of -- dispatching calls (see Expand_Dispatching_Call) @@ -4642,10 +4577,8 @@ package body Sem_Ch6 is end if; if Has_Discriminants (Formal_Type) - and then - ((not Is_Constrained (Formal_Type) - and then not Is_Indefinite_Subtype (Formal_Type)) - or else Present (Extra_Formal (Formal))) + and then not Is_Constrained (Formal_Type) + and then not Is_Indefinite_Subtype (Formal_Type) then Set_Extra_Constrained (Formal, @@ -4657,7 +4590,7 @@ package body Sem_Ch6 is -- Create extra formal for supporting accessibility checking -- This is suppressed if we specifically suppress accessibility - -- checks at the pacage level for either the subprogram, or the + -- checks at the package level for either the subprogram, or the -- package in which it resides. However, we do not suppress it -- simply if the scope has accessibility checks suppressed, since -- this could cause trouble when clients are compiled with a @@ -4687,63 +4620,110 @@ package body Sem_Ch6 is end if; end if; - if Present (P_Formal) then - Next_Formal (P_Formal); - end if; - -- This label is required when skipping extra formal generation for -- Unchecked_Union parameters. <<Skip_Extra_Formal_Generation>> + if Present (P_Formal) then + Next_Formal (P_Formal); + end if; + Next_Formal (Formal); end loop; -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add - -- an extra formal that will be passed the address of the return object - -- within the caller. This is added as the last extra formal, but - -- eventually will be accompanied by other implicit formals related to - -- build-in-place functions (such as allocate/deallocate subprograms, - -- finalization list, constrained flag, task master, task activation - -- list, etc.). - - if Expander_Active - and then Ada_Version >= Ada_05 - and then Is_Build_In_Place_Function (E) - then + -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind. + + if Ada_Version >= Ada_05 and then Is_Build_In_Place_Function (E) then declare - Formal_Type : constant Entity_Id := - Create_Itype - (E_Anonymous_Access_Type, - E, Scope_Id => Scope (E)); - Result_Subt : constant Entity_Id := Etype (E); - Result_Addr_Formal : Entity_Id; + Result_Subt : constant Entity_Id := Etype (E); + + Discard : Entity_Id; + pragma Warnings (Off, Discard); begin - Set_Directly_Designated_Type (Formal_Type, Result_Subt); - Set_Etype (Formal_Type, Formal_Type); - Init_Size_Align (Formal_Type); - Set_Depends_On_Private - (Formal_Type, Has_Private_Component (Formal_Type)); - Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type))); - Set_Is_Access_Constant (Formal_Type, False); - Set_Can_Never_Be_Null (Formal_Type); + -- In the case of functions with unconstrained result subtypes, + -- add a 3-state formal indicating whether the return object is + -- allocated by the caller (0), or should be allocated by the + -- callee on the secondary stack (1) or in the global heap (2). + -- For the moment we just use Natural for the type of this formal. + -- Note that this formal isn't needed in the case where the + -- result subtype is constrained. + + if not Is_Constrained (Result_Subt) then + Discard := + Add_Extra_Formal + (E, Standard_Natural, + E, BIP_Formal_Suffix (BIP_Alloc_Form)); + end if; - -- Ada 2005 (AI-50217): Propagate the attribute that indicates - -- the designated type comes from the limited view (for back-end - -- purposes). + -- In the case of functions whose result type has controlled + -- parts, we have an extra formal of type + -- System.Finalization_Implementation.Finalizable_Ptr_Ptr. That + -- is, we are passing a pointer to a finalization list (which is + -- itself a pointer). This extra formal is then passed along to + -- Move_Final_List in case of successful completion of a return + -- statement. We cannot pass an 'in out' parameter, because we + -- need to update the finalization list during an abort-deferred + -- region, rather than using copy-back after the function + -- returns. This is true even if we are able to get away with + -- having 'in out' parameters, which are normally illegal for + -- functions. + + if Is_Controlled (Result_Subt) + or else Has_Controlled_Component (Result_Subt) + then + Discard := + Add_Extra_Formal + (E, RTE (RE_Finalizable_Ptr_Ptr), + E, BIP_Formal_Suffix (BIP_Final_List)); + end if; + + -- If the result type contains tasks, we have two extra formals: + -- the master of the tasks to be created, and the caller's + -- activation chain. + + if Has_Task (Result_Subt) then + Discard := + Add_Extra_Formal + (E, RTE (RE_Master_Id), + E, BIP_Formal_Suffix (BIP_Master)); + Discard := + Add_Extra_Formal + (E, RTE (RE_Activation_Chain_Access), + E, BIP_Formal_Suffix (BIP_Activation_Chain)); + end if; - Set_From_With_Type (Formal_Type, From_With_Type (Result_Subt)); + -- All build-in-place functions get an extra formal that will be + -- passed the address of the return object within the caller. - Layout_Type (Formal_Type); + declare + Formal_Type : constant Entity_Id := + Create_Itype + (E_Anonymous_Access_Type, E, + Scope_Id => Scope (E)); + begin + Set_Directly_Designated_Type (Formal_Type, Result_Subt); + Set_Etype (Formal_Type, Formal_Type); + Init_Size_Align (Formal_Type); + Set_Depends_On_Private + (Formal_Type, Has_Private_Component (Formal_Type)); + Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type))); + Set_Is_Access_Constant (Formal_Type, False); - Result_Addr_Formal := Add_Extra_Formal (E, Formal_Type, E, "RA"); + -- Ada 2005 (AI-50217): Propagate the attribute that indicates + -- the designated type comes from the limited view (for + -- back-end purposes). - -- For some reason the following is not effective and the - -- dereference of the formal within the function still gets - -- a check. ??? + Set_From_With_Type (Formal_Type, From_With_Type (Result_Subt)); - Set_Can_Never_Be_Null (Result_Addr_Formal); + Layout_Type (Formal_Type); + + Discard := + Add_Extra_Formal + (E, Formal_Type, E, BIP_Formal_Suffix (BIP_Object_Access)); + end; end; end if; end Create_Extra_Formals; @@ -4813,8 +4793,10 @@ package body Sem_Ch6 is -- Warn unless genuine overloading - if (not Is_Overloadable (E)) - or else Subtype_Conformant (E, S) + if (not Is_Overloadable (E) or else Subtype_Conformant (E, S)) + and then (Is_Immediately_Visible (E) + or else + Is_Potentially_Use_Visible (S)) then Error_Msg_Sloc := Sloc (E); Error_Msg_N ("declaration of & hides one#?", S); @@ -5698,7 +5680,7 @@ package body Sem_Ch6 is Remove (Decl); Set_Has_Completion (Op_Name); Set_Corresponding_Equality (Op_Name, S); - Set_Is_Abstract (Op_Name, Is_Abstract (S)); + Set_Is_Abstract_Subprogram (Op_Name, Is_Abstract_Subprogram (S)); end; end Make_Inequality_Operator; @@ -5827,7 +5809,7 @@ package body Sem_Ch6 is -- declarations because they don't have interface lists. if Nkind (Parent (Typ)) /= N_Full_Type_Declaration then - Collect_Synchronized_Interfaces (Typ, Ifaces_List); + Collect_Abstract_Interfaces (Typ, Ifaces_List); if not Is_Empty_Elmt_List (Ifaces_List) then Overridden_Subp := @@ -5900,22 +5882,14 @@ package body Sem_Ch6 is and then Visible_Part_Type (T) and then not In_Instance then - if Is_Abstract (T) - and then Is_Abstract (S) - and then (not Is_Overriding or else not Is_Abstract (E)) + if Is_Abstract_Type (T) + and then Is_Abstract_Subprogram (S) + and then (not Is_Overriding + or else not Is_Abstract_Subprogram (E)) then - if not Is_Interface (T) then - Error_Msg_N ("abstract subprograms must be visible " + Error_Msg_N ("abstract subprograms must be visible " & "('R'M 3.9.3(10))!", S); - -- Ada 2005 (AI-251) - - else - Error_Msg_N ("primitive subprograms of interface types " - & "declared in a visible part, must be declared in " - & "the visible part ('R'M 3.9.4)!", S); - end if; - elsif Ekind (S) = E_Function and then Is_Tagged_Type (T) and then T = Base_Type (Etype (S)) @@ -6609,6 +6583,12 @@ package body Sem_Ch6 is Formal_Type := Access_Definition (Related_Nod, Parameter_Type (Param_Spec)); + -- No need to continue if we already notified errors + + if not Present (Formal_Type) then + return; + end if; + -- Ada 2005 (AI-254) declare @@ -6619,7 +6599,7 @@ package body Sem_Ch6 is if Present (AD) and then Protected_Present (AD) then Formal_Type := Replace_Anonymous_Access_To_Protected_Subprogram - (Param_Spec, Formal_Type); + (Param_Spec); end if; end; end if; diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index 52b657080bc..f465c80debf 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -27,6 +27,12 @@ with Types; use Types; package Sem_Ch6 is + type Conformance_Type is + (Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant); + -- Conformance type used in conformance checks between specs and bodies, + -- and for overriding. The literals match the RM definitions of the + -- corresponding terms. + procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id); procedure Analyze_Extended_Return_Statement (N : Node_Id); procedure Analyze_Function_Call (N : Node_Id); @@ -39,7 +45,8 @@ package Sem_Ch6 is function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id; -- Analyze subprogram specification in both subprogram declarations - -- and body declarations. Returns the defining entity for the spec. + -- and body declarations. Returns the defining entity for the + -- specification N. procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id); -- This procedure is called if the node N, an instance of a call to @@ -55,9 +62,9 @@ package Sem_Ch6 is -- their respective counterparts. procedure Check_Delayed_Subprogram (Designator : Entity_Id); - -- Designator can be a E_Subrpgram_Type, E_Procedure or E_Function. If a + -- Designator can be a E_Subprogram_Type, E_Procedure or E_Function. If a -- type in its profile depends on a private type without a full - -- declaration, indicate that the subprogram is delayed. + -- declaration, indicate that the subprogram or type is delayed. procedure Check_Discriminant_Conformance (N : Node_Id; @@ -112,6 +119,16 @@ package Sem_Ch6 is -- the flag being placed on the Err_Loc node if it is specified, and -- on the appropriate component of the New_Id construct if not. + function Conforming_Types + (T1 : Entity_Id; + T2 : Entity_Id; + Ctype : Conformance_Type; + Get_Inst : Boolean := False) return Boolean; + -- Check that the types of two formal parameters are conforming. In most + -- cases this is just a name comparison, but within an instance it involves + -- generic actual types, and in the presence of anonymous access types + -- it must examine the designated types. + procedure Create_Extra_Formals (E : Entity_Id); -- For each parameter of a subprogram or entry that requires an additional -- formal (such as for access parameters and indefinite discriminated |