From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id C42633857C51; Wed, 20 Oct 2021 10:18:14 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org C42633857C51 MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Pierre-Marie de Rodat To: gcc-cvs@gcc.gnu.org Subject: [gcc r12-4542] [Ada] tech debt: Clean up Uint fields, such as Esize X-Act-Checkin: gcc X-Git-Author: Bob Duff X-Git-Refname: refs/heads/master X-Git-Oldrev: 749e01a5f310f2c4327f030d425aa6e23afbbbd5 X-Git-Newrev: 36e38022125f2f336e5d281fb3e5e66191d21e73 Message-Id: <20211020101814.C42633857C51@sourceware.org> Date: Wed, 20 Oct 2021 10:18:14 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Wed, 20 Oct 2021 10:18:14 -0000 https://gcc.gnu.org/g:36e38022125f2f336e5d281fb3e5e66191d21e73 commit r12-4542-g36e38022125f2f336e5d281fb3e5e66191d21e73 Author: Bob Duff Date: Wed Oct 6 09:03:53 2021 -0400 [Ada] tech debt: Clean up Uint fields, such as Esize gcc/ada/ * atree.ads: Comment improvements. How is a "completely new node" different from a "new node"? Document default values corresponding to field types. * exp_ch7.adb (Process_Tagged_Type_Declaration): Use higher-level Scope_Depth instead of Scope_Depth_Value. Remove confusing comment: not clear what a "true" library level package is. * uintp.adb (Image_Out): Print No_Uint in a more readable way. * gen_il-gen.adb, gen_il-gen-gen_entities.adb, gen_il-gen-gen_nodes.adb, gen_il-types.ads: Tighten up the subtypes of fields whose type is Uint, where possible; use more-constrained subtypes such as Unat. * einfo-utils.adb, einfo-utils.ads, exp_attr.adb, exp_ch3.adb, exp_intr.adb, exp_unst.adb, exp_util.adb, freeze.adb, repinfo.adb, sem.adb, sem_ch12.adb, sem_ch13.adb, sem_ch3.adb, sem_ch8.adb, sem_util.adb, sprint.adb, treepr.adb: No longer use Uint_0 to indicate "unknown" or "not yet known" for various fields whose type is Uint. Use No_Uint for that, except in a small number of legacy cases that cause test failures. Protect many queries of such fields with calls to Known_... functions. Improve comments. * exp_aggr.adb: Likewise. (Is_OK_Aggregate): Check whether Csiz is present. (Aggr_Assignment_OK_For_Backend): Ensure we do not access an uninitialized size. * exp_strm.adb (Build_Elementary_Input_Call, Build_Elementary_Write_Call): Check whether P_Size is present. * cstand.adb: Leave Component_Size of Any_Composite unknown. Similar for RM_Size of Standard_Exception_Type. These should not be used. * einfo.ads: Comment improvements. * exp_disp.ads: Minor. * gen_il-internals.ads, gen_il-internals.adb: Minor. * sinfo-utils.adb: Take advantage of full-coverage rules. * types.h: Minor. Diff: --- gcc/ada/atree.ads | 45 ++++--- gcc/ada/cstand.adb | 6 +- gcc/ada/einfo-utils.adb | 72 ++++------- gcc/ada/einfo-utils.ads | 96 +++++++-------- gcc/ada/einfo.ads | 5 +- gcc/ada/exp_aggr.adb | 9 +- gcc/ada/exp_attr.adb | 5 +- gcc/ada/exp_ch3.adb | 11 +- gcc/ada/exp_ch7.adb | 7 +- gcc/ada/exp_disp.ads | 6 +- gcc/ada/exp_intr.adb | 5 +- gcc/ada/exp_strm.adb | 4 +- gcc/ada/exp_unst.adb | 4 +- gcc/ada/exp_util.adb | 3 +- gcc/ada/freeze.adb | 38 ++++-- gcc/ada/gen_il-gen-gen_entities.adb | 38 +++--- gcc/ada/gen_il-gen-gen_nodes.adb | 6 +- gcc/ada/gen_il-gen.adb | 7 ++ gcc/ada/gen_il-internals.adb | 2 +- gcc/ada/gen_il-internals.ads | 7 +- gcc/ada/gen_il-types.ads | 2 + gcc/ada/repinfo.adb | 72 +++++------ gcc/ada/sem.adb | 14 ++- gcc/ada/sem_ch12.adb | 4 +- gcc/ada/sem_ch13.adb | 6 +- gcc/ada/sem_ch3.adb | 234 ++++++++++++++++++------------------ gcc/ada/sem_ch8.adb | 16 ++- gcc/ada/sem_util.adb | 7 +- gcc/ada/sinfo-utils.adb | 29 +++-- gcc/ada/sprint.adb | 7 +- gcc/ada/treepr.adb | 15 ++- gcc/ada/types.h | 8 +- gcc/ada/uintp.adb | 18 ++- 33 files changed, 431 insertions(+), 377 deletions(-) diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 2f3ca40ad08..4861236b669 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -230,11 +230,18 @@ package Atree is function New_Node (New_Node_Kind : Node_Kind; New_Sloc : Source_Ptr) return Node_Id; - -- Allocates a completely new node with the given node type and source - -- location values. All other fields are set to their standard defaults: + -- Allocates a new node with the given node type and source location + -- values. Fields have defaults depending on their type: + + -- Flag: False + -- Node_Id: Empty + -- List_Id: Empty + -- Elist_Id: No_Elist + -- Uint: No_Uint -- - -- Empty for all FieldN fields - -- False for all FlagN fields + -- Name_Id, String_Id, Valid_Uint, Unat, Upos, Nonzero_Uint, Ureal: + -- No default. This means it is an error to call the getter before + -- calling the setter. -- -- The usual approach is to build a new node using this function and -- then, using the value returned, use the Set_xxx functions to set @@ -288,16 +295,16 @@ package Atree is -- with copying aspect specifications where this is required. function New_Copy (Source : Node_Id) return Node_Id; - -- This function allocates a completely new node, and then initializes - -- it by copying the contents of the source node into it. The contents of - -- the source node is not affected. The target node is always marked as - -- not being in a list (even if the source is a list member), and not - -- overloaded. The new node will have an extension if the source has - -- an extension. New_Copy (Empty) returns Empty, and New_Copy (Error) - -- returns Error. Note that, unlike Copy_Separate_Tree, New_Copy does not - -- recursively copy any descendants, so in general parent pointers are not - -- set correctly for the descendants of the copied node. Both normal and - -- extended nodes (entities) may be copied using New_Copy. + -- This function allocates a new node, and then initializes it by copying + -- the contents of the source node into it. The contents of the source node + -- is not affected. The target node is always marked as not being in a list + -- (even if the source is a list member), and not overloaded. The new node + -- will have an extension if the source has an extension. New_Copy (Empty) + -- returns Empty, and New_Copy (Error) returns Error. Note that, unlike + -- Copy_Separate_Tree, New_Copy does not recursively copy any descendants, + -- so in general parent pointers are not set correctly for the descendants + -- of the copied node. Both normal and extended nodes (entities) may be + -- copied using New_Copy. function Relocate_Node (Source : Node_Id) return Node_Id; -- Source is a non-entity node that is to be relocated. A new node is @@ -340,11 +347,11 @@ package Atree is -- Exchange the contents of two entities. The parent pointers are switched -- as well as the Defining_Identifier fields in the parents, so that the -- entities point correctly to their original parents. The effect is thus - -- to leave the tree completely unchanged in structure, except that the - -- entity ID values of the two entities are interchanged. Neither of the - -- two entities may be list members. Note that entities appear on two - -- semantic chains: Homonym and Next_Entity: the corresponding links must - -- be adjusted by the caller, according to context. + -- to leave the tree unchanged in structure, except that the entity ID + -- values of the two entities are interchanged. Neither of the two entities + -- may be list members. Note that entities appear on two semantic chains: + -- Homonym and Next_Entity: the corresponding links must be adjusted by the + -- caller, according to context. procedure Extend_Node (Source : Node_Id); -- This turns a node into an entity; it function is used only by Sinfo.CN. diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 41de2a57476..3822d932046 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -1233,10 +1233,11 @@ package body CStand is Mutate_Ekind (Any_Composite, E_Array_Type); Set_Scope (Any_Composite, Standard_Standard); Set_Etype (Any_Composite, Any_Composite); - Set_Component_Size (Any_Composite, Uint_0); Set_Component_Type (Any_Composite, Standard_Integer); Reinit_Size_Align (Any_Composite); + pragma Assert (not Known_Component_Size (Any_Composite)); + Any_Discrete := New_Standard_Entity ("a discrete type"); Mutate_Ekind (Any_Discrete, E_Signed_Integer_Type); Set_Scope (Any_Discrete, Standard_Standard); @@ -1508,10 +1509,11 @@ package body CStand is Set_Scope (Standard_Exception_Type, Standard_Standard); Set_Stored_Constraint (Standard_Exception_Type, No_Elist); - Set_RM_Size (Standard_Exception_Type, Uint_0); Set_Size_Known_At_Compile_Time (Standard_Exception_Type, True); + pragma Assert (not Known_RM_Size (Standard_Exception_Type)); + Make_Aliased_Component (Standard_Exception_Type, Standard_Boolean, "Not_Handled_By_Others"); Make_Aliased_Component (Standard_Exception_Type, Standard_Character, diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index 0274e6b1aa8..0c89c82bd1b 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -390,34 +390,23 @@ package body Einfo.Utils is function Known_Static_Component_Bit_Offset (E : Entity_Id) return B is begin - return Present (Component_Bit_Offset (E)) + return Known_Component_Bit_Offset (E) and then Component_Bit_Offset (E) >= Uint_0; end Known_Static_Component_Bit_Offset; function Known_Component_Size (E : Entity_Id) return B is begin - return Component_Size (E) /= Uint_0 - and then Present (Component_Size (E)); + return Present (Component_Size (E)); end Known_Component_Size; function Known_Static_Component_Size (E : Entity_Id) return B is begin - return Component_Size (E) > Uint_0; + return Known_Component_Size (E) and then Component_Size (E) >= Uint_0; end Known_Static_Component_Size; - Use_New_Unknown_Rep : constant Boolean := False; - -- If False, we represent "unknown" as Uint_0, which is wrong. - -- We intend to make it True (and remove it), and represent - -- "unknown" as Field_Is_Initial_Zero. We also need to change - -- the type of Esize and RM_Size from Uint to Valid_Uint. - function Known_Esize (E : Entity_Id) return B is begin - if Use_New_Unknown_Rep then - return not Field_Is_Initial_Zero (E, F_Esize); - else - return Present (Esize (E)) and then Esize (E) /= Uint_0; - end if; + return Present (Esize (E)); end Known_Esize; function Known_Static_Esize (E : Entity_Id) return B is @@ -429,11 +418,7 @@ package body Einfo.Utils is procedure Reinit_Esize (Id : E) is begin - if Use_New_Unknown_Rep then - Reinit_Field_To_Zero (Id, F_Esize); - else - Set_Esize (Id, Uint_0); - end if; + Reinit_Field_To_Zero (Id, F_Esize); end Reinit_Esize; procedure Copy_Esize (To, From : E) is @@ -452,7 +437,7 @@ package body Einfo.Utils is function Known_Static_Normalized_First_Bit (E : Entity_Id) return B is begin - return Present (Normalized_First_Bit (E)) + return Known_Normalized_First_Bit (E) and then Normalized_First_Bit (E) >= Uint_0; end Known_Static_Normalized_First_Bit; @@ -463,43 +448,25 @@ package body Einfo.Utils is function Known_Static_Normalized_Position (E : Entity_Id) return B is begin - return Present (Normalized_Position (E)) + return Known_Normalized_Position (E) and then Normalized_Position (E) >= Uint_0; end Known_Static_Normalized_Position; function Known_RM_Size (E : Entity_Id) return B is begin - if Use_New_Unknown_Rep then - return not Field_Is_Initial_Zero (E, F_RM_Size); - else - return Present (RM_Size (E)) - and then (RM_Size (E) /= Uint_0 - or else Is_Discrete_Type (E) - or else Is_Fixed_Point_Type (E)); - end if; + return Present (RM_Size (E)); end Known_RM_Size; function Known_Static_RM_Size (E : Entity_Id) return B is begin - if Use_New_Unknown_Rep then - return Known_RM_Size (E) - and then RM_Size (E) >= Uint_0 - and then not Is_Generic_Type (E); - else - return (RM_Size (E) > Uint_0 - or else Is_Discrete_Type (E) - or else Is_Fixed_Point_Type (E)) - and then not Is_Generic_Type (E); - end if; + return Known_RM_Size (E) + and then RM_Size (E) >= Uint_0 + and then not Is_Generic_Type (E); end Known_Static_RM_Size; procedure Reinit_RM_Size (Id : E) is begin - if Use_New_Unknown_Rep then - Reinit_Field_To_Zero (Id, F_RM_Size); - else - Set_RM_Size (Id, Uint_0); - end if; + Reinit_Field_To_Zero (Id, F_RM_Size); end Reinit_RM_Size; procedure Copy_RM_Size (To, From : E) is @@ -541,9 +508,8 @@ package body Einfo.Utils is begin pragma Assert (Is_Type (Id)); pragma Assert (not Known_Esize (Id) or else Esize (Id) = V); - if Use_New_Unknown_Rep then - pragma Assert (not Known_RM_Size (Id) or else RM_Size (Id) = V); - end if; + pragma Assert (not Known_RM_Size (Id) or else RM_Size (Id) = V); + Set_Esize (Id, UI_From_Int (V)); Set_RM_Size (Id, UI_From_Int (V)); end Init_Size; @@ -2593,6 +2559,16 @@ package body Einfo.Utils is return Scope_Depth_Value (Scop); end Scope_Depth; + function Scope_Depth_Default_0 (Id : E) return U is + begin + if Scope_Depth_Set (Id) then + return Scope_Depth (Id); + + else + return Uint_0; + end if; + end Scope_Depth_Default_0; + --------------------- -- Scope_Depth_Set -- --------------------- diff --git a/gcc/ada/einfo-utils.ads b/gcc/ada/einfo-utils.ads index 8046722442b..0e6c8cdd25a 100644 --- a/gcc/ada/einfo-utils.ads +++ b/gcc/ada/einfo-utils.ads @@ -274,14 +274,21 @@ package Einfo.Utils is function Safe_Emax_Value (Id : E) return U; function Safe_First_Value (Id : E) return R; function Safe_Last_Value (Id : E) return R; - function Scope_Depth (Id : E) return U; - function Scope_Depth_Set (Id : E) return B; function Size_Clause (Id : E) return N; function Stream_Size_Clause (Id : E) return N; function Type_High_Bound (Id : E) return N; function Type_Low_Bound (Id : E) return N; function Underlying_Type (Id : E) return E; + function Scope_Depth (Id : E) return U; + function Scope_Depth_Set (Id : E) return B; + + function Scope_Depth_Default_0 (Id : E) return U; + -- In rare cases, the Scope_Depth_Value (queried by Scope_Depth) is + -- not correctly set before querying it; this may be used instead of + -- Scope_Depth in such cases. It returns Uint_0 if the Scope_Depth_Value + -- has not been set. See documentation in Einfo. + pragma Inline (Address_Clause); pragma Inline (Alignment_Clause); pragma Inline (Base_Type); @@ -314,41 +321,58 @@ package Einfo.Utils is -- Type Representation Attribute Fields -- ------------------------------------------ - -- Each of the following fields can be in a "known" or "unknown" state: + function Known_Alignment (E : Entity_Id) return B with Inline; + procedure Reinit_Alignment (Id : E) with Inline; + procedure Copy_Alignment (To, From : E); + + function Known_Component_Bit_Offset (E : Entity_Id) return B with Inline; + function Known_Static_Component_Bit_Offset (E : Entity_Id) return B + with Inline; + + function Known_Component_Size (E : Entity_Id) return B with Inline; + function Known_Static_Component_Size (E : Entity_Id) return B with Inline; + + function Known_Esize (E : Entity_Id) return B with Inline; + function Known_Static_Esize (E : Entity_Id) return B with Inline; + procedure Reinit_Esize (Id : E) with Inline; + procedure Copy_Esize (To, From : E); + + function Known_Normalized_First_Bit (E : Entity_Id) return B with Inline; + function Known_Static_Normalized_First_Bit (E : Entity_Id) return B + with Inline; + + function Known_Normalized_Position (E : Entity_Id) return B with Inline; + function Known_Static_Normalized_Position (E : Entity_Id) return B + with Inline; + + function Known_RM_Size (E : Entity_Id) return B with Inline; + function Known_Static_RM_Size (E : Entity_Id) return B with Inline; + procedure Reinit_RM_Size (Id : E) with Inline; + procedure Copy_RM_Size (To, From : E); - -- Alignment - -- Component_Size - -- Component_Bit_Offset - -- Digits_Value - -- Esize - -- Normalized_First_Bit - -- Normalized_Position - -- RM_Size - -- -- NOTE: "known" here does not mean "known at compile time". It means that -- the compiler has computed the value of the field (either by default, or -- by noting some representation clauses), and the field has not been -- reinitialized. -- - -- We document the Esize functions here; the others are analogous: + -- We document the Esize functions here; the others above are analogous: -- -- Known_Esize: True if Set_Esize has been called without a subsequent -- Reinit_Esize. -- -- Known_Static_Esize: True if Known_Esize and the Esize is known at -- compile time. (We're not using "static" in the Ada RM sense here. We - -- are using it to mean "known at compile time.) + -- are using it to mean "known at compile time".) -- -- Reinit_Esize: Set the Esize field to its initial unknown state. -- -- Copy_Esize: Copies the Esize from From to To; Known_Esize (From) may -- be False, in which case Known_Esize (To) becomes False. -- - -- Esize: This is the normal automatially-generated getter for Esize, - -- declared elsewhere. It is an error to call this if Set_Esize has not - -- yet been called, or if Reinit_Esize has been called subsequently. + -- Esize: This is the normal automatically-generated getter for Esize, + -- declared elsewhere. Returns No_Uint if not Known_Esize. -- - -- Set_Esize: This is the normal automatially-generated setter for + -- Set_Esize: This is the normal automatically-generated setter for -- Esize. After a call to this, Known_Esize is True. It is an error -- to call this with a No_Uint value. -- @@ -357,13 +381,6 @@ package Einfo.Utils is -- before calling Esize, because the code is written in such a way that we -- don't know whether Set_Esize has already been called. -- - -- We intend to use the initial zero value to represent "unknown". Note - -- that this value is different from No_Uint, and different from Uint_0. - -- However, this is work in progress; we are still using No_Uint or Uint_0 - -- to represent "unknown" in some cases. Using Uint_0 leads to several - -- bugs, because zero is a legitimate value (T'Size can be zero bits) -- - -- Uint_0 shouldn't mean two different things. - -- -- In two cases, Known_Static_Esize and Known_Static_RM_Size, there is one -- more consideration, which is that we always return False for generic -- types. Within a template, the size can look Known_Static, because of the @@ -371,35 +388,6 @@ package Einfo.Utils is -- Known_Static and anyone testing if they are Known_Static within the -- template should get False as a result to prevent incorrect assumptions. - function Known_Alignment (E : Entity_Id) return B with Inline; - procedure Reinit_Alignment (Id : E) with Inline; - procedure Copy_Alignment (To, From : E); - - function Known_Component_Bit_Offset (E : Entity_Id) return B with Inline; - function Known_Static_Component_Bit_Offset (E : Entity_Id) return B - with Inline; - - function Known_Component_Size (E : Entity_Id) return B with Inline; - function Known_Static_Component_Size (E : Entity_Id) return B with Inline; - - function Known_Esize (E : Entity_Id) return B with Inline; - function Known_Static_Esize (E : Entity_Id) return B with Inline; - procedure Reinit_Esize (Id : E) with Inline; - procedure Copy_Esize (To, From : E); - - function Known_Normalized_First_Bit (E : Entity_Id) return B with Inline; - function Known_Static_Normalized_First_Bit (E : Entity_Id) return B - with Inline; - - function Known_Normalized_Position (E : Entity_Id) return B with Inline; - function Known_Static_Normalized_Position (E : Entity_Id) return B - with Inline; - - function Known_RM_Size (E : Entity_Id) return B with Inline; - function Known_Static_RM_Size (E : Entity_Id) return B with Inline; - procedure Reinit_RM_Size (Id : E) with Inline; - procedure Copy_RM_Size (To, From : E); - --------------------------------------------------------- -- Procedures for setting multiple of the above fields -- --------------------------------------------------------- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 0239a702659..13440ce2e53 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -4323,7 +4323,8 @@ package Einfo is -- Indicates the number of scopes that statically enclose the declaration -- of the unit or type. Library units have a depth of zero. Note that -- record types can act as scopes but do NOT have this field set (see --- Scope_Depth above). +-- Scope_Depth above). Queries should normally be via Scope_Depth, +-- and not call Scope_Depth_Value directly. -- Scope_Depth_Set (synthesized) -- Applies to a special predicate function that returns a Boolean value @@ -4555,7 +4556,7 @@ package Einfo is -- in inheritance of subprograms between views of the same type. -- Subps_Index --- Present in subprogram entries. Set if the subprogram contains nested +-- Present in subprogram entities. Set if the subprogram contains nested -- subprograms, or is a subprogram nested within such a subprogram. Holds -- the index in the Exp_Unst.Subps table for the subprogram. Note that -- for the outer level subprogram, this is the starting index in the Subp diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index ebc7a873ee8..f3d83a566ce 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -490,7 +490,7 @@ package body Exp_Aggr is -- Fat pointers are rejected as they are not really elementary -- for the backend. - if Csiz /= System_Address_Size then + if No (Csiz) or else Csiz /= System_Address_Size then return False; end if; @@ -504,8 +504,7 @@ package body Exp_Aggr is -- Scalar types are OK if their size is a multiple of Storage_Unit - elsif Is_Scalar_Type (Ctyp) then - pragma Assert (Present (Csiz)); + elsif Is_Scalar_Type (Ctyp) and then Present (Csiz) then if Csiz mod System_Storage_Unit /= 0 then return False; @@ -9098,11 +9097,11 @@ package body Exp_Aggr is ----------------------------- function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean is - C : constant Int := UI_To_Int (Component_Size (Typ)); + C : constant Uint := Component_Size (Typ); begin return Number_Dimensions (Typ) = 2 and then Is_Bit_Packed_Array (Typ) - and then (C = 1 or else C = 2 or else C = 4); + and then C in Uint_1 | Uint_2 | Uint_4; -- False if No_Uint end Is_Two_Dim_Packed_Array; -------------------- diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 096671f4e73..49f5c9413dd 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -6294,7 +6294,7 @@ package body Exp_Attr is -- size. This applies to both types and objects. The size of an -- object can be specified in the following ways: - -- An explicit size object is given for an object + -- An explicit size clause is given for an object -- A component size is specified for an indexed component -- A component clause is specified for a selected component -- The object is a component of a packed composite object @@ -6310,7 +6310,7 @@ package body Exp_Attr is or else Is_Packed (Etype (Prefix (Pref))))) or else (Nkind (Pref) = N_Indexed_Component - and then (Component_Size (Etype (Prefix (Pref))) /= 0 + and then (Known_Component_Size (Etype (Prefix (Pref))) or else Is_Packed (Etype (Prefix (Pref))))) then Set_Attribute_Name (N, Name_Size); @@ -7970,7 +7970,6 @@ package body Exp_Attr is elsif Id = Attribute_Size and then Is_Entity_Name (Pref) and then Is_Object (Entity (Pref)) - and then Known_Esize (Entity (Pref)) and then Known_Static_Esize (Entity (Pref)) then Siz := Esize (Entity (Pref)); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index d4373eed8bc..e7eed282fbe 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -942,11 +942,11 @@ package body Exp_Ch3 is (Case_Id : Entity_Id; Variant : Node_Id) return Node_Id; -- Build a case statement containing only two alternatives. The first - -- alternative corresponds exactly to the discrete choices given on the - -- variant with contains the components that we are generating the - -- checks for. If the discriminant is one of these return False. The - -- second alternative is an OTHERS choice that will return True - -- indicating the discriminant did not match. + -- alternative corresponds to the discrete choices given on the variant + -- that contains the components that we are generating the checks + -- for. If the discriminant is one of these return False. The second + -- alternative is an OTHERS choice that returns True indicating the + -- discriminant did not match. function Build_Dcheck_Function (Case_Id : Entity_Id; @@ -976,6 +976,7 @@ package body Exp_Ch3 is begin Case_Node := New_Node (N_Case_Statement, Loc); + Set_End_Span (Case_Node, Uint_0); -- Replace the discriminant which controls the variant with the name -- of the formal of the checking function. diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 71cad989dc1..59c9c446037 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -3613,11 +3613,10 @@ package body Exp_Ch7 is and then (not Is_Library_Level_Entity (Spec_Id) - -- Nested packages are considered to be library level entities, - -- but do not need to be processed separately. True library level - -- packages have a scope value of 1. + -- Nested packages are library level entities, but do not need to + -- be processed separately. - or else Scope_Depth_Value (Spec_Id) /= Uint_1 + or else Scope_Depth (Spec_Id) /= Uint_1 or else (Is_Generic_Instance (Spec_Id) and then Package_Instantiation (Spec_Id) /= N)) diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 9d9811b8845..f286763949e 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -373,9 +373,9 @@ package Exp_Disp is -- target object in its first argument; such implicit argument is explicit -- in the IP procedures built here. - procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint); - -- Set the position of a dispatching primitive its dispatch table. For - -- subprogram wrappers propagate the value to the wrapped subprogram. + procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint); + -- Set the position of a dispatching primitive in its dispatch table. + -- For subprogram wrappers propagate the value to the wrapped subprogram. procedure Set_DTC_Entity_Value (Tagged_Type : Entity_Id; Prim : Entity_Id); -- Set the definite value of the DTC_Entity value associated with a given diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 86cb70234e6..c139bb42524 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -325,7 +325,7 @@ package body Exp_Intr is Result_Typ := Class_Wide_Type (Etype (Act_Constr)); -- Check that the accessibility level of the tag is no deeper than that - -- of the constructor function (unless CodePeer_Mode) + -- of the constructor function (unless CodePeer_Mode). if not CodePeer_Mode then Insert_Action (N, @@ -335,7 +335,8 @@ package body Exp_Intr is Left_Opnd => Build_Get_Access_Level (Loc, New_Copy_Tree (Tag_Arg)), Right_Opnd => - Make_Integer_Literal (Loc, Scope_Depth (Act_Constr))), + Make_Integer_Literal + (Loc, Scope_Depth_Default_0 (Act_Constr))), Then_Statements => New_List ( Make_Raise_Statement (Loc, diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index c87b88129b9..8983dab1c9d 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -624,7 +624,7 @@ package body Exp_Strm is end if; else pragma Assert (Is_Access_Type (U_Type)); - if P_Size > System_Address_Size then + if Present (P_Size) and then P_Size > System_Address_Size then Lib_RE := RE_I_AD; else Lib_RE := RE_I_AS; @@ -868,7 +868,7 @@ package body Exp_Strm is else pragma Assert (Is_Access_Type (U_Type)); - if P_Size > System_Address_Size then + if Present (P_Size) and then P_Size > System_Address_Size then Lib_RE := RE_W_AD; else Lib_RE := RE_W_AS; diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index c071a9c7e35..1c5f61806c1 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -270,7 +270,9 @@ package body Exp_Unst is begin pragma Assert (Is_Subprogram (E)); - if Subps_Index (E) = Uint_0 then + if Field_Is_Initial_Zero (E, F_Subps_Index) + or else Subps_Index (E) = Uint_0 + then E := Ultimate_Alias (E); -- The body of a protected operation has a different name and diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 0a6837ce992..9bc94490acf 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4784,7 +4784,8 @@ package body Exp_Util is -- record or bit-packed array, then everything is fine, since the back -- end can handle these cases correctly. - elsif Esize (Comp) <= System_Max_Integer_Size + elsif Known_Esize (Comp) + and then Esize (Comp) <= System_Max_Integer_Size and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT)) then return False; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5f81d9efbda..fac709478cd 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -865,9 +865,12 @@ package body Freeze is Error_Msg_NE (Size_Too_Small_Message, Size_Clause (T), T); end if; - -- Set size if not set already + -- Set size if not set already. Do not set it to Uint_0, because in + -- some cases (notably array-of-record), the Component_Size is + -- No_Uint, which causes S to be Uint_0. Presumably the RM_Size and + -- Component_Size will eventually be set correctly by the back end. - elsif not Known_RM_Size (T) then + elsif not Known_RM_Size (T) and then S /= Uint_0 then Set_RM_Size (T, S); end if; end Set_Small_Size; @@ -899,8 +902,17 @@ package body Freeze is -- String literals always have known size, and we can set it if Ekind (T) = E_String_Literal_Subtype then - Set_Small_Size - (T, Component_Size (T) * String_Literal_Length (T)); + if Known_Component_Size (T) then + Set_Small_Size + (T, Component_Size (T) * String_Literal_Length (T)); + + else + -- The following is wrong, but does what previous versions + -- did. The Component_Size is unknown for the string in a + -- pragma Warnings. + Set_Small_Size (T, Uint_0); + end if; + return True; -- Unconstrained types never have known at compile time size @@ -932,6 +944,12 @@ package body Freeze is Dim : Uint; begin + -- See comment in Set_Small_Size above + + if No (Size) then + Size := Uint_0; + end if; + Index := First_Index (T); while Present (Index) loop if Nkind (Index) = N_Range then @@ -954,7 +972,7 @@ package body Freeze is else Dim := Expr_Value (High) - Expr_Value (Low) + 1; - if Dim >= 0 then + if Dim > Uint_0 then Size := Size * Dim; else Size := Uint_0; @@ -3703,6 +3721,7 @@ package body Freeze is 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 Known_Esize (Base_Type (Ctyp)) and then Esize (Base_Type (Ctyp)) = Csiz + 1 then Error_Msg_Uint_1 := Csiz; @@ -6646,7 +6665,7 @@ package body Freeze is Dim := Expr_Value (Hi) - Expr_Value (Lo) + 1; - if Dim >= 0 then + if Dim > Uint_0 then Num_Elmts := Num_Elmts * Dim; else Num_Elmts := Uint_0; @@ -6668,9 +6687,12 @@ package body Freeze is if Implicit_Packing then Set_Component_Size (Btyp, Rsiz); - -- Otherwise give an error message + -- Otherwise give an error message, except that if the + -- specified Size is zero, there is no need for pragma + -- Pack. Note that size zero is not considered + -- Addressable. - else + elsif RM_Size (E) /= Uint_0 then Error_Msg_NE ("size given for& too small", SZ, E); Error_Msg_N -- CODEFIX diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index 1fa7f0b46ee..d91faaa2b5a 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -252,7 +252,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Contract, Node_Id), Sm (Is_Elaboration_Warnings_OK_Id, Flag), Sm (Original_Record_Component, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (SPARK_Pragma, Node_Id), Sm (SPARK_Pragma_Inherited, Flag), Sm (Current_Value, Node_Id), -- setter only @@ -607,7 +607,7 @@ begin -- Gen_IL.Gen.Gen_Entities -- this is the first named subtype). Ab (Decimal_Fixed_Point_Kind, Fixed_Point_Kind, - (Sm (Digits_Value, Uint), + (Sm (Digits_Value, Upos), Sm (Has_Machine_Radix_Clause, Flag), Sm (Machine_Radix_10, Flag), Sm (Scale_Value, Uint))); @@ -623,7 +623,7 @@ begin -- Gen_IL.Gen.Gen_Entities -- first named subtype). Ab (Float_Kind, Real_Kind, - (Sm (Digits_Value, Uint))); + (Sm (Digits_Value, Upos))); Cc (E_Floating_Point_Type, Float_Kind); -- Floating point type, used for the anonymous base type of the @@ -866,23 +866,23 @@ begin -- Gen_IL.Gen.Gen_Entities -- A private type, created by a private type declaration that has -- neither the keyword limited nor the keyword tagged. (Sm (Scalar_Range, Node_Id), - Sm (Scope_Depth_Value, Uint))); + Sm (Scope_Depth_Value, Unat))); Cc (E_Private_Subtype, Private_Kind, -- A subtype of a private type, created by a subtype declaration used -- to declare a subtype of a private type. - (Sm (Scope_Depth_Value, Uint))); + (Sm (Scope_Depth_Value, Unat))); Cc (E_Limited_Private_Type, Private_Kind, -- A limited private type, created by a private type declaration that -- has the keyword limited, but not the keyword tagged. (Sm (Scalar_Range, Node_Id), - Sm (Scope_Depth_Value, Uint))); + Sm (Scope_Depth_Value, Unat))); Cc (E_Limited_Private_Subtype, Private_Kind, -- A subtype of a limited private type, created by a subtype declaration -- used to declare a subtype of a limited private type. - (Sm (Scope_Depth_Value, Uint))); + (Sm (Scope_Depth_Value, Unat))); Ab (Incomplete_Kind, Incomplete_Or_Private_Kind, (Sm (Non_Limited_View, Node_Id))); @@ -900,7 +900,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (First_Entity, Node_Id), Sm (First_Private_Entity, Node_Id), Sm (Last_Entity, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (Stored_Constraint, Elist_Id))); Ab (Task_Kind, Concurrent_Kind, @@ -1005,11 +1005,11 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Linker_Section_Pragma, Node_Id), Sm (Overridden_Operation, Node_Id), Sm (Protected_Body_Subprogram, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (Static_Call_Helper, Node_Id), Sm (SPARK_Pragma, Node_Id), Sm (SPARK_Pragma_Inherited, Flag), - Sm (Subps_Index, Uint))); + Sm (Subps_Index, Unat))); Cc (E_Function, Subprogram_Kind, -- A function, created by a function declaration or a function body @@ -1137,7 +1137,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Postconditions_Proc, Node_Id), Sm (Protected_Body_Subprogram, Node_Id), Sm (Protection_Object, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (SPARK_Pragma, Node_Id), Sm (SPARK_Pragma_Inherited, Flag))); @@ -1164,7 +1164,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Protected_Body_Subprogram, Node_Id), Sm (Protection_Object, Node_Id), Sm (Renamed_Or_Alias, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (SPARK_Pragma, Node_Id), Sm (SPARK_Pragma_Inherited, Flag))); @@ -1178,7 +1178,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Last_Entity, Node_Id), Sm (Renamed_Or_Alias, Node_Id), Sm (Return_Applies_To, Node_Id), - Sm (Scope_Depth_Value, Uint))); + Sm (Scope_Depth_Value, Unat))); Cc (E_Entry_Index_Parameter, Entity_Kind, -- An entry index parameter created by an entry index specification @@ -1209,7 +1209,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Elaboration_Warnings_OK_Id, Flag), Sm (Last_Entity, Node_Id), Sm (Renamed_Or_Alias, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (SPARK_Pragma, Node_Id), Sm (SPARK_Pragma_Inherited, Flag))); @@ -1254,7 +1254,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Has_Loop_Entry_Attributes, Flag), Sm (Last_Entity, Node_Id), Sm (Renamed_Or_Alias, Node_Id), - Sm (Scope_Depth_Value, Uint))); + Sm (Scope_Depth_Value, Unat))); Cc (E_Return_Statement, Entity_Kind, -- A dummy entity created for each return statement. Used to hold @@ -1266,7 +1266,7 @@ begin -- Gen_IL.Gen.Gen_Entities (Sm (First_Entity, Node_Id), Sm (Last_Entity, Node_Id), Sm (Return_Applies_To, Node_Id), - Sm (Scope_Depth_Value, Uint))); + Sm (Scope_Depth_Value, Unat))); Cc (E_Package, Entity_Kind, -- A package, created by a package declaration @@ -1303,7 +1303,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Related_Instance, Node_Id), Sm (Renamed_In_Spec, Flag), Sm (Renamed_Or_Alias, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (SPARK_Aux_Pragma, Node_Id), Sm (SPARK_Aux_Pragma_Inherited, Flag), Sm (SPARK_Pragma, Node_Id), @@ -1323,7 +1323,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Last_Entity, Node_Id), Sm (Related_Instance, Node_Id), Sm (Renamed_Or_Alias, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (SPARK_Aux_Pragma, Node_Id), Sm (SPARK_Aux_Pragma_Inherited, Flag), Sm (SPARK_Pragma, Node_Id), @@ -1358,7 +1358,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Interface_Name, Node_Id), Sm (Last_Entity, Node_Id), Sm (Renamed_Or_Alias, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (SPARK_Pragma, Node_Id), Sm (SPARK_Pragma_Inherited, Flag))); diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index 20d25ea83ac..3b6bd68cbd9 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -984,7 +984,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Cc (N_Case_Statement, N_Statement_Other_Than_Procedure_Call, (Sy (Expression, Node_Id, Default_Empty), Sy (Alternatives, List_Id, Default_No_List), - Sy (End_Span, Uint, Default_Uint_0), + Sy (End_Span, Unat, Default_Uint_0), Sm (From_Conditional_Expression, Flag))); Cc (N_Code_Statement, N_Statement_Other_Than_Procedure_Call, @@ -1094,7 +1094,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sy (Then_Statements, List_Id), Sy (Elsif_Parts, List_Id, Default_No_List), Sy (Else_Statements, List_Id, Default_No_List), - Sy (End_Span, Uint, Default_Uint_0), + Sy (End_Span, Unat, Default_Uint_0), Sm (From_Conditional_Expression, Flag))); Cc (N_Accept_Alternative, Node_Kind, @@ -1594,7 +1594,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sm (Dcheck_Function, Node_Id), Sm (Enclosing_Variant, Node_Id), Sm (Has_SP_Choice, Flag), - Sm (Present_Expr, Uint))); + Sm (Present_Expr, Valid_Uint))); Cc (N_Variant_Part, Node_Kind, (Sy (Name, Node_Id, Default_Empty), diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb index e786251fb30..eed98ee97cc 100644 --- a/gcc/ada/gen_il-gen.adb +++ b/gcc/ada/gen_il-gen.adb @@ -1197,6 +1197,12 @@ package body Gen_IL.Gen is for F in First .. Last loop if Field_Table (F).Field_Type in Node_Or_Entity_Type then Result (Node_Id) := True; + + -- Subtypes of Uint all use the same Cast for Uint + + elsif Field_Table (F).Field_Type in Uint_Subtype then + Result (Uint) := True; + else Result (Field_Table (F).Field_Type) := True; end if; @@ -1767,6 +1773,7 @@ package body Gen_IL.Gen is end if; Put_Get_Set_Incr (S, F, "Set"); + Decrease_Indent (S, 3); Put (S, "end Set_" & Image (F) & ";" & LF & LF); end Put_Setter_Body; diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb index fe1af78ca12..a1a8062c4ac 100644 --- a/gcc/ada/gen_il-internals.adb +++ b/gcc/ada/gen_il-internals.adb @@ -370,7 +370,7 @@ package body Gen_IL.Internals is return Image (Default); else - -- Strip off the prefix and capitalize it + -- Strip off the prefix declare Im : constant String := Image (Default); diff --git a/gcc/ada/gen_il-internals.ads b/gcc/ada/gen_il-internals.ads index a811e0b4100..7b095c09692 100644 --- a/gcc/ada/gen_il-internals.ads +++ b/gcc/ada/gen_il-internals.ads @@ -133,7 +133,7 @@ package Gen_IL.Internals is Default_Uint_0); -- Uint -- Default value for a field in the Nmake functions. No_Default if the -- field parameter has no default value. Otherwise this indicates the - -- default value used, which must matcht the type of the field. + -- default value used, which must match the type of the field. function Image (Default : Field_Default_Value) return String; -- This will be something like "Default_Empty". @@ -191,7 +191,10 @@ package Gen_IL.Internals is function Special_Default (Field_Type : Type_Enum) return String is - (if Field_Type = Elist_Id then "No_Elist" else "Uint_0"); + (case Field_Type is + when Elist_Id => "No_Elist", + when Uint => "No_Uint", + when others => "can't happen"); ---------------- diff --git a/gcc/ada/gen_il-types.ads b/gcc/ada/gen_il-types.ads index 97b9dd22fc3..9395e00818d 100644 --- a/gcc/ada/gen_il-types.ads +++ b/gcc/ada/gen_il-types.ads @@ -589,5 +589,7 @@ package Gen_IL.Types is subtype Uint_Subtype is Type_Enum with Predicate => Uint_Subtype in Valid_Uint | Unat | Upos | Nonzero_Uint; + -- These are the subtypes of Uint that have predicates restricting their + -- values. end Gen_IL.Types; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 084ca9189d0..83d9681d7a2 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -367,46 +367,48 @@ package body Repinfo is null; else - -- If Esize and RM_Size are the same, list as Size. This is a common - -- case, which we may as well list in simple form. + if Known_Esize (Ent) and then Known_RM_Size (Ent) then + -- If Esize and RM_Size are the same, list as Size. This is a + -- common case, which we may as well list in simple form. - if Esize (Ent) = RM_Size (Ent) then - if List_Representation_Info_To_JSON then - Write_Str (" ""Size"": "); - Write_Val (Esize (Ent)); - Write_Line (","); - else - Write_Str ("for "); - List_Name (Ent); - Write_Str ("'Size use "); - Write_Val (Esize (Ent)); - Write_Line (";"); - end if; + if Esize (Ent) = RM_Size (Ent) then + if List_Representation_Info_To_JSON then + Write_Str (" ""Size"": "); + Write_Val (Esize (Ent)); + Write_Line (","); + else + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Size use "); + Write_Val (Esize (Ent)); + Write_Line (";"); + end if; - -- Otherwise list size values separately + -- Otherwise list size values separately - else - if List_Representation_Info_To_JSON then - Write_Str (" ""Object_Size"": "); - Write_Val (Esize (Ent)); - Write_Line (","); + else + if List_Representation_Info_To_JSON then + Write_Str (" ""Object_Size"": "); + Write_Val (Esize (Ent)); + Write_Line (","); - Write_Str (" ""Value_Size"": "); - Write_Val (RM_Size (Ent)); - Write_Line (","); + Write_Str (" ""Value_Size"": "); + Write_Val (RM_Size (Ent)); + Write_Line (","); - else - Write_Str ("for "); - List_Name (Ent); - Write_Str ("'Object_Size use "); - Write_Val (Esize (Ent)); - Write_Line (";"); - - Write_Str ("for "); - List_Name (Ent); - Write_Str ("'Value_Size use "); - Write_Val (RM_Size (Ent)); - Write_Line (";"); + else + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Object_Size use "); + Write_Val (Esize (Ent)); + Write_Line (";"); + + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Value_Size use "); + Write_Val (RM_Size (Ent)); + Write_Line (";"); + end if; end if; end if; end if; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 3eee2ee31b7..ee5c7cfe3f9 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -1022,16 +1022,20 @@ package body Sem is Scop : Entity_Id; begin - -- Entity is global if defined outside of current outer_generic_scope: - -- Either the entity has a smaller depth that the outer generic, or it + -- Entity is global if defined outside of current Outer_Generic_Scope: + -- Either the entity has a smaller depth than the outer generic, or it -- is in a different compilation unit, or it is defined within a unit - -- in the same compilation, that is not within the outer_generic. + -- in the same compilation, that is not within the outer generic. if No (Outer_Generic_Scope) then return False; - elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope) - or else not In_Same_Source_Unit (E, Outer_Generic_Scope) + -- It makes no sense to compare depths if not in same unit. Scope_Depth + -- is not set for inherited operations. + + elsif not In_Same_Source_Unit (E, Outer_Generic_Scope) + or else not Scope_Depth_Set (Scope (E)) + or else Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope) then return True; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 54406e9bbc5..a62eb7cfb9f 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -8090,7 +8090,9 @@ package body Sem_Ch12 is (Scope (Ent) = Current_Instantiated_Parent.Gen_Id and then not Is_Child_Unit (Ent)) or else - (Scope_Depth (Scope (Ent)) > + (Scope_Depth_Set (Scope (Ent)) + and then + Scope_Depth (Scope (Ent)) > Scope_Depth (Current_Instantiated_Parent.Gen_Id) and then Get_Source_Unit (Ent) = diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index c60dd97beaf..3374e8bf1f6 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -7960,7 +7960,7 @@ package body Sem_Ch13 is ("stream size for elementary type must be 8, 16, 24, " & "32 or 64", N); - elsif RM_Size (U_Ent) > Size then + elsif Known_RM_Size (U_Ent) and then RM_Size (U_Ent) > Size then Error_Msg_Uint_1 := RM_Size (U_Ent); Error_Msg_N ("stream size for elementary type must be 8, 16, 24, " & @@ -17569,7 +17569,9 @@ package body Sem_Ch13 is Source_Siz := RM_Size (Source); Target_Siz := RM_Size (Target); - if Source_Siz /= Target_Siz then + if Present (Source_Siz) and then Present (Target_Siz) + and then Source_Siz /= Target_Siz + then Error_Msg ("?z?types for unchecked conversion have different sizes!", Eloc, Act_Unit); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 57db6378579..c8d4ec1abf3 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6343,7 +6343,7 @@ package body Sem_Ch3 is -- Complete setup of implicit base type - Set_Component_Size (Implicit_Base, Uint_0); + pragma Assert (not Known_Component_Size (Implicit_Base)); Set_Component_Type (Implicit_Base, Element_Type); Set_Finalize_Storage_Only (Implicit_Base, @@ -6372,7 +6372,7 @@ package body Sem_Ch3 is Reinit_Size_Align (T); Set_Etype (T, T); Set_Scope (T, Current_Scope); - Set_Component_Size (T, Uint_0); + pragma Assert (not Known_Component_Size (T)); Set_Is_Constrained (T, False); Set_Is_Fixed_Lower_Bound_Array_Subtype (T, Has_FLB_Index); @@ -17585,7 +17585,7 @@ package body Sem_Ch3 is Set_High_Bound (R_Node, B_Node); -- Initialize various fields of the type. Some of this information - -- may be overwritten later through rep.clauses. + -- may be overwritten later through rep. clauses. Set_Scalar_Range (T, R_Node); Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); @@ -18517,7 +18517,12 @@ package body Sem_Ch3 is Set_Size_Info (T, Implicit_Base); Set_RM_Size (T, RM_Size (Implicit_Base)); Inherit_Rep_Item_Chain (T, Implicit_Base); - Set_Digits_Value (T, Digs_Val); + + if Digs_Val >= Uint_1 then + Set_Digits_Value (T, Digs_Val); + else + pragma Assert (Serious_Errors_Detected > 0); null; + end if; end Floating_Point_Type_Declaration; ---------------------------- @@ -19641,8 +19646,8 @@ package body Sem_Ch3 is return; end if; - -- If the range bounds are "T'Low .. T'High" where T is a name of - -- a discrete type, then use T as the type of the index. + -- If the range bounds are "T'First .. T'Last" where T is a name of a + -- discrete type, then use T as the type of the index. if Nkind (Low_Bound (N)) = N_Attribute_Reference and then Attribute_Name (Low_Bound (N)) = Name_First @@ -21747,141 +21752,130 @@ package body Sem_Ch3 is -- represent the null range the Constraint_Error exception should -- not be raised. - -- ??? The Is_Null_Range (Lo, Hi) test should disappear since it - -- is done in the call to Range_Check (R, T); below. + -- Capture values of bounds and generate temporaries for them + -- if needed, before applying checks, since checks may cause + -- duplication of the expression without forcing evaluation. - if Is_Null_Range (Lo, Hi) then - null; + -- The forced evaluation removes side effects from expressions, + -- which should occur also in GNATprove mode. Otherwise, we end up + -- with unexpected insertions of actions at places where this is + -- not supposed to occur, e.g. on default parameters of a call. - else - -- Capture values of bounds and generate temporaries for them - -- if needed, before applying checks, since checks may cause - -- duplication of the expression without forcing evaluation. - - -- The forced evaluation removes side effects from expressions, - -- which should occur also in GNATprove mode. Otherwise, we end up - -- with unexpected insertions of actions at places where this is - -- not supposed to occur, e.g. on default parameters of a call. - - if Expander_Active or GNATprove_Mode then - - -- Call Force_Evaluation to create declarations as needed - -- to deal with side effects, and also create typ_FIRST/LAST - -- entities for bounds if we have a subtype name. - - -- Note: we do this transformation even if expansion is not - -- active if we are in GNATprove_Mode since the transformation - -- is in general required to ensure that the resulting tree has - -- proper Ada semantics. - - Force_Evaluation - (Lo, Related_Id => Subtyp, Is_Low_Bound => True); - Force_Evaluation - (Hi, Related_Id => Subtyp, Is_High_Bound => True); - end if; + if Expander_Active or GNATprove_Mode then - -- We use a flag here instead of suppressing checks on the type - -- because the type we check against isn't necessarily the place - -- where we put the check. + -- Call Force_Evaluation to create declarations as needed + -- to deal with side effects, and also create typ_FIRST/LAST + -- entities for bounds if we have a subtype name. - R_Checks := Get_Range_Checks (R, T); + -- Note: we do this transformation even if expansion is not + -- active if we are in GNATprove_Mode since the transformation + -- is in general required to ensure that the resulting tree has + -- proper Ada semantics. - -- Look up tree to find an appropriate insertion point. We can't - -- just use insert_actions because later processing depends on - -- the insertion node. Prior to Ada 2012 the insertion point could - -- only be a declaration or a loop, but quantified expressions can - -- appear within any context in an expression, and the insertion - -- point can be any statement, pragma, or declaration. + Force_Evaluation + (Lo, Related_Id => Subtyp, Is_Low_Bound => True); + Force_Evaluation + (Hi, Related_Id => Subtyp, Is_High_Bound => True); + end if; - Insert_Node := Parent (R); - while Present (Insert_Node) loop - exit when - Nkind (Insert_Node) in N_Declaration - and then - Nkind (Insert_Node) not in N_Component_Declaration - | N_Loop_Parameter_Specification - | N_Function_Specification - | N_Procedure_Specification; - - exit when Nkind (Insert_Node) in - N_Later_Decl_Item | - N_Statement_Other_Than_Procedure_Call | - N_Procedure_Call_Statement | - N_Pragma; - - Insert_Node := Parent (Insert_Node); - end loop; + -- We use a flag here instead of suppressing checks on the type + -- because the type we check against isn't necessarily the place + -- where we put the check. - -- Why would Type_Decl not be present??? Without this test, - -- short regression tests fail. + R_Checks := Get_Range_Checks (R, T); - if Present (Insert_Node) then + -- Look up tree to find an appropriate insertion point. We can't + -- just use insert_actions because later processing depends on + -- the insertion node. Prior to Ada 2012 the insertion point could + -- only be a declaration or a loop, but quantified expressions can + -- appear within any context in an expression, and the insertion + -- point can be any statement, pragma, or declaration. - -- Case of loop statement. Verify that the range is part of the - -- subtype indication of the iteration scheme. + Insert_Node := Parent (R); + while Present (Insert_Node) loop + exit when + Nkind (Insert_Node) in N_Declaration + and then + Nkind (Insert_Node) not in N_Component_Declaration + | N_Loop_Parameter_Specification + | N_Function_Specification + | N_Procedure_Specification; + + exit when Nkind (Insert_Node) in + N_Later_Decl_Item | + N_Statement_Other_Than_Procedure_Call | + N_Procedure_Call_Statement | + N_Pragma; + + Insert_Node := Parent (Insert_Node); + end loop; - if Nkind (Insert_Node) = N_Loop_Statement then - declare - Indic : Node_Id; + if Present (Insert_Node) then - begin - Indic := Parent (R); - while Present (Indic) - and then Nkind (Indic) /= N_Subtype_Indication - loop - Indic := Parent (Indic); - end loop; + -- Case of loop statement. Verify that the range is part of the + -- subtype indication of the iteration scheme. - if Present (Indic) then - Def_Id := Etype (Subtype_Mark (Indic)); + if Nkind (Insert_Node) = N_Loop_Statement then + declare + Indic : Node_Id; - Insert_Range_Checks - (R_Checks, - Insert_Node, - Def_Id, - Sloc (Insert_Node), - Do_Before => True); - end if; - end; + begin + Indic := Parent (R); + while Present (Indic) + and then Nkind (Indic) /= N_Subtype_Indication + loop + Indic := Parent (Indic); + end loop; - -- Case of declarations. If the declaration is for a type and - -- involves discriminants, the checks are premature at the - -- declaration point and need to wait for the expansion of the - -- initialization procedure, which will pass in the list to put - -- them on; otherwise, the checks are done at the declaration - -- point and there is no need to do them again in the - -- initialization procedure. + if Present (Indic) then + Def_Id := Etype (Subtype_Mark (Indic)); - elsif Nkind (Insert_Node) in N_Declaration then - Def_Id := Defining_Identifier (Insert_Node); + Insert_Range_Checks + (R_Checks, + Insert_Node, + Def_Id, + Sloc (Insert_Node), + Do_Before => True); + end if; + end; - if (Ekind (Def_Id) = E_Record_Type - and then Depends_On_Discriminant (R)) - or else - (Ekind (Def_Id) = E_Protected_Type - and then Has_Discriminants (Def_Id)) - then - if Present (Check_List) then - Append_Range_Checks - (R_Checks, - Check_List, Def_Id, Sloc (Insert_Node)); - end if; + -- Case of declarations. If the declaration is for a type and + -- involves discriminants, the checks are premature at the + -- declaration point and need to wait for the expansion of the + -- initialization procedure, which will pass in the list to put + -- them on; otherwise, the checks are done at the declaration + -- point and there is no need to do them again in the + -- initialization procedure. - else - if No (Check_List) then - Insert_Range_Checks - (R_Checks, - Insert_Node, Def_Id, Sloc (Insert_Node)); - end if; - end if; + elsif Nkind (Insert_Node) in N_Declaration then + Def_Id := Defining_Identifier (Insert_Node); - -- Case of statements. Drop the checks, as the range appears in - -- the context of a quantified expression. Insertion will take - -- place when expression is expanded. + if (Ekind (Def_Id) = E_Record_Type + and then Depends_On_Discriminant (R)) + or else + (Ekind (Def_Id) = E_Protected_Type + and then Has_Discriminants (Def_Id)) + then + if Present (Check_List) then + Append_Range_Checks + (R_Checks, + Check_List, Def_Id, Sloc (Insert_Node)); + end if; else - null; + if No (Check_List) then + Insert_Range_Checks + (R_Checks, + Insert_Node, Def_Id, Sloc (Insert_Node)); + end if; end if; + + -- Case of statements. Drop the checks, as the range appears in + -- the context of a quantified expression. Insertion will take + -- place when expression is expanded. + + else + null; end if; end if; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 494ec648f46..7b3dfa606f7 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -7279,8 +7279,10 @@ package body Sem_Ch8 is if Within (It.Nam, Inst) then if Within (Old_S, Inst) then declare - It_D : constant Uint := Scope_Depth (It.Nam); - Old_D : constant Uint := Scope_Depth (Old_S); + It_D : constant Uint := + Scope_Depth_Default_0 (It.Nam); + Old_D : constant Uint := + Scope_Depth_Default_0 (Old_S); N_Ent : Entity_Id; begin -- Choose the innermost subprogram, which @@ -9057,10 +9059,12 @@ package body Sem_Ch8 is Set_Scope_Depth_Value (S, Uint_1); elsif not Is_Record_Type (Current_Scope) then - if Ekind (S) = E_Loop then - Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope)); - else - Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1); + if Scope_Depth_Set (Current_Scope) then + if Ekind (S) = E_Loop then + Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope)); + else + Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1); + end if; end if; end if; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e79c5345f1d..b8ed8a4bcb9 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -315,7 +315,8 @@ package body Sem_Util is -- Ignore transient scopes made during expansion if Comes_From_Source (Node_Par) then - return Scope_Depth (Encl_Scop) + Master_Lvl_Modifier; + return + Scope_Depth_Default_0 (Encl_Scop) + Master_Lvl_Modifier; end if; -- For a return statement within a function, return @@ -1137,6 +1138,10 @@ package body Sem_Util is function Addressable (V : Uint) return Boolean is begin + if No (V) then + return False; + end if; + return V = Uint_8 or else V = Uint_16 or else V = Uint_32 or else diff --git a/gcc/ada/sinfo-utils.adb b/gcc/ada/sinfo-utils.adb index cf0ecc10eff..79269a5972d 100644 --- a/gcc/ada/sinfo-utils.adb +++ b/gcc/ada/sinfo-utils.adb @@ -242,15 +242,28 @@ package body Sinfo.Utils is use Seinfo; function Is_In_Union_Id (F_Kind : Field_Kind) return Boolean is - (F_Kind in Node_Id_Field - | List_Id_Field - | Elist_Id_Field - | Name_Id_Field - | String_Id_Field - | Uint_Field - | Ureal_Field - | Union_Id_Field); -- True if the field type is one that can be converted to Types.Union_Id + (case F_Kind is + when Node_Id_Field + | List_Id_Field + | Elist_Id_Field + | Name_Id_Field + | String_Id_Field + | Valid_Uint_Field + | Unat_Field + | Upos_Field + | Nonzero_Uint_Field + | Uint_Field + | Ureal_Field + | Union_Id_Field => True, + when Flag_Field + | Node_Kind_Type_Field + | Entity_Kind_Type_Field + | Source_Ptr_Field + | Small_Paren_Count_Type_Field + | Convention_Id_Field + | Component_Alignment_Kind_Field + | Mechanism_Type_Field => False); ----------------------- -- Walk_Sinfo_Fields -- diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 9b78adaade4..69996cbbc00 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -4394,7 +4394,12 @@ package body Sprint is when E_Modular_Integer_Type => Write_Header; Write_Str ("mod "); - Write_Uint_With_Col_Check (Modulus (Typ), Auto); + + if No (Modulus (Typ)) then + Write_Uint_With_Col_Check (Uint_0, Auto); + else + Write_Uint_With_Col_Check (Modulus (Typ), Auto); + end if; -- Floating-point types and subtypes diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 2e9d2c27808..d36042ca579 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -885,14 +885,13 @@ package body Treepr is Val : constant Uint := Get_Uint (N, FD.Offset); function Cast is new Unchecked_Conversion (Uint, Int); begin - -- Do this even if Val = No_Uint, because Uint fields default - -- to Uint_0. - - Print_Initial; - UI_Write (Val, Format); - Write_Str (" (Uint = "); - Write_Int (Cast (Val)); - Write_Char (')'); + if Present (Val) then + Print_Initial; + UI_Write (Val, Format); + Write_Str (" (Uint = "); + Write_Int (Cast (Val)); + Write_Char (')'); + end if; end; when Valid_Uint_Field | Unat_Field | Upos_Field diff --git a/gcc/ada/types.h b/gcc/ada/types.h index 2806e50ddd7..093836547db 100644 --- a/gcc/ada/types.h +++ b/gcc/ada/types.h @@ -261,10 +261,10 @@ typedef Int String_Id; /* Type used for representation of universal integers. */ typedef Int Uint; -typedef Int Valid_Uint; -typedef Int Unat; -typedef Int Upos; -typedef Int Nonzero_Uint; +typedef Uint Valid_Uint; +typedef Uint Unat; +typedef Uint Upos; +typedef Uint Nonzero_Uint; /* Used to indicate missing Uint value. */ #define No_Uint Uint_Low_Bound diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index 29d409b49e1..5d1dec1e1bd 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -282,7 +282,10 @@ package body Uintp is -- value is returned from a correctness point of view. procedure Image_Char (C : Character); - -- Internal procedure to output one character + -- Output one character + + procedure Image_String (S : String); + -- Output characters procedure Image_Exponent (N : Natural); -- Output non-zero exponent. Note that we only use the exponent form in @@ -371,6 +374,17 @@ package body Uintp is Character'Val (Character'Pos ('0') + N mod 10); end Image_Exponent; + ------------------ + -- Image_String -- + ------------------ + + procedure Image_String (S : String) is + begin + for X in S'Range loop + Image_Char (S (X)); + end loop; + end Image_String; + ---------------- -- Image_Uint -- ---------------- @@ -401,7 +415,7 @@ package body Uintp is begin if No (Input) then - Image_Char ('?'); + Image_String ("No_Uint"); return; end if;