From 99425ec329df4fa7d48f34803efd901284267197 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 17 Oct 2014 11:07:50 +0200 Subject: [PATCH] [multiple changes] 2014-10-17 Robert Dewar * sem_attr.adb (Eval_Attribute): Ensure that attribute reference is not marked as being a static expression if the prefix evaluation raises CE. 2014-10-17 Robert Dewar * exp_pakd.adb: Move bit packed entity tables to spec. * exp_pakd.ads: Move bit packed entity tables here from body. * freeze.adb (Freeze_Array_Type): Check that packed array type is supported. * rtsfind.adb (PRE_Id_Table): New table (Entity_Not_Defined): Specialize messages using PRE_Id_Table. * uintp.ads, uintp.adb (UI_Image): New functional form. 2014-10-17 Robert Dewar * aspects.ads, aspects.adb: Add Suppress_Initialization aspect. * einfo.ads, einfo.adb (Suppress_Initialization): Now applies to E_Variable. * exp_ch3.adb (Default_Initialize_Object): Handle Suppress_Initialization. * exp_prag.adb (Expand_Pragma_Suppress_Initialization): New procedure (Expand_N_Pragma): Handle Suppress_Initialization (Expand_Pragma_Import_Or_Interface): Use Undo_Initialization (Undo_Initialization): New procedure. * sem_prag.adb (Analyze_Pragma, case Suppress_Initialization): This is now allowed for E_Variable case. * gnat_rm.texi: Document new aspect Suppress_Initialization Suppress_Initialization aspect/pragma can apply to variable. * einfo.ads: Minor reformatting. 2014-10-17 Arnaud Charlet * spark_xrefs.ads: Add documentation pointer to Flow_Computed_Globals. 2014-10-17 Robert Dewar * cstand.adb (Create_Standard): Mark Short_Integer as implementation defined. * sem_util.adb (Set_Entity_With_Checks): Avoid blow up for compiler built with assertions for No_Implementation_Identifiers test. From-SVN: r216379 --- gcc/ada/ChangeLog | 44 +++++ gcc/ada/aspects.adb | 1 + gcc/ada/aspects.ads | 4 + gcc/ada/cstand.adb | 1 + gcc/ada/einfo.adb | 4 +- gcc/ada/einfo.ads | 66 ++++---- gcc/ada/exp_ch3.adb | 5 +- gcc/ada/exp_pakd.adb | 360 --------------------------------------- gcc/ada/exp_pakd.ads | 364 +++++++++++++++++++++++++++++++++++++++- gcc/ada/exp_prag.adb | 90 ++++++---- gcc/ada/freeze.adb | 18 ++ gcc/ada/gnat_rm.texi | 23 ++- gcc/ada/rtsfind.adb | 108 +++++++++++- gcc/ada/sem_attr.adb | 6 +- gcc/ada/sem_prag.adb | 7 +- gcc/ada/sem_util.adb | 5 +- gcc/ada/spark_xrefs.ads | 17 +- gcc/ada/uintp.adb | 11 +- gcc/ada/uintp.ads | 15 +- 19 files changed, 704 insertions(+), 445 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a151364dc72..7ae4ea2a0b9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,47 @@ +2014-10-17 Robert Dewar + + * sem_attr.adb (Eval_Attribute): Ensure that attribute + reference is not marked as being a static expression if the + prefix evaluation raises CE. + +2014-10-17 Robert Dewar + + * exp_pakd.adb: Move bit packed entity tables to spec. + * exp_pakd.ads: Move bit packed entity tables here from body. + * freeze.adb (Freeze_Array_Type): Check that packed array type + is supported. + * rtsfind.adb (PRE_Id_Table): New table (Entity_Not_Defined): + Specialize messages using PRE_Id_Table. + * uintp.ads, uintp.adb (UI_Image): New functional form. + +2014-10-17 Robert Dewar + + * aspects.ads, aspects.adb: Add Suppress_Initialization aspect. + * einfo.ads, einfo.adb (Suppress_Initialization): Now applies to + E_Variable. + * exp_ch3.adb (Default_Initialize_Object): Handle + Suppress_Initialization. + * exp_prag.adb (Expand_Pragma_Suppress_Initialization): New + procedure (Expand_N_Pragma): Handle Suppress_Initialization + (Expand_Pragma_Import_Or_Interface): Use Undo_Initialization + (Undo_Initialization): New procedure. + * sem_prag.adb (Analyze_Pragma, case Suppress_Initialization): + This is now allowed for E_Variable case. + * gnat_rm.texi: Document new aspect Suppress_Initialization + Suppress_Initialization aspect/pragma can apply to variable. + * einfo.ads: Minor reformatting. + +2014-10-17 Arnaud Charlet + + * spark_xrefs.ads: Add documentation pointer to Flow_Computed_Globals. + +2014-10-17 Robert Dewar + + * cstand.adb (Create_Standard): Mark Short_Integer as + implementation defined. + * sem_util.adb (Set_Entity_With_Checks): Avoid blow up for + compiler built with assertions for No_Implementation_Identifiers test. + 2014-10-17 Robert Dewar * aspects.ads: Documentation fix, aspect Lock_Free does have a diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 82f0c911a67..472f95700b3 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -585,6 +585,7 @@ package body Aspects is Aspect_Stream_Size => Aspect_Stream_Size, Aspect_Suppress => Aspect_Suppress, Aspect_Suppress_Debug_Info => Aspect_Suppress_Debug_Info, + Aspect_Suppress_Initialization => Aspect_Suppress_Initialization, Aspect_Synchronization => Aspect_Synchronization, Aspect_Test_Case => Aspect_Test_Case, Aspect_Thread_Local_Storage => Aspect_Thread_Local_Storage, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 3410b00d220..60b64740889 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -188,6 +188,7 @@ package Aspects is Aspect_Shared, -- GNAT (equivalent to Atomic) Aspect_Simple_Storage_Pool_Type, -- GNAT Aspect_Suppress_Debug_Info, -- GNAT + Aspect_Suppress_Initialization, -- GNAT Aspect_Thread_Local_Storage, -- GNAT Aspect_Unchecked_Union, Aspect_Universal_Aliasing, -- GNAT @@ -243,6 +244,7 @@ package Aspects is Aspect_Simple_Storage_Pool => True, Aspect_Simple_Storage_Pool_Type => True, Aspect_Suppress_Debug_Info => True, + Aspect_Suppress_Initialization => True, Aspect_Thread_Local_Storage => True, Aspect_Test_Case => True, Aspect_Universal_Aliasing => True, @@ -469,6 +471,7 @@ package Aspects is Aspect_Stream_Size => Name_Stream_Size, Aspect_Suppress => Name_Suppress, Aspect_Suppress_Debug_Info => Name_Suppress_Debug_Info, + Aspect_Suppress_Initialization => Name_Suppress_Initialization, Aspect_Thread_Local_Storage => Name_Thread_Local_Storage, Aspect_Synchronization => Name_Synchronization, Aspect_Test_Case => Name_Test_Case, @@ -659,6 +662,7 @@ package Aspects is Aspect_Stream_Size => Always_Delay, Aspect_Suppress => Always_Delay, Aspect_Suppress_Debug_Info => Always_Delay, + Aspect_Suppress_Initialization => Always_Delay, Aspect_Thread_Local_Storage => Always_Delay, Aspect_Type_Invariant => Always_Delay, Aspect_Unchecked_Union => Always_Delay, diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 2fe357666da..2032b9b4c03 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -735,6 +735,7 @@ package body CStand is Build_Signed_Integer_Type (Standard_Short_Integer, Standard_Short_Integer_Size); + Set_Is_Implementation_Defined (Standard_Short_Integer); Build_Signed_Integer_Type (Standard_Integer, Standard_Integer_Size); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index e4e03601996..6aa7c48a429 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -3090,7 +3090,7 @@ package body Einfo is function Suppress_Initialization (Id : E) return B is begin - pragma Assert (Is_Type (Id)); + pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Variable); return Flag105 (Id); end Suppress_Initialization; @@ -5943,7 +5943,7 @@ package body Einfo is procedure Set_Suppress_Initialization (Id : E; V : B := True) is begin - pragma Assert (Is_Type (Id)); + pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Variable); Set_Flag105 (Id, V); end Set_Suppress_Initialization; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index da63627748c..d680c774382 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2990,7 +2990,7 @@ package Einfo is -- vtable (i.e. the one to be extended by derivation). -- Is_Tagged_Type (Flag55) --- Defined in all entities. Set for an entity for a tagged type. +-- Defined in all entities. Set for an entity that is a tagged type. -- Is_Task_Interface (synthesized) -- Defined in types that are interfaces. True if interface is declared as @@ -4081,14 +4081,16 @@ package Einfo is -- avoid multiple elaboration warnings for the same variable. -- Suppress_Initialization (Flag105) --- Defined in all type and subtype entities. If set for the base type, --- then the generation of initialization procedures is suppressed for the --- type. Any other implicit initialiation (e.g. from the use of pragma --- Initialize_Scalars) is also suppressed if this flag is set either for --- the subtype in question, or for the base type. Set by use of pragma --- Suppress_Initialization and also for internal entities where we know --- that no initialization is required. For example, enumeration image --- table entities set it. +-- Defined in all variable, type and subtype entities. If set for a base +-- type, then the generation of initialization procedures is suppressed +-- for the type. Any other implicit initialiation (e.g. from the use of +-- pragma Initialize_Scalars) is also suppressed if this flag is set for +-- either the subtype in question, or for the base type. For variables, +-- this flag suppresses all implicit initialization for the object, even +-- if the type would normally require initialization. Set by use of +-- pragma Suppress_Initialization and also for internal entities where +-- we know that no initialization is required. For example, enumeration +-- image table entities set it. -- Suppress_Style_Checks (Flag165) -- Defined in all entities. Suppresses any style checks specifically @@ -4481,8 +4483,8 @@ package Einfo is -- is created for the base type, and this is the first named subtype). E_Ordinary_Fixed_Point_Type, - -- Ordinary fixed type, used for the anonymous base type of the - -- fixed subtype created by an ordinary fixed point type declaration. + -- Ordinary fixed type, used for the anonymous base type of the fixed + -- subtype created by an ordinary fixed point type declaration. E_Ordinary_Fixed_Point_Subtype, -- Ordinary fixed point subtype, created by either an ordinary fixed @@ -4603,19 +4605,18 @@ package Einfo is -- A record subtype, created by a record subtype declaration E_Record_Type_With_Private, - -- Used for types defined by a private extension declaration, and - -- for tagged private types. Includes the fields for both private - -- types and for record types (with the sole exception of - -- Corresponding_Concurrent_Type which is obviously not needed). - -- This entity is considered to be both a record type and - -- a private type. + -- Used for types defined by a private extension declaration, + -- and for tagged private types. Includes the fields for both + -- private types and for record types (with the sole exception of + -- Corresponding_Concurrent_Type which is obviously not needed). This + -- entity is considered to be both a record type and a private type. E_Record_Subtype_With_Private, -- A subtype of a type defined by a private extension declaration E_Private_Type, - -- A private type, created by a private type declaration - -- that has neither the keyword limited nor the keyword tagged. + -- A private type, created by a private type declaration that has + -- neither the keyword limited nor the keyword tagged. E_Private_Subtype, -- A subtype of a private type, created by a subtype declaration used @@ -4662,10 +4663,10 @@ package Einfo is -- The type of an exception created by an exception declaration E_Subprogram_Type, - -- This is the designated type of an Access_To_Subprogram. Has type - -- and signature like a subprogram entity, so can appear in calls, - -- which are resolved like regular calls, except that such an entity - -- is not overloadable. + -- This is the designated type of an Access_To_Subprogram. Has type and + -- signature like a subprogram entity, so can appear in calls, which + -- are resolved like regular calls, except that such an entity is not + -- overloadable. --------------------------- -- Overloadable Entities -- @@ -4681,9 +4682,9 @@ package Einfo is E_Operator, -- A predefined operator, appearing in Standard, or an implicitly - -- defined concatenation operator created whenever an array is - -- declared. We do not make normal derived operators explicit in - -- the tree, but the concatenation operators are made explicit. + -- defined concatenation operator created whenever an array is declared. + -- We do not make normal derived operators explicit in the tree, but the + -- concatenation operators are made explicit. E_Procedure, -- A procedure, created by a procedure declaration or a procedure @@ -6238,6 +6239,7 @@ package Einfo is -- OK_To_Rename (Flag247) -- Optimize_Alignment_Space (Flag241) -- Optimize_Alignment_Time (Flag242) + -- Suppress_Initialization (Flag105) -- Treat_As_Volatile (Flag41) -- Address_Clause (synth) -- Alignment_Clause (synth) @@ -8794,12 +8796,12 @@ package Einfo is -- END XEINFO INLINES - -- The following Inline pragmas are *not* read by xeinfo when building - -- the C version of this interface automatically (so the C version will - -- end up making out of line calls). The pragma scan in xeinfo will be - -- terminated on encountering the END XEINFO INLINES line. We inline - -- things here which are small, but not of the canonical attribute - -- access/set format that can be handled by xeinfo. + -- The following Inline pragmas are *not* read by xeinfo when building the + -- C version of this interface automatically (so the C version will end up + -- making out of line calls). The pragma scan in xeinfo will be terminated + -- on encountering the END XEINFO INLINES line. We inline things here which + -- are small, but not of the canonical attribute access/set format that can + -- be handled by xeinfo. pragma Inline (Base_Type); pragma Inline (Is_Base_Type); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 1aa813e3acc..837e58fd471 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5082,9 +5082,10 @@ package body Exp_Ch3 is -- known to be imported (i.e. whose declaration specifies the Import -- aspect). Note that for objects with a pragma Import, we generate -- initialization here, and then remove it downstream when processing - -- the pragma. + -- the pragma. It is also suppressed for variables for which a pragma + -- Suppress_Initialization has been explicitly given - if Is_Imported (Def_Id) then + if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then return; end if; diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 6ff75278d97..21487c0b3f5 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -34,7 +34,6 @@ with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; -with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; @@ -77,365 +76,6 @@ package body Exp_Pakd is -- right rotate into a left rotate, avoiding the subtract, if the machine -- architecture provides such an instruction. - ---------------------------------------------- - -- Entity Tables for Packed Access Routines -- - ---------------------------------------------- - - -- For the cases of component size = 3,5-7,9-15,17-31,33-63 we call library - -- routines. This table provides the entity for the proper routine. - - type E_Array is array (Int range 01 .. 63) of RE_Id; - - -- Array of Bits_nn entities. Note that we do not use library routines - -- for the 8-bit and 16-bit cases, but we still fill in the table, using - -- entries from System.Unsigned, because we also use this table for - -- certain special unchecked conversions in the big-endian case. - - Bits_Id : constant E_Array := - (01 => RE_Bits_1, - 02 => RE_Bits_2, - 03 => RE_Bits_03, - 04 => RE_Bits_4, - 05 => RE_Bits_05, - 06 => RE_Bits_06, - 07 => RE_Bits_07, - 08 => RE_Unsigned_8, - 09 => RE_Bits_09, - 10 => RE_Bits_10, - 11 => RE_Bits_11, - 12 => RE_Bits_12, - 13 => RE_Bits_13, - 14 => RE_Bits_14, - 15 => RE_Bits_15, - 16 => RE_Unsigned_16, - 17 => RE_Bits_17, - 18 => RE_Bits_18, - 19 => RE_Bits_19, - 20 => RE_Bits_20, - 21 => RE_Bits_21, - 22 => RE_Bits_22, - 23 => RE_Bits_23, - 24 => RE_Bits_24, - 25 => RE_Bits_25, - 26 => RE_Bits_26, - 27 => RE_Bits_27, - 28 => RE_Bits_28, - 29 => RE_Bits_29, - 30 => RE_Bits_30, - 31 => RE_Bits_31, - 32 => RE_Unsigned_32, - 33 => RE_Bits_33, - 34 => RE_Bits_34, - 35 => RE_Bits_35, - 36 => RE_Bits_36, - 37 => RE_Bits_37, - 38 => RE_Bits_38, - 39 => RE_Bits_39, - 40 => RE_Bits_40, - 41 => RE_Bits_41, - 42 => RE_Bits_42, - 43 => RE_Bits_43, - 44 => RE_Bits_44, - 45 => RE_Bits_45, - 46 => RE_Bits_46, - 47 => RE_Bits_47, - 48 => RE_Bits_48, - 49 => RE_Bits_49, - 50 => RE_Bits_50, - 51 => RE_Bits_51, - 52 => RE_Bits_52, - 53 => RE_Bits_53, - 54 => RE_Bits_54, - 55 => RE_Bits_55, - 56 => RE_Bits_56, - 57 => RE_Bits_57, - 58 => RE_Bits_58, - 59 => RE_Bits_59, - 60 => RE_Bits_60, - 61 => RE_Bits_61, - 62 => RE_Bits_62, - 63 => RE_Bits_63); - - -- Array of Get routine entities. These are used to obtain an element from - -- a packed array. The N'th entry is used to obtain elements from a packed - -- array whose component size is N. RE_Null is used as a null entry, for - -- the cases where a library routine is not used. - - Get_Id : constant E_Array := - (01 => RE_Null, - 02 => RE_Null, - 03 => RE_Get_03, - 04 => RE_Null, - 05 => RE_Get_05, - 06 => RE_Get_06, - 07 => RE_Get_07, - 08 => RE_Null, - 09 => RE_Get_09, - 10 => RE_Get_10, - 11 => RE_Get_11, - 12 => RE_Get_12, - 13 => RE_Get_13, - 14 => RE_Get_14, - 15 => RE_Get_15, - 16 => RE_Null, - 17 => RE_Get_17, - 18 => RE_Get_18, - 19 => RE_Get_19, - 20 => RE_Get_20, - 21 => RE_Get_21, - 22 => RE_Get_22, - 23 => RE_Get_23, - 24 => RE_Get_24, - 25 => RE_Get_25, - 26 => RE_Get_26, - 27 => RE_Get_27, - 28 => RE_Get_28, - 29 => RE_Get_29, - 30 => RE_Get_30, - 31 => RE_Get_31, - 32 => RE_Null, - 33 => RE_Get_33, - 34 => RE_Get_34, - 35 => RE_Get_35, - 36 => RE_Get_36, - 37 => RE_Get_37, - 38 => RE_Get_38, - 39 => RE_Get_39, - 40 => RE_Get_40, - 41 => RE_Get_41, - 42 => RE_Get_42, - 43 => RE_Get_43, - 44 => RE_Get_44, - 45 => RE_Get_45, - 46 => RE_Get_46, - 47 => RE_Get_47, - 48 => RE_Get_48, - 49 => RE_Get_49, - 50 => RE_Get_50, - 51 => RE_Get_51, - 52 => RE_Get_52, - 53 => RE_Get_53, - 54 => RE_Get_54, - 55 => RE_Get_55, - 56 => RE_Get_56, - 57 => RE_Get_57, - 58 => RE_Get_58, - 59 => RE_Get_59, - 60 => RE_Get_60, - 61 => RE_Get_61, - 62 => RE_Get_62, - 63 => RE_Get_63); - - -- Array of Get routine entities to be used in the case where the packed - -- array is itself a component of a packed structure, and therefore may not - -- be fully aligned. This only affects the even sizes, since for the odd - -- sizes, we do not get any fixed alignment in any case. - - GetU_Id : constant E_Array := - (01 => RE_Null, - 02 => RE_Null, - 03 => RE_Get_03, - 04 => RE_Null, - 05 => RE_Get_05, - 06 => RE_GetU_06, - 07 => RE_Get_07, - 08 => RE_Null, - 09 => RE_Get_09, - 10 => RE_GetU_10, - 11 => RE_Get_11, - 12 => RE_GetU_12, - 13 => RE_Get_13, - 14 => RE_GetU_14, - 15 => RE_Get_15, - 16 => RE_Null, - 17 => RE_Get_17, - 18 => RE_GetU_18, - 19 => RE_Get_19, - 20 => RE_GetU_20, - 21 => RE_Get_21, - 22 => RE_GetU_22, - 23 => RE_Get_23, - 24 => RE_GetU_24, - 25 => RE_Get_25, - 26 => RE_GetU_26, - 27 => RE_Get_27, - 28 => RE_GetU_28, - 29 => RE_Get_29, - 30 => RE_GetU_30, - 31 => RE_Get_31, - 32 => RE_Null, - 33 => RE_Get_33, - 34 => RE_GetU_34, - 35 => RE_Get_35, - 36 => RE_GetU_36, - 37 => RE_Get_37, - 38 => RE_GetU_38, - 39 => RE_Get_39, - 40 => RE_GetU_40, - 41 => RE_Get_41, - 42 => RE_GetU_42, - 43 => RE_Get_43, - 44 => RE_GetU_44, - 45 => RE_Get_45, - 46 => RE_GetU_46, - 47 => RE_Get_47, - 48 => RE_GetU_48, - 49 => RE_Get_49, - 50 => RE_GetU_50, - 51 => RE_Get_51, - 52 => RE_GetU_52, - 53 => RE_Get_53, - 54 => RE_GetU_54, - 55 => RE_Get_55, - 56 => RE_GetU_56, - 57 => RE_Get_57, - 58 => RE_GetU_58, - 59 => RE_Get_59, - 60 => RE_GetU_60, - 61 => RE_Get_61, - 62 => RE_GetU_62, - 63 => RE_Get_63); - - -- Array of Set routine entities. These are used to assign an element of a - -- packed array. The N'th entry is used to assign elements for a packed - -- array whose component size is N. RE_Null is used as a null entry, for - -- the cases where a library routine is not used. - - Set_Id : constant E_Array := - (01 => RE_Null, - 02 => RE_Null, - 03 => RE_Set_03, - 04 => RE_Null, - 05 => RE_Set_05, - 06 => RE_Set_06, - 07 => RE_Set_07, - 08 => RE_Null, - 09 => RE_Set_09, - 10 => RE_Set_10, - 11 => RE_Set_11, - 12 => RE_Set_12, - 13 => RE_Set_13, - 14 => RE_Set_14, - 15 => RE_Set_15, - 16 => RE_Null, - 17 => RE_Set_17, - 18 => RE_Set_18, - 19 => RE_Set_19, - 20 => RE_Set_20, - 21 => RE_Set_21, - 22 => RE_Set_22, - 23 => RE_Set_23, - 24 => RE_Set_24, - 25 => RE_Set_25, - 26 => RE_Set_26, - 27 => RE_Set_27, - 28 => RE_Set_28, - 29 => RE_Set_29, - 30 => RE_Set_30, - 31 => RE_Set_31, - 32 => RE_Null, - 33 => RE_Set_33, - 34 => RE_Set_34, - 35 => RE_Set_35, - 36 => RE_Set_36, - 37 => RE_Set_37, - 38 => RE_Set_38, - 39 => RE_Set_39, - 40 => RE_Set_40, - 41 => RE_Set_41, - 42 => RE_Set_42, - 43 => RE_Set_43, - 44 => RE_Set_44, - 45 => RE_Set_45, - 46 => RE_Set_46, - 47 => RE_Set_47, - 48 => RE_Set_48, - 49 => RE_Set_49, - 50 => RE_Set_50, - 51 => RE_Set_51, - 52 => RE_Set_52, - 53 => RE_Set_53, - 54 => RE_Set_54, - 55 => RE_Set_55, - 56 => RE_Set_56, - 57 => RE_Set_57, - 58 => RE_Set_58, - 59 => RE_Set_59, - 60 => RE_Set_60, - 61 => RE_Set_61, - 62 => RE_Set_62, - 63 => RE_Set_63); - - -- Array of Set routine entities to be used in the case where the packed - -- array is itself a component of a packed structure, and therefore may not - -- be fully aligned. This only affects the even sizes, since for the odd - -- sizes, we do not get any fixed alignment in any case. - - SetU_Id : constant E_Array := - (01 => RE_Null, - 02 => RE_Null, - 03 => RE_Set_03, - 04 => RE_Null, - 05 => RE_Set_05, - 06 => RE_SetU_06, - 07 => RE_Set_07, - 08 => RE_Null, - 09 => RE_Set_09, - 10 => RE_SetU_10, - 11 => RE_Set_11, - 12 => RE_SetU_12, - 13 => RE_Set_13, - 14 => RE_SetU_14, - 15 => RE_Set_15, - 16 => RE_Null, - 17 => RE_Set_17, - 18 => RE_SetU_18, - 19 => RE_Set_19, - 20 => RE_SetU_20, - 21 => RE_Set_21, - 22 => RE_SetU_22, - 23 => RE_Set_23, - 24 => RE_SetU_24, - 25 => RE_Set_25, - 26 => RE_SetU_26, - 27 => RE_Set_27, - 28 => RE_SetU_28, - 29 => RE_Set_29, - 30 => RE_SetU_30, - 31 => RE_Set_31, - 32 => RE_Null, - 33 => RE_Set_33, - 34 => RE_SetU_34, - 35 => RE_Set_35, - 36 => RE_SetU_36, - 37 => RE_Set_37, - 38 => RE_SetU_38, - 39 => RE_Set_39, - 40 => RE_SetU_40, - 41 => RE_Set_41, - 42 => RE_SetU_42, - 43 => RE_Set_43, - 44 => RE_SetU_44, - 45 => RE_Set_45, - 46 => RE_SetU_46, - 47 => RE_Set_47, - 48 => RE_SetU_48, - 49 => RE_Set_49, - 50 => RE_SetU_50, - 51 => RE_Set_51, - 52 => RE_SetU_52, - 53 => RE_Set_53, - 54 => RE_SetU_54, - 55 => RE_Set_55, - 56 => RE_SetU_56, - 57 => RE_Set_57, - 58 => RE_SetU_58, - 59 => RE_Set_59, - 60 => RE_SetU_60, - 61 => RE_Set_61, - 62 => RE_SetU_62, - 63 => RE_Set_63); - ----------------------- -- Local Subprograms -- ----------------------- diff --git a/gcc/ada/exp_pakd.ads b/gcc/ada/exp_pakd.ads index 586d80687e8..80b63247e3c 100644 --- a/gcc/ada/exp_pakd.ads +++ b/gcc/ada/exp_pakd.ads @@ -25,7 +25,8 @@ -- Expand routines for manipulation of packed arrays -with Types; use Types; +with Rtsfind; use Rtsfind; +with Types; use Types; package Exp_Pakd is @@ -203,6 +204,367 @@ package Exp_Pakd is -- and now, we do indeed have the same representation for the memory -- version in the constrained and unconstrained cases. + ---------------------------------------------- + -- Entity Tables for Packed Access Routines -- + ---------------------------------------------- + + -- For the cases of component size = 3,5-7,9-15,17-31,33-63 we call library + -- routines. These tables provide the entity for the proper routine. They + -- are exposed in the spec to allow checking for the presence of the needed + -- routine when an array is subject to pragma Pack. + + type E_Array is array (Int range 01 .. 63) of RE_Id; + + -- Array of Bits_nn entities. Note that we do not use library routines + -- for the 8-bit and 16-bit cases, but we still fill in the table, using + -- entries from System.Unsigned, because we also use this table for + -- certain special unchecked conversions in the big-endian case. + + Bits_Id : constant E_Array := + (01 => RE_Bits_1, + 02 => RE_Bits_2, + 03 => RE_Bits_03, + 04 => RE_Bits_4, + 05 => RE_Bits_05, + 06 => RE_Bits_06, + 07 => RE_Bits_07, + 08 => RE_Unsigned_8, + 09 => RE_Bits_09, + 10 => RE_Bits_10, + 11 => RE_Bits_11, + 12 => RE_Bits_12, + 13 => RE_Bits_13, + 14 => RE_Bits_14, + 15 => RE_Bits_15, + 16 => RE_Unsigned_16, + 17 => RE_Bits_17, + 18 => RE_Bits_18, + 19 => RE_Bits_19, + 20 => RE_Bits_20, + 21 => RE_Bits_21, + 22 => RE_Bits_22, + 23 => RE_Bits_23, + 24 => RE_Bits_24, + 25 => RE_Bits_25, + 26 => RE_Bits_26, + 27 => RE_Bits_27, + 28 => RE_Bits_28, + 29 => RE_Bits_29, + 30 => RE_Bits_30, + 31 => RE_Bits_31, + 32 => RE_Unsigned_32, + 33 => RE_Bits_33, + 34 => RE_Bits_34, + 35 => RE_Bits_35, + 36 => RE_Bits_36, + 37 => RE_Bits_37, + 38 => RE_Bits_38, + 39 => RE_Bits_39, + 40 => RE_Bits_40, + 41 => RE_Bits_41, + 42 => RE_Bits_42, + 43 => RE_Bits_43, + 44 => RE_Bits_44, + 45 => RE_Bits_45, + 46 => RE_Bits_46, + 47 => RE_Bits_47, + 48 => RE_Bits_48, + 49 => RE_Bits_49, + 50 => RE_Bits_50, + 51 => RE_Bits_51, + 52 => RE_Bits_52, + 53 => RE_Bits_53, + 54 => RE_Bits_54, + 55 => RE_Bits_55, + 56 => RE_Bits_56, + 57 => RE_Bits_57, + 58 => RE_Bits_58, + 59 => RE_Bits_59, + 60 => RE_Bits_60, + 61 => RE_Bits_61, + 62 => RE_Bits_62, + 63 => RE_Bits_63); + + -- Array of Get routine entities. These are used to obtain an element from + -- a packed array. The N'th entry is used to obtain elements from a packed + -- array whose component size is N. RE_Null is used as a null entry, for + -- the cases where a library routine is not used. + + Get_Id : constant E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Get_03, + 04 => RE_Null, + 05 => RE_Get_05, + 06 => RE_Get_06, + 07 => RE_Get_07, + 08 => RE_Null, + 09 => RE_Get_09, + 10 => RE_Get_10, + 11 => RE_Get_11, + 12 => RE_Get_12, + 13 => RE_Get_13, + 14 => RE_Get_14, + 15 => RE_Get_15, + 16 => RE_Null, + 17 => RE_Get_17, + 18 => RE_Get_18, + 19 => RE_Get_19, + 20 => RE_Get_20, + 21 => RE_Get_21, + 22 => RE_Get_22, + 23 => RE_Get_23, + 24 => RE_Get_24, + 25 => RE_Get_25, + 26 => RE_Get_26, + 27 => RE_Get_27, + 28 => RE_Get_28, + 29 => RE_Get_29, + 30 => RE_Get_30, + 31 => RE_Get_31, + 32 => RE_Null, + 33 => RE_Get_33, + 34 => RE_Get_34, + 35 => RE_Get_35, + 36 => RE_Get_36, + 37 => RE_Get_37, + 38 => RE_Get_38, + 39 => RE_Get_39, + 40 => RE_Get_40, + 41 => RE_Get_41, + 42 => RE_Get_42, + 43 => RE_Get_43, + 44 => RE_Get_44, + 45 => RE_Get_45, + 46 => RE_Get_46, + 47 => RE_Get_47, + 48 => RE_Get_48, + 49 => RE_Get_49, + 50 => RE_Get_50, + 51 => RE_Get_51, + 52 => RE_Get_52, + 53 => RE_Get_53, + 54 => RE_Get_54, + 55 => RE_Get_55, + 56 => RE_Get_56, + 57 => RE_Get_57, + 58 => RE_Get_58, + 59 => RE_Get_59, + 60 => RE_Get_60, + 61 => RE_Get_61, + 62 => RE_Get_62, + 63 => RE_Get_63); + + -- Array of Get routine entities to be used in the case where the packed + -- array is itself a component of a packed structure, and therefore may not + -- be fully aligned. This only affects the even sizes, since for the odd + -- sizes, we do not get any fixed alignment in any case. + + GetU_Id : constant E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Get_03, + 04 => RE_Null, + 05 => RE_Get_05, + 06 => RE_GetU_06, + 07 => RE_Get_07, + 08 => RE_Null, + 09 => RE_Get_09, + 10 => RE_GetU_10, + 11 => RE_Get_11, + 12 => RE_GetU_12, + 13 => RE_Get_13, + 14 => RE_GetU_14, + 15 => RE_Get_15, + 16 => RE_Null, + 17 => RE_Get_17, + 18 => RE_GetU_18, + 19 => RE_Get_19, + 20 => RE_GetU_20, + 21 => RE_Get_21, + 22 => RE_GetU_22, + 23 => RE_Get_23, + 24 => RE_GetU_24, + 25 => RE_Get_25, + 26 => RE_GetU_26, + 27 => RE_Get_27, + 28 => RE_GetU_28, + 29 => RE_Get_29, + 30 => RE_GetU_30, + 31 => RE_Get_31, + 32 => RE_Null, + 33 => RE_Get_33, + 34 => RE_GetU_34, + 35 => RE_Get_35, + 36 => RE_GetU_36, + 37 => RE_Get_37, + 38 => RE_GetU_38, + 39 => RE_Get_39, + 40 => RE_GetU_40, + 41 => RE_Get_41, + 42 => RE_GetU_42, + 43 => RE_Get_43, + 44 => RE_GetU_44, + 45 => RE_Get_45, + 46 => RE_GetU_46, + 47 => RE_Get_47, + 48 => RE_GetU_48, + 49 => RE_Get_49, + 50 => RE_GetU_50, + 51 => RE_Get_51, + 52 => RE_GetU_52, + 53 => RE_Get_53, + 54 => RE_GetU_54, + 55 => RE_Get_55, + 56 => RE_GetU_56, + 57 => RE_Get_57, + 58 => RE_GetU_58, + 59 => RE_Get_59, + 60 => RE_GetU_60, + 61 => RE_Get_61, + 62 => RE_GetU_62, + 63 => RE_Get_63); + + -- Array of Set routine entities. These are used to assign an element of a + -- packed array. The N'th entry is used to assign elements for a packed + -- array whose component size is N. RE_Null is used as a null entry, for + -- the cases where a library routine is not used. + + Set_Id : constant E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Set_03, + 04 => RE_Null, + 05 => RE_Set_05, + 06 => RE_Set_06, + 07 => RE_Set_07, + 08 => RE_Null, + 09 => RE_Set_09, + 10 => RE_Set_10, + 11 => RE_Set_11, + 12 => RE_Set_12, + 13 => RE_Set_13, + 14 => RE_Set_14, + 15 => RE_Set_15, + 16 => RE_Null, + 17 => RE_Set_17, + 18 => RE_Set_18, + 19 => RE_Set_19, + 20 => RE_Set_20, + 21 => RE_Set_21, + 22 => RE_Set_22, + 23 => RE_Set_23, + 24 => RE_Set_24, + 25 => RE_Set_25, + 26 => RE_Set_26, + 27 => RE_Set_27, + 28 => RE_Set_28, + 29 => RE_Set_29, + 30 => RE_Set_30, + 31 => RE_Set_31, + 32 => RE_Null, + 33 => RE_Set_33, + 34 => RE_Set_34, + 35 => RE_Set_35, + 36 => RE_Set_36, + 37 => RE_Set_37, + 38 => RE_Set_38, + 39 => RE_Set_39, + 40 => RE_Set_40, + 41 => RE_Set_41, + 42 => RE_Set_42, + 43 => RE_Set_43, + 44 => RE_Set_44, + 45 => RE_Set_45, + 46 => RE_Set_46, + 47 => RE_Set_47, + 48 => RE_Set_48, + 49 => RE_Set_49, + 50 => RE_Set_50, + 51 => RE_Set_51, + 52 => RE_Set_52, + 53 => RE_Set_53, + 54 => RE_Set_54, + 55 => RE_Set_55, + 56 => RE_Set_56, + 57 => RE_Set_57, + 58 => RE_Set_58, + 59 => RE_Set_59, + 60 => RE_Set_60, + 61 => RE_Set_61, + 62 => RE_Set_62, + 63 => RE_Set_63); + + -- Array of Set routine entities to be used in the case where the packed + -- array is itself a component of a packed structure, and therefore may not + -- be fully aligned. This only affects the even sizes, since for the odd + -- sizes, we do not get any fixed alignment in any case. + + SetU_Id : constant E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Set_03, + 04 => RE_Null, + 05 => RE_Set_05, + 06 => RE_SetU_06, + 07 => RE_Set_07, + 08 => RE_Null, + 09 => RE_Set_09, + 10 => RE_SetU_10, + 11 => RE_Set_11, + 12 => RE_SetU_12, + 13 => RE_Set_13, + 14 => RE_SetU_14, + 15 => RE_Set_15, + 16 => RE_Null, + 17 => RE_Set_17, + 18 => RE_SetU_18, + 19 => RE_Set_19, + 20 => RE_SetU_20, + 21 => RE_Set_21, + 22 => RE_SetU_22, + 23 => RE_Set_23, + 24 => RE_SetU_24, + 25 => RE_Set_25, + 26 => RE_SetU_26, + 27 => RE_Set_27, + 28 => RE_SetU_28, + 29 => RE_Set_29, + 30 => RE_SetU_30, + 31 => RE_Set_31, + 32 => RE_Null, + 33 => RE_Set_33, + 34 => RE_SetU_34, + 35 => RE_Set_35, + 36 => RE_SetU_36, + 37 => RE_Set_37, + 38 => RE_SetU_38, + 39 => RE_Set_39, + 40 => RE_SetU_40, + 41 => RE_Set_41, + 42 => RE_SetU_42, + 43 => RE_Set_43, + 44 => RE_SetU_44, + 45 => RE_Set_45, + 46 => RE_SetU_46, + 47 => RE_Set_47, + 48 => RE_SetU_48, + 49 => RE_Set_49, + 50 => RE_SetU_50, + 51 => RE_Set_51, + 52 => RE_SetU_52, + 53 => RE_Set_53, + 54 => RE_SetU_54, + 55 => RE_Set_55, + 56 => RE_SetU_56, + 57 => RE_Set_57, + 58 => RE_SetU_58, + 59 => RE_Set_59, + 60 => RE_SetU_60, + 61 => RE_Set_61, + 62 => RE_SetU_62, + 63 => RE_Set_63); + ----------------- -- Subprograms -- ----------------- diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index ae97013a5c5..f48db6f605f 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -71,6 +71,14 @@ package body Exp_Prag is procedure Expand_Pragma_Loop_Variant (N : Node_Id); procedure Expand_Pragma_Psect_Object (N : Node_Id); procedure Expand_Pragma_Relative_Deadline (N : Node_Id); + procedure Expand_Pragma_Suppress_Initialization (N : Node_Id); + + procedure Undo_Initialization (Def_Id : Entity_Id; N : Node_Id); + -- This procedure is used to undo initialization already done for Def_Id, + -- which is always an E_Variable, in response to the occurrence of the + -- pragma N, a pragma Interface, Import, or Suppress_Initialization. In all + -- these cases we want no initialization to occur, but we have already done + -- the initialization by the time we see the pragma, so we have to undo it. ---------- -- Arg1 -- @@ -836,6 +844,9 @@ package body Exp_Prag is when Pragma_Relative_Deadline => Expand_Pragma_Relative_Deadline (N); + when Pragma_Suppress_Initialization => + Expand_Pragma_Suppress_Initialization (N); + -- All other pragmas need no expander action when others => null; @@ -1170,7 +1181,6 @@ package body Exp_Prag is procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is Def_Id : Entity_Id; - Init_Call : Node_Id; begin -- In Relaxed_RM_Semantics, support old Ada 83 style: @@ -1186,35 +1196,10 @@ package body Exp_Prag is Def_Id := Entity (Arg2 (N)); end if; - -- Variable case + -- Variable case (we have to undo any initialization already done) if Ekind (Def_Id) = E_Variable then - - -- When applied to a variable, the default initialization must not be - -- done. As it is already done when the pragma is found, we just get - -- rid of the call the initialization procedure which followed the - -- object declaration. The call is inserted after the declaration, - -- but validity checks may also have been inserted and thus the - -- initialization call does not necessarily appear immediately - -- after the object declaration. - - -- We can't use the freezing mechanism for this purpose, since we - -- have to elaborate the initialization expression when it is first - -- seen (so this elaboration cannot be deferred to the freeze point). - - -- Find and remove generated initialization call for object, if any - - Init_Call := Remove_Init_Call (Def_Id, Rep_Clause => N); - - -- Any default initialization expression should be removed (e.g. - -- null defaults for access objects, zero initialization of packed - -- bit arrays). Imported objects aren't allowed to have explicit - -- initialization, so the expression must have been generated by - -- the compiler. - - if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then - Set_Expression (Parent (Def_Id), Empty); - end if; + Undo_Initialization (Def_Id, N); -- Case of exception with convention C++ @@ -1831,4 +1816,53 @@ package body Exp_Prag is end if; end Expand_Pragma_Relative_Deadline; + ------------------------------------------- + -- Expand_Pragma_Suppress_Initialization -- + ------------------------------------------- + + procedure Expand_Pragma_Suppress_Initialization (N : Node_Id) is + Def_Id : constant Entity_Id := Entity (Arg1 (N)); + + begin + -- Variable case (we have to undo any initialization already done) + + if Ekind (Def_Id) = E_Variable then + Undo_Initialization (Def_Id, N); + end if; + end Expand_Pragma_Suppress_Initialization; + + ------------------------- + -- Undo_Initialization -- + ------------------------- + + procedure Undo_Initialization (Def_Id : Entity_Id; N : Node_Id) is + Init_Call : Node_Id; + + begin + -- When applied to a variable, the default initialization must not be + -- done. As it is already done when the pragma is found, we just get rid + -- of the call the initialization procedure which followed the object + -- declaration. The call is inserted after the declaration, but validity + -- checks may also have been inserted and thus the initialization call + -- does not necessarily appear immediately after the object declaration. + + -- We can't use the freezing mechanism for this purpose, since we have + -- to elaborate the initialization expression when it is first seen (so + -- this elaboration cannot be deferred to the freeze point). + + -- Find and remove generated initialization call for object, if any + + Init_Call := Remove_Init_Call (Def_Id, Rep_Clause => N); + + -- Any default initialization expression should be removed (e.g. + -- null defaults for access objects, zero initialization of packed + -- bit arrays). Imported objects aren't allowed to have explicit + -- initialization, so the expression must have been generated by + -- the compiler. + + if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then + Set_Expression (Parent (Def_Id), Empty); + end if; + end Undo_Initialization; + end Exp_Prag; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 981c7f5e104..2eea620a979 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2370,6 +2370,24 @@ package body Freeze is Set_Has_Non_Standard_Rep (Base_Type (Arr), True); Set_Is_Bit_Packed_Array (Base_Type (Arr), True); Set_Is_Packed (Base_Type (Arr), True); + + -- Make sure that we have the necessary routines to + -- implement the packing, and complain now if not. + + declare + CS : constant Int := UI_To_Int (Csiz); + RE : constant RE_Id := Get_Id (CS); + + begin + if RE /= RE_Null + and then not RTE_Available (RE) + then + Error_Msg_CRT + ("packing of " & UI_Image (Csiz) + & "-bit components", + First_Subtype (Etype (Arr))); + end if; + end; end if; end; end if; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index c4ae3ee8a74..44230c22c3d 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -330,6 +330,7 @@ Implementation Defined Aspects * Aspect Simple_Storage_Pool_Type:: * Aspect SPARK_Mode:: * Aspect Suppress_Debug_Info:: +* Aspect Suppress_Initialization:: * Aspect Test_Case:: * Aspect Thread_Local_Storage:: * Aspect Universal_Aliasing:: @@ -7029,13 +7030,16 @@ with this pragma and others compiled in normal mode without it. Syntax: @smallexample @c ada -pragma Suppress_Initialization ([Entity =>] subtype_Name); +pragma Suppress_Initialization ([Entity =>] variable_or_subtype_Name); @end smallexample @noindent -Here subtype_Name is the name introduced by a type declaration -or subtype declaration. -This pragma suppresses any implicit or explicit initialization +Here variable_or_subtype_Name is the name introduced by a type declaration +or subtype declaration or the name of a variable introduced by an +object declaration. + +In the case of a type or subtype +this pragma suppresses any implicit or explicit initialization for all variables of the given type or subtype, including initialization resulting from the use of pragmas Normalize_Scalars or Initialize_Scalars. @@ -7055,6 +7059,10 @@ you will have to use some non-portable mechanism (e.g. address overlays or unchecked conversion) to achieve required initialization of these fields before accessing any object of the corresponding type. +For the variable case, implicit initialization for the named variable +is suppressed, just as though its subtype had been given in a pragma +Suppress_Initialization, as described above. + @node Pragma Task_Name @unnumberedsec Pragma Task_Name @findex Task_Name @@ -8119,6 +8127,7 @@ or attribute definition clause. * Aspect Simple_Storage_Pool_Type:: * Aspect SPARK_Mode:: * Aspect Suppress_Debug_Info:: +* Aspect Suppress_Initialization:: * Aspect Test_Case:: * Aspect Thread_Local_Storage:: * Aspect Universal_Aliasing:: @@ -8494,6 +8503,12 @@ of a subprogram or package. @noindent This boolean aspect is equivalent to pragma @code{Suppress_Debug_Info}. +@node Aspect Suppress_Initialization +@unnumberedsec Aspect Suppress_Initialization +@findex Suppress_Initialization +@noindent +This boolean aspect is equivalent to pragma @code{Suppress_Initialization}. + @node Aspect Test_Case @unnumberedsec Aspect Test_Case @findex Test_Case diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index a31215f960b..7dc74ed4a7a 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -128,6 +128,60 @@ package body Rtsfind is -- The field First_Implicit_With in the unit table record are used to -- avoid creating duplicate with_clauses. + ---------------------------------------------- + -- Table of Predefined RE_Id Error Messages -- + ---------------------------------------------- + + -- If an attempt is made to load an entity, given an RE_Id value, and the + -- entity is not available in the current configuration, an error message + -- is given (see Entity_Not_Defined below). The general form of such an + -- error message is for example: + + -- entity "System.Pack_43.Bits_43" not defined + + -- The following table defines a set of RE_Id image values for which this + -- error message is specialized and replaced by specific text indicating + -- the exact message to be output. For example, in the case above, for the + -- RE_Id value RE_Bits_43, we do indeed specialize the message, and the + -- above generic message is replaced by: + + -- packed component size of 43 is not supported + + type CString_Ptr is access constant String; + + type PRE_Id_Entry is record + Str : CString_Ptr; + -- Pointer to string with the RE_Id image. The sequence ?? may appear + -- in which case it will match any characters in the RE_Id image value. + -- This is used to avoid the need for dozens of entries for RE_Bits_??. + + Msg : CString_Ptr; + -- Pointer to string with the corresponding error text. The sequence + -- ?? may appear, in which case, it is replaced by the corresponding + -- sequence ?? in the Str value (if the first ? is zero, then it is + -- omitted from the message). + end record; + + Str1 : aliased constant String := "RE_BITS_??"; + Str2 : aliased constant String := "RE_GET_??"; + Str3 : aliased constant String := "RE_SET_??"; + Str4 : aliased constant String := "RE_CALL_SIMPLE"; + + MsgPack : aliased constant String := + "packed component size of ?? is not supported"; + MsgRV : aliased constant String := + "task rendezvous is not supported"; + + PRE_Id_Table : constant array (Natural range <>) of PRE_Id_Entry := + (1 => (Str1'Access, MsgPack'Access), + 2 => (Str2'Access, MsgPack'Access), + 3 => (Str3'Access, MsgPack'Access), + 4 => (Str4'Access, MsgRV'Access)); + -- We will add entries to this table as we find cases where it is a good + -- idea to do so. By no means all the RE_Id values need entries, because + -- the expander often gives clear messages before it makes the Rtsfind + -- call expecting to find the entity. + ----------------------- -- Local Subprograms -- ----------------------- @@ -141,7 +195,8 @@ package body Rtsfind is 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 or - -- configurable run time mode as required). + -- configurable run time mode as required). See also table of pre-defined + -- messages for entities above (RE_Id_Messages). function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type; -- Retrieves the Unit Name given a unit id represented by its enumeration @@ -191,8 +246,7 @@ package body Rtsfind is 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 - -- is only effective in All_Errors mode. + -- corresponding to Id, appending the string given by Msg. function RE_Chars (E : RE_Id) return Name_Id; -- Given a RE_Id value returns the Chars of the corresponding entity @@ -432,6 +486,54 @@ package body Rtsfind is RTE_Error_Msg ("run-time configuration error"); end if; + -- See if this entry is to be found in the PRE_Id table that provides + -- specialized messages for some RE_Id values. + + for J in PRE_Id_Table'Range loop + declare + TStr : constant String := PRE_Id_Table (J).Str.all; + RStr : constant String := RE_Id'Image (Id); + TMsg : String := PRE_Id_Table (J).Msg.all; + LMsg : Natural := TMsg'Length; + + begin + if TStr'Length = RStr'Length then + for J in TStr'Range loop + if TStr (J) /= RStr (J) and then TStr (J) /= '?' then + goto Continue; + end if; + end loop; + + for J in TMsg'First .. TMsg'Last - 1 loop + if TMsg (J) = '?' then + for K in 1 .. TStr'Last loop + if TStr (K) = '?' then + if RStr (K) = '0' then + TMsg (J) := RStr (K + 1); + TMsg (J + 1 .. LMsg - 1) := TMsg (J + 2 .. LMsg); + LMsg := LMsg - 1; + else + TMsg (J .. J + 1) := RStr (K .. K + 1); + end if; + + exit; + end if; + end loop; + end if; + end loop; + + RTE_Error_Msg (TMsg (1 .. LMsg)); + return; + end if; + end; + + <> null; + end loop; + + -- We did not find an entry in the table, so output the generic entity + -- not found message, where the name of the entity corresponds to the + -- given RE_Id value. + Output_Entity_Name (Id, "not defined"); end Entity_Not_Defined; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 56c1e6dd1c9..ca1deebf12f 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -7553,15 +7553,17 @@ package body Sem_Attr is Static := Static and then not Is_Constr_Subt_For_U_Nominal (P_Type); Set_Is_Static_Expression (N, Static); - end if; while Present (Nod) loop if not Is_Static_Subtype (Etype (Nod)) then Static := False; Set_Is_Static_Expression (N, False); + elsif not Is_OK_Static_Subtype (Etype (Nod)) then Set_Raises_Constraint_Error (N); + Static := False; + Set_Is_Static_Expression (N, False); end if; -- If however the index type is generic, or derived from @@ -7591,6 +7593,7 @@ package body Sem_Attr is begin E := E1; + while Present (E) loop -- If expression is not static, then the attribute reference @@ -7638,6 +7641,7 @@ package body Sem_Attr is end loop; if Raises_Constraint_Error (Prefix (N)) then + Set_Is_Static_Expression (N, False); return; end if; end; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c1b9b6e58d0..32a3cf3a5e1 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -19927,8 +19927,9 @@ package body Sem_Prag is E := Entity (E_Id); - if not Is_Type (E) then - Error_Pragma_Arg ("pragma% requires type or subtype", Arg1); + if not Is_Type (E) and then Ekind (E) /= E_Variable then + Error_Pragma_Arg + ("pragma% requires variable, type or subtype", Arg1); end if; if Rep_Item_Too_Early (E, N) @@ -19953,7 +19954,7 @@ package body Sem_Prag is elsif Is_First_Subtype (E) then Set_Suppress_Initialization (Base_Type (E)); - -- For other than first subtype, set flag on subtype itself + -- For other than first subtype, set flag on subtype or variable else Set_Suppress_Initialization (E); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1eac0b2ffd0..4b00be0f3fc 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -16462,8 +16462,9 @@ package body Sem_Util is -- the entities within it). if (Is_Implementation_Defined (Val) - or else - Is_Implementation_Defined (Scope (Val))) + or else + (Present (Scope (Val)) + and then Is_Implementation_Defined (Scope (Val)))) and then not (Ekind_In (Val, E_Package, E_Generic_Package) and then Is_Library_Level_Entity (Val)) then diff --git a/gcc/ada/spark_xrefs.ads b/gcc/ada/spark_xrefs.ads index b17d7996c6c..41719ea3aec 100644 --- a/gcc/ada/spark_xrefs.ads +++ b/gcc/ada/spark_xrefs.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2014, 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- -- @@ -187,6 +187,21 @@ package SPARK_Xrefs is -- Examples: ??? add examples here + -- ------------------------------- + -- -- Generated Globals Section -- + -- ------------------------------- + + -- The Generated Globals section is located at the end of the ALI file. + + -- All lines introducing information related to the Generated Globals + -- have the string "GG" appearing in the beginning. This string ("GG") + -- should therefore not be used in the beginning of any line that does + -- not relate to Generated Globals. + + -- The processing (reading and writing) of this section happens in + -- package Flow_Computed_Globals (from the SPARK 2014 sources), for + -- further information please refer there. + ---------------- -- Xref Table -- ---------------- diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index 226c1877fca..7a554392a79 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -1662,6 +1662,15 @@ package body Uintp is Image_Out (Input, True, Format); end UI_Image; + function UI_Image + (Input : Uint; + Format : UI_Format := Auto) return String + is + begin + Image_Out (Input, True, Format); + return UI_Image_Buffer (1 .. UI_Image_Length); + end UI_Image; + ------------------------- -- UI_Is_In_Int_Range -- ------------------------- diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads index d76d2852704..1d90524b9a2 100644 --- a/gcc/ada/uintp.ads +++ b/gcc/ada/uintp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -299,10 +299,15 @@ package Uintp is -- followed by the value in UI_Image_Buffer. The form of the value is an -- integer literal in either decimal (no base) or hexadecimal (base 16) -- format. If Hex is True on entry, then hex mode is forced, otherwise - -- UI_Image makes a guess at which output format is more convenient. - -- The value must fit in UI_Image_Buffer. If necessary, the result is an - -- approximation of the proper value, using an exponential format. The - -- image of No_Uint is output as a single question mark. + -- UI_Image makes a guess at which output format is more convenient. The + -- value must fit in UI_Image_Buffer. The actual length of the result is + -- returned in UI_Image_Length. If necessary to meet this requirement, the + -- result is an approximation of the proper value, using an exponential + -- format. The image of No_Uint is output as a single question mark. + + function UI_Image (Input : Uint; Format : UI_Format := Auto) return String; + -- Functional form, in which the result is returned as a string. This call + -- also leaves the result in UI_Image_Buffer/Length as described above. procedure UI_Write (Input : Uint; Format : UI_Format := Auto); -- Writes a representation of Uint, consisting of a possible minus sign, -- 2.30.2