Patchwork [Ada] Minor code reorganization

login
register
mail settings
Submitter Arnaud Charlet
Date Dec. 2, 2011, 2:55 p.m.
Message ID <20111202145538.GA27348@adacore.com>
Download mbox | patch
Permalink /patch/128885/
State New
Headers show

Comments

Arnaud Charlet - Dec. 2, 2011, 2:55 p.m.
This patch does not modify the functionality of the compiler. It
moves semantic routines from Sem_Util to Sem_Aux to have them
available in ASIS.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-12-02  Javier Miranda  <miranda@adacore.com>

	* sem_util.ads, sem_util.adb, sem_aux.ads, sem_aux.adb
	(Effectively_Has_Constrained_Partial_View): Moved to sem_aux
	(In_Generic_Body): Moved to sem_aux.
	(Unit_Declaration_Node): Moved to sem_aux.
	* einfo.ads (Effectively_Has_Constrained_Partial_View): Complete
	documentation.
	* exp_attr.adb, live.adb, sem_ch10.adb, checks.adb, sem.adb,
	rtsfind.adb, sem_attr.adb, sem_elab.adb, exp_ch4.adb, sem_ch4.adb,
	exp_ch13.adb: Add with-clause on Sem_Aux.

Patch

Index: sem_aux.adb
===================================================================
--- sem_aux.adb	(revision 181910)
+++ sem_aux.adb	(working copy)
@@ -152,6 +152,25 @@ 
       end if;
    end Constant_Value;
 
+   ----------------------------------------------
+   -- Effectively_Has_Constrained_Partial_View --
+   ----------------------------------------------
+
+   function Effectively_Has_Constrained_Partial_View
+     (Typ  : Entity_Id;
+      Scop : Entity_Id) return Boolean
+   is
+   begin
+      return Has_Constrained_Partial_View (Typ)
+        or else (In_Generic_Body (Scop)
+                   and then Is_Generic_Type (Base_Type (Typ))
+                   and then Is_Private_Type (Base_Type (Typ))
+                   and then not Is_Tagged_Type (Typ)
+                   and then not (Is_Array_Type (Typ)
+                                   and then not Is_Constrained (Typ))
+                   and then Has_Discriminants (Typ));
+   end Effectively_Has_Constrained_Partial_View;
+
    -----------------------------
    -- Enclosing_Dynamic_Scope --
    -----------------------------
@@ -419,6 +438,43 @@ 
    end Initialize;
 
    ---------------------
+   -- In_Generic_Body --
+   ---------------------
+
+   function In_Generic_Body (Id : Entity_Id) return Boolean is
+      S : Entity_Id;
+
+   begin
+      --  Climb scopes looking for generic body
+
+      S := Id;
+      while Present (S) and then S /= Standard_Standard loop
+
+         --  Generic package body
+
+         if Ekind (S) = E_Generic_Package
+           and then In_Package_Body (S)
+         then
+            return True;
+
+         --  Generic subprogram body
+
+         elsif Is_Subprogram (S)
+           and then Nkind (Unit_Declaration_Node (S))
+                      = N_Generic_Subprogram_Declaration
+         then
+            return True;
+         end if;
+
+         S := Scope (S);
+      end loop;
+
+      --  False if top of scope stack without finding a generic body
+
+      return False;
+   end In_Generic_Body;
+
+   ---------------------
    -- Is_By_Copy_Type --
    ---------------------
 
@@ -904,4 +960,53 @@ 
       return E;
    end Ultimate_Alias;
 
