From 63bb4268049d7a6a1944c3a15b374bca8ccf2b45 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 14 Oct 2013 15:40:56 +0200 Subject: [PATCH] [multiple changes] 2013-10-14 Arnaud Charlet * exp_ch11.adb: Fix typo. 2013-10-14 Thomas Quinot * exp_util.ads: Minor reformatting. 2013-10-14 Ed Schonberg * sem_ch3.adb (Build_Derived_Record_Type): Reject full views with no explicit discriminant constraints, when the parents of the partial view and the full view are constrained subtypes with different constraints. 2013-10-14 Robert Dewar * freeze.adb (Freeze_Array_Type): New procedure, abstracts out this code from Freeze. (Freeze_Array_Type): Detect pragma Pack overriding foreign convention (Freeze_Record_Type): Ditto. From-SVN: r203553 --- gcc/ada/ChangeLog | 22 + gcc/ada/exp_ch11.adb | 2 +- gcc/ada/exp_util.ads | 6 +- gcc/ada/freeze.adb | 1053 ++++++++++++++++++++++-------------------- gcc/ada/sem_ch3.adb | 81 ++-- 5 files changed, 632 insertions(+), 532 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a102f90fb1db..dee974fe992f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,25 @@ +2013-10-14 Arnaud Charlet + + * exp_ch11.adb: Fix typo. + +2013-10-14 Thomas Quinot + + * exp_util.ads: Minor reformatting. + +2013-10-14 Ed Schonberg + + * sem_ch3.adb (Build_Derived_Record_Type): Reject full views + with no explicit discriminant constraints, when the parents of + the partial view and the full view are constrained subtypes with + different constraints. + +2013-10-14 Robert Dewar + + * freeze.adb (Freeze_Array_Type): New procedure, abstracts out + this code from Freeze. + (Freeze_Array_Type): Detect pragma Pack overriding foreign convention + (Freeze_Record_Type): Ditto. + 2013-10-14 Hristian Kirtchev * sem_prag.adb (Analyze_Dependency_Clause): Add new local variable diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 476b69ce538b..ba6a85278dcc 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1026,7 +1026,7 @@ package body Exp_Ch11 is -- end; -- This expansion is not performed when using GCC ZCX. Gigi - -- will insert a call to intialize the choice parameter. + -- will insert a call to initialize the choice parameter. if Present (Choice_Parameter (Handler)) and then Exception_Mechanism /= Back_End_Exceptions diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 7ca7c0132a8d..60a21324ce2f 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -359,9 +359,9 @@ package Exp_Util is -- by the compiler and used by GDB. procedure Evaluate_Name (Nam : Node_Id); - -- Remove the all side effects from a name which appears as part of an - -- object renaming declaration. More comments are needed here that explain - -- how this differs from Force_Evaluation and Remove_Side_Effects ??? + -- Remove all side effects from a name which appears as part of an object + -- renaming declaration. More comments are needed here that explain how + -- this differs from Force_Evaluation and Remove_Side_Effects ??? procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id); -- Rewrites Cond with the expression: Cond and then Cond1. If Cond is diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index b810a18e321b..2844ebfa3289 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1698,12 +1698,15 @@ package body Freeze is -- integer literal without an explicit corresponding size clause. The -- caller has checked that Utype is a modular integer type. + procedure Freeze_Array_Type (Arr : Entity_Id); + -- Freeze array type, including freezing index and component types + function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id; -- Create Freeze_Generic_Entity nodes for types declared in a generic -- package. Recurse on inner generic packages. procedure Freeze_Record_Type (Rec : Entity_Id); - -- Freeze each component, handle some representation clauses, and freeze + -- Freeze record type, including freezing component types, and freezing -- primitive operations if this is a tagged type. ------------------- @@ -1948,6 +1951,529 @@ package body Freeze is end if; end Check_Suspicious_Modulus; + ----------------------- + -- Freeze_Array_Type -- + ----------------------- + + procedure Freeze_Array_Type (Arr : Entity_Id) is + FS : constant Entity_Id := First_Subtype (Arr); + Ctyp : constant Entity_Id := Component_Type (Arr); + Clause : Entity_Id; + + Non_Standard_Enum : Boolean := False; + -- Set true if any of the index types is an enumeration type with a + -- non-standard representation. + + begin + Freeze_And_Append (Ctyp, N, Result); + + Indx := First_Index (Arr); + while Present (Indx) loop + Freeze_And_Append (Etype (Indx), N, Result); + + if Is_Enumeration_Type (Etype (Indx)) + and then Has_Non_Standard_Rep (Etype (Indx)) + then + Non_Standard_Enum := True; + end if; + + Next_Index (Indx); + end loop; + + -- Processing that is done only for base types + + if Ekind (Arr) = E_Array_Type then + + -- Propagate flags for component type + + if Is_Controlled (Component_Type (Arr)) + or else Has_Controlled_Component (Ctyp) + then + Set_Has_Controlled_Component (Arr); + end if; + + if Has_Unchecked_Union (Component_Type (Arr)) then + Set_Has_Unchecked_Union (Arr); + end if; + + -- Warn for pragma Pack overriding foreign convention + + if Has_Foreign_Convention (Ctyp) + and then Has_Pragma_Pack (Arr) + then + declare + CN : constant Name_Id := + Get_Convention_Name (Convention (Ctyp)); + PP : constant Node_Id := + Get_Pragma (First_Subtype (Arr), Pragma_Pack); + begin + if Present (PP) then + Error_Msg_Name_1 := CN; + Error_Msg_Sloc := Sloc (Arr); + Error_Msg_N + ("pragma Pack affects convention % components #??", + PP); + Error_Msg_Name_1 := CN; + Error_Msg_N + ("\array components may not have % compatible " + & "representation??", PP); + end if; + end; + end if; + + -- If packing was requested or if the component size was + -- set explicitly, then see if bit packing is required. This + -- processing is only done for base types, since all of the + -- representation aspects involved are type-related. This is not + -- just an optimization, if we start processing the subtypes, they + -- interfere with the settings on the base type (this is because + -- Is_Packed has a slightly different meaning before and after + -- freezing). + + declare + Csiz : Uint; + Esiz : Uint; + + begin + if (Is_Packed (Arr) or else Has_Pragma_Pack (Arr)) + and then Known_Static_RM_Size (Ctyp) + and then not Has_Component_Size_Clause (Arr) + then + Csiz := UI_Max (RM_Size (Ctyp), 1); + + elsif Known_Component_Size (Arr) then + Csiz := Component_Size (Arr); + + elsif not Known_Static_Esize (Ctyp) then + Csiz := Uint_0; + + else + Esiz := Esize (Ctyp); + + -- We can set the component size if it is less than 16, + -- rounding it up to the next storage unit size. + + if Esiz <= 8 then + Csiz := Uint_8; + elsif Esiz <= 16 then + Csiz := Uint_16; + else + Csiz := Uint_0; + end if; + + -- Set component size up to match alignment if it would + -- otherwise be less than the alignment. This deals with + -- cases of types whose alignment exceeds their size (the + -- padded type cases). + + if Csiz /= 0 then + declare + A : constant Uint := Alignment_In_Bits (Ctyp); + begin + if Csiz < A then + Csiz := A; + end if; + end; + end if; + end if; + + -- Case of component size that may result in packing + + if 1 <= Csiz and then Csiz <= 64 then + declare + Ent : constant Entity_Id := + First_Subtype (Arr); + Pack_Pragma : constant Node_Id := + Get_Rep_Pragma (Ent, Name_Pack); + Comp_Size_C : constant Node_Id := + Get_Attribute_Definition_Clause + (Ent, Attribute_Component_Size); + begin + -- Warn if we have pack and component size so that the + -- pack is ignored. + + -- Note: here we must check for the presence of a + -- component size before checking for a Pack pragma to + -- deal with the case where the array type is a derived + -- type whose parent is currently private. + + if Present (Comp_Size_C) + and then Has_Pragma_Pack (Ent) + and then Warn_On_Redundant_Constructs + then + Error_Msg_Sloc := Sloc (Comp_Size_C); + Error_Msg_NE + ("?r?pragma Pack for& ignored!", + Pack_Pragma, Ent); + Error_Msg_N + ("\?r?explicit component size given#!", + Pack_Pragma); + Set_Is_Packed (Base_Type (Ent), False); + Set_Is_Bit_Packed_Array (Base_Type (Ent), False); + end if; + + -- Set component size if not already set by a component + -- size clause. + + if not Present (Comp_Size_C) then + Set_Component_Size (Arr, Csiz); + end if; + + -- Check for base type of 8, 16, 32 bits, where an + -- unsigned subtype has a length one less than the + -- base type (e.g. Natural subtype of Integer). + + -- In such cases, if a component size was not set + -- explicitly, then generate a warning. + + if Has_Pragma_Pack (Arr) + and then not Present (Comp_Size_C) + and then + (Csiz = 7 or else Csiz = 15 or else Csiz = 31) + and then Esize (Base_Type (Ctyp)) = Csiz + 1 + then + Error_Msg_Uint_1 := Csiz; + + if Present (Pack_Pragma) then + Error_Msg_N + ("??pragma Pack causes component size " + & "to be ^!", Pack_Pragma); + Error_Msg_N + ("\??use Component_Size to set " + & "desired value!", Pack_Pragma); + end if; + end if; + + -- Actual packing is not needed for 8, 16, 32, 64. Also + -- not needed for 24 if alignment is 1. + + if Csiz = 8 + or else Csiz = 16 + or else Csiz = 32 + or else Csiz = 64 + or else (Csiz = 24 and then Alignment (Ctyp) = 1) + then + -- Here the array was requested to be packed, but + -- the packing request had no effect, so Is_Packed + -- is reset. + + -- Note: semantically this means that we lose track + -- of the fact that a derived type inherited a pragma + -- Pack that was non- effective, but that seems fine. + + -- We regard a Pack pragma as a request to set a + -- representation characteristic, and this request + -- may be ignored. + + Set_Is_Packed (Base_Type (Arr), False); + Set_Is_Bit_Packed_Array (Base_Type (Arr), False); + + if Known_Static_Esize (Component_Type (Arr)) + and then Esize (Component_Type (Arr)) = Csiz + then + Set_Has_Non_Standard_Rep + (Base_Type (Arr), False); + end if; + + -- In all other cases, packing is indeed needed + + else + 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); + end if; + end; + end if; + end; + + -- Check for Atomic_Components or Aliased with unsuitable packing + -- or explicit component size clause given. + + if (Has_Atomic_Components (Arr) + or else Has_Aliased_Components (Arr)) + and then (Has_Component_Size_Clause (Arr) + or else Is_Packed (Arr)) + then + Alias_Atomic_Check : declare + + procedure Complain_CS (T : String); + -- Outputs error messages for incorrect CS clause or pragma + -- Pack for aliased or atomic components (T is "aliased" or + -- "atomic"); + + ----------------- + -- Complain_CS -- + ----------------- + + procedure Complain_CS (T : String) is + begin + if Has_Component_Size_Clause (Arr) then + Clause := + Get_Attribute_Definition_Clause + (FS, Attribute_Component_Size); + + if Known_Static_Esize (Ctyp) then + Error_Msg_N + ("incorrect component size for " + & T & " components", Clause); + Error_Msg_Uint_1 := Esize (Ctyp); + Error_Msg_N + ("\only allowed value is^", Clause); + + else + Error_Msg_N + ("component size cannot be given for " + & T & " components", Clause); + end if; + + else + Error_Msg_N + ("cannot pack " & T & " components", + Get_Rep_Pragma (FS, Name_Pack)); + end if; + + return; + end Complain_CS; + + -- Start of processing for Alias_Atomic_Check + + begin + + -- If object size of component type isn't known, we cannot + -- be sure so we defer to the back end. + + if not Known_Static_Esize (Ctyp) then + null; + + -- Case where component size has no effect. First check for + -- object size of component type multiple of the storage + -- unit size. + + elsif Esize (Ctyp) mod System_Storage_Unit = 0 + + -- OK in both packing case and component size case if RM + -- size is known and static and same as the object size. + + and then + ((Known_Static_RM_Size (Ctyp) + and then Esize (Ctyp) = RM_Size (Ctyp)) + + -- Or if we have an explicit component size clause and + -- the component size and object size are equal. + + or else + (Has_Component_Size_Clause (Arr) + and then Component_Size (Arr) = Esize (Ctyp))) + then + null; + + elsif Has_Aliased_Components (Arr) + or else Is_Aliased (Ctyp) + then + Complain_CS ("aliased"); + + elsif Has_Atomic_Components (Arr) + or else Is_Atomic (Ctyp) + then + Complain_CS ("atomic"); + end if; + end Alias_Atomic_Check; + end if; + + -- Warn for case of atomic type + + Clause := Get_Rep_Pragma (FS, Name_Atomic); + + if Present (Clause) + and then not Addressable (Component_Size (FS)) + then + Error_Msg_NE + ("non-atomic components of type& may not be " + & "accessible by separate tasks??", Clause, Arr); + + if Has_Component_Size_Clause (Arr) then + Error_Msg_Sloc := + Sloc + (Get_Attribute_Definition_Clause + (FS, Attribute_Component_Size)); + Error_Msg_N + ("\because of component size clause#??", + Clause); + + elsif Has_Pragma_Pack (Arr) then + Error_Msg_Sloc := + Sloc (Get_Rep_Pragma (FS, Name_Pack)); + Error_Msg_N + ("\because of pragma Pack#??", Clause); + end if; + end if; + + -- Check for scalar storage order + + if Present (Get_Attribute_Definition_Clause + (Arr, Attribute_Scalar_Storage_Order)) + then + Check_Component_Storage_Order (Arr, Empty); + end if; + + -- Processing that is done only for subtypes + + else + -- Acquire alignment from base type + + if Unknown_Alignment (Arr) then + Set_Alignment (Arr, Alignment (Base_Type (Arr))); + Adjust_Esize_Alignment (Arr); + end if; + end if; + + -- Specific checks for bit-packed arrays + + if Is_Bit_Packed_Array (Arr) then + + -- Check number of elements for bit packed arrays that come from + -- source and have compile time known ranges. The bit-packed + -- arrays circuitry does not support arrays with more than + -- Integer'Last + 1 elements, and when this restriction is + -- violated, causes incorrect data access. + + -- For the case where this is not compile time known, a run-time + -- check should be generated??? + + if Comes_From_Source (Arr) and then Is_Constrained (Arr) then + declare + Elmts : Uint; + Index : Node_Id; + Ilen : Node_Id; + Ityp : Entity_Id; + + begin + Elmts := Uint_1; + Index := First_Index (Arr); + while Present (Index) loop + Ityp := Etype (Index); + + -- Never generate an error if any index is of a generic + -- type. We will check this in instances. + + if Is_Generic_Type (Ityp) then + Elmts := Uint_0; + exit; + end if; + + Ilen := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Ityp, Loc), + Attribute_Name => Name_Range_Length); + Analyze_And_Resolve (Ilen); + + -- No attempt is made to check number of elements + -- if not compile time known. + + if Nkind (Ilen) /= N_Integer_Literal then + Elmts := Uint_0; + exit; + end if; + + Elmts := Elmts * Intval (Ilen); + Next_Index (Index); + end loop; + + if Elmts > Intval (High_Bound + (Scalar_Range + (Standard_Integer))) + 1 + then + Error_Msg_N + ("bit packed array type may not have " + & "more than Integer''Last+1 elements", Arr); + end if; + end; + end if; + + -- Check size + + if Known_RM_Size (Arr) then + declare + SizC : constant Node_Id := Size_Clause (Arr); + + Discard : Boolean; + pragma Warnings (Off, Discard); + + begin + -- It is not clear if it is possible to have no size clause + -- at this stage, but it is not worth worrying about. Post + -- error on the entity name in the size clause if present, + -- else on the type entity itself. + + if Present (SizC) then + Check_Size (Name (SizC), Arr, RM_Size (Arr), Discard); + else + Check_Size (Arr, Arr, RM_Size (Arr), Discard); + end if; + end; + end if; + end if; + + -- If any of the index types was an enumeration type with a + -- non-standard rep clause, then we indicate that the array type + -- is always packed (even if it is not bit packed). + + if Non_Standard_Enum then + Set_Has_Non_Standard_Rep (Base_Type (Arr)); + Set_Is_Packed (Base_Type (Arr)); + end if; + + Set_Component_Alignment_If_Not_Set (Arr); + + -- If the array is packed, we must create the packed array type to be + -- used to actually implement the type. This is only needed for real + -- array types (not for string literal types, since they are present + -- only for the front end). + + if Is_Packed (Arr) + and then Ekind (Arr) /= E_String_Literal_Subtype + then + Create_Packed_Array_Type (Arr); + Freeze_And_Append (Packed_Array_Type (Arr), N, Result); + + -- Size information of packed array type is copied to the array + -- type, since this is really the representation. But do not + -- override explicit existing size values. If the ancestor subtype + -- is constrained the packed_array_type will be inherited from it, + -- but the size may have been provided already, and must not be + -- overridden either. + + if not Has_Size_Clause (Arr) + and then + (No (Ancestor_Subtype (Arr)) + or else not Has_Size_Clause (Ancestor_Subtype (Arr))) + then + Set_Esize (Arr, Esize (Packed_Array_Type (Arr))); + Set_RM_Size (Arr, RM_Size (Packed_Array_Type (Arr))); + end if; + + if not Has_Alignment_Clause (Arr) then + Set_Alignment (Arr, Alignment (Packed_Array_Type (Arr))); + end if; + end if; + + -- For non-packed arrays set the alignment of the array to the + -- alignment of the component type if it is unknown. Skip this + -- in atomic case (atomic arrays may need larger alignments). + + if not Is_Packed (Arr) + and then Unknown_Alignment (Arr) + and then Known_Alignment (Ctyp) + and then Known_Static_Component_Size (Arr) + and then Known_Static_Esize (Ctyp) + and then Esize (Ctyp) = Component_Size (Arr) + and then not Is_Atomic (Arr) + then + Set_Alignment (Arr, Alignment (Component_Type (Arr))); + end if; + end Freeze_Array_Type; + ----------------------------- -- Freeze_Generic_Entities -- ----------------------------- @@ -2201,6 +2727,31 @@ package body Freeze is Freeze_And_Append (Etype (Comp), N, Result); + -- Warn for pragma Pack overriding foreign convention + + if Has_Foreign_Convention (Etype (Comp)) + and then Has_Pragma_Pack (Rec) + then + declare + CN : constant Name_Id := + Get_Convention_Name (Convention (Etype (Comp))); + PP : constant Node_Id := + Get_Pragma (Rec, Pragma_Pack); + begin + if Present (PP) then + Error_Msg_Name_1 := CN; + Error_Msg_Sloc := Sloc (Comp); + Error_Msg_N + ("pragma Pack affects convention % component#??", + PP); + Error_Msg_Name_1 := CN; + Error_Msg_NE + ("\component & may not have % compatible " + & "representation??", PP, Comp); + end if; + end; + end if; + -- Check for error of component clause given for variable -- sized type. We have to delay this test till this point, -- since the component type has to be frozen for us to know @@ -3749,506 +4300,10 @@ package body Freeze is Inherit_Aspects_At_Freeze_Point (E); end if; - -- For array type, freeze index types and component type first - -- before freezing the array (RM 13.14(15)). + -- Array type if Is_Array_Type (E) then - declare - FS : constant Entity_Id := First_Subtype (E); - Ctyp : constant Entity_Id := Component_Type (E); - Clause : Entity_Id; - - Non_Standard_Enum : Boolean := False; - -- Set true if any of the index types is an enumeration type - -- with a non-standard representation. - - begin - Freeze_And_Append (Ctyp, N, Result); - - Indx := First_Index (E); - while Present (Indx) loop - Freeze_And_Append (Etype (Indx), N, Result); - - if Is_Enumeration_Type (Etype (Indx)) - and then Has_Non_Standard_Rep (Etype (Indx)) - then - Non_Standard_Enum := True; - end if; - - Next_Index (Indx); - end loop; - - -- Processing that is done only for base types - - if Ekind (E) = E_Array_Type then - - -- Propagate flags for component type - - if Is_Controlled (Component_Type (E)) - or else Has_Controlled_Component (Ctyp) - then - Set_Has_Controlled_Component (E); - end if; - - if Has_Unchecked_Union (Component_Type (E)) then - Set_Has_Unchecked_Union (E); - end if; - - -- If packing was requested or if the component size was set - -- explicitly, then see if bit packing is required. This - -- processing is only done for base types, since all the - -- representation aspects involved are type-related. This - -- is not just an optimization, if we start processing the - -- subtypes, they interfere with the settings on the base - -- type (this is because Is_Packed has a slightly different - -- meaning before and after freezing). - - declare - Csiz : Uint; - Esiz : Uint; - - begin - if (Is_Packed (E) or else Has_Pragma_Pack (E)) - and then Known_Static_RM_Size (Ctyp) - and then not Has_Component_Size_Clause (E) - then - Csiz := UI_Max (RM_Size (Ctyp), 1); - - elsif Known_Component_Size (E) then - Csiz := Component_Size (E); - - elsif not Known_Static_Esize (Ctyp) then - Csiz := Uint_0; - - else - Esiz := Esize (Ctyp); - - -- We can set the component size if it is less than - -- 16, rounding it up to the next storage unit size. - - if Esiz <= 8 then - Csiz := Uint_8; - elsif Esiz <= 16 then - Csiz := Uint_16; - else - Csiz := Uint_0; - end if; - - -- Set component size up to match alignment if it - -- would otherwise be less than the alignment. This - -- deals with cases of types whose alignment exceeds - -- their size (padded types). - - if Csiz /= 0 then - declare - A : constant Uint := Alignment_In_Bits (Ctyp); - begin - if Csiz < A then - Csiz := A; - end if; - end; - end if; - end if; - - -- Case of component size that may result in packing - - if 1 <= Csiz and then Csiz <= 64 then - declare - Ent : constant Entity_Id := - First_Subtype (E); - Pack_Pragma : constant Node_Id := - Get_Rep_Pragma (Ent, Name_Pack); - Comp_Size_C : constant Node_Id := - Get_Attribute_Definition_Clause - (Ent, Attribute_Component_Size); - begin - -- Warn if we have pack and component size so that - -- the pack is ignored. - - -- Note: here we must check for the presence of a - -- component size before checking for a Pack pragma - -- to deal with the case where the array type is a - -- derived type whose parent is currently private. - - if Present (Comp_Size_C) - and then Has_Pragma_Pack (Ent) - and then Warn_On_Redundant_Constructs - then - Error_Msg_Sloc := Sloc (Comp_Size_C); - Error_Msg_NE - ("?r?pragma Pack for& ignored!", - Pack_Pragma, Ent); - Error_Msg_N - ("\?r?explicit component size given#!", - Pack_Pragma); - Set_Is_Packed (Base_Type (Ent), False); - Set_Is_Bit_Packed_Array (Base_Type (Ent), False); - end if; - - -- Set component size if not already set by a - -- component size clause. - - if not Present (Comp_Size_C) then - Set_Component_Size (E, Csiz); - end if; - - -- Check for base type of 8, 16, 32 bits, where an - -- unsigned subtype has a length one less than the - -- base type (e.g. Natural subtype of Integer). - - -- In such cases, if a component size was not set - -- explicitly, then generate a warning. - - if Has_Pragma_Pack (E) - and then not Present (Comp_Size_C) - and then - (Csiz = 7 or else Csiz = 15 or else Csiz = 31) - and then Esize (Base_Type (Ctyp)) = Csiz + 1 - then - Error_Msg_Uint_1 := Csiz; - - if Present (Pack_Pragma) then - Error_Msg_N - ("??pragma Pack causes component size " - & "to be ^!", Pack_Pragma); - Error_Msg_N - ("\??use Component_Size to set " - & "desired value!", Pack_Pragma); - end if; - end if; - - -- Actual packing is not needed for 8, 16, 32, 64. - -- Also not needed for 24 if alignment is 1. - - if Csiz = 8 - or else Csiz = 16 - or else Csiz = 32 - or else Csiz = 64 - or else (Csiz = 24 and then Alignment (Ctyp) = 1) - then - -- Here the array was requested to be packed, - -- but the packing request had no effect, so - -- Is_Packed is reset. - - -- Note: semantically this means that we lose - -- track of the fact that a derived type - -- inherited a pragma Pack that was non- - -- effective, but that seems fine. - - -- We regard a Pack pragma as a request to set - -- a representation characteristic, and this - -- request may be ignored. - - Set_Is_Packed (Base_Type (E), False); - Set_Is_Bit_Packed_Array (Base_Type (E), False); - - if Known_Static_Esize (Component_Type (E)) - and then Esize (Component_Type (E)) = Csiz - then - Set_Has_Non_Standard_Rep - (Base_Type (E), False); - end if; - - -- In all other cases, packing is indeed needed - - else - Set_Has_Non_Standard_Rep (Base_Type (E), True); - Set_Is_Bit_Packed_Array (Base_Type (E), True); - Set_Is_Packed (Base_Type (E), True); - end if; - end; - end if; - end; - - -- Check for Atomic_Components or Aliased with unsuitable - -- packing or explicit component size clause given. - - if (Has_Atomic_Components (E) - or else Has_Aliased_Components (E)) - and then (Has_Component_Size_Clause (E) - or else Is_Packed (E)) - then - Alias_Atomic_Check : declare - - procedure Complain_CS (T : String); - -- Outputs error messages for incorrect CS clause or - -- pragma Pack for aliased or atomic components (T is - -- "aliased" or "atomic"); - - ----------------- - -- Complain_CS -- - ----------------- - - procedure Complain_CS (T : String) is - begin - if Has_Component_Size_Clause (E) then - Clause := - Get_Attribute_Definition_Clause - (FS, Attribute_Component_Size); - - if Known_Static_Esize (Ctyp) then - Error_Msg_N - ("incorrect component size for " - & T & " components", Clause); - Error_Msg_Uint_1 := Esize (Ctyp); - Error_Msg_N - ("\only allowed value is^", Clause); - - else - Error_Msg_N - ("component size cannot be given for " - & T & " components", Clause); - end if; - - else - Error_Msg_N - ("cannot pack " & T & " components", - Get_Rep_Pragma (FS, Name_Pack)); - end if; - - return; - end Complain_CS; - - -- Start of processing for Alias_Atomic_Check - - begin - - -- If object size of component type isn't known, we - -- cannot be sure so we defer to the back end. - - if not Known_Static_Esize (Ctyp) then - null; - - -- Case where component size has no effect. First - -- check for object size of component type multiple - -- of the storage unit size. - - elsif Esize (Ctyp) mod System_Storage_Unit = 0 - - -- OK in both packing case and component size case - -- if RM size is known and static and the same as - -- the object size. - - and then - ((Known_Static_RM_Size (Ctyp) - and then Esize (Ctyp) = RM_Size (Ctyp)) - - -- Or if we have an explicit component size - -- clause and the component size and object size - -- are equal. - - or else - (Has_Component_Size_Clause (E) - and then Component_Size (E) = Esize (Ctyp))) - then - null; - - elsif Has_Aliased_Components (E) - or else Is_Aliased (Ctyp) - then - Complain_CS ("aliased"); - - elsif Has_Atomic_Components (E) - or else Is_Atomic (Ctyp) - then - Complain_CS ("atomic"); - end if; - end Alias_Atomic_Check; - end if; - - -- Warn for case of atomic type - - Clause := Get_Rep_Pragma (FS, Name_Atomic); - - if Present (Clause) - and then not Addressable (Component_Size (FS)) - then - Error_Msg_NE - ("non-atomic components of type& may not be " - & "accessible by separate tasks??", Clause, E); - - if Has_Component_Size_Clause (E) then - Error_Msg_Sloc := - Sloc - (Get_Attribute_Definition_Clause - (FS, Attribute_Component_Size)); - Error_Msg_N - ("\because of component size clause#??", - Clause); - - elsif Has_Pragma_Pack (E) then - Error_Msg_Sloc := - Sloc (Get_Rep_Pragma (FS, Name_Pack)); - Error_Msg_N - ("\because of pragma Pack#??", Clause); - end if; - end if; - - -- Check for scalar storage order - - if Present (Get_Attribute_Definition_Clause - (E, Attribute_Scalar_Storage_Order)) - then - Check_Component_Storage_Order (E, Empty); - end if; - - -- Processing that is done only for subtypes - - else - -- Acquire alignment from base type - - if Unknown_Alignment (E) then - Set_Alignment (E, Alignment (Base_Type (E))); - Adjust_Esize_Alignment (E); - end if; - end if; - - -- Specific checks for bit-packed arrays - - if Is_Bit_Packed_Array (E) then - - -- Check number of elements for bit packed arrays that come - -- from source and have compile time known ranges. The - -- bit-packed arrays circuitry does not support arrays - -- with more than Integer'Last + 1 elements, and when this - -- restriction is violated, causes incorrect data access. - - -- For the case where this is not compile time known, a - -- run-time check should be generated??? - - if Comes_From_Source (E) and then Is_Constrained (E) then - declare - Elmts : Uint; - Index : Node_Id; - Ilen : Node_Id; - Ityp : Entity_Id; - - begin - Elmts := Uint_1; - Index := First_Index (E); - while Present (Index) loop - Ityp := Etype (Index); - - -- Never generate an error if any index is of a - -- generic type. We will check this in instances. - - if Is_Generic_Type (Ityp) then - Elmts := Uint_0; - exit; - end if; - - Ilen := - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Ityp, Loc), - Attribute_Name => Name_Range_Length); - Analyze_And_Resolve (Ilen); - - -- No attempt is made to check number of elements - -- if not compile time known. - - if Nkind (Ilen) /= N_Integer_Literal then - Elmts := Uint_0; - exit; - end if; - - Elmts := Elmts * Intval (Ilen); - Next_Index (Index); - end loop; - - if Elmts > Intval (High_Bound - (Scalar_Range - (Standard_Integer))) + 1 - then - Error_Msg_N - ("bit packed array type may not have " - & "more than Integer''Last+1 elements", E); - end if; - end; - end if; - - -- Check size - - if Known_RM_Size (E) then - declare - SizC : constant Node_Id := Size_Clause (E); - - Discard : Boolean; - pragma Warnings (Off, Discard); - - begin - -- It is not clear if it is possible to have no size - -- clause at this stage, but it is not worth worrying - -- about. Post error on the entity name in the size - -- clause if present, else on the type entity itself. - - if Present (SizC) then - Check_Size (Name (SizC), E, RM_Size (E), Discard); - else - Check_Size (E, E, RM_Size (E), Discard); - end if; - end; - end if; - end if; - - -- If any of the index types was an enumeration type with a - -- non-standard rep clause, then we indicate that the array - -- type is always packed (even if it is not bit packed). - - if Non_Standard_Enum then - Set_Has_Non_Standard_Rep (Base_Type (E)); - Set_Is_Packed (Base_Type (E)); - end if; - - Set_Component_Alignment_If_Not_Set (E); - - -- If the array is packed, we must create the packed array - -- type to be used to actually implement the type. This is - -- only needed for real array types (not for string literal - -- types, since they are present only for the front end). - - if Is_Packed (E) - and then Ekind (E) /= E_String_Literal_Subtype - then - Create_Packed_Array_Type (E); - Freeze_And_Append (Packed_Array_Type (E), N, Result); - - -- Size information of packed array type is copied to the - -- array type, since this is really the representation. But - -- do not override explicit existing size values. If the - -- ancestor subtype is constrained the packed_array_type - -- will be inherited from it, but the size may have been - -- provided already, and must not be overridden either. - - if not Has_Size_Clause (E) - and then - (No (Ancestor_Subtype (E)) - or else not Has_Size_Clause (Ancestor_Subtype (E))) - then - Set_Esize (E, Esize (Packed_Array_Type (E))); - Set_RM_Size (E, RM_Size (Packed_Array_Type (E))); - end if; - - if not Has_Alignment_Clause (E) then - Set_Alignment (E, Alignment (Packed_Array_Type (E))); - end if; - end if; - - -- For non-packed arrays set the alignment of the array to the - -- alignment of the component type if it is unknown. Skip this - -- in atomic case (atomic arrays may need larger alignments). - - if not Is_Packed (E) - and then Unknown_Alignment (E) - and then Known_Alignment (Ctyp) - and then Known_Static_Component_Size (E) - and then Known_Static_Esize (Ctyp) - and then Esize (Ctyp) = Component_Size (E) - and then not Is_Atomic (E) - then - Set_Alignment (E, Alignment (Component_Type (E))); - end if; - end; + Freeze_Array_Type (E); -- For a class-wide type, the corresponding specific type is -- frozen as well (RM 13.14(15)) diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 4440910ab693..9ef25f73c855 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1001,7 +1001,7 @@ package body Sem_Ch3 is if Nkind (Def) in N_Has_Etype then if Etype (Def) = T_Name then Error_Msg_N - ("type& cannot be used before end of its declaration", Def); + ("typer cannot be used before end of its declaration", Def); end if; -- If this is not a subtype, then this is an access_definition @@ -7337,45 +7337,68 @@ package body Sem_Ch3 is and then (Is_Constrained (Parent_Type) or else Constraint_Present) then -- First, we must analyze the constraint (see comment in point 5.) + -- The constraint may come from the subtype indication of the full + -- declaration. if Constraint_Present then - New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic); + New_Discrs := + Build_Discriminant_Constraints (Parent_Type, Indic); - if Has_Discriminants (Derived_Type) - and then Has_Private_Declaration (Derived_Type) - and then Present (Discriminant_Constraint (Derived_Type)) - then - -- Verify that constraints of the full view statically match - -- those given in the partial view. + -- If there is no explicit constraint, there might be one that is + -- inherited from a constrained parent type. In that case verify that + -- it conforms to the constraint in the partial view. In perverse + -- cases the parent subtypes of the partial and full view can have + -- different constraints. - declare - C1, C2 : Elmt_Id; + elsif Present (Stored_Constraint (Parent_Type)) then + New_Discrs := Stored_Constraint (Parent_Type); - begin - C1 := First_Elmt (New_Discrs); - C2 := First_Elmt (Discriminant_Constraint (Derived_Type)); - while Present (C1) and then Present (C2) loop - if Fully_Conformant_Expressions (Node (C1), Node (C2)) - or else - (Is_OK_Static_Expression (Node (C1)) - and then - Is_OK_Static_Expression (Node (C2)) - and then - Expr_Value (Node (C1)) = Expr_Value (Node (C2))) - then - null; + else + New_Discrs := No_Elist; + end if; - else + if Has_Discriminants (Derived_Type) + and then Has_Private_Declaration (Derived_Type) + and then Present (Discriminant_Constraint (Derived_Type)) + and then Present (New_Discrs) + then + -- Verify that constraints of the full view statically match + -- those given in the partial view. + + declare + C1, C2 : Elmt_Id; + Error_Node : Node_Id; + + begin + C1 := First_Elmt (New_Discrs); + C2 := First_Elmt (Discriminant_Constraint (Derived_Type)); + while Present (C1) and then Present (C2) loop + if Fully_Conformant_Expressions (Node (C1), Node (C2)) + or else + (Is_OK_Static_Expression (Node (C1)) + and then + Is_OK_Static_Expression (Node (C2)) + and then + Expr_Value (Node (C1)) = Expr_Value (Node (C2))) + then + null; + + else + if Constraint_Present then Error_Msg_N ( "constraint not conformant to previous declaration", Node (C1)); + else + Error_Msg_N ( + "constraint of full view is incompatible " & + "with partial view", N); end if; + end if; - Next_Elmt (C1); - Next_Elmt (C2); - end loop; - end; - end if; + Next_Elmt (C1); + Next_Elmt (C2); + end loop; + end; end if; -- Insert and analyze the declaration for the unconstrained base type -- 2.47.2