+2015-03-02 Robert Dewar <dewar@adacore.com>
+
+ * debug.adb: Document new debug flag -gnatd.1.
+ * einfo.ads, einfo.adb (Has_Nested_Subprogram): New flag.
+ (Has_Uplevel_Reference): New flag (Is_Static_Type): New flag.
+ (Uplevel_Reference_Noted):New flag (Uplevel_References): New field.
+ * elists.ads elists.adb (List_Length): New function.
+ * exp_ch6.adb (Expand_N_Subprogram_Body): Call Unnest_Subprogram
+ when appropriate (Process_Preconditions): Minor code
+ reorganization and reformatting
+ * exp_unst.ads, exp_unst.adb: New files.
+ * gnat1drv.adb (Adjust_Global_Switches): Set
+ Unnest_Subprogram_Mode if -gnatd.1
+ * namet.ads, namet.adb (Name_Find_Str): New version of Name_Find with
+ string argument.
+ * opt.ads (Unnest_Subprogram_Mode): New flag.
+ * par-ch3.adb (P_Identifier_Declarations): Fixes to -gnatd.2 handling.
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Set
+ Has_Nested_Subprogram flag.
+ * sem_ch8.adb (Find_Direct_Name): New calling sequence for
+ Check_Nested_Access.
+ (Find_Selected_Component): Minor comment addition.
+ * sem_util.adb (Check_Nested_Access): New version for use with Exp_Unst.
+ (Note_Possible_Modification): New calling sequence for
+ Check_Nested_Access.
+ * sem_util.ads (Check_Nested_Access): New version for use with Exp_Unst.
+ * gcc-interface/Make-lang.in (GNAT1_OBJS): Add exp_unst.o
+
2015-03-02 Pierre-Marie de Rodat <derodat@adacore.com>
* gcc-interface/utils.c (gnat_pushdecl): For non-artificial pointer
-- d9 This allows lock free implementation for protected objects
-- (see Exp_Ch9).
- -- d.1 Enable unnesting of nested procedures. This special pass does not
- -- actually unnest things, but it ensures that a nested procedure
- -- does not contain any uplevel references.
+ -- d.1 Sets Opt.Unnest_Subprogram_Mode to enable unnesting of subprograms.
+ -- This special pass does not actually unnest things, but it ensures
+ -- that a nested procedure does not contain any uplevel references.
+ -- See spec of Exp_Unst for full details.
-- d.2 Allow statements within declarative parts. This is not usually
-- allowed, but in some debugging contexts (e.g. testing the circuit
-- Stored_Constraint Elist23
-- Related_Expression Node24
+ -- Uplevel_References Elist24
-- Interface_Alias Node25
-- Interfaces Elist25
-- Has_Pragma_Unreferenced_Objects Flag212
-- Requires_Overriding Flag213
-- Has_RACW Flag214
- -- Has_Up_Level_Access Flag215
+ -- Has_Uplevel_Reference Flag215
-- Universal_Aliasing Flag216
-- Suppress_Value_Tracking_On_Call Flag217
-- Is_Primitive Flag218
-- Contains_Ignored_Ghost_Code Flag279
-- Partial_View_Has_Unknown_Discr Flag280
- -- (unused) Flag281
- -- (unused) Flag282
- -- (unused) Flag283
+ -- Is_Static_Type Flag281
+ -- Has_Nested_Subprogram Flag282
+ -- Uplevel_Reference_Noted Flag283
+
-- (unused) Flag284
-- (unused) Flag285
-- (unused) Flag286
return Flag101 (Id);
end Has_Nested_Block_With_Handler;
+ function Has_Nested_Subprogram (Id : E) return B is
+ begin
+ pragma Assert (Is_Subprogram (Id));
+ return Flag282 (Id);
+ end Has_Nested_Subprogram;
+
function Has_Non_Standard_Rep (Id : E) return B is
begin
return Flag75 (Implementation_Base_Type (Id));
return Flag72 (Id);
end Has_Unknown_Discriminants;
- function Has_Up_Level_Access (Id : E) return B is
+ function Has_Uplevel_Reference (Id : E) return B is
begin
- pragma Assert
- (Ekind_In (Id, E_Variable, E_Constant, E_Loop_Parameter));
return Flag215 (Id);
- end Has_Up_Level_Access;
+ end Has_Uplevel_Reference;
function Has_Visible_Refinement (Id : E) return B is
begin
return Flag60 (Id);
end Is_Shared_Passive;
+ function Is_Static_Type (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag281 (Id);
+ end Is_Static_Type;
+
function Is_Statically_Allocated (Id : E) return B is
begin
return Flag28 (Id);
return Node16 (Id);
end Unset_Reference;
+ function Uplevel_Reference_Noted (Id : E) return B is
+ begin
+ return Flag283 (Id);
+ end Uplevel_Reference_Noted;
+
+ function Uplevel_References (Id : E) return L is
+ begin
+ pragma Assert (Is_Subprogram (Id));
+ return Elist24 (Id);
+ end Uplevel_References;
+
function Used_As_Generic_Actual (Id : E) return B is
begin
return Flag222 (Id);
Set_Flag101 (Id, V);
end Set_Has_Nested_Block_With_Handler;
- procedure Set_Has_Up_Level_Access (Id : E; V : B := True) is
+ procedure Set_Has_Nested_Subprogram (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Subprogram (Id));
+ Set_Flag282 (Id, V);
+ end Set_Has_Nested_Subprogram;
+
+ procedure Set_Has_Uplevel_Reference (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Variable, E_Constant, E_Loop_Parameter));
Set_Flag215 (Id, V);
- end Set_Has_Up_Level_Access;
+ end Set_Has_Uplevel_Reference;
procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True) is
begin
Set_Flag60 (Id, V);
end Set_Is_Shared_Passive;
+ procedure Set_Is_Static_Type (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag281 (Id, V);
+ end Set_Is_Static_Type;
+
procedure Set_Is_Statically_Allocated (Id : E; V : B := True) is
begin
pragma Assert
Set_Node16 (Id, V);
end Set_Unset_Reference;
+ procedure Set_Uplevel_Reference_Noted (Id : E; V : B := True) is
+ begin
+ Set_Flag283 (Id, V);
+ end Set_Uplevel_Reference_Noted;
+
+ procedure Set_Uplevel_References (Id : E; V : L) is
+ begin
+ pragma Assert (Is_Subprogram (Id));
+ Set_Elist24 (Id, V);
+ end Set_Uplevel_References;
+
procedure Set_Used_As_Generic_Actual (Id : E; V : B := True) is
begin
Set_Flag222 (Id, V);
W ("Has_Master_Entity", Flag21 (Id));
W ("Has_Missing_Return", Flag142 (Id));
W ("Has_Nested_Block_With_Handler", Flag101 (Id));
+ W ("Has_Nested_Subprogram", Flag282 (Id));
W ("Has_Non_Standard_Rep", Flag75 (Id));
W ("Has_Out_Or_In_Out_Parameter", Flag110 (Id));
W ("Has_Object_Size_Clause", Flag172 (Id));
W ("Has_Thunks", Flag228 (Id));
W ("Has_Unchecked_Union", Flag123 (Id));
W ("Has_Unknown_Discriminants", Flag72 (Id));
- W ("Has_Up_Level_Access", Flag215 (Id));
+ W ("Has_Uplevel_Reference", Flag215 (Id));
W ("Has_Visible_Refinement", Flag263 (Id));
W ("Has_Volatile_Components", Flag87 (Id));
W ("Has_Xref_Entry", Flag182 (Id));
W ("Is_Return_Object", Flag209 (Id));
W ("Is_Safe_To_Reevaluate", Flag249 (Id));
W ("Is_Shared_Passive", Flag60 (Id));
+ W ("Is_Static_Type", Flag281 (Id));
W ("Is_Statically_Allocated", Flag28 (Id));
W ("Is_Tag", Flag78 (Id));
W ("Is_Tagged_Type", Flag55 (Id));
W ("Suppress_Value_Tracking_On_Call", Flag217 (Id));
W ("Treat_As_Volatile", Flag41 (Id));
W ("Universal_Aliasing", Flag216 (Id));
+ W ("Uplevel_Reference_Noted", Flag283 (Id));
W ("Used_As_Generic_Actual", Flag222 (Id));
W ("Uses_Sec_Stack", Flag95 (Id));
W ("Warnings_Off", Flag96 (Id));
Type_Kind =>
Write_Str ("Related_Expression");
+ when E_Function |
+ E_Operator |
+ E_Procedure =>
+ Write_Str ("Uplevel_References");
+
when others =>
Write_Str ("Field24???");
end case;
-- optimizations to ensure that they are consistent with exceptions.
-- See documentation in backend for further details.
--- Has_Non_Null_Refinement (synth)
+-- Has_Nested_Subprogram (Flag282)
+-- Defined in subprogram entities. Set for a subprogram which contains at
+-- least one nested subprogram.
+
+ -- Has_Non_Null_Refinement (synth)
-- Defined in E_Abstract_State entities. True if the state has at least
-- one variable or state constituent in aspect/pragma Refined_State.
-- on the partial view, to insure that discriminants are properly
-- inherited in certain contexts.
--- Has_Up_Level_Access (Flag215)
--- Defined in E_Variable and E_Constant entities. Set if the entity
--- is a local variable declared in a subprogram p and is accessed in
--- a subprogram nested inside p. Currently this flag is only set when
--- VM_Target /= No_VM, for efficiency, since only the .NET back-end
--- makes use of it to generate proper code for up-level references.
+-- Has_Uplevel_Reference (Flag215)
+-- Defined in all entities. Indicates that the entity is locally defined
+-- within a subprogram P, and there is a reference to the entity within
+-- a subprogram nested within P (at any depth). Set only for the VM case
+-- (where it is set for variables, constants and loop parameters), and in
+-- the case where we are unnesting nested subprograms (in which case it
+-- is also set for types and subtypes which are not static types, and
+-- that are referenced uplevel, as well as for subprograms that contain
+-- uplevel references or call other subprogram, see Exp_unst for details.
-- Has_Visible_Refinement (Flag263)
-- Defined in E_Abstract_State entities. Set when a state has at least
-- type is one of the standard string types (String, Wide_String, or
-- Wide_Wide_String).
+-- Is_Static_Type (Flag281)
+-- Defined in all type and subtype entities. If set, indicates that the
+-- type is known to be a static type (defined as a discrete type with
+-- static bounds, a record all of whose component types are static types,
+-- or an array, all of whose bounds are of a static type, and also have
+-- a component type that is a static type. See Set_Uplevel_Type for more
+-- information on how this flag is used. Note that if Is_Static_Type is
+-- True, then it is never the case that the Has_Uplevel_Reference flag is
+-- set for the same type.
+
-- Is_Statically_Allocated (Flag28)
-- Defined in all entities. This can only be set for exception,
-- variable, constant, and type/subtype entities. If the flag is set,
-- is identified. This field is used to generate a warning message if
-- necessary (see Sem_Warn.Check_Unset_Reference).
+-- Uplevel_Reference_Noted (Flag283)
+-- Defined in all entities, used in Exp_Unst processing to note that an
+-- uplevel reference to the entity has been noted (to avoid processing a
+-- given entity more than once).
+
+-- Uplevel_References (Elist24)
+-- Defined in subprogram entities. Set only if Has_Uplevel_Reference is
+-- set and if we are Unnest_Subprogram_Mode, otherwise undefined. Points
+-- to a list of explicit uplevel references to entities declared in
+-- the subprogram which need rewriting. See spec of Exp_Unst for details.
+
-- Used_As_Generic_Actual (Flag222)
-- Defined in all entities, set if the entity is used as an argument to
-- a generic instantiation. Used to tune certain warning messages.
-- Suppress_Elaboration_Warnings (Flag148)
-- Suppress_Style_Checks (Flag165)
-- Suppress_Value_Tracking_On_Call (Flag217)
+ -- Uplevel_Reference_Noted (Flag283)
-- Used_As_Generic_Actual (Flag222)
-- Warnings_Off (Flag96)
-- Warnings_Off_Used (Flag236)
-- Has_Static_Predicate_Aspect (Flag259)
-- Has_Task (Flag30) (base type only)
-- Has_Unchecked_Union (Flag123) (base type only)
+ -- Has_Uplevel_Reference (Flag215)
-- Has_Volatile_Components (Flag87) (base type only)
-- In_Use (Flag8)
-- Is_Abstract_Type (Flag146)
-- Is_Non_Static_Subtype (Flag109)
-- Is_Packed (Flag51) (base type only)
-- Is_Private_Composite (Flag107)
+ -- Is_Static_Type (Flag281)
-- Is_Unsigned_Type (Flag144)
-- Is_Volatile (Flag16)
-- Itype_Printed (Flag202) (itypes only)
-- Has_Independent_Components (Flag34)
-- Has_Size_Clause (Flag29)
-- Has_Thunks (Flag228) (constants only)
- -- Has_Up_Level_Access (Flag215)
+ -- Has_Uplevel_Reference (Flag215)
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
-- Generic_Renamings (Elist23) (for an instance)
-- Inner_Instances (Elist23) (generic case only)
-- Protection_Object (Node23) (for concurrent kind)
+ -- Uplevel_References (Elist24) (non-generic case only)
-- Interface_Alias (Node25)
-- Overridden_Operation (Node26)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Has_Master_Entity (Flag21)
-- Has_Missing_Return (Flag142)
-- Has_Nested_Block_With_Handler (Flag101)
+ -- Has_Nested_Subprogram (Flag282)
-- Has_Out_Or_In_Out_Parameter (Flag110)
-- Has_Recursive_Call (Flag143)
-- Is_Abstract_Subprogram (Flag19) (non-generic case only)
-- Alias (Node18)
-- Extra_Accessibility_Of_Result (Node19)
-- Last_Entity (Node20)
+ -- Has_Nested_Subprogram (Flag282)
+ -- Uplevel_References (Elist24)
-- Overridden_Operation (Node26)
-- Subprograms_For_Type (Node29)
-- Linker_Section_Pragma (Node33)
-- Generic_Renamings (Elist23) (for an instance)
-- Inner_Instances (Elist23) (generic case only)
-- Protection_Object (Node23) (for concurrent kind)
+ -- Uplevel_References (Elist24) (non-generic case only)
-- Interface_Alias (Node25)
-- Overridden_Operation (Node26) (never for init proc)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Has_Invariants (Flag232)
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
+ -- Has_Nested_Subprogram (Flag282)
-- Is_Abstract_Subprogram (Flag19) (non-generic case only)
-- Is_Asynchronous (Flag81)
-- Is_Called (Flag102) (non-generic case only)
-- Has_Independent_Components (Flag34)
-- Has_Initial_Value (Flag219)
-- Has_Size_Clause (Flag29)
- -- Has_Up_Level_Access (Flag215)
+ -- Has_Uplevel_Reference (Flag215)
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
function Has_Master_Entity (Id : E) return B;
function Has_Missing_Return (Id : E) return B;
function Has_Nested_Block_With_Handler (Id : E) return B;
+ function Has_Nested_Subprogram (Id : E) return B;
function Has_Non_Standard_Rep (Id : E) return B;
function Has_Object_Size_Clause (Id : E) return B;
function Has_Out_Or_In_Out_Parameter (Id : E) return B;
function Has_Thunks (Id : E) return B;
function Has_Unchecked_Union (Id : E) return B;
function Has_Unknown_Discriminants (Id : E) return B;
- function Has_Up_Level_Access (Id : E) return B;
+ function Has_Uplevel_Reference (Id : E) return B;
function Has_Visible_Refinement (Id : E) return B;
function Has_Volatile_Components (Id : E) return B;
function Has_Xref_Entry (Id : E) return B;
function Is_Return_Object (Id : E) return B;
function Is_Safe_To_Reevaluate (Id : E) return B;
function Is_Shared_Passive (Id : E) return B;
+ function Is_Static_Type (Id : E) return B;
function Is_Statically_Allocated (Id : E) return B;
function Is_Tag (Id : E) return B;
function Is_Tagged_Type (Id : E) return B;
function Underlying_Record_View (Id : E) return E;
function Universal_Aliasing (Id : E) return B;
function Unset_Reference (Id : E) return N;
+ function Uplevel_Reference_Noted (Id : E) return B;
+ function Uplevel_References (Id : E) return L;
function Used_As_Generic_Actual (Id : E) return B;
function Uses_Lock_Free (Id : E) return B;
function Uses_Sec_Stack (Id : E) return B;
procedure Set_Has_Master_Entity (Id : E; V : B := True);
procedure Set_Has_Missing_Return (Id : E; V : B := True);
procedure Set_Has_Nested_Block_With_Handler (Id : E; V : B := True);
+ procedure Set_Has_Nested_Subprogram (Id : E; V : B := True);
procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True);
procedure Set_Has_Object_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Out_Or_In_Out_Parameter (Id : E; V : B := True);
procedure Set_Has_Thunks (Id : E; V : B := True);
procedure Set_Has_Unchecked_Union (Id : E; V : B := True);
procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True);
- procedure Set_Has_Up_Level_Access (Id : E; V : B := True);
+ procedure Set_Has_Uplevel_Reference (Id : E; V : B := True);
procedure Set_Has_Visible_Refinement (Id : E; V : B := True);
procedure Set_Has_Volatile_Components (Id : E; V : B := True);
procedure Set_Has_Xref_Entry (Id : E; V : B := True);
procedure Set_Is_Return_Object (Id : E; V : B := True);
procedure Set_Is_Safe_To_Reevaluate (Id : E; V : B := True);
procedure Set_Is_Shared_Passive (Id : E; V : B := True);
+ procedure Set_Is_Static_Type (Id : E; V : B := True);
procedure Set_Is_Statically_Allocated (Id : E; V : B := True);
procedure Set_Is_Tag (Id : E; V : B := True);
procedure Set_Is_Tagged_Type (Id : E; V : B := True);
procedure Set_Underlying_Record_View (Id : E; V : E);
procedure Set_Universal_Aliasing (Id : E; V : B := True);
procedure Set_Unset_Reference (Id : E; V : N);
+ procedure Set_Uplevel_Reference_Noted (Id : E; V : B := True);
+ procedure Set_Uplevel_References (Id : E; V : L);
procedure Set_Used_As_Generic_Actual (Id : E; V : B := True);
procedure Set_Uses_Lock_Free (Id : E; V : B := True);
procedure Set_Uses_Sec_Stack (Id : E; V : B := True);
pragma Inline (Has_Master_Entity);
pragma Inline (Has_Missing_Return);
pragma Inline (Has_Nested_Block_With_Handler);
+ pragma Inline (Has_Nested_Subprogram);
pragma Inline (Has_Non_Standard_Rep);
pragma Inline (Has_Object_Size_Clause);
pragma Inline (Has_Out_Or_In_Out_Parameter);
pragma Inline (Has_Thunks);
pragma Inline (Has_Unchecked_Union);
pragma Inline (Has_Unknown_Discriminants);
- pragma Inline (Has_Up_Level_Access);
+ pragma Inline (Has_Uplevel_Reference);
pragma Inline (Has_Visible_Refinement);
pragma Inline (Has_Volatile_Components);
pragma Inline (Has_Xref_Entry);
pragma Inline (Is_Scalar_Type);
pragma Inline (Is_Shared_Passive);
pragma Inline (Is_Signed_Integer_Type);
+ pragma Inline (Is_Static_Type);
pragma Inline (Is_Statically_Allocated);
pragma Inline (Is_Subprogram);
pragma Inline (Is_Tag);
pragma Inline (Underlying_Record_View);
pragma Inline (Universal_Aliasing);
pragma Inline (Unset_Reference);
+ pragma Inline (Uplevel_Reference_Noted);
+ pragma Inline (Uplevel_References);
pragma Inline (Used_As_Generic_Actual);
pragma Inline (Uses_Lock_Free);
pragma Inline (Uses_Sec_Stack);
pragma Inline (Set_Has_Master_Entity);
pragma Inline (Set_Has_Missing_Return);
pragma Inline (Set_Has_Nested_Block_With_Handler);
+ pragma Inline (Set_Has_Nested_Subprogram);
pragma Inline (Set_Has_Non_Standard_Rep);
pragma Inline (Set_Has_Object_Size_Clause);
pragma Inline (Set_Has_Out_Or_In_Out_Parameter);
pragma Inline (Set_Has_Thunks);
pragma Inline (Set_Has_Unchecked_Union);
pragma Inline (Set_Has_Unknown_Discriminants);
- pragma Inline (Set_Has_Up_Level_Access);
+ pragma Inline (Set_Has_Uplevel_Reference);
pragma Inline (Set_Has_Visible_Refinement);
pragma Inline (Set_Has_Volatile_Components);
pragma Inline (Set_Has_Xref_Entry);
pragma Inline (Set_Is_Return_Object);
pragma Inline (Set_Is_Safe_To_Reevaluate);
pragma Inline (Set_Is_Shared_Passive);
+ pragma Inline (Set_Is_Static_Type);
pragma Inline (Set_Is_Statically_Allocated);
pragma Inline (Set_Is_Tag);
pragma Inline (Set_Is_Tagged_Type);
pragma Inline (Set_Underlying_Full_View);
pragma Inline (Set_Underlying_Record_View);
pragma Inline (Set_Universal_Aliasing);
+ pragma Inline (Set_Uplevel_Reference_Noted);
+ pragma Inline (Set_Uplevel_References);
pragma Inline (Set_Unset_Reference);
pragma Inline (Set_Used_As_Generic_Actual);
pragma Inline (Set_Uses_Lock_Free);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
return Elmts.Last;
end Last_Elmt_Id;
+ -----------------
+ -- List_Length --
+ -----------------
+
+ function List_Length (List : Elist_Id) return Nat is
+ Elmt : Elmt_Id;
+ N : Nat;
+ begin
+ N := 0;
+ Elmt := First_Elmt (List);
+ loop
+ if No (Elmt) then
+ return N;
+ else
+ Next_Elmt (Elmt);
+ end if;
+ end loop;
+ end List_Length;
+
----------
-- Lock --
----------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
-- Obtains the last element of the given element list or, if the list has
-- no items, then No_Elmt is returned.
+ function List_Length (List : Elist_Id) return Nat;
+ -- Returns number of elements in given List
+
function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id;
pragma Inline (Next_Elmt);
-- This function returns the next element on an element list. The argument
with Exp_Pakd; use Exp_Pakd;
with Exp_Prag; use Exp_Prag;
with Exp_Tss; use Exp_Tss;
+with Exp_Unst; use Exp_Unst;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Inline; use Inline;
-- Set to encode entity names in package body before gigi is called
Qualify_Entity_Names (N);
+
+ -- If we are unnesting procedures, and this is an outer level procedure
+ -- with nested subprograms, do the unnesting operation now.
+
+ if Opt.Unnest_Subprogram_Mode
+ and then Is_Library_Level_Entity (Spec_Id)
+ and then Has_Nested_Subprogram (Spec_Id)
+ then
+ Unnest_Subprogram (Spec_Id, N);
+ end if;
end Expand_N_Subprogram_Body;
-----------------------------------
if Present (Decls) then
Decl := First (Decls);
-
while Present (Decl) loop
- if Comes_From_Source (Decl) then
- exit;
- else
- Insert_Node := Decl;
- end if;
-
+ exit when Comes_From_Source (Decl);
+ Insert_Node := Decl;
Next (Decl);
end loop;
end if;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- E X P _ U N S T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2015, 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Rtsfind; use Rtsfind;
+with Sem_Aux; use Sem_Aux;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Table;
+with Tbuild; use Tbuild;
+
+package body Exp_Unst is
+
+ -------------------------------------
+ -- Check_Uplevel_Reference_To_Type --
+ -------------------------------------
+
+ procedure Check_Uplevel_Reference_To_Type (Typ : Entity_Id) is
+ function Check_Dynamic_Type (T : Entity_Id) return Boolean;
+ -- This is an internal recursive routine that checks if T or any of
+ -- its subsdidiary types are dynamic. If so, then the original Typ is
+ -- marked as having an uplevel reference, as is the subsidiary type in
+ -- question, and any referenced dynamic bounds are also marked as having
+ -- an uplevel reference, and True is returned. If the type is a static
+ -- type, then False is returned;
+
+ ------------------------
+ -- Check_Dynamic_Type --
+ ------------------------
+
+ function Check_Dynamic_Type (T : Entity_Id) return Boolean is
+ DT : Boolean := False;
+
+ begin
+ -- If it's a static type, nothing to do
+
+ if Is_Static_Type (T) then
+ return False;
+
+ -- If the type is uplevel referenced, then it must be dynamic
+
+ elsif Has_Uplevel_Reference (T) then
+ Set_Has_Uplevel_Reference (Typ);
+ return True;
+
+ -- Otherwise we need to figure out what the story is with this type
+
+ else
+ DT := False;
+
+ -- For a scalar type, check bounds
+
+ if Is_Scalar_Type (T) then
+
+ -- If both bounds static, then this is a static type
+
+ declare
+ LB : constant Node_Id := Type_Low_Bound (T);
+ UB : constant Node_Id := Type_High_Bound (T);
+
+ begin
+ if not Is_Static_Expression (LB) then
+ Set_Has_Uplevel_Reference (Entity (LB));
+ DT := True;
+ end if;
+
+ if not Is_Static_Expression (UB) then
+ Set_Has_Uplevel_Reference (Entity (UB));
+ DT := True;
+ end if;
+ end;
+
+ -- For record type, check all components
+
+ elsif Is_Record_Type (T) then
+ declare
+ C : Entity_Id;
+
+ begin
+ C := First_Component_Or_Discriminant (T);
+ while Present (T) loop
+ if Check_Dynamic_Type (C) then
+ DT := True;
+ end if;
+
+ Next_Component_Or_Discriminant (C);
+ end loop;
+ end;
+
+ -- For array type, check index types and component type
+
+ elsif Is_Array_Type (T) then
+ declare
+ IX : Node_Id;
+
+ begin
+ if Check_Dynamic_Type (Component_Type (T)) then
+ DT := True;
+ end if;
+
+ IX := First_Index (T);
+ while Present (IX) loop
+ if Check_Dynamic_Type (Etype (IX)) then
+ DT := True;
+ end if;
+
+ Next_Index (IX);
+ end loop;
+ end;
+
+ -- For now, ignore other types
+
+ else
+ return False;
+ end if;
+
+ -- See if we marked that type as dynamic
+
+ if DT then
+ Set_Has_Uplevel_Reference (T);
+ Set_Has_Uplevel_Reference (Typ);
+ return True;
+
+ -- If not mark it as static
+
+ else
+ Set_Is_Static_Type (T);
+ return False;
+ end if;
+ end if;
+ end Check_Dynamic_Type;
+
+ -- Start of processing for Check_Uplevel_Reference_To_Type
+
+ begin
+ -- Nothing to do if we know this is a static type
+
+ if Is_Static_Type (Typ) then
+ return;
+
+ -- Nothing to do if already marked as uplevel referenced
+
+ elsif Has_Uplevel_Reference (Typ) then
+ return;
+
+ -- Otherwise check if we have a dynamic type
+
+ else
+ if Check_Dynamic_Type (Typ) then
+ Set_Has_Uplevel_Reference (Typ);
+ end if;
+ end if;
+
+ null;
+ end Check_Uplevel_Reference_To_Type;
+
+ ----------------------------
+ -- Note_Uplevel_Reference --
+ ----------------------------
+
+ procedure Note_Uplevel_Reference (N : Node_Id; Subp : Entity_Id) is
+ begin
+ -- Establish list if first call for Uplevel_References
+
+ if No (Uplevel_References (Subp)) then
+ Set_Uplevel_References (Subp, New_Elmt_List);
+ end if;
+
+ -- Add new element to Uplevel_References
+
+ Append_Elmt (N, Uplevel_References (Subp));
+ Set_Has_Uplevel_Reference (Entity (N));
+ end Note_Uplevel_Reference;
+
+ -----------------------
+ -- Unnest_Subprogram --
+ -----------------------
+
+ -- Tables used by Unnest_Subprogram
+
+ type Subp_Entry is record
+ Ent : Entity_Id;
+ -- Entity of the subprogram
+
+ Bod : Node_Id;
+ -- Subprogram_Body node for this subprogram
+
+ Lev : Nat;
+ -- Subprogram level (1 = outer subprogram (Subp argument), 2 = nested
+ -- immediately within this outer subprogram etc.)
+ end record;
+
+ package Subps is new Table.Table (
+ Table_Component_Type => Subp_Entry,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 100,
+ Table_Increment => 200,
+ Table_Name => "Subps");
+ -- Records the subprograms in the nest whose outer subprogram is Subp
+
+ type Call_Entry is record
+ N : Node_Id;
+ -- The actual call
+
+ From : Entity_Id;
+ -- Entity of the subprogram containing the call
+
+ To : Entity_Id;
+ -- Entity of the subprogram called
+ end record;
+
+ package Calls is new Table.Table (
+ Table_Component_Type => Call_Entry,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 100,
+ Table_Increment => 200,
+ Table_Name => "Calls");
+ -- Records each call within the outer subprogram and all nested subprograms
+ -- that are to other subprograms nested within the outer subprogram. These
+ -- are the calls that may need an additional parameter.
+
+ procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is
+
+ function Get_AREC_String (Lev : Pos) return String;
+ -- Given a level value, 1, 2, ... returns the string AREC, AREC2, ...
+
+ function Get_Level (Sub : Entity_Id) return Nat;
+ -- Sub is either Subp itself, or a subprogram nested within Subp. This
+ -- function returns the level of nesting (Subp = 1, subprograms that
+ -- are immediately nested within Subp = 2, etc).
+
+ ---------------------
+ -- Get_AREC_String --
+ ---------------------
+
+ function Get_AREC_String (Lev : Pos) return String is
+ begin
+ if Lev > 9 then
+ return
+ Get_AREC_String (Lev / 10) & Character'Val (Lev mod 10 + 48);
+ else
+ return
+ "AREC" & Character'Val (Lev + 48);
+ end if;
+ end Get_AREC_String;
+
+ ---------------
+ -- Get_Level --
+ ---------------
+
+ function Get_Level (Sub : Entity_Id) return Nat is
+ Lev : Nat;
+ S : Entity_Id;
+ begin
+ Lev := 1;
+ S := Sub;
+ loop
+ if S = Subp then
+ return Lev;
+ else
+ S := Enclosing_Dynamic_Scope (S);
+ Lev := Lev + 1;
+ end if;
+ end loop;
+ end Get_Level;
+
+ -- Start of processing for Unnest_Subprogram
+
+ begin
+ -- First step, we must mark all nested subprograms that require a static
+ -- link (activation record) because either they contain explicit uplevel
+ -- references (as indicated by Has_Uplevel_Reference being set at this
+ -- point), or they make calls to other subprograms in the same nest that
+ -- require a static link (in which case we set this flag).
+
+ -- This is a recursive definition, and to implement this, we have to
+ -- build a call graph for the set of nested subprograms, and then go
+ -- over this graph to implement recursively the invariant that if a
+ -- subprogram has a call to a subprogram requiring a static link, then
+ -- the calling subprogram requires a static link.
+
+ -- First step, populate the above tables
+
+ Subps.Init;
+ Calls.Init;
+
+ Build_Tables : declare
+ function Visit_Node (N : Node_Id) return Traverse_Result;
+ -- Visit a single node in Subp
+
+ ----------------
+ -- Visit_Node --
+ ----------------
+
+ function Visit_Node (N : Node_Id) return Traverse_Result is
+ Ent : Entity_Id;
+
+ function Find_Current_Subprogram return Entity_Id;
+ -- Finds the current subprogram containing the call N
+
+ -----------------------------
+ -- Find_Current_Subprogram --
+ -----------------------------
+
+ function Find_Current_Subprogram return Entity_Id is
+ Nod : Node_Id;
+
+ begin
+ Nod := N;
+ loop
+ Nod := Parent (Nod);
+
+ if Nkind (Nod) = N_Subprogram_Body then
+ if Acts_As_Spec (Nod) then
+ return Defining_Unit_Name (Specification (Nod));
+ else
+ return Corresponding_Spec (Nod);
+ end if;
+ end if;
+ end loop;
+ end Find_Current_Subprogram;
+
+ -- Start of processing for Visit_Node
+
+ begin
+ if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then
+ Ent := Entity (Name (N));
+
+ if not Is_Library_Level_Entity (Ent) then
+ Calls.Append ((N, Find_Current_Subprogram, Ent));
+ end if;
+
+ elsif Nkind (N) = N_Subprogram_Body and then Acts_As_Spec (N) then
+ Ent := Defining_Unit_Name (Specification (N));
+ Subps.Append
+ ((Ent => Ent,
+ Bod => N,
+ Lev => Get_Level (Ent)));
+
+ elsif Nkind (N) = N_Subprogram_Declaration then
+ Ent := Defining_Unit_Name (Specification (N));
+ Subps.Append
+ ((Ent => Ent,
+ Bod => Corresponding_Body (N),
+ Lev => Get_Level (Ent)));
+ end if;
+
+ return OK;
+ end Visit_Node;
+
+ -----------
+ -- Visit --
+ -----------
+
+ procedure Visit is new Traverse_Proc (Visit_Node);
+ -- Used to traverse the body of Subp, populating the tables
+
+ begin
+ Visit (Subp_Body);
+ end Build_Tables;
+
+ -- Second step is to do the transitive closure, if any subprogram has
+ -- a call to a subprogram for which Has_Uplevel_Reference is set, then
+ -- we set Has_Uplevel_Reference for the calling routine.
+
+ Closure : declare
+ Modified : Boolean;
+
+ begin
+ -- We use a simple minded algorithm as follows (obviously this can
+ -- be done more efficiently, using one of the standard algorithms
+ -- for efficient transitive closure computation, but this is simple
+ -- and most likely fast enough that its speed does not matter).
+
+ -- Repeatedly scan the list of calls. Any time we find a call from
+ -- A to B, where A does not have Has_Uplevel_Reference, and B does
+ -- have this flag set, then set the flag for A, and note that we
+ -- have made a change by setting Modified True. We repeat this until
+ -- we make a pass with no modifications.
+
+ Outer : loop
+ Modified := False;
+ Inner : for J in Calls.First .. Calls.Last loop
+ if not Has_Uplevel_Reference (Calls.Table (J).From)
+ and then Has_Uplevel_Reference (Calls.Table (J).To)
+ then
+ Set_Has_Uplevel_Reference (Calls.Table (J).From);
+ Modified := True;
+ end if;
+ end loop Inner;
+
+ exit Outer when not Modified;
+ end loop Outer;
+ end Closure;
+
+ -- Next step, process each subprogram in turn, inserting necessary
+ -- declarations for ARECxx types and variables for any subprogram
+ -- that has nested subprograms, and is uplevel referenced.
+
+ Arec_Decls : declare
+ Addr : constant Entity_Id := RTE (RE_Address);
+
+ begin
+ for J in Subps.First .. Subps.Last loop
+ declare
+ STJ : Subp_Entry renames Subps.Table (J);
+
+ begin
+ -- We add AREC declarations for any subprogram that has at
+ -- least one nested subprogram, and has uplevel references.
+
+ if Has_Nested_Subprogram (STJ.Ent)
+ and then Has_Uplevel_Reference (STJ.Ent)
+ then
+ Add_AREC_Declarations : declare
+ Loc : constant Source_Ptr := Sloc (STJ.Bod);
+ ARS : constant String := Get_AREC_String (STJ.Lev);
+ Urefs : constant Elist_Id :=
+ Uplevel_References (STJ.Ent);
+ Elmt : Elmt_Id;
+ Ent : Entity_Id;
+ Clist : List_Id;
+
+ Uplevel_Entities :
+ array (1 .. List_Length (Urefs)) of Entity_Id;
+ Num_Uplevel_Entities : Nat;
+ -- Uplevel_Entities (1 .. Num_Uplevel_Entities) contains
+ -- a list (with no duplicates) of the entities for this
+ -- subprogram that are referenced uplevel. The maximum
+ -- number of entries cannot exceed the total number of
+ -- uplevel references.
+
+ begin
+ -- Populate the Uplevel_Entities array, using the flag
+ -- Uplevel_Reference_Noted to avoid duplicates.
+
+ Num_Uplevel_Entities := 0;
+ Elmt := First_Elmt (Urefs);
+ while Present (Elmt) loop
+ Ent := Entity (Node (Elmt));
+
+ if not Uplevel_Reference_Noted (Ent) then
+ Set_Uplevel_Reference_Noted (Ent, True);
+ Num_Uplevel_Entities := Num_Uplevel_Entities + 1;
+ Uplevel_Entities (Num_Uplevel_Entities) := Ent;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ -- Build list of component declarations for ARECnT
+
+ Clist := Empty_List;
+
+ -- If not top level, include ARECn : ARECnPT := ARECnP
+
+ if STJ.Lev > 1 then
+ Append_To (Clist,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_Find_Str (ARS)),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ Make_Identifier (Loc,
+ Chars => Name_Find_Str (ARS & "PT"))),
+ Expression =>
+ Make_Identifier (Loc,
+ Chars => Name_Find_Str (ARS & "P"))));
+ end if;
+
+ -- Add components for uplevel referenced entities
+
+ for J in 1 .. Num_Uplevel_Entities loop
+ Append_To (Clist,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Uplevel_Entities (J))),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (Addr, Loc))));
+ end loop;
+
+ -- Now we can insert the AREC declarations into the body
+
+ Prepend_List_To (Declarations (STJ.Bod),
+ New_List (
+
+ -- type ARECT is record .. end record;
+
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_Find_Str (ARS & "T")),
+ Type_Definition =>
+ Make_Record_Definition (Loc,
+ Component_List =>
+ Make_Component_List (Loc,
+ Component_Items => Clist))),
+
+ -- type ARECPT is access all ARECT;
+
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_Find_Str (ARS & "PT")),
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ Make_Identifier (Loc,
+ Chars => Name_Find_Str (ARS & "T")))),
+
+ -- ARECP : constant ARECPT := AREC'Access;
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_Find_Str (ARS & "P")),
+ Constant_Present => True,
+ Object_Definition =>
+ Make_Identifier (Loc, Name_Find_Str (ARS & "PT")),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_Find_Str (ARS)),
+ Attribute_Name => Name_Access))));
+ end Add_AREC_Declarations;
+ end if;
+ end;
+ end loop;
+ end Arec_Decls;
+
+ -- Next step, for each uplevel referenced entity, add assignment
+ -- operations to set the corresponding AREC fields, and define
+ -- the PTR types.
+
+ return;
+ end Unnest_Subprogram;
+
+end Exp_Unst;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- E X P _ U N S T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2015, 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Expand routines for unnesting subprograms
+
+with Types; use Types;
+
+package Exp_Unst is
+
+ -- -----------------
+ -- -- The Problem --
+ -- -----------------
+
+ -- Normally, nested subprograms in the source result in corresponding
+ -- nested subprograms in the resulting tree. We then expect the back end
+ -- to handle such nested subprograms, including all cases of uplevel
+ -- references. For example, the GCC back end can do this relatively easily
+ -- since GNU C (as an extension) allows nested functions with uplevel
+ -- references, and implements an appropriate static chain approach to
+ -- dealing with such uplevel references.
+
+ -- However, we also want to be able to interface with back ends that do
+ -- not easily handle such uplevel references. One example is the back end
+ -- that translates the tree into standard C source code. In the future,
+ -- other back ends might need the same capability (e.g. a back end that
+ -- generated LLVM intermediate code).
+
+ -- We could imagine simply handling such references in the appropriate
+ -- back end. For example the back end that generates C could recognize
+ -- nested subprograms and rig up some way of translating them, e.g. by
+ -- making a static-link source level visible.
+
+ -- Rather than take that approach, we prefer to do a semantics-preserving
+ -- transformation on the GNAT tree, that eliminates the problem before we
+ -- hand the tree over to the back end. There are two reasons for preferring
+ -- this approach:
+
+ -- First: the work needs only to be done once for all affected back ends
+ -- and we can remain within the semantics of the tree. The front end is
+ -- full of tree transformations, so we have all the infrastructure for
+ -- doing transformations of this type.
+
+ -- Second: given that the transformation will be semantics-preserving,
+ -- we can still used the standard GCC back end to build code from it.
+ -- This means we can easily run our full test suite to verify that the
+ -- transformations are indeed semantics preserving. It is a lot more
+ -- work to thoroughly test the output of specialized back ends.
+
+ -- Looking at the problem, we have three situations to deal with. Note
+ -- that in these examples, we use all lower case, since that is the way
+ -- the internal tree is cased.
+
+ -- First, cases where there are no uplevel references, for example
+
+ -- procedure case1 is
+ -- function max (m, n : Integer) return integer is
+ -- begin
+ -- return integer'max (m, n);
+ -- end max;
+ -- ...
+ -- end case1;
+
+ -- Second, cases where there are explicit uplevel references.
+
+ -- procedure case2 (b : integer) is
+ -- procedure Inner (bb : integer);
+ --
+ -- procedure inner2 is
+ -- begin
+ -- inner(5);
+ -- end;
+ --
+ -- x : integer := 77;
+ -- y : constant integer := 15 * 16;
+ -- rv : integer := 10;
+ --
+ -- procedure inner (bb : integer) is
+ -- begin
+ -- x := rv + y + bb + b;
+ -- end;
+ --
+ -- begin
+ -- inner2;
+ -- end case2;
+
+ -- In this second example, B, X, RV are uplevel referenced. Y is not
+ -- considered as an uplevel reference since it is a static constant
+ -- where references are replaced by the value at compile time.
+
+ -- Third, cases where there are implicit uplevel references via types
+ -- whose bounds depend on locally declared constants or variables:
+
+ -- function case3 (x, y : integer) return boolean is
+ -- subtype dynam is integer range x .. y + 3;
+ -- subtype static is integer range 42 .. 73;
+ -- xx : dynam := y;
+ --
+ -- type darr is array (dynam) of Integer;
+ -- type darec is record
+ -- A : darr;
+ -- B : integer;
+ -- end record;
+ -- darecv : darec;
+ --
+ -- function inner (b : integer) return boolean is
+ -- begin
+ -- return b in dynam and then darecv.b in static;
+ -- end inner;
+ --
+ -- begin
+ -- return inner (42) and then inner (xx * 3 - y * 2);
+ -- end case3;
+ --
+ -- In this third example, the membership test implicitly references the
+ -- the bounds of Dynam, which both involve uplevel references.
+
+ -- ------------------
+ -- -- The Solution --
+ -- ------------------
+
+ -- Looking at the three cases above, the first case poses no problem at
+ -- all. Indeed the subprogram could have been declared at the outer level
+ -- (perhaps changing the name). But this style is quite common as a way
+ -- of limiting the scope of a local procedure called only within the outer
+ -- procedure. We could move it to the outer level (with a name change if
+ -- needed), but we don't bother. We leave it nested, and the back end just
+ -- translates it as though it were not nested.
+
+ -- In general we leave nested procedures nested, rather than trying to move
+ -- them to the outer level (the back end may do that, e.g. as part of the
+ -- translation to C, but we don't do it in the tree itself). This saves a
+ -- LOT of trouble in terms of visibility and semantics.
+
+ -- But of course we have to deal with the uplevel references. The idea is
+ -- to rewrite these nested subprograms so that they no longer have any such
+ -- uplevel references, so by the time they reach the back end, they all are
+ -- case 1 (no uplevel references) and thus easily handled.
+
+ -- To deal with explicit uplevel references (case 2 above), we proceed with
+ -- the following steps:
+
+ -- All entities marked as being uplevel referenced are marked as aliased
+ -- since they will be accessed indirectly via an activation record as
+ -- described below.
+
+ -- For each such entity xxx we create an access type xxxPTR (forced to
+ -- single length in the unconstrained case).
+
+ -- An activation record is created containing system address values
+ -- for each uplevel referenced entity in a given scope. In the example
+ -- given before, we would have:
+
+ -- type AREC1T is record
+ -- b : Address;
+ -- x : Address;
+ -- rv : Address;
+ -- end record;
+ -- type AREC1P is access all AREC1T;
+ -- AREC1 : AREC1T;
+
+ -- The fields of AREC1 are set at the point the corresponding entity
+ -- is declared (immediately for parameters).
+
+ -- Note: the 1 in all these names represents the fact that we are at the
+ -- outer level of nesting. As we will see later, deeper levels of nesting
+ -- will use AREC2, AREC3, ...
+
+ -- For all subprograms nested immediately within the corresponding scope,
+ -- a parameter AREC1P is passed, and all calls to these routines have
+ -- AREC1 added as an additional formal.
+
+ -- Now within the nested procedures, any reference to an uplevel entity
+ -- xxx is replaced by Tnn!(AREC1.xxx).all (where ! represents a call
+ -- to unchecked conversion to convert the address to the access type
+ -- and Tnn is a locally declared type that is "access all t", where t
+ -- is the type of the reference.
+
+ -- Note: the reason that we use Address as the component type in the
+ -- declaration of AREC1T is that we may create this type before we see
+ -- the declaration of this type.
+
+ -- The following shows example 2 above after this translation:
+
+ -- procedure case2x (b : aliased Integer) is
+ -- type AREC1T is record
+ -- b : Address;
+ -- x : Address;
+ -- rv : Address;
+ -- end record;
+ --
+ -- AREC1 : aliased AREC1T;
+ -- type AREC1PT is access all AREC1T;
+ -- AREC1P : constant AREC1PT := AREC1'Access;
+ --
+ -- AREC1.b := b'Address;
+ --
+ -- procedure inner (bb : integer; AREC1P : AREC1PT);
+ --
+ -- procedure inner2 (AREC1P : AREC1PT) is
+ -- begin
+ -- inner(5, AREC1P);
+ -- end;
+ --
+ -- x : aliased integer := 77;
+ -- AREC1.x := X'Address;
+ --
+ -- y : constant Integer := 15 * 16;
+ --
+ -- rv : aliased Integer;
+ -- AREC1.rv := rv'Address;
+ --
+ -- procedure inner (bb : integer; AREC1P : AREC1PT) is
+ -- begin
+ -- type Tnn1 is access all Integer;
+ -- type Tnn2 is access all Integer;
+ -- type Tnn3 is access all Integer;
+ -- Tnn1!(AREC1P.x).all :=
+ -- Tnn2!(AREC1P.rv).all + y + b + Tnn3!(AREC1P.b).all;
+ -- end;
+ --
+ -- begin
+ -- inner2 (AREC1P);
+ -- end case2x;
+
+ -- And now the inner procedures INNER2 and INNER have no uplevel references
+ -- so they have been reduced to case 1, which is the case easily handled by
+ -- the back end. Note that the generated code is not strictly legal Ada
+ -- because of the assignments to AREC1 in the declarative sequence, but the
+ -- GNAT tree always allows such mixing of declarations and statements, so
+ -- the back end must be prepared to handle this in any case.
+
+ -- Case 3 where we have uplevel references to types is a bit more complex.
+ -- That would especially be the case if we did a full transformation that
+ -- completely eliminated such uplevel references as we did for case 2. But
+ -- instead of trying to do that, we rewrite the subprogram so that the code
+ -- generator can easily detect and deal with these uplevel type references.
+
+ -- First we distinguish two cases
+
+ -- Static types are one of the two following cases:
+
+ -- Discrete types whose bounds are known at compile time. This is not
+ -- quite the same as what is tested by Is_OK_Static_Subtype, in that
+ -- it allows compile time known values that are not static expressions.
+
+ -- Composite types, whose components are (recursively) static types.
+
+ -- Dynamic types are one of the two following cases:
+
+ -- Discrete types with at least one bound not known at compile time.
+
+ -- Composite types with at least one component that is (recursively)
+ -- a dynamic type.
+
+ -- Uplevel references to static types are not a problem, the front end
+ -- or the code generator fetches the bounds as required, and since they
+ -- are compile time known values, this value can just be extracted and
+ -- no actual uplevel reference is required.
+
+ -- Uplevel references to dynamic types are a potential problem, since
+ -- such references may involve an implicit access to a dynamic bound,
+ -- and this reference is an implicit uplevel access.
+
+ -- To fully unnest such references would be messy, since we would have
+ -- to create local copies of the dynamic types involved, so that the
+ -- front end or code generator could generate an explicit uplevel
+ -- reference to the bound involved. Rather than do that, we set things
+ -- up so that this situation can be easily detected and dealt with when
+ -- there is an implicit reference to the bounds.
+
+ -- What we do is to always generate a local constant for any dynamic
+ -- bound in a dynamic subtype xx with name xx_FIRST or xx_LAST. The one
+ -- case where we can skip this is where the bound is For
+ -- example in the third example above, subtype dynam is expanded as
+
+ -- dynam_LAST : constant Integer := y + 3;
+ -- subtype dynam is integer range x .. dynam_LAST;
+
+ -- Now if type dynam is uplevel referenced (as it is this case), then
+ -- the bounds x and dynam_LAST are marked as uplevel references
+ -- so that appropriate entries are made in the activation record. Any
+ -- explicit reference to such a bound in the front end generated code
+ -- will be handled by the normal uplevel reference mechanism which we
+ -- described above for case 2. For implicit references by a back end
+ -- that needs to unnest things, any such implicit reference to one of
+ -- these bounds can be replaced by an appropriate reference to the entry
+ -- in the activation record for xx_FIRST or xx_LAST. Thus the back end
+ -- can eliminate the problematical uplevel reference without the need to
+ -- do the heavy tree modification to do that at the code expansion level
+
+ -- Looking at case 3 again, here is the normal -gnatG expanded code
+
+ -- function case3 (x : integer; y : integer) return boolean is
+ -- dynam_LAST : constant integer := y {+} 3;
+ -- subtype dynam is integer range x .. dynam_LAST;
+ -- subtype static is integer range 42 .. 73;
+ --
+ -- [constraint_error when
+ -- not (y in x .. dynam_LAST)
+ -- "range check failed"]
+ --
+ -- xx : dynam := y;
+ --
+ -- type darr is array (x .. dynam_LAST) of integer;
+ -- type darec is record
+ -- a : darr;
+ -- b : integer;
+ -- end record;
+ -- [type TdarrB is array (x .. dynam_LAST range <>) of integer]
+ -- freeze TdarrB []
+ -- darecv : darec;
+ --
+ -- function inner (b : integer) return boolean is
+ -- begin
+ -- return b in x .. dynam_LAST and then darecv.b in 42 .. 73;
+ -- end inner;
+ -- begin
+ -- return inner (42) and then inner (xx {*} 3 {-} y {*} 2);
+ -- end case3;
+
+ -- Note: the actual expanded code has fully qualified names so for
+ -- example function inner is actually function case3__inner. For now
+ -- we ignore that detail to clarify the examples.
+
+ -- Here we see that some of the bounds references are expanded by the
+ -- front end, so that we get explicit references to y or dynamLast. These
+ -- cases are handled by the normal uplevel reference mechanism described
+ -- above for case 2. This is the case for the constraint check for the
+ -- initialization of xx, and the range check in function inner.
+
+ -- But the reference darecv.b in the return statement of function
+ -- inner has an implicit reference to the bounds of dynam, since to
+ -- compute the location of b in the record, we need the length of a.
+
+ -- Here is the full translation of the third example:
+
+ -- function case3x (x, y : integer) return boolean is
+ -- type AREC1T is record
+ -- x : Address;
+ -- dynam_LAST : Address;
+ -- end record;
+ --
+ -- AREC1 : aliased AREC1T;
+ -- type AREC1PT is access all AREC1T;
+ -- AREC1P : constant AREC1PT := AREC1'Access;
+ --
+ -- AREC1.x := x'Address;
+ --
+ -- dynam_LAST : constant integer := y {+} 3;
+ -- AREC1.dynam_LAST := dynam_LAST'Address;
+ -- subtype dynam is integer range x .. dynam_LAST;
+ -- xx : dynam := y;
+ --
+ -- [constraint_error when
+ -- not (y in x .. dynam_LAST)
+ -- "range check failed"]
+ --
+ -- subtype static is integer range 42 .. 73;
+ --
+ -- type darr is array (x .. dynam_LAST) of Integer;
+ -- type darec is record
+ -- A : darr;
+ -- B : integer;
+ -- end record;
+ -- darecv : darec;
+ --
+ -- function inner (b : integer; AREC1P : AREC1PT) return boolean is
+ -- begin
+ -- type Tnn is access all Integer
+ -- return b in x .. Tnn!(AREC1P.dynam_LAST).all
+ -- and then darecv.b in 42 .. 73;
+ -- end inner;
+ --
+ -- begin
+ -- return inner (42, AREC1P) and then inner (xx * 3, AREC1P);
+ -- end case3x;
+
+ -- And now the back end when it processes darecv.b will access the bounds
+ -- of darecv.a by referencing the d and dynam_LAST fields of AREC1P.
+
+ -----------------------------
+ -- Multiple Nesting Levels --
+ -----------------------------
+
+ -- In our examples so far, we have only nested to a single level, but the
+ -- scheme generalizes to multiple levels of nesting and in this section we
+ -- discuss how this generalization works.
+
+ -- Consider this example with two nesting levels
+
+ -- To deal with elimination of uplevel references, we follow the same basic
+ -- approach described above for case 2, except that we need an activation
+ -- record at each nested level. Basically the rule is that any procedure
+ -- that has nested procedures needs an activation record. When we do this,
+ -- the inner activation records have a pointer to the immediately enclosing
+ -- activation record, the normal arrangement of static links. The following
+ -- shows the full translation of this fourth case.
+
+ -- function case4x (x : integer) return integer is
+ -- type AREC1T is record
+ -- v1 : Address;
+ -- end record;
+ --
+ -- AREC1 : aliased AREC1T;
+ -- type AREC1PT is access all AREC1T;
+ -- AREC1P : constant AREC1PT := AREC1'Access;
+ --
+ -- v1 : integer := x;
+ -- AREC1.v1 := v1'Address;
+ --
+ -- function inner1 (y : integer; AREC1P : ARECPT) return integer is
+ -- type AREC2T is record
+ -- AREC1 : AREC1PT := AREC1P;
+ -- v2 : Address;
+ -- end record;
+ --
+ -- AREC2 : aliased AREC2T;
+ -- type AREC2PT is access all AREC2T;
+ -- AREC2P : constant AREC2PT := AREC2'Access;
+ --
+ -- type Tnn1 is access all Integer;
+ -- v2 : integer := Tnn1!(AREC1P.v1).all {+} 1;
+ -- AREC2.v2 := v2'Address;
+ --
+ -- function inner2
+ -- (z : integer; AREC2P : AREC2PT) return integer
+ -- is
+ -- begin
+ -- type Tnn1 is access all Integer;
+ -- type Tnn2 is access all Integer;
+ -- return integer(z {+}
+ -- Tnn1!(AREC2P.AREC1.v1).all {+}
+ -- Tnn2!(AREC2P.v2).all);
+ -- end inner2;
+ -- begin
+ -- type Tnn is access all Integer;
+ -- return integer(y {+} inner2 (Tnn!(AREC1P.v1).all, AREC2P));
+ -- end inner1;
+ -- begin
+ -- return inner1 (x, AREC1P);
+ -- end case4x;
+
+ -- As can be seen in this example, the level number following AREC in the
+ -- names avoids any confusion between AREC names at different levels.
+
+ -------------------------
+ -- Name Disambiguation --
+ -------------------------
+
+ -- As described above, the translation scheme would raise issues when the
+ -- code generator did the actual unnesting if identically named nested
+ -- subprograms exist. Similarly overloading would cause a naming issue.
+
+ -- In fact, the expanded code includes qualified names which eliminate this
+ -- problem. We omitted the qualification from the exapnded examples above
+ -- for simplicity. But to see this in action, consider this example:
+
+ -- function Mnames return Boolean is
+ -- procedure Inner is
+ -- procedure Inner is
+ -- begin
+ -- null;
+ -- end;
+ -- begin
+ -- Inner;
+ -- end;
+ -- function F (A : Boolean) return Boolean is
+ -- begin
+ -- return not A;
+ -- end;
+ -- function F (A : Integer) return Boolean is
+ -- begin
+ -- return A > 42;
+ -- end;
+ -- begin
+ -- Inner;
+ -- return F (42) or F (True);
+ -- end;
+
+ -- The expanded code actually looks like:
+
+ -- function mnames return boolean is
+ -- procedure mnames__inner is
+ -- procedure mnames__inner__inner is
+ -- begin
+ -- null;
+ -- return;
+ -- end mnames__inner__inner;
+ -- begin
+ -- mnames__inner__inner;
+ -- return;
+ -- end mnames__inner;
+ -- function mnames__f (a : boolean) return boolean is
+ -- begin
+ -- return not a;
+ -- end mnames__f;
+ -- function mnames__f__2 (a : integer) return boolean is
+ -- begin
+ -- return a > 42;
+ -- end mnames__f__2;
+ -- begin
+ -- mnames__inner;
+ -- return mnames__f__2 (42) or mnames__f (true);
+ -- end mnames;
+
+ -- As can be seen from studying this example, the qualification deals both
+ -- with the issue of clashing names (mnames__inner, mnames__inner__inner),
+ -- and with overloading (mnames__f, mnames__f__2).
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Check_Uplevel_Reference_To_Type (Typ : Entity_Id);
+ -- This procedure is called if Sem_Util.Check_Nested_Access detects an
+ -- uplevel reference to a type or subtype entity Typ. On return there are
+ -- two cases, if Typ is a static type (defined as a discrete type with
+ -- static bounds, or a record all of whose components are of a static type,
+ -- or an array whose index and component types are all static types), then
+ -- the flag Is_Static_Type (Typ) will be set True, and in this case the
+ -- flag Has_Uplevel_Reference is not set since we don't need to worry about
+ -- uplevel references to static types. If on the other hand Typ is not a
+ -- static type, then the flag Has_Uplevel_Reference will be set, and any
+ -- non-static bounds referenced by the type will also be marked as having
+ -- uplevel references (by setting Has_Uplevel_Reference for these bounds).
+
+ procedure Note_Uplevel_Reference (N : Node_Id; Subp : Entity_Id);
+ -- Called in Unnest_Subprogram_Mode when we detect an explicit uplevel
+ -- reference (node N) to an enclosing subprogram Subp.
+
+ procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id);
+ -- Subp is a library level subprogram which has nested subprograms, and
+ -- Subp_Body is the corresponding N_Subprogram_Body node. This procedure
+ -- declares the AREC types and objects, adds assignments to the AREC record
+ -- as required, defines the xxxPTR types for uplevel referenced objects,
+ -- adds the ARECP parameter to all nested subprograms which need it, and
+ -- modifies all uplevel references appropriately.
+
+end Exp_Unst;
ada/exp_smem.o \
ada/exp_strm.o \
ada/exp_tss.o \
+ ada/exp_unst.o \
ada/exp_util.o \
ada/expander.o \
ada/fmap.o \
Relaxed_RM_Semantics := True;
end if;
+ -- -gnatd.1 enables unnesting of subprograms
+
+ if Debug_Flag_Dot_1 then
+ Unnest_Subprogram_Mode := True;
+ end if;
+
-- -gnatd.V or -gnatd.u enables special C expansion mode
if Debug_Flag_Dot_VV or Debug_Flag_Dot_U then
end if;
end Name_Find;
+ -------------------
+ -- Name_Find_Str --
+ -------------------
+
+ function Name_Find_Str (S : String) return Name_Id is
+ begin
+ Name_Len := S'Length;
+ Name_Buffer (1 .. Name_Len) := S;
+ return Name_Find;
+ end Name_Find_Str;
+
-------------
-- Nam_In --
-------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
-- not modified by this call. Note that it is permissible for Name_Len to
-- be set to zero to lookup the null name string.
+ function Name_Find_Str (S : String) return Name_Id;
+ -- Similar to Name_Find, except that the string is provided as an argument.
+ -- This call destroys the contents of Name_Buffer and Name_Len (by storing
+ -- the given string there.
+
function Name_Enter return Name_Id;
-- Name_Enter has the same calling interface as Name_Find. The difference
-- is that it does not search the table for an existing match, and also
-- Indicates if error messages are to be prefixed by the string error:
-- Initialized from Tag_Errors, can be forced on with the -gnatU switch.
+ Unnest_Subprogram_Mode : Boolean := False;
+ -- If true, activates the circuitry for unnesting subprograms (see the spec
+ -- of Exp_Unst for full details). Currently set only by use of -gnatd.1.
+
Universal_Addressing_On_AAMP : Boolean := False;
-- GNAAMP
-- Indicates if library-level objects should be accessed and updated using
return;
-- Otherwise we definitely have an ordinary identifier with a junk
- -- token after it. Just complain that we expect a declaration, and
- -- skip to a semicolon
+ -- token after it.
else
- Set_Declaration_Expected;
- Resync_Past_Semicolon;
- Done := False;
- return;
+ -- If in -gnatd.2 mode, try for statements
+
+ if Debug_Flag_Dot_2 then
+ Restore_Scan_State (Scan_State);
+
+ -- Reset Token_Node, because it already got changed from an
+ -- Identifier to a Defining_Identifier, and we don't want that
+ -- for a statement!
+
+ Token_Node :=
+ Make_Identifier (Sloc (Token_Node), Chars (Token_Node));
+
+ -- And now scan out one or more statements
+
+ Statement_When_Declaration_Expected (Decls, Done, In_Spec);
+ return;
+
+ -- Normal case, just complain and skip to semicolon
+
+ else
+ Set_Declaration_Expected;
+ Resync_Past_Semicolon;
+ Done := False;
+ return;
+ end if;
end if;
end if;
-- We make two copies of the given spec, one for the new
-- declaration, and one for the body.
- if No (Spec_Id)
- and then GNATprove_Mode
+ if No (Spec_Id) and then GNATprove_Mode
-- Inlining does not apply during pre-analysis of code
Check_References (Body_Id);
end;
+
+ -- Check for nested subprogram, and mark outer level subprogram if so
+
+ declare
+ Ent : Entity_Id;
+
+ begin
+ if Present (Spec_Id) then
+ Ent := Spec_Id;
+ else
+ Ent := Body_Id;
+ end if;
+
+ loop
+ Ent := Enclosing_Subprogram (Ent);
+ exit when No (Ent) or else Is_Subprogram (Ent);
+ end loop;
+
+ if Present (Ent) then
+ Set_Has_Nested_Subprogram (Ent);
+ end if;
+ end;
end Analyze_Subprogram_Body_Helper;
---------------------------------
end if;
end if;
- Check_Nested_Access (E);
+ Check_Nested_Access (N, E);
end if;
Set_Entity_Or_Discriminal (N, E);
and then (not Is_Entity_Name (P)
or else Chars (Entity (P)) /= Name_uInit)
then
+ -- Check if we already have an available subtype we can use
+
if Ekind (Etype (P)) = E_Record_Subtype
and then Nkind (Parent (Etype (P))) = N_Subtype_Declaration
and then Is_Array_Type (Etype (Selector))
with Errout; use Errout;
with Exp_Ch11; use Exp_Ch11;
with Exp_Disp; use Exp_Disp;
+with Exp_Unst; use Exp_Unst;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze;
-- Check_Nested_Access --
-------------------------
- procedure Check_Nested_Access (Ent : Entity_Id) is
+ procedure Check_Nested_Access (N : Node_Id; Ent : Entity_Id) is
Scop : constant Entity_Id := Current_Scope;
Current_Subp : Entity_Id;
Enclosing : Entity_Id;
begin
-- Currently only enabled for VM back-ends for efficiency, should we
- -- enable it more systematically ???
+ -- enable it more systematically? Probably not unless someone actually
+ -- needs it. It will be needed for C generation and is activated if the
+ -- Opt.Unnest_Subprogram_Mode flag is set True.
- -- Check for Is_Imported needs commenting below ???
-
- if VM_Target /= No_VM
- and then Ekind_In (Ent, E_Variable, E_Constant, E_Loop_Parameter)
+ if (VM_Target /= No_VM or else Unnest_Subprogram_Mode)
and then Scope (Ent) /= Empty
and then not Is_Library_Level_Entity (Ent)
+
+ -- Comment the exclusion of imported entities ???
+
and then not Is_Imported (Ent)
then
+ -- For VM case, we are only interested in variables, constants,
+ -- and loop parameters. For general nested procedure usage, we
+ -- allow types as well.
+
+ if Ekind_In (Ent, E_Variable, E_Constant, E_Loop_Parameter) then
+ null;
+ elsif not (Unnest_Subprogram_Mode and then Is_Type (Ent)) then
+ return;
+ end if;
+
+ -- Get current subprogram that is relevant
+
if Is_Subprogram (Scop)
or else Is_Generic_Subprogram (Scop)
or else Is_Entry (Scop)
Enclosing := Enclosing_Subprogram (Ent);
+ -- Set flag if uplevel reference
+
if Enclosing /= Empty and then Enclosing /= Current_Subp then
- Set_Has_Up_Level_Access (Ent, True);
+ if Is_Type (Ent) then
+ Check_Uplevel_Reference_To_Type (Ent);
+ else
+ Set_Has_Uplevel_Reference (Ent, True);
+
+ if Unnest_Subprogram_Mode then
+ Set_Has_Uplevel_Reference (Current_Subp, True);
+ Note_Uplevel_Reference (N, Enclosing);
+ end if;
+ end if;
end if;
end if;
end Check_Nested_Access;
end if;
end if;
- Check_Nested_Access (Ent);
+ Check_Nested_Access (N, Ent);
end if;
Kill_Checks (Ent);
-- remains in the Examiner (JB01-005). Note that the Examiner does not
-- count package declarations in later declarative items.
- procedure Check_Nested_Access (Ent : Entity_Id);
+ procedure Check_Nested_Access (N : Node_Id; Ent : Entity_Id);
-- Check whether Ent denotes an entity declared in an uplevel scope, which
- -- is accessed inside a nested procedure, and set Has_Up_Level_Access flag
- -- accordingly. This is currently only enabled for VM_Target /= No_VM.
+ -- is accessed inside a nested procedure, and set the Has_Uplevel_Reference
+ -- flag accordingly. This is currently only enabled for if on a VM target,
+ -- or if Opt.Unnest_Subprogram_Mode is active. N is the node for the
+ -- possible uplevel reference.
procedure Check_No_Hidden_State (Id : Entity_Id);
-- Determine whether object or state Id introduces a hidden state. If this
projects / gcc.git / commitdiff