This is an initial checkin for the feature of unnesting subprograms
in the front end (for use by alternate, non GCC backends). The documentation is
complete, but the implementation checked in is only part of the
final implementation, so no test needed yet.
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-03-02 Robert Dewar <de...@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
Index: debug.adb
===================================================================
--- debug.adb (revision 221098)
+++ debug.adb (working copy)
@@ -746,9 +746,10 @@
-- 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
Index: einfo.adb
===================================================================
--- einfo.adb (revision 221102)
+++ einfo.adb (working copy)
@@ -213,6 +213,7 @@
-- Stored_Constraint Elist23
-- Related_Expression Node24
+ -- Uplevel_References Elist24
-- Interface_Alias Node25
-- Interfaces Elist25
@@ -505,7 +506,7 @@
-- 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
@@ -578,9 +579,10 @@
-- 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
@@ -1544,6 +1546,12 @@
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));
@@ -1786,12 +1794,10 @@
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
@@ -2376,6 +2382,12 @@
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);
@@ -3188,6 +3200,17 @@
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);
@@ -4371,11 +4394,16 @@
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 (Ekind_In (Id, E_Variable, E_Constant, E_Loop_Parameter));
+ 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
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
@@ -5270,6 +5298,12 @@
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
@@ -6119,6 +6153,17 @@
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);
@@ -8517,6 +8562,7 @@
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));
@@ -8561,7 +8607,7 @@
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));
@@ -8662,6 +8708,7 @@
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));
@@ -8728,6 +8775,7 @@
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));
@@ -9638,6 +9686,11 @@
Type_Kind =>
Write_Str ("Related_Expression");
+ when E_Function |
+ E_Operator |
+ E_Procedure =>
+ Write_Str ("Uplevel_References");
+
when others =>
Write_Str ("Field24???");
end case;
Index: einfo.ads
===================================================================
--- einfo.ads (revision 221103)
+++ einfo.ads (working copy)
@@ -1693,7 +1693,11 @@
-- 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.
@@ -1987,12 +1991,15 @@
-- 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
@@ -2966,6 +2973,16 @@
-- 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,
@@ -4237,6 +4254,17 @@
-- 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.
@@ -5269,6 +5297,7 @@
-- 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)
@@ -5339,6 +5368,7 @@
-- 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)
@@ -5355,6 +5385,7 @@
-- 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)
@@ -5555,7 +5586,7 @@
-- 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)
@@ -5723,6 +5754,7 @@
-- 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)
@@ -5748,6 +5780,7 @@
-- 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)
@@ -5891,6 +5924,8 @@
-- 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)
@@ -6022,6 +6057,7 @@
-- 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)
@@ -6046,6 +6082,7 @@
-- 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)
@@ -6274,7 +6311,7 @@
-- 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)
@@ -6676,6 +6713,7 @@
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;
@@ -6720,7 +6758,7 @@
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;
@@ -6823,6 +6861,7 @@
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;
@@ -6959,6 +6998,8 @@
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;
@@ -7318,6 +7359,7 @@
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);
@@ -7362,7 +7404,7 @@
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);
@@ -7471,6 +7513,7 @@
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);
@@ -7607,6 +7650,8 @@
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);
@@ -8076,6 +8121,7 @@
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);
@@ -8120,7 +8166,7 @@
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);
@@ -8266,6 +8312,7 @@
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);
@@ -8407,6 +8454,8 @@
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);
@@ -8566,6 +8615,7 @@
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);
@@ -8610,7 +8660,7 @@
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);
@@ -8718,6 +8768,7 @@
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);
@@ -8853,6 +8904,8 @@
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);
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 221107)
+++ sem_util.adb (working copy)
@@ -32,6 +32,7 @@
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;
@@ -2863,23 +2864,37 @@
-- 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)
@@ -2891,8 +2906,19 @@
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;
@@ -15168,7 +15194,7 @@
end if;
end if;
- Check_Nested_Access (Ent);
+ Check_Nested_Access (N, Ent);
end if;
Kill_Checks (Ent);
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 221103)
+++ sem_util.ads (working copy)
@@ -308,10 +308,12 @@
-- 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
Index: gnat1drv.adb
===================================================================
--- gnat1drv.adb (revision 221098)
+++ gnat1drv.adb (working copy)
@@ -130,6 +130,12 @@
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
Index: elists.adb
===================================================================
--- elists.adb (revision 221098)
+++ elists.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- 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- --
@@ -288,6 +288,25 @@
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 --
----------
Index: elists.ads
===================================================================
--- elists.ads (revision 221098)
+++ elists.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- 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- --
@@ -107,6 +107,9 @@
-- 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
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb (revision 221103)
+++ exp_ch6.adb (working copy)
@@ -42,6 +42,7 @@
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;
@@ -5339,6 +5340,16 @@
-- 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;
-----------------------------------
@@ -7716,14 +7727,9 @@
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;
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb (revision 221101)
+++ sem_ch6.adb (working copy)
@@ -3223,8 +3223,7 @@
-- 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
@@ -4157,6 +4156,28 @@
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;
---------------------------------
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb (revision 221103)
+++ sem_ch8.adb (working copy)
@@ -5623,7 +5623,7 @@
end if;
end if;
- Check_Nested_Access (E);
+ Check_Nested_Access (N, E);
end if;
Set_Entity_Or_Discriminal (N, E);
@@ -6593,6 +6593,8 @@
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))
Index: namet.adb
===================================================================
--- namet.adb (revision 221098)
+++ namet.adb (working copy)
@@ -1104,6 +1104,17 @@
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 --
-------------
Index: namet.ads
===================================================================
--- namet.ads (revision 221098)
+++ namet.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- 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- --
@@ -422,6 +422,11 @@
-- 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
Index: opt.ads
===================================================================
--- opt.ads (revision 221098)
+++ opt.ads (working copy)
@@ -1533,6 +1533,10 @@
-- 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
Index: par-ch3.adb
===================================================================
--- par-ch3.adb (revision 221098)
+++ par-ch3.adb (working copy)
@@ -1514,14 +1514,34 @@
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;
Index: exp_unst.adb
===================================================================
--- exp_unst.adb (revision 0)
+++ exp_unst.adb (revision 0)
@@ -0,0 +1,574 @@
+------------------------------------------------------------------------------
+-- --
+-- 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;
Property changes on: exp_unst.adb
___________________________________________________________________
Added: svn:executable
+ *
Index: exp_unst.ads
===================================================================
--- exp_unst.ads (revision 0)
+++ exp_unst.ads (revision 0)
@@ -0,0 +1,561 @@
+------------------------------------------------------------------------------
+-- --
+-- 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;
Index: gcc-interface/Make-lang.in
===================================================================
--- gcc-interface/Make-lang.in (revision 221098)
+++ gcc-interface/Make-lang.in (working copy)
@@ -282,6 +282,7 @@
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 \
