public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-4542] [Ada] tech debt: Clean up Uint fields, such as Esize
@ 2021-10-20 10:18 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2021-10-20 10:18 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:36e38022125f2f336e5d281fb3e5e66191d21e73
commit r12-4542-g36e38022125f2f336e5d281fb3e5e66191d21e73
Author: Bob Duff <duff@adacore.com>
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;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-10-20 10:18 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-10-20 10:18 [gcc r12-4542] [Ada] tech debt: Clean up Uint fields, such as Esize Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).