+   --------------------------
+   -- Unit_Declaration_Node --
+   --------------------------
+
+   function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
+      N : Node_Id := Parent (Unit_Id);
+
+   begin
+      --  Predefined operators do not have a full function declaration
+
+      if Ekind (Unit_Id) = E_Operator then
+         return N;
+      end if;
+
+      --  Isn't there some better way to express the following ???
+
+      while Nkind (N) /= N_Abstract_Subprogram_Declaration
+        and then Nkind (N) /= N_Formal_Package_Declaration
+        and then Nkind (N) /= N_Function_Instantiation
+        and then Nkind (N) /= N_Generic_Package_Declaration
+        and then Nkind (N) /= N_Generic_Subprogram_Declaration
+        and then Nkind (N) /= N_Package_Declaration
+        and then Nkind (N) /= N_Package_Body
+        and then Nkind (N) /= N_Package_Instantiation
+        and then Nkind (N) /= N_Package_Renaming_Declaration
+        and then Nkind (N) /= N_Procedure_Instantiation
+        and then Nkind (N) /= N_Protected_Body
+        and then Nkind (N) /= N_Subprogram_Declaration
+        and then Nkind (N) /= N_Subprogram_Body
+        and then Nkind (N) /= N_Subprogram_Body_Stub
+        and then Nkind (N) /= N_Subprogram_Renaming_Declaration
+        and then Nkind (N) /= N_Task_Body
+        and then Nkind (N) /= N_Task_Type_Declaration
+        and then Nkind (N) not in N_Formal_Subprogram_Declaration
+        and then Nkind (N) not in N_Generic_Renaming_Declaration
+      loop
+         N := Parent (N);
+
+         --  We don't use Assert here, because that causes an infinite loop
+         --  when assertions are turned off. Better to crash.
+
+         if No (N) then
+            raise Program_Error;
+         end if;
+      end loop;
+
+      return N;
+   end Unit_Declaration_Node;
+
 end Sem_Aux;
Index: sem_aux.ads
===================================================================
--- sem_aux.ads	(revision 181910)
+++ sem_aux.ads	(working copy)
@@ -104,6 +104,14 @@ 
    --  constants from the point of view of constant folding. Empty is also
    --  returned for variables with no initialization expression.
 
+   function Effectively_Has_Constrained_Partial_View
+     (Typ  : Entity_Id;
+      Scop : Entity_Id) return Boolean;
+   --  Return True if Typ has attribute Has_Constrained_Partial_View set to
+   --  True; in addition, within a generic body, return True if a subtype is
+   --  a descendant of an untagged generic formal private or derived type, and
+   --  the subtype is not an unconstrained array subtype (RM 3.3(23.10/3)).
+
    function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id;
    --  For any entity, Ent, returns the closest dynamic scope in which the
    --  entity is declared or Standard_Standard for library-level entities.
@@ -147,6 +155,9 @@ 
    --  Typ must be a tagged record type. This function returns the Entity for
    --  the first _Tag field in the record type.
 
+   function In_Generic_Body (Id : Entity_Id) return Boolean;
+   --  Determine whether entity Id appears inside a generic body
+
    function Is_By_Copy_Type (Ent : Entity_Id) return Boolean;
    --  Ent is any entity. Returns True if Ent is a type entity where the type
    --  is required to be passed by copy, as defined in (RM 6.2(3)).
@@ -228,4 +239,11 @@ 
    --  Return the last entity in the chain of aliased entities of Prim. If Prim
    --  has no alias return Prim.
 
+   function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id;
+   --  Unit_Id is the simple name of a program unit, this function returns the
+   --  corresponding xxx_Declaration node for the entity. Also applies to the
+   --  body entities for subprograms, tasks and protected units, in which case
+   --  it returns the subprogram, task or protected body node for it. The unit
+   --  may be a child unit with any number of ancestors.
+
 end Sem_Aux;
Index: exp_attr.adb
===================================================================
--- exp_attr.adb	(revision 181914)
+++ exp_attr.adb	(working copy)
@@ -1563,7 +1563,8 @@ 
                            (Nkind (Obj) = N_Explicit_Dereference
                               and then
                                 not Effectively_Has_Constrained_Partial_View
-                                      (Base_Type (Etype (Obj)))));
+                                      (Typ  => Base_Type (Etype (Obj)),
+                                       Scop => Current_Scope)));
             end if;
          end Is_Constrained_Aliased_View;
 
