* [Ada] Move Has_Inferable_Discriminants to Sem_Util
@ 2021-05-07 9:38 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2021-05-07 9:38 UTC (permalink / raw)
To: gcc-patches; +Cc: Claire Dross
[-- Attachment #1: Type: text/plain, Size: 308 bytes --]
Move the Has_Inferable_Discriminants utility to Sem_Util so that it can
be reused inside GNATprove.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* exp_ch4.adb (Has_Inferable_Discriminants): Moved to Sem_Util.
* sem_util.ads, sem_util.adb (Has_Inferable_Discriminants):
Moved from Exp_Ch4.
[-- Attachment #2: patch.diff --]
[-- Type: text/x-diff, Size: 8681 bytes --]
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -176,17 +176,6 @@ package body Exp_Ch4 is
-- Return the size of a small signed integer type covering Lo .. Hi, the
-- main goal being to return a size lower than that of standard types.
- function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
- -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
- -- discriminants if it has a constrained nominal type, unless the object
- -- is a component of an enclosing Unchecked_Union object that is subject
- -- to a per-object constraint and the enclosing object lacks inferable
- -- discriminants.
- --
- -- An expression of an Unchecked_Union type has inferable discriminants
- -- if it is either a name of an object with inferable discriminants or a
- -- qualified expression whose subtype mark denotes a constrained subtype.
-
procedure Insert_Dereference_Action (N : Node_Id);
-- N is an expression whose type is an access. When the type of the
-- associated storage pool is derived from Checked_Pool, generate a
@@ -13358,84 +13347,6 @@ package body Exp_Ch4 is
end if;
end Get_Size_For_Range;
- ---------------------------------
- -- Has_Inferable_Discriminants --
- ---------------------------------
-
- function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
-
- function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
- -- Determines whether the left-most prefix of a selected component is a
- -- formal parameter in a subprogram. Assumes N is a selected component.
-
- --------------------------------
- -- Prefix_Is_Formal_Parameter --
- --------------------------------
-
- function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
- Sel_Comp : Node_Id;
-
- begin
- -- Move to the left-most prefix by climbing up the tree
-
- Sel_Comp := N;
- while Present (Parent (Sel_Comp))
- and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
- loop
- Sel_Comp := Parent (Sel_Comp);
- end loop;
-
- return Is_Formal (Entity (Prefix (Sel_Comp)));
- end Prefix_Is_Formal_Parameter;
-
- -- Start of processing for Has_Inferable_Discriminants
-
- begin
- -- For selected components, the subtype of the selector must be a
- -- constrained Unchecked_Union. If the component is subject to a
- -- per-object constraint, then the enclosing object must have inferable
- -- discriminants.
-
- if Nkind (N) = N_Selected_Component then
- if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
-
- -- A small hack. If we have a per-object constrained selected
- -- component of a formal parameter, return True since we do not
- -- know the actual parameter association yet.
-
- if Prefix_Is_Formal_Parameter (N) then
- return True;
-
- -- Otherwise, check the enclosing object and the selector
-
- else
- return Has_Inferable_Discriminants (Prefix (N))
- and then Has_Inferable_Discriminants (Selector_Name (N));
- end if;
-
- -- The call to Has_Inferable_Discriminants will determine whether
- -- the selector has a constrained Unchecked_Union nominal type.
-
- else
- return Has_Inferable_Discriminants (Selector_Name (N));
- end if;
-
- -- A qualified expression has inferable discriminants if its subtype
- -- mark is a constrained Unchecked_Union subtype.
-
- elsif Nkind (N) = N_Qualified_Expression then
- return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
- and then Is_Constrained (Etype (Subtype_Mark (N)));
-
- -- For all other names, it is sufficient to have a constrained
- -- Unchecked_Union nominal subtype.
-
- else
- return Is_Unchecked_Union (Base_Type (Etype (N)))
- and then Is_Constrained (Etype (N));
- end if;
- end Has_Inferable_Discriminants;
-
-------------------------------
-- Insert_Dereference_Action --
-------------------------------
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -12435,6 +12435,84 @@ package body Sem_Util is
return False;
end Has_Fully_Default_Initializing_DIC_Pragma;
+ ---------------------------------
+ -- Has_Inferable_Discriminants --
+ ---------------------------------
+
+ function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
+
+ function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
+ -- Determines whether the left-most prefix of a selected component is a
+ -- formal parameter in a subprogram. Assumes N is a selected component.
+
+ --------------------------------
+ -- Prefix_Is_Formal_Parameter --
+ --------------------------------
+
+ function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
+ Sel_Comp : Node_Id;
+
+ begin
+ -- Move to the left-most prefix by climbing up the tree
+
+ Sel_Comp := N;
+ while Present (Parent (Sel_Comp))
+ and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
+ loop
+ Sel_Comp := Parent (Sel_Comp);
+ end loop;
+
+ return Is_Formal (Entity (Prefix (Sel_Comp)));
+ end Prefix_Is_Formal_Parameter;
+
+ -- Start of processing for Has_Inferable_Discriminants
+
+ begin
+ -- For selected components, the subtype of the selector must be a
+ -- constrained Unchecked_Union. If the component is subject to a
+ -- per-object constraint, then the enclosing object must have inferable
+ -- discriminants.
+
+ if Nkind (N) = N_Selected_Component then
+ if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
+
+ -- A small hack. If we have a per-object constrained selected
+ -- component of a formal parameter, return True since we do not
+ -- know the actual parameter association yet.
+
+ if Prefix_Is_Formal_Parameter (N) then
+ return True;
+
+ -- Otherwise, check the enclosing object and the selector
+
+ else
+ return Has_Inferable_Discriminants (Prefix (N))
+ and then Has_Inferable_Discriminants (Selector_Name (N));
+ end if;
+
+ -- The call to Has_Inferable_Discriminants will determine whether
+ -- the selector has a constrained Unchecked_Union nominal type.
+
+ else
+ return Has_Inferable_Discriminants (Selector_Name (N));
+ end if;
+
+ -- A qualified expression has inferable discriminants if its subtype
+ -- mark is a constrained Unchecked_Union subtype.
+
+ elsif Nkind (N) = N_Qualified_Expression then
+ return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
+ and then Is_Constrained (Etype (Subtype_Mark (N)));
+
+ -- For all other names, it is sufficient to have a constrained
+ -- Unchecked_Union nominal subtype.
+
+ else
+ return Is_Unchecked_Union (Base_Type (Etype (N)))
+ and then Is_Constrained (Etype (N));
+ end if;
+ end Has_Inferable_Discriminants;
+
--------------------
-- Has_Infinities --
--------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1388,6 +1388,17 @@ package Sem_Util is
-- Determine whether type Typ has a suitable Default_Initial_Condition
-- pragma which provides the full default initialization of the type.
+ function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
+ -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
+ -- discriminants if it has a constrained nominal type, unless the object
+ -- is a component of an enclosing Unchecked_Union object that is subject
+ -- to a per-object constraint and the enclosing object lacks inferable
+ -- discriminants.
+ --
+ -- An expression of an Unchecked_Union type has inferable discriminants
+ -- if it is either a name of an object with inferable discriminants or a
+ -- qualified expression whose subtype mark denotes a constrained subtype.
+
function Has_Infinities (E : Entity_Id) return Boolean;
-- Determines if the range of the floating-point type E includes
-- infinities. Returns False if E is not a floating-point type.
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-05-07 9:38 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-05-07 9:38 [Ada] Move Has_Inferable_Discriminants to Sem_Util 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).