@@ -1686,7 +1687,8 @@ 
                      (Nkind (Pref) = N_Explicit_Dereference
                        and then
                          not Effectively_Has_Constrained_Partial_View
-                               (Base_Type (Ptyp)))
+                               (Typ  => Base_Type (Ptyp),
+                                Scop => Current_Scope))
                     or else Is_Constrained (Underlying_Type (Ptyp))
                     or else (Ada_Version >= Ada_2012
                               and then Is_Tagged_Type (Underlying_Type (Ptyp))
Index: live.adb
===================================================================
--- live.adb	(revision 181910)
+++ live.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2000-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 2000-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -27,6 +27,7 @@ 
 with Einfo;    use Einfo;
 with Lib;      use Lib;
 with Nlists;   use Nlists;
+with Sem_Aux;  use Sem_Aux;
 with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
 with Types;    use Types;
Index: sem_ch10.adb
===================================================================
--- sem_ch10.adb	(revision 181910)
+++ sem_ch10.adb	(working copy)
@@ -47,6 +47,7 @@ 
 with Rident;   use Rident;
 with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
+with Sem_Aux;  use Sem_Aux;
 with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch6;  use Sem_Ch6;
 with Sem_Ch7;  use Sem_Ch7;
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 181914)
+++ einfo.ads	(working copy)
@@ -1420,8 +1420,11 @@ 
 --       type has no discriminants and the full view has discriminants with
 --       defaults. In Ada 2005 heap-allocated objects of such types are not
 --       constrained, and can change their discriminants with full assignment.
---       Sem_Util.Effectively_Has_Constrained_Partial_View should be always
---       used by callers, rather than reading this attribute directly.
+--       Sem_Aux.Effectively_Has_Constrained_Partial_View should be always
+--       used by callers, rather than reading this attribute directly because,
+--       according to RM 3.10.2 (27/2), untagged generic formal private types
+--       and subtypes are also considered to have a constrained partial view
+--       [when in a generic body].
 
 --    Has_Contiguous_Rep (Flag181)
 --       Present in enumeration types. True if the type as a representation
Index: checks.adb
===================================================================
--- checks.adb	(revision 181914)
+++ checks.adb	(working copy)
@@ -1240,7 +1240,9 @@ 
       --  partial view that is constrained.
 
       elsif Ada_Version >= Ada_2005
-        and then Effectively_Has_Constrained_Partial_View (Base_Type (T_Typ))
+        and then Effectively_Has_Constrained_Partial_View
+                   (Typ  => Base_Type (T_Typ),
+                    Scop => Current_Scope)
       then
          return;
       end if;
Index: sem.adb
===================================================================
--- sem.adb	(revision 181910)
+++ sem.adb	(working copy)
@@ -37,6 +37,7 @@ 
 with Output;   use Output;
 with Restrict; use Restrict;
 with Sem_Attr; use Sem_Attr;
+with Sem_Aux;  use Sem_Aux;
 with Sem_Ch2;  use Sem_Ch2;
 with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch4;  use Sem_Ch4;
Index: rtsfind.adb
===================================================================
--- rtsfind.adb	(revision 181910)
+++ rtsfind.adb	(working copy)
@@ -42,6 +42,7 @@ 
 with Opt;      use Opt;
 with Restrict; use Restrict;
 with Sem;      use Sem;
+with Sem_Aux;  use Sem_Aux;
 with Sem_Ch7;  use Sem_Ch7;
 with Sem_Dist; use Sem_Dist;
 with Sem_Util; use Sem_Util;
Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 181916)
+++ sem_util.adb	(working copy)
@@ -3039,25 +3039,6 @@ 
       return Extra_Accessibility (Id);
    end Effective_Extra_Accessibility;
 
-   ----------------------------------------------
-   -- Effectively_Has_Constrained_Partial_View --
-   ----------------------------------------------
-
-   function Effectively_Has_Constrained_Partial_View
-     (Typ  : Entity_Id;
-      Scop : Entity_Id := Current_Scope) return Boolean
-   is
-   begin
-      return Has_Constrained_Partial_View (Typ)
-        or else (In_Generic_Body (Scop)
-                   and then Is_Generic_Type (Base_Type (Typ))
-                   and then Is_Private_Type (Base_Type (Typ))
-                   and then not Is_Tagged_Type (Typ)
-                   and then not (Is_Array_Type (Typ)
-                                   and then not Is_Constrained (Typ))
-                   and then Has_Discriminants (Typ));
-   end Effectively_Has_Constrained_Partial_View;
-
    --------------------------
    -- Enclosing_CPP_Parent --
    --------------------------
@@ -6107,43 +6088,6 @@ 
       return False;
    end Implements_Interface;
 
-   ---------------------
-   -- In_Generic_Body --
-   ---------------------
-
-   function In_Generic_Body (Id : Entity_Id) return Boolean is
-      S : Entity_Id;
-
-   begin
-      --  Climb scopes looking for generic body
-
-      S := Id;
-      while Present (S) and then S /= Standard_Standard loop
-
-         --  Generic package body
-
-         if Ekind (S) = E_Generic_Package
-           and then In_Package_Body (S)
-         then
-            return True;
-
-         --  Generic subprogram body
-
-         elsif Is_Subprogram (S)
-           and then Nkind (Unit_Declaration_Node (S))
-                      = N_Generic_Subprogram_Declaration
-         then
-            return True;
-         end if;
-
-         S := Scope (S);
-      end loop;
-
-      --  False if top of scope stack without finding a generic body
-
-      return False;
-   end In_Generic_Body;
-
    -----------------
    -- In_Instance --
    -----------------
@@ -7002,7 +6946,8 @@ 
 
                   if Ekind (Prefix_Type) = E_Access_Type
                     and then not Effectively_Has_Constrained_Partial_View
-                                   (Designated_Type (Prefix_Type))
+                                   (Typ  => Designated_Type (Prefix_Type),
+                                    Scop => Current_Scope)
                   then
                      return False;
 
@@ -12985,55 +12930,6 @@ 
       end if;
    end Unique_Name;
 
-   --------------------------
-   -- Unit_Declaration_Node --
-   --------------------------
-
-   function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
-      N : Node_Id := Parent (Unit_Id);
-
-   begin
-      --  Predefined operators do not have a full function declaration
-
-      if Ekind (Unit_Id) = E_Operator then
-         return N;
-      end if;
-
-      --  Isn't there some better way to express the following ???
-
-      while Nkind (N) /= N_Abstract_Subprogram_Declaration
-        and then Nkind (N) /= N_Formal_Package_Declaration
-        and then Nkind (N) /= N_Function_Instantiation
-        and then Nkind (N) /= N_Generic_Package_Declaration
-        and then Nkind (N) /= N_Generic_Subprogram_Declaration
-        and then Nkind (N) /= N_Package_Declaration
-        and then Nkind (N) /= N_Package_Body
-        and then Nkind (N) /= N_Package_Instantiation
-        and then Nkind (N) /= N_Package_Renaming_Declaration
-        and then Nkind (N) /= N_Procedure_Instantiation
-        and then Nkind (N) /= N_Protected_Body
-        and then Nkind (N) /= N_Subprogram_Declaration
-        and then Nkind (N) /= N_Subprogram_Body
-        and then Nkind (N) /= N_Subprogram_Body_Stub
-        and then Nkind (N) /= N_Subprogram_Renaming_Declaration
-        and then Nkind (N) /= N_Task_Body
-        and then Nkind (N) /= N_Task_Type_Declaration
-        and then Nkind (N) not in N_Formal_Subprogram_Declaration
-        and then Nkind (N) not in N_Generic_Renaming_Declaration
-      loop
-         N := Parent (N);
-
-         --  We don't use Assert here, because that causes an infinite loop
-         --  when assertions are turned off. Better to crash.
-
-         if No (N) then
-            raise Program_Error;
-         end if;
-      end loop;
-
-      return N;
-   end Unit_Declaration_Node;
-
    ---------------------
    -- Unit_Is_Visible --
    ---------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads	(revision 181914)
+++ sem_util.ads	(working copy)
@@ -368,14 +368,6 @@ 
    --  Same as Einfo.Extra_Accessibility except thtat object renames
    --  are looked through.
 
-   function Effectively_Has_Constrained_Partial_View
-     (Typ  : Entity_Id;
-      Scop : Entity_Id := Current_Scope) return Boolean;
-   --  Return True if Typ has attribute Has_Constrained_Partial_View set to
-   --  True; in addition, within a generic body, return True if a subtype is
-   --  a descendant of an untagged generic formal private or derived type, and
-   --  the subtype is not an unconstrained array subtype (RM 3.3(23.10/3)).
-
    function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id;
    --  Returns the closest ancestor of Typ that is a CPP type.
 
@@ -725,9 +717,6 @@ 
       Exclude_Parents : Boolean := False) return Boolean;
    --  Returns true if the Typ_Ent implements interface Iface_Ent
 
-   function In_Generic_Body (Id : Entity_Id) return Boolean;
-   --  Determine whether entity Id appears inside a generic body
-
    function In_Instance return Boolean;
    --  Returns True if the current scope is within a generic instance
 
@@ -1503,13 +1492,6 @@ 
    --  Return a unique name for entity E, which could be used to identify E
    --  across compilation units.
 
-   function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id;
-   --  Unit_Id is the simple name of a program unit, this function returns the
-   --  corresponding xxx_Declaration node for the entity. Also applies to the
-   --  body entities for subprograms, tasks and protected units, in which case
-   --  it returns the subprogram, task or protected body node for it. The unit
-   --  may be a child unit with any number of ancestors.
-
    function Unit_Is_Visible (U : Entity_Id) return Boolean;
    --  Determine whether a compilation unit is visible in the current context,
    --  because there is a with_clause that makes the unit available. Used to
Index: sem_attr.adb
===================================================================
--- sem_attr.adb	(revision 181914)
+++ sem_attr.adb	(working copy)
@@ -8633,7 +8633,8 @@ 
                    (Ada_Version < Ada_2005
                      or else
                        not Effectively_Has_Constrained_Partial_View
-                             (Designated_Type (Base_Type (Typ))))
+                        (Typ => Designated_Type (Base_Type (Typ)),
+                         Scop => Current_Scope))
                then
                   null;
 
Index: sem_elab.adb
===================================================================
--- sem_elab.adb	(revision 181910)
+++ sem_elab.adb	(working copy)
@@ -43,6 +43,7 @@ 
 with Restrict; use Restrict;
 with Rident;   use Rident;
 with Sem;      use Sem;
+with Sem_Aux;  use Sem_Aux;
 with Sem_Cat;  use Sem_Cat;
 with Sem_Ch7;  use Sem_Ch7;
 with Sem_Ch8;  use Sem_Ch8;
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 181914)
+++ exp_ch4.adb	(working copy)
@@ -3905,7 +3905,8 @@ 
                        and then (Ada_Version < Ada_2005
                                   or else not
                                     Effectively_Has_Constrained_Partial_View
-                                      (Typ))
+                                      (Typ  => Typ,
+                                       Scop => Current_Scope))
                      then
                         Typ := Build_Default_Subtype (Typ, N);
                         Set_Expression (N, New_Reference_To (Typ, Loc));
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb	(revision 181914)
+++ sem_ch4.adb	(working copy)
@@ -576,7 +576,9 @@ 
                --  and the allocated object is unconstrained.
 
                elsif Ada_Version >= Ada_2005
-                 and then Effectively_Has_Constrained_Partial_View (Base_Typ)
+                 and then Effectively_Has_Constrained_Partial_View
+                            (Typ  => Base_Typ,
+                             Scop => Current_Scope)
                then
                   Error_Msg_N
                     ("constraint not allowed when type " &
Index: exp_ch13.adb
===================================================================
--- exp_ch13.adb	(revision 181910)
+++ exp_ch13.adb	(working copy)
@@ -39,6 +39,7 @@ 
 with Rident;   use Rident;
 with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
+with Sem_Aux;  use Sem_Aux;
 with Sem_Ch7;  use Sem_Ch7;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Eval; use Sem_Eval;