diff options
| author | Arnaud Charlet <charlet@gcc.gnu.org> | 2015-05-12 10:36:45 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2015-05-12 10:36:45 +0200 |
| commit | f8dae9bb29d4dffc332c5a0670ff814816c87731 (patch) | |
| tree | 57218611df0267da5328f2edf73b0d2ae8c2c482 /gcc/ada | |
| parent | 73cc8f6230c672fab16f0d43a661c62744b5f0cb (diff) | |
| download | gcc-f8dae9bb29d4dffc332c5a0670ff814816c87731.zip gcc-f8dae9bb29d4dffc332c5a0670ff814816c87731.tar.gz gcc-f8dae9bb29d4dffc332c5a0670ff814816c87731.tar.bz2 | |
[multiple changes]
2015-05-12 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb: Minor reformatting.
2015-05-12 Vincent Celier <celier@adacore.com>
* gnatcmd.adb: If we want to invoke gnatmake (gnatclean) with
-P, then check if gprbuild (gprclean) is available; if it is,
use gprbuild (gprclean) instead of gnatmake (gnatclean).
2015-05-12 Robert Dewar <dewar@adacore.com>
* debug.adb: Add flag -gnatd.3 to output diagnostic info from
Exp_Unst.
* einfo.ad, einfo.adb: Reorganize (and remove most of) flags used by
Exp_Unst.
* exp_ch6.adb (Unest_Bodies): Table for delayed calls to
Unnest_Subprogram (Expand_N_Subprogram_Body): Add entry to table
for later call instead of calling Unnest_Subprogram directly
(Initialize): New procedure (Unnest_Subprograms): New procedure
* exp_ch6.ads (Add_Extra_Actual_To_Call): Move into proper
alpha order.
(Initialize): New procedure.
(Unnest_Subprograms): New procedure.
* exp_unst.adb (Unnest_Subprogram): Major rewrite, moving
all processing to this routine which is now called late
after instantiating bodies. Fully handles the case of generic
instantiations now.
* exp_unst.ads: Major rewrite, moving all processing to
Unnest_Subprogram.
* frontend.adb (Frontend): Add call to Exp_Ch6.Initialize.
(Frontend): Add call to Unnest_Subprograms.
* sem_ch8.adb (Find_Direct_Name): Back to old calling sequence
for Check_Nested_Access.
* sem_util.adb (Build_Default_Subtype): Minor reformatting
(Check_Nested_Access): Back to original VM-only form (we
now do all the processing for Unnest_Subprogram at the time
it is called.
(Denotes_Same_Object): Minor reformatting
(Note_Possible_Modification): Old calling sequence for
Check_Nested_Access.
* sem_util.ads (Check_Nested_Access): Back to original VM-only
form (we now do all the processing for Unnest_Subprogram at the
time it is called.
From-SVN: r223043
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 45 | ||||
| -rw-r--r-- | gcc/ada/debug.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 71 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 67 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 106 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.ads | 20 | ||||
| -rw-r--r-- | gcc/ada/exp_unst.adb | 1628 | ||||
| -rw-r--r-- | gcc/ada/exp_unst.ads | 17 | ||||
| -rw-r--r-- | gcc/ada/frontend.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/gnatcmd.adb | 43 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 51 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 8 |
14 files changed, 1197 insertions, 881 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0cba4e7..10af3d8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,50 @@ 2015-05-12 Robert Dewar <dewar@adacore.com> + * sem_ch3.adb: Minor reformatting. + +2015-05-12 Vincent Celier <celier@adacore.com> + + * gnatcmd.adb: If we want to invoke gnatmake (gnatclean) with + -P, then check if gprbuild (gprclean) is available; if it is, + use gprbuild (gprclean) instead of gnatmake (gnatclean). + +2015-05-12 Robert Dewar <dewar@adacore.com> + + * debug.adb: Add flag -gnatd.3 to output diagnostic info from + Exp_Unst. + * einfo.ad, einfo.adb: Reorganize (and remove most of) flags used by + Exp_Unst. + * exp_ch6.adb (Unest_Bodies): Table for delayed calls to + Unnest_Subprogram (Expand_N_Subprogram_Body): Add entry to table + for later call instead of calling Unnest_Subprogram directly + (Initialize): New procedure (Unnest_Subprograms): New procedure + * exp_ch6.ads (Add_Extra_Actual_To_Call): Move into proper + alpha order. + (Initialize): New procedure. + (Unnest_Subprograms): New procedure. + * exp_unst.adb (Unnest_Subprogram): Major rewrite, moving + all processing to this routine which is now called late + after instantiating bodies. Fully handles the case of generic + instantiations now. + * exp_unst.ads: Major rewrite, moving all processing to + Unnest_Subprogram. + * frontend.adb (Frontend): Add call to Exp_Ch6.Initialize. + (Frontend): Add call to Unnest_Subprograms. + * sem_ch8.adb (Find_Direct_Name): Back to old calling sequence + for Check_Nested_Access. + * sem_util.adb (Build_Default_Subtype): Minor reformatting + (Check_Nested_Access): Back to original VM-only form (we + now do all the processing for Unnest_Subprogram at the time + it is called. + (Denotes_Same_Object): Minor reformatting + (Note_Possible_Modification): Old calling sequence for + Check_Nested_Access. + * sem_util.ads (Check_Nested_Access): Back to original VM-only + form (we now do all the processing for Unnest_Subprogram at the + time it is called. + +2015-05-12 Robert Dewar <dewar@adacore.com> + * sem_ch3.adb, freeze.adb, sem_ch6.adb: Minor reformatting. 2015-05-12 Ed Schonberg <schonberg@adacore.com> diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index e04b5b5..116fcfc 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -157,7 +157,7 @@ package body Debug is -- d.1 Enable unnesting of nested procedures -- d.2 Allow statements in declarative part - -- d.3 + -- d.3 Output debugging information from Exp_Unst -- d.4 -- d.5 -- d.6 @@ -755,6 +755,9 @@ package body Debug is -- allowed, but in some debugging contexts (e.g. testing the circuit -- for unnesting of procedures), it is useful to allow this. + -- d.3 Output debugging information from Exp_Unst, including the name of + -- any unreachable subprograms that get deleted. + ------------------------------------------ -- Documentation for Binder Debug Flags -- ------------------------------------------ diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 2e7d519..772195b 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -213,7 +213,6 @@ package body Einfo is -- Stored_Constraint Elist23 -- Related_Expression Node24 - -- Uplevel_References Elist24 -- Subps_Index Uint24 -- Interface_Alias Node25 @@ -590,7 +589,7 @@ package body Einfo is -- Is_Static_Type Flag281 -- Has_Nested_Subprogram Flag282 - -- Uplevel_Reference_Noted Flag283 + -- Is_Uplevel_Referenced_Entity Flag283 -- Is_Unimplemented Flag284 -- (unused) Flag285 @@ -2418,7 +2417,6 @@ package body Einfo is function Is_Static_Type (Id : E) return B is begin - pragma Assert (Is_Type (Id)); return Flag281 (Id); end Is_Static_Type; @@ -2474,6 +2472,11 @@ package body Einfo is return Flag144 (Id); end Is_Unsigned_Type; + function Is_Uplevel_Referenced_Entity (Id : E) return B is + begin + return Flag283 (Id); + end Is_Uplevel_Referenced_Entity; + function Is_Valued_Procedure (Id : E) return B is begin pragma Assert (Ekind (Id) = E_Procedure); @@ -2684,8 +2687,10 @@ package body Einfo is begin pragma Assert (Ekind (Id) in Incomplete_Kind - or else Ekind (Id) in Class_Wide_Kind - or else Ekind (Id) = E_Abstract_State); + or else + Ekind (Id) in Class_Wide_Kind + or else + Ekind (Id) = E_Abstract_State); return Node19 (Id); end Non_Limited_View; @@ -3247,17 +3252,6 @@ package body Einfo is 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); @@ -4458,11 +4452,6 @@ package body Einfo is 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_Uplevel_Reference; - procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True) is begin pragma Assert (Id = Base_Type (Id)); @@ -4713,6 +4702,11 @@ package body Einfo is Set_Flag72 (Id, V); end Set_Has_Unknown_Discriminants; + procedure Set_Has_Uplevel_Reference (Id : E; V : B := True) is + begin + Set_Flag215 (Id, V); + end Set_Has_Uplevel_Reference; + procedure Set_Has_Visible_Refinement (Id : E; V : B := True) is begin pragma Assert (Ekind (Id) = E_Abstract_State); @@ -5423,6 +5417,15 @@ package body Einfo is Set_Flag144 (Id, V); end Set_Is_Unsigned_Type; + procedure Set_Is_Uplevel_Referenced_Entity (Id : E; V : B := True) is + begin + pragma Assert + (Ekind_In (Id, E_Constant, E_Variable) + or else Is_Formal (Id) + or else Is_Type (Id)); + Set_Flag283 (Id, V); + end Set_Is_Uplevel_Referenced_Entity; + procedure Set_Is_Valued_Procedure (Id : E; V : B := True) is begin pragma Assert (Ekind (Id) = E_Procedure); @@ -5632,8 +5635,7 @@ package body Einfo is begin pragma Assert (Ekind (Id) in Incomplete_Kind - or else Ekind (Id) = E_Abstract_State - or else Ekind (Id) = E_Class_Wide_Type); + or else Ekind_In (Id, E_Abstract_State, E_Class_Wide_Type)); Set_Node19 (Id, V); end Set_Non_Limited_View; @@ -6224,17 +6226,6 @@ package body Einfo is 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); @@ -7116,8 +7107,8 @@ package body Einfo is function Has_Non_Limited_View (Id : E) return B is begin return (Ekind (Id) in Incomplete_Kind - or else Ekind (Id) in Class_Wide_Kind - or else Ekind (Id) = E_Abstract_State) + or else Ekind (Id) in Class_Wide_Kind + or else Ekind (Id) = E_Abstract_State) and then Present (Non_Limited_View (Id)); end Has_Non_Limited_View; @@ -8802,6 +8793,7 @@ package body Einfo is W ("Is_Underlying_Record_View", Flag246 (Id)); W ("Is_Unimplemented", Flag284 (Id)); W ("Is_Unsigned_Type", Flag144 (Id)); + W ("Is_Uplevel_Referenced_Entity", Flag283 (Id)); W ("Is_Valued_Procedure", Flag127 (Id)); W ("Is_Visible_Formal", Flag206 (Id)); W ("Is_Visible_Lib_Unit", Flag116 (Id)); @@ -8859,7 +8851,6 @@ package body Einfo is 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)); @@ -9774,11 +9765,7 @@ package body Einfo is when E_Function | E_Operator | E_Procedure => - if Field24 (Id) in Uint_Range then - Write_Str ("Subps_Index"); - else - Write_Str ("Uplevel_References"); - end if; + Write_Str ("Subps_Index"); when others => Write_Str ("Field24???"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 6779a4b..c25be53 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2009,11 +2009,10 @@ package Einfo is -- 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 subprograms (Exp_Unst has details). +-- (where it is set for variables, constants and loop parameters). Note +-- that this is similar in usage to Is_Uplevel_Referenced_Entity (which +-- is used when we are unnesting subprograms), but the usages are a bit +-- different and it is cleaner to leave the old VM usage unchanged. -- Has_Visible_Refinement (Flag263) -- Defined in E_Abstract_State entities. Set when a state has at least @@ -2988,8 +2987,8 @@ package Einfo is -- 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 +-- Defined in entities. Only set for (sub)types. 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 @@ -3111,6 +3110,20 @@ package Einfo is -- subtype is still unsigned, but this cannot be determined by looking -- at its bounds or the bounds of the corresponding base type. +-- Is_Uplevel_Referenced_Entity (Flag283) +-- Defined in all entities. Used when unnesting subprograms to indicate +-- that an 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 for uplevel referenced objects (variables, constants and +-- loop parameters), and also for upreferenced dynamic types, including +-- the cases where the reference is implicit (e.g. the type of an array +-- used for computing the location of an element in an array. This is +-- used internally in Exp_Unst, see this package for further details. +-- Note that this is similar to the Has_Uplevel_Reference flag which +-- is used in the VM case but we prefer to keep the two cases entirely +-- separated, so that the VM usage is not disturbed by work on the +-- Unnesting_Subprograms mode. + -- Is_Valued_Procedure (Flag127) -- Defined in procedure entities. Set if an Import_Valued_Procedure -- or Export_Valued_Procedure pragma applies to the procedure entity. @@ -4142,8 +4155,6 @@ package Einfo is -- Subps_Index (Uint24) -- Used during Exp_Inst.Unnest_Subprogram to hold the index in the Subps -- table for a subprogram. See processing in this procedure for details. --- Note that this overlaps Uplevel_References, it is only set after the --- latter field has been acquired. -- Suppress_Elaboration_Warnings (Flag148) -- Defined in all entities, can be set only for subprogram entities and @@ -4278,19 +4289,6 @@ package Einfo is -- 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. Each entry uses two elements of --- the list, the first is the node that is the actual reference, the --- second is the entity of the enclosing subprogram for the reference. - -- 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. @@ -5255,6 +5253,7 @@ package Einfo is -- Has_Qualified_Name (Flag161) -- Has_Stream_Size_Clause (Flag184) -- Has_Unknown_Discriminants (Flag72) + -- Has_Uplevel_Reference (Flag215) -- Has_Xref_Entry (Flag182) -- In_Private_Part (Flag45) -- Is_Ada_2005_Only (Flag185) @@ -5304,6 +5303,7 @@ package Einfo is -- Is_Renaming_Of_Object (Flag112) -- Is_Shared_Passive (Flag60) -- Is_Statically_Allocated (Flag28) + -- Is_Static_Type (Flag281) -- Is_Tagged_Type (Flag55) -- Is_Thunk (Flag225) -- Is_Trivial_Subprogram (Flag235) @@ -5324,7 +5324,6 @@ package Einfo is -- 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) @@ -5395,7 +5394,6 @@ package Einfo is -- 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) @@ -5412,7 +5410,6 @@ package Einfo is -- 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) @@ -5617,7 +5614,6 @@ package Einfo is -- Has_Independent_Components (Flag34) -- Has_Size_Clause (Flag29) -- Has_Thunks (Flag228) (constants only) - -- Has_Uplevel_Reference (Flag215) -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) @@ -5625,6 +5621,7 @@ package Einfo is -- Is_Processed_Transient (Flag252) (constants only) -- Is_Return_Object (Flag209) -- Is_True_Constant (Flag163) + -- Is_Uplevel_Referenced_Entity (Flag283) -- Is_Volatile (Flag16) -- Stores_Attribute_Old_Prefix (Flag270) (constants only) -- Optimize_Alignment_Space (Flag241) (constants only) @@ -5785,7 +5782,6 @@ package Einfo is -- 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) -- Subps_Index (Uint24) (non-generic case only) -- Interface_Alias (Node25) -- Overridden_Operation (Node26) @@ -5960,7 +5956,6 @@ package Einfo is -- Extra_Accessibility_Of_Result (Node19) -- Last_Entity (Node20) -- Has_Nested_Subprogram (Flag282) - -- Uplevel_References (Elist24) -- Subps_Index (Uint24) -- Overridden_Operation (Node26) -- Subprograms_For_Type (Node29) @@ -6094,7 +6089,6 @@ package Einfo is -- 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) -- Subps_Index (Uint24) (non-generic case only) -- Interface_Alias (Node25) -- Overridden_Operation (Node26) (never for init proc) @@ -6351,7 +6345,6 @@ package Einfo is -- Has_Independent_Components (Flag34) -- Has_Initial_Value (Flag219) -- Has_Size_Clause (Flag29) - -- Has_Uplevel_Reference (Flag215) -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) @@ -6362,6 +6355,7 @@ package Einfo is -- Is_True_Constant (Flag163) -- Is_Volatile (Flag16) -- Is_Return_Object (Flag209) + -- Is_Uplevel_Referenced_Entity (Flag283) -- OK_To_Rename (Flag247) -- Optimize_Alignment_Space (Flag241) -- Optimize_Alignment_Time (Flag242) @@ -6913,6 +6907,7 @@ package Einfo is function Is_Underlying_Record_View (Id : E) return B; function Is_Unimplemented (Id : E) return B; function Is_Unsigned_Type (Id : E) return B; + function Is_Uplevel_Referenced_Entity (Id : E) return B; function Is_Valued_Procedure (Id : E) return B; function Is_Visible_Formal (Id : E) return B; function Is_Visible_Lib_Unit (Id : E) return B; @@ -7041,8 +7036,6 @@ package Einfo is 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; @@ -7569,6 +7562,7 @@ package Einfo is procedure Set_Is_Underlying_Record_View (Id : E; V : B := True); procedure Set_Is_Unimplemented (Id : E; V : B := True); procedure Set_Is_Unsigned_Type (Id : E; V : B := True); + procedure Set_Is_Uplevel_Referenced_Entity (Id : E; V : B := True); procedure Set_Is_Valued_Procedure (Id : E; V : B := True); procedure Set_Is_Visible_Formal (Id : E; V : B := True); procedure Set_Is_Visible_Lib_Unit (Id : E; V : B := True); @@ -7697,8 +7691,6 @@ package Einfo is 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); @@ -8380,6 +8372,7 @@ package Einfo is pragma Inline (Is_Underlying_Record_View); pragma Inline (Is_Unimplemented); pragma Inline (Is_Unsigned_Type); + pragma Inline (Is_Uplevel_Referenced_Entity); pragma Inline (Is_Valued_Procedure); pragma Inline (Is_Visible_Formal); pragma Inline (Is_Visible_Lib_Unit); @@ -8510,8 +8503,6 @@ package Einfo is 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); @@ -8717,7 +8708,6 @@ package Einfo is pragma Inline (Set_Has_Thunks); pragma Inline (Set_Has_Unchecked_Union); pragma Inline (Set_Has_Unknown_Discriminants); - pragma Inline (Set_Has_Uplevel_Reference); pragma Inline (Set_Has_Visible_Refinement); pragma Inline (Set_Has_Volatile_Components); pragma Inline (Set_Has_Xref_Entry); @@ -8836,6 +8826,7 @@ package Einfo is pragma Inline (Set_Is_Underlying_Record_View); pragma Inline (Set_Is_Unimplemented); pragma Inline (Set_Is_Unsigned_Type); + pragma Inline (Set_Is_Uplevel_Referenced_Entity); pragma Inline (Set_Is_Valued_Procedure); pragma Inline (Set_Is_Visible_Formal); pragma Inline (Set_Is_Visible_Lib_Unit); @@ -8963,8 +8954,6 @@ package Einfo is 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); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 0b9fb75..8677562 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -71,6 +71,7 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; +with Table; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -78,6 +79,33 @@ with Validsw; use Validsw; package body Exp_Ch6 is + ------------------------------------- + -- Table for Unnesting Subprograms -- + ------------------------------------- + + -- When we expand a subprogram body, if it has nested subprograms and if + -- we are in Unnest_Subprogram_Mode, then we record the subprogram entity + -- and the body in this table, to later be passed to Unnest_Subprogram. + + -- We need this delaying mechanism, because we have to wait untiil all + -- instantiated bodies have been inserted before doing the unnesting. + + type Unest_Entry is record + Ent : Entity_Id; + -- Entity for subprogram to be unnested + + Bod : Node_Id; + -- Subprogram body to be unnested + end record; + + package Unest_Bodies is new Table.Table ( + Table_Component_Type => Unest_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "Unest_Bodies"); + ----------------------- -- Local Subprograms -- ----------------------- @@ -5360,7 +5388,7 @@ package body Exp_Ch6 is and then Has_Nested_Subprogram (Spec_Id) then - Unnest_Subprogram (Spec_Id, N); + Unest_Bodies.Append ((Spec_Id, N)); end if; end Expand_N_Subprogram_Body; @@ -5788,32 +5816,6 @@ package body Exp_Ch6 is end if; end Expand_Protected_Subprogram_Call; - -------------------------------------------- - -- Has_Unconstrained_Access_Discriminants -- - -------------------------------------------- - - function Has_Unconstrained_Access_Discriminants - (Subtyp : Entity_Id) return Boolean - is - Discr : Entity_Id; - - begin - if Has_Discriminants (Subtyp) - and then not Is_Constrained (Subtyp) - then - Discr := First_Discriminant (Subtyp); - while Present (Discr) loop - if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then - return True; - end if; - - Next_Discriminant (Discr); - end loop; - end if; - - return False; - end Has_Unconstrained_Access_Discriminants; - ----------------------------------- -- Expand_Simple_Function_Return -- ----------------------------------- @@ -7999,6 +8001,41 @@ package body Exp_Ch6 is end if; end Expand_Subprogram_Contract; + -------------------------------------------- + -- Has_Unconstrained_Access_Discriminants -- + -------------------------------------------- + + function Has_Unconstrained_Access_Discriminants + (Subtyp : Entity_Id) return Boolean + is + Discr : Entity_Id; + + begin + if Has_Discriminants (Subtyp) + and then not Is_Constrained (Subtyp) + then + Discr := First_Discriminant (Subtyp); + while Present (Discr) loop + if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then + return True; + end if; + + Next_Discriminant (Discr); + end loop; + end if; + + return False; + end Has_Unconstrained_Access_Discriminants; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Unest_Bodies.Init; + end Initialize; + -------------------------------- -- Is_Build_In_Place_Function -- -------------------------------- @@ -9489,4 +9526,19 @@ package body Exp_Ch6 is end if; end Needs_Result_Accessibility_Level; + ------------------------ + -- Unnest_Subprograms -- + ------------------------ + + procedure Unnest_Subprograms is + begin + for J in Unest_Bodies.First .. Unest_Bodies.Last loop + declare + UBJ : Unest_Entry renames Unest_Bodies.Table (J); + begin + Unnest_Subprogram (UBJ.Ent, UBJ.Bod); + end; + end loop; + end Unnest_Subprograms; + end Exp_Ch6; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 48b98e8..5cbcc96 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -97,6 +97,13 @@ package Exp_Ch6 is -- -- ??? We might also need to be able to pass in a constrained flag. + procedure Add_Extra_Actual_To_Call + (Subprogram_Call : Node_Id; + Extra_Formal : Entity_Id; + Extra_Actual : Node_Id); + -- Adds Extra_Actual as a named parameter association for the formal + -- Extra_Formal in Subprogram_Call. + function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String; -- Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names -- for build-in-place formal parameters of the given kind. @@ -109,6 +116,9 @@ package Exp_Ch6 is -- function Func, and returns its Entity_Id. It is a bug if not found; the -- caller should ensure this is called only when the extra formal exists. + procedure Initialize; + -- Initialize internal tables + function Is_Build_In_Place_Function (E : Entity_Id) return Boolean; -- Ada 2005 (AI-318-02): Returns True if E denotes a function, generic -- function, or access-to-function type whose result must be built in @@ -201,11 +211,9 @@ package Exp_Ch6 is -- parameter to identify the accessibility level of the function result -- "determined by the point of call". - procedure Add_Extra_Actual_To_Call - (Subprogram_Call : Node_Id; - Extra_Formal : Entity_Id; - Extra_Actual : Node_Id); - -- Adds Extra_Actual as a named parameter association for the formal - -- Extra_Formal in Subprogram_Call. + procedure Unnest_Subprograms; + -- Called to unnest subprograms. If we are in unnest subprogram mode, and + -- subprograms have been gathered in the Unest_Bodies table, this is the + -- call that causes them to be processed for unnesting. end Exp_Ch6; diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 446f3fc..e80002d 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Lib; use Lib; @@ -31,14 +32,15 @@ with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; +with Output; use Output; with Rtsfind; use Rtsfind; -with Sinput; use Sinput; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; +with Sinput; use Sinput; with Snames; use Snames; with Table; with Tbuild; use Tbuild; @@ -46,7 +48,37 @@ with Uintp; use Uintp; package body Exp_Unst is - -- Tables used by Unnest_Subprogram + --------------------------- + -- Terminology for Calls -- + --------------------------- + + -- The level of a subprogram in the nest being analyzed is defined to be + -- the level of nesting, so the outer level subprogram (the one passed to + -- Unnest_Subprogram) is 1, subprograms immediately nested within this + -- outer level subprogram have a level of 2, etc. + + -- Calls within the nest being analyzed are of three types: + + -- Downward call: this is a call from a subprogram to a subprogram that + -- is immediately nested with in the caller, and thus has a level that + -- is one greater than the caller. It is a fundamental property of the + -- nesting structure and visibility that it is not possible to make a + -- call from level N to level M, where M is greater than N + 1. + + -- Parallel call: this is a call from a nested subprogram to another + -- nested subprogram that is at the same level. + + -- Upward call: this is a call from a subprogram to a subprogram that + -- encloses the caller. The level of the callee is less than the level + -- of the caller, and there is no limit on the difference, e.g. for an + -- uplevel call, a subprogram at level 5 can call one at level 2 or even + -- the outer level subprogram at level 1. + + ----------- + -- Subps -- + ----------- + + -- Table to record subprograms within the nest being currently analyzed type Subp_Entry is record Ent : Entity_Id; @@ -59,31 +91,69 @@ package body Exp_Unst is -- Subprogram level (1 = outer subprogram (Subp argument), 2 = nested -- immediately within this outer subprogram etc.) - Urefs : Elist_Id; - -- This is a copy of the Uplevel_References field from the entity for - -- the subprogram. Copy this to reuse the field for Subps_Index. + Reachable : Boolean; + -- This flag is set True if there is a call path from the outer level + -- subprogram to this subprogram. If Reachable is False, it means that + -- the subprogram is declared but not actually referenced. We remove + -- such suprograms from the tree, which simplifies our task, because + -- we don't have to worry about e.g. uplevel references from such an + -- unreferenced subpogram, which might require (useless) activation + -- records to be created. This is computed by setting the outer level + -- subprogram (Subp itself) as reachable, and then doing a transitive + -- closure following all calls. + + Uplevel_Ref : Nat; + -- The outermost level which defines entities which this subprogram + -- references either directly or indirectly via a call. This cannot + -- be greater than Lev. If it is equal to Lev, then it means that the + -- subprogram does not make any uplevel references and that thus it + -- does not need an activation record pointer passed. If it is less than + -- Lev, then an activation record pointer is needed, since there is at + -- least one uplevel reference. This is computed by initially setting + -- Uplevel_Ref to Lev for all subprograms. Then on the initial tree + -- traversal, decreasing Uplevel_Ref for an explicit uplevel reference, + -- and finally by doing a transitive closure that follows calls (if A + -- calls B and B has an uplevel reference to level X, then A references + -- level X indirectly). + + Declares_AREC : Boolean; + -- This is set True for a subprogram which include the declarations + -- for a local activation record to bew passed on downward calls. It + -- is set True for the target level of an uplevel reference, and for + -- all intervening nested subprograms. For example, if a subprogram X + -- at level 5 makes an uplevel reference to an entity declared in a + -- level 2 subprogram, then the subprograms at levels 4,3,2 enclosing + -- the level 5 subprogram will have this flag set True. + + Uents : Elist_Id; + -- This is a list of entities declared in this subprogram which are + -- uplevel referenced. It contains both objects (which will be put in + -- the corresponding AREC activation record), and types. The types are + -- not put in the AREC activation record, but referenced bounds (i.e. + -- generated _FIRST and _LAST entites, and formal parameters) will be + -- in the list in their own right. ARECnF : Entity_Id; - -- This entity is defined for all subprograms with uplevel references - -- except for the top-level subprogram (Subp itself). It is the entity - -- for the formal which is added to the parameter list to pass the - -- pointer to the activation record. Note that for this entity, n is - -- one less than the current level. + -- This entity is defined for all subprograms which need an extra formal + -- that contains a pointer to the activation record needed for uplevel + -- references. ARECnF must be defined for any subprogram which has a + -- direct or indirect uplevel reference (i.e. Reference_Level < Lev). ARECn : Entity_Id; ARECnT : Entity_Id; ARECnPT : Entity_Id; ARECnP : Entity_Id; -- These AREC entities are defined only for subprograms for which we - -- generate an activation record declaration, i.e. for subprograms - -- with at least one nested subprogram that have uplevel referennces. - -- They are set to Empty for all other cases. + -- generate an activation record declaration, i.e. for subprograms for + -- which the Declares_AREC flag is set True. ARECnU : Entity_Id; -- This AREC entity is the uplink component. It is other than Empty only - -- for nested subprograms that themselves have nested subprograms and - -- have uplevel references. Note that the n here is one less than the - -- level of the subprogram defining the activation record. + -- for nested subprograms that declare an activation record as indicated + -- by Declares_AREC being Ture, and which have uplevel references (Lev + -- greater than Uplevel_Ref). It is the additional component in the + -- activation record that references the ARECnF pointer (which points + -- the activation record one level higher, thus forming the chain). end record; @@ -98,15 +168,24 @@ package body Exp_Unst is Table_Name => "Unnest_Subps"); -- Records the subprograms in the nest whose outer subprogram is Subp + ----------- + -- Calls -- + ----------- + + -- Table to record calls within the nest being analyzed. These are the + -- calls which may need to have an AREC actual added. + type Call_Entry is record N : Node_Id; -- The actual call - From : Entity_Id; - -- Entity of the subprogram containing the call + Caller : Entity_Id; + -- Entity of the subprogram containing the call (can be at any level) - To : Entity_Id; - -- Entity of the subprogram called + Callee : Entity_Id; + -- Entity of the subprogram called (always at level 2 or higher). Note + -- that in accordance with the basic rules of nesting, the level of To + -- is either less than or equal to the level of From, or one greater. end record; package Calls is new Table.Table ( @@ -120,227 +199,48 @@ package body Exp_Unst is -- that are to other subprograms nested within the outer subprogram. These -- are the calls that may need an additional parameter. - ------------------------------------- - -- 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; - - -- If the type is at library level, always consider it static, since - -- uplevel references do not matter in this case. - - elsif Is_Library_Level_Entity (T) then - Set_Is_Static_Type (T); - return False; - - -- 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 (C) loop - if Check_Dynamic_Type (Etype (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 inside a generic (all processing is for instance) - - if Inside_A_Generic then - return; - - -- Nothing to do if we know this is a static type - - elsif 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; + ----------- + -- Urefs -- + ----------- - ---------------------------- - -- Note_Uplevel_Reference -- - ---------------------------- + -- Table to record explicit uplevel references to objects (variables, + -- constants, formal parameters). These are the references that will + -- need rewriting to use the activation table (AREC) pointers. Also + -- included are implicit and explicit uplevel references to types, but + -- these do not get rewritten by the front end. - procedure Note_Uplevel_Reference (N : Node_Id; Subp : Entity_Id) is - Elmt : Elmt_Id; + type Uref_Entry is record + Ref : Node_Id; + -- The reference itself. For objects this is always an entity reference + -- and the referenced entity will have its Is_Uplevel_Referenced_Entity + -- flag set and will appear in the Uplevel_Referenced_Entities list of + -- the subprogram declaring this entity. - begin - -- Nothing to do inside a generic (all processing is for instance) - - if Inside_A_Generic then - return; - end if; - - -- Nothing to do if reference has no entity field - - if Nkind (N) not in N_Has_Entity then - return; - end if; - - -- Establish list if first call for Uplevel_References - - if No (Uplevel_References (Subp)) then - Set_Uplevel_References (Subp, New_Elmt_List); - end if; - - -- Ignore if node is already in the list. This is a bit inefficient, - -- but we can definitely get duplicates that cause trouble! - - Elmt := First_Elmt (Uplevel_References (Subp)); - while Present (Elmt) loop - if N = Node (Elmt) then - return; - else - Next_Elmt (Elmt); - end if; - end loop; - - -- Add new entry to Uplevel_References. Each entry is two elements of - -- the list. The first is the actual reference, the second is the - -- enclosing subprogram at the point of reference + Ent : Entity_Id; + -- The Entity_Id of the uplevel referenced object or type - Append_Elmt (N, Uplevel_References (Subp)); + Caller : Entity_Id; + -- The entity for the subprogram immediately containing this entity - if Is_Subprogram (Current_Scope) then - Append_Elmt (Current_Scope, Uplevel_References (Subp)); - else - Append_Elmt - (Enclosing_Subprogram (Current_Scope), Uplevel_References (Subp)); - end if; + Callee : Entity_Id; + -- The entity for the subprogram containing the referenced entity. Note + -- that the level of Callee must be less than the level of Caller, since + -- this is uplevel reference. + end record; - Set_Has_Uplevel_Reference (Entity (N)); - Set_Has_Uplevel_Reference (Subp); - end Note_Uplevel_Reference; + package Urefs is new Table.Table ( + Table_Component_Type => Uref_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "Unnest_Urefs"); ----------------------- -- Unnest_Subprogram -- ----------------------- procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is - function Actual_Ref (N : Node_Id) return Node_Id; - -- This function is applied to an element in the Uplevel_References - -- list, and it finds the actual reference. Often this is just N itself, - -- but in some cases it gets rewritten, e.g. as a Type_Conversion, and - -- this function digs out the actual reference - function AREC_String (Lev : Pos) return String; -- Given a level value, 1, 2, ... returns the string AREC, AREC2, ... @@ -357,43 +257,14 @@ package body Exp_Unst is function Subp_Index (Sub : Entity_Id) return SI_Type; -- Given the entity for a subprogram, return corresponding Subps index - function Upref_Name (Ent : Entity_Id) return Name_Id; + function Upref_Name (Ent : Entity_Id; Clist : List_Id) return Name_Id; -- This function returns the name to be used in the activation record to - -- reference the variable uplevel. Normally this is just a copy of the - -- Chars field of the entity. The exception is when the scope of Ent - -- is a declare block, in which case we append the entity number to - -- make sure that no confusion occurs between use of the same name - -- in different declare blocks. - - ---------------- - -- Actual_Ref -- - ---------------- - - function Actual_Ref (N : Node_Id) return Node_Id is - begin - case Nkind (N) is - - -- If we have an entity reference, then this is the actual ref - - when N_Has_Entity => - return N; - - -- For a type conversion, go get the expression - - when N_Type_Conversion => - return Expression (N); - - -- For an explicit dereference, get the prefix - - when N_Explicit_Dereference => - return Prefix (N); - - -- No other possibilities should exist - - when others => - raise Program_Error; - end case; - end Actual_Ref; + -- reference the variable uplevel. Clist is the list of components that + -- have been created in the activation record so far. Normally this is + -- just a copy of the Chars field of the entity. The exception is when + -- the name has already been used, in which case we suffix the name with + -- the entity number to avoid duplication. This happens with declare + -- blocks and generic parameters at least. ----------------- -- AREC_String -- @@ -456,17 +327,25 @@ package body Exp_Unst is -- Upref_Name -- ---------------- - function Upref_Name (Ent : Entity_Id) return Name_Id is + function Upref_Name (Ent : Entity_Id; Clist : List_Id) return Name_Id is + C : Node_Id; + begin - if Ekind (Scope (Ent)) /= E_Block then - return Chars (Ent); + C := First (Clist); + loop + if No (C) then + return Chars (Ent); - else - Get_Name_String (Chars (Ent)); - Add_Str_To_Name_Buffer ("__"); - Add_Nat_To_Name_Buffer (Nat (Ent)); - return Name_Enter; - end if; + elsif Chars (Defining_Identifier (C)) = Chars (Ent) then + Get_Name_String (Chars (Ent)); + Add_Str_To_Name_Buffer ("__"); + Add_Nat_To_Name_Buffer (Nat (Ent)); + return Name_Enter; + + else + Next (C); + end if; + end loop; end Upref_Name; -- Start of processing for Unnest_Subprogram @@ -477,15 +356,22 @@ package body Exp_Unst is if Inside_A_Generic then return; end if; + -- At least for now, do not unnest anything but main source unit if not In_Extended_Main_Source_Unit (Subp_Body) then return; end if; + -- This routine is called late, after the scope stack is gone. The + -- following creates a suitable dummy scope stack to be used for the + -- analyze/expand calls made from this routine. + + Push_Scope (Subp); + -- 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 + -- references (as indicated by ??? 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). @@ -499,43 +385,194 @@ package body Exp_Unst is Subps.Init; Calls.Init; + Urefs.Init; Build_Tables : declare + Current_Subprogram : Entity_Id; + -- When we scan a subprogram body, we set Current_Subprogram to the + -- corresponding entity. This gets recursively saved and restored. + function Visit_Node (N : Node_Id) return Traverse_Result; -- Visit a single node in Subp + ----------- + -- Visit -- + ----------- + + procedure Visit is new Traverse_Proc (Visit_Node); + -- Used to traverse the body of Subp, populating the tables + ---------------- -- Visit_Node -- ---------------- function Visit_Node (N : Node_Id) return Traverse_Result is - Ent : Entity_Id; - Csub : Entity_Id; + Ent : Entity_Id; + Caller : Entity_Id; + Callee : Entity_Id; + + procedure Check_Static_Type (T : Entity_Id; DT : in out Boolean); + -- Given a type T, checks if it is a static type defined as a + -- type with no dynamic bounds in sight. If so, the only action + -- is to set Is_Static_Type True for T. If T is not a static + -- type, then all types with dynamic bounds associated with + -- T are detected, and their bounds are marked as uplevel + -- referenced if not at the library level, and DT is set True. + + procedure Note_Uplevel_Ref + (E : Entity_Id; + Caller : Entity_Id; + Callee : Entity_Id); + -- Called when we detect an explicit or implicit uplevel reference + -- from within Caller to entity E declared in Callee. E can be a + -- an object or a type. + + ----------------------- + -- Check_Static_Type -- + ----------------------- + + procedure Check_Static_Type (T : Entity_Id; DT : in out Boolean) is + procedure Note_Uplevel_Bound (N : Node_Id); + -- N is the bound of a dynamic type. This procedure notes that + -- this bound is uplevel referenced, it can handle references + -- to entities (typically _FIRST and _LAST entities), and also + -- attribute references of the form T'name (name is typically + -- FIRST or LAST) where T is the uplevel referenced bound. + + ------------------------ + -- Note_Uplevel_Bound -- + ------------------------ + + procedure Note_Uplevel_Bound (N : Node_Id) is + begin + -- Entity name case + + if Is_Entity_Name (N) then + if Present (Entity (N)) then + Note_Uplevel_Ref + (E => Entity (N), + Caller => Current_Subprogram, + Callee => Enclosing_Subprogram (Entity (N))); + end if; - function Find_Current_Subprogram return Entity_Id; - -- Finds the current subprogram containing the call N + -- Attribute case - ----------------------------- - -- Find_Current_Subprogram -- - ----------------------------- + elsif Nkind (N) = N_Attribute_Reference then + Note_Uplevel_Bound (Prefix (N)); + end if; + end Note_Uplevel_Bound; - function Find_Current_Subprogram return Entity_Id is - Nod : Node_Id; + -- Start of processing for Check_Static_Type begin - Nod := N; - loop - Nod := Parent (Nod); + -- If already marked static, immediate return - if Nkind (Nod) = N_Subprogram_Body then - if Acts_As_Spec (Nod) then - return Defining_Entity (Specification (Nod)); - else - return Corresponding_Spec (Nod); + if Is_Static_Type (T) then + return; + end if; + + -- If the type is at library level, always consider it static, + -- since such uplevel references are irrelevant. + + if Is_Library_Level_Entity (T) then + Set_Is_Static_Type (T); + return; + end if; + + -- Otherwise figure out what the story is with this type + + -- 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 + Note_Uplevel_Bound (LB); + DT := True; end if; - end if; - end loop; - end Find_Current_Subprogram; + + if not Is_Static_Expression (UB) then + Note_Uplevel_Bound (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 (C) loop + Check_Static_Type (Etype (C), DT); + 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 + Check_Static_Type (Component_Type (T), DT); + + IX := First_Index (T); + while Present (IX) loop + Check_Static_Type (Etype (IX), DT); + Next_Index (IX); + end loop; + end; + + -- For now, ignore other types + + else + return; + end if; + + if not DT then + Set_Is_Static_Type (T); + end if; + end Check_Static_Type; + + ---------------------- + -- Note_Uplevel_Ref -- + ---------------------- + + procedure Note_Uplevel_Ref + (E : Entity_Id; + Caller : Entity_Id; + Callee : Entity_Id) + is + begin + -- Nothing to do for static type + + if Is_Static_Type (E) then + return; + end if; + + -- Nothing to do if Caller and Callee are the same + + if Caller = Callee then + return; + end if; + + -- We have a new uplevel referenced entity + + -- All we do at this stage is to add the uplevel reference to + -- the table. It's too earch to do anything else, since this + -- uplevel reference may come from an unreachable subprogram + -- in which case the entry will be deleted. + + Urefs.Append ((N, E, Caller, Callee)); + end Note_Uplevel_Ref; -- Start of processing for Visit_Node @@ -557,29 +594,18 @@ package body Exp_Unst is if Scope_Within (Ent, Subp) then - -- For now, ignore calls to generic instances. Seems to be - -- some problem there which we will investigate later ??? - - if Original_Location (Sloc (Ent)) /= Sloc (Ent) - or else Is_Generic_Instance (Ent) - then - null; - -- Ignore calls to imported routines - elsif Is_Imported (Ent) then + if Is_Imported (Ent) then null; -- Here we have a call to keep and analyze else - Csub := Find_Current_Subprogram; + -- Both caller and callee must be subprograms - -- Both caller and callee must be subprograms (we ignore - -- generic subprograms). - - if Is_Subprogram (Csub) and then Is_Subprogram (Ent) then - Calls.Append ((N, Find_Current_Subprogram, Ent)); + if Is_Subprogram (Ent) then + Calls.Append ((N, Current_Subprogram, Ent)); end if; end if; end if; @@ -589,103 +615,425 @@ package body Exp_Unst is -- that it has a corresponding body we can get hold of. The case -- of no corresponding body being available is ignored for now. - elsif (Nkind (N) = N_Subprogram_Body and then Acts_As_Spec (N)) - or else (Nkind (N) = N_Subprogram_Declaration - and then Present (Corresponding_Body (N))) - then - Subps.Increment_Last; + elsif Nkind (N) = N_Subprogram_Body then + Ent := Corresponding_Spec_Of (N); + + -- Ignore generic subprogram + + if Is_Generic_Subprogram (Ent) then + return Skip; + end if; + + -- Make new entry in subprogram table if not already made + + declare + L : constant Nat := Get_Level (Ent); + begin + Subps.Append + ((Ent => Ent, + Bod => N, + Lev => L, + Reachable => False, + Uplevel_Ref => L, + Declares_AREC => False, + Uents => No_Elist, + ARECnF => Empty, + ARECn => Empty, + ARECnT => Empty, + ARECnPT => Empty, + ARECnP => Empty, + ARECnU => Empty)); + Set_Subps_Index (Ent, UI_From_Int (Subps.Last)); + end; + + -- We make a recursive call to scan the subprogram body, so + -- that we can save and restore Current_Subprogram. declare - STJ : Subp_Entry renames Subps.Table (Subps.Last); + Save_CS : constant Entity_Id := Current_Subprogram; + Decl : Node_Id; begin - -- Set fields of Subp_Entry for new subprogram + Current_Subprogram := Ent; - STJ.Ent := Defining_Entity (Specification (N)); - STJ.Lev := Get_Level (STJ.Ent); + -- Scan declarations - if Nkind (N) = N_Subprogram_Body then - STJ.Bod := N; - else - STJ.Bod := - Parent (Declaration_Node (Corresponding_Body (N))); - pragma Assert (Nkind (STJ.Bod) = N_Subprogram_Body); - end if; + Decl := First (Declarations (N)); + while Present (Decl) loop + Visit (Decl); + Next (Decl); + end loop; + + -- Scan statements + + Visit (Handled_Statement_Sequence (N)); - -- Capture Uplevel_References, and then set (uses the same - -- field), the Subps_Index value for this subprogram. + -- Restore current subprogram setting - STJ.Urefs := Uplevel_References (STJ.Ent); - Set_Subps_Index (STJ.Ent, UI_From_Int (Int (Subps.Last))); + Current_Subprogram := Save_CS; end; + + -- Now at this level, return skipping the subprogram body + -- descendents, since we already took care of them! + + return Skip; + + -- Record an uplevel reference + + elsif Nkind (N) in N_Has_Entity and then Present (Entity (N)) then + Ent := Entity (N); + + -- Only interested in entities declared within our nest + + if not Is_Library_Level_Entity (Ent) + and then Scope_Within_Or_Same (Scope (Ent), Subp) + and then + + -- Constants and variables are interesting + + (Ekind_In (Ent, E_Constant, E_Variable) + + -- Formals are interesting, but not if being used as mere + -- names of parameters for name notation calls. + + or else + (Is_Formal (Ent) + and then not + (Nkind (Parent (N)) = N_Parameter_Association + and then Selector_Name (Parent (N)) = N)) + + -- Types other than known Is_Static types are interesting + + or else (Is_Type (Ent) + and then not Is_Static_Type (Ent))) + then + -- Here we have a possible interesting uplevel reference + + if Is_Type (Ent) then + declare + DT : Boolean := False; + + begin + Check_Static_Type (Ent, DT); + + if Is_Static_Type (Ent) then + return OK; + end if; + end; + end if; + + Caller := Current_Subprogram; + Callee := Enclosing_Subprogram (Ent); + + if Callee /= Caller and then not Is_Static_Type (Ent) then + Note_Uplevel_Ref (Ent, Caller, Callee); + end if; + end if; + + -- Skip generic declarations + + elsif Nkind (N) in N_Generic_Declaration then + return Skip; + + -- Skip generic package body + + elsif Nkind (N) = N_Package_Body + and then Present (Corresponding_Spec (N)) + and then Ekind (Corresponding_Spec (N)) = E_Generic_Package + then + return Skip; end if; + -- Fall through to continue scanning children of this node + return OK; end Visit_Node; - ----------- - -- Visit -- - ----------- - - procedure Visit is new Traverse_Proc (Visit_Node); - -- Used to traverse the body of Subp, populating the tables - -- Start of processing for Build_Tables begin - -- A special case, if the outer level subprogram has a separate spec - -- then we won't catch it in the traversal of the body. But we do - -- want to visit the declaration in this case! - - if not Acts_As_Spec (Subp_Body) then - declare - Dummy : Traverse_Result; - Decl : constant Node_Id := - Parent (Declaration_Node (Corresponding_Spec (Subp_Body))); - pragma Assert (Nkind (Decl) = N_Subprogram_Declaration); - begin - Dummy := Visit_Node (Decl); - end; - end if; - - -- Traverse the body to get the rest of the subprograms and calls + -- Traverse the body to get subprograms, calls and uplevel references 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. + -- Now do the first transitive closure which determines which + -- subprograms in the nest are actually reachable. - Closure : declare + Reachable_Closure : declare Modified : Boolean; begin + Subps.Table (1).Reachable := True; + -- 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. + -- A to B, where A is reachable, but B is not, then B is reachable, + -- 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; + declare + CTJ : Call_Entry renames Calls.Table (J); + + SINF : constant SI_Type := Subp_Index (CTJ.Caller); + SINT : constant SI_Type := Subp_Index (CTJ.Callee); + + SUBF : Subp_Entry renames Subps.Table (SINF); + SUBT : Subp_Entry renames Subps.Table (SINT); + + begin + if SUBF.Reachable and then not SUBT.Reachable then + SUBT.Reachable := True; + Modified := True; + end if; + end; end loop Inner; exit Outer when not Modified; end loop Outer; - end Closure; + end Reachable_Closure; + + -- Remove calls from unreachable subprograms + + declare + New_Index : Nat; + + begin + New_Index := 0; + for J in Calls.First .. Calls.Last loop + declare + CTJ : Call_Entry renames Calls.Table (J); + + SINF : constant SI_Type := Subp_Index (CTJ.Caller); + SINT : constant SI_Type := Subp_Index (CTJ.Callee); + + SUBF : Subp_Entry renames Subps.Table (SINF); + SUBT : Subp_Entry renames Subps.Table (SINT); + + begin + if SUBF.Reachable then + pragma Assert (SUBT.Reachable); + New_Index := New_Index + 1; + Calls.Table (New_Index) := Calls.Table (J); + end if; + end; + end loop; + + Calls.Set_Last (New_Index); + end; + + -- Remove uplevel references from unreachable subprograms + + declare + New_Index : Nat; + + begin + New_Index := 0; + for J in Urefs.First .. Urefs.Last loop + declare + URJ : Uref_Entry renames Urefs.Table (J); + + SINF : constant SI_Type := Subp_Index (URJ.Caller); + SINT : constant SI_Type := Subp_Index (URJ.Callee); + + SUBF : Subp_Entry renames Subps.Table (SINF); + SUBT : Subp_Entry renames Subps.Table (SINT); + + S : Entity_Id; + + begin + -- Keep reachable reference + + if SUBF.Reachable then + New_Index := New_Index + 1; + Urefs.Table (New_Index) := Urefs.Table (J); + + -- And since we know we are keeping this one, this is a good + -- place to fill in information for a good reference. + + -- Mark all enclosing subprograms need to declare AREC + + S := URJ.Caller; + loop + S := Enclosing_Subprogram (S); + Subps.Table (Subp_Index (S)).Declares_AREC := True; + exit when S = URJ.Callee; + end loop; + + -- Add to list of uplevel referenced entities for Callee. + -- We do not add types to this list, only actual references + -- to objects that will be referenced uplevel, and we use + -- the flag Is_Uplevel_Referenced_Entity to avoid making + -- duplicate entries in the list. + + if not Is_Uplevel_Referenced_Entity (URJ.Ent) then + Set_Is_Uplevel_Referenced_Entity (URJ.Ent); + + if not Is_Type (URJ.Ent) then + Append_New_Elmt (URJ.Ent, SUBT.Uents); + end if; + end if; + + -- And set uplevel indication for caller + + if SUBT.Lev < SUBF.Uplevel_Ref then + SUBF.Uplevel_Ref := SUBT.Lev; + end if; + end if; + end; + end loop; + + Urefs.Set_Last (New_Index); + end; + + -- Remove unreachable subprograms from Subps table. Note that we do + -- this after eliminating entries from the other two tables, since + -- thos elimination steps depend on referencing the Subps table. + + declare + New_SI : SI_Type; + + begin + New_SI := 0; + for J in Subps.First .. Subps.Last loop + declare + STJ : Subp_Entry renames Subps.Table (J); + Spec : Node_Id; + Decl : Node_Id; + + begin + -- Subprogram is reachable, copy and reset index + + if STJ.Reachable then + New_SI := New_SI + 1; + Subps.Table (New_SI) := STJ; + Set_Subps_Index (STJ.Ent, UI_From_Int (New_SI)); + + -- Subprogram is not reachable + + else + -- Clear index, since no longer active + + Set_Subps_Index (Subps.Table (J).Ent, Uint_0); + + -- Output debug information if -gnatd.3 set + + if Debug_Flag_Dot_3 then + Write_Str ("Eliminate "); + Write_Name (Chars (Subps.Table (J).Ent)); + Write_Str (" at "); + Write_Location (Sloc (Subps.Table (J).Ent)); + Write_Str (" (not referenced)"); + Write_Eol; + end if; + + -- Rewrite declaration and body to null statements + + Spec := Corresponding_Spec (STJ.Bod); + + if Present (Spec) then + Decl := Parent (Declaration_Node (Spec)); + Rewrite (Decl, Make_Null_Statement (Sloc (Decl))); + end if; + + Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod))); + end if; + end; + end loop; + + Subps.Set_Last (New_SI); + end; + + -- Now it is time for the second transitive closure, which follows calls + -- and makes sure that A calls B, and B has uplevel references, then A + -- is also marked as having uplevel references. + + Closure_Uplevel : 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 B has uplevel references, make sure that A is marked + -- as having at least the same level of uplevel referencing. + + Outer2 : loop + Modified := False; + Inner2 : for J in Calls.First .. Calls.Last loop + declare + CTJ : Call_Entry renames Calls.Table (J); + SINF : constant SI_Type := Subp_Index (CTJ.Caller); + SINT : constant SI_Type := Subp_Index (CTJ.Callee); + SUBF : Subp_Entry renames Subps.Table (SINF); + SUBT : Subp_Entry renames Subps.Table (SINT); + begin + if SUBT.Lev > SUBT.Uplevel_Ref + and then SUBF.Uplevel_Ref > SUBT.Uplevel_Ref + then + SUBF.Uplevel_Ref := SUBT.Uplevel_Ref; + Modified := True; + end if; + end; + end loop Inner2; + + exit Outer2 when not Modified; + end loop Outer2; + end Closure_Uplevel; + + -- We have one more step before the tables are complete. An uplevel + -- call from subprogram A to subprogram B where subprogram B has uplevel + -- references is in effect an uplevel reference, and must arrange for + -- the proper activation link to be passed. + + for J in Calls.First .. Calls.Last loop + declare + CTJ : Call_Entry renames Calls.Table (J); + + SINF : constant SI_Type := Subp_Index (CTJ.Caller); + SINT : constant SI_Type := Subp_Index (CTJ.Callee); + + SUBF : Subp_Entry renames Subps.Table (SINF); + SUBT : Subp_Entry renames Subps.Table (SINT); + + A : Entity_Id; + + begin + -- If callee has uplevel references + + if SUBT.Uplevel_Ref < SUBT.Lev + + -- And this is an uplevel call + + and then SUBT.Lev < SUBF.Lev + then + -- We need to arrange for finding the uplink + + A := CTJ.Caller; + loop + A := Enclosing_Subprogram (A); + Subps.Table (Subp_Index (A)).Declares_AREC := True; + exit when A = CTJ.Callee; + + -- In any case exit when we get to the outer level. This + -- happens in some odd cases with generics (in particular + -- sem_ch3.adb does not compile without this kludge ???). + + exit when A = Subp; + end loop; + end if; + end; + end loop; -- Next step, create the entities for code we will insert. We do this -- at the start so that all the entities are defined, regardless of the @@ -698,30 +1046,18 @@ package body Exp_Unst is ARS : constant String := AREC_String (STJ.Lev); begin - -- First we create the ARECnF entity for the additional formal - -- for all subprograms requiring that an activation record pointer - -- be passed. This is true of all subprograms that have uplevel - -- references, and whose enclosing subprogram also has uplevel - -- references. - - if Has_Uplevel_Reference (STJ.Ent) - and then STJ.Ent /= Subp - and then Has_Uplevel_Reference (Enclosing_Subprogram (STJ.Ent)) - then + -- First we create the ARECnF entity for the additional formal for + -- all subprograms which need an activation record passed. + + if STJ.Uplevel_Ref < STJ.Lev then STJ.ARECnF := Make_Defining_Identifier (Loc, Chars => Name_Find_Str (AREC_String (STJ.Lev - 1) & "F")); - else - STJ.ARECnF := Empty; end if; - -- Now define the AREC entities for the activation record. This - -- is needed for any subprogram that has nested subprograms and - -- has uplevel references. + -- Define the AREC entities for the activation record if needed - if Has_Nested_Subprogram (STJ.Ent) - and then Has_Uplevel_Reference (STJ.Ent) - then + if STJ.Declares_AREC then STJ.ARECn := Make_Defining_Identifier (Loc, Name_Find_Str (ARS)); STJ.ARECnT := @@ -731,27 +1067,17 @@ package body Exp_Unst is STJ.ARECnP := Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "P")); - else - STJ.ARECn := Empty; - STJ.ARECnT := Empty; - STJ.ARECnPT := Empty; - STJ.ARECnP := Empty; - STJ.ARECnU := Empty; - end if; - - -- Define uplink component entity if inner nesting case - - if Has_Uplevel_Reference (STJ.Ent) and then STJ.Lev > 1 then - declare - ARS1 : constant String := AREC_String (STJ.Lev - 1); - begin - STJ.ARECnU := - Make_Defining_Identifier (Loc, - Chars => Name_Find_Str (ARS1 & "U")); - end; + -- Define uplink component entity if inner nesting case - else - STJ.ARECnU := Empty; + if Present (STJ.ARECnF) then + declare + ARS1 : constant String := AREC_String (STJ.Lev - 1); + begin + STJ.ARECnU := + Make_Defining_Identifier (Loc, + Chars => Name_Find_Str (ARS1 & "U")); + end; + end if; end if; end; end loop Create_Entities; @@ -850,19 +1176,14 @@ package body Exp_Unst is end Add_Extra_Formal; end if; - -- Processing for subprograms that have at least one nested - -- subprogram, and have uplevel references. + -- Processing for subprograms that declare an activation record + + if Present (STJ.ARECn) then - if Has_Nested_Subprogram (STJ.Ent) - and then Has_Uplevel_Reference (STJ.Ent) - then -- Local declarations for one such subprogram declare Loc : constant Source_Ptr := Sloc (STJ.Bod); - Elmt : Elmt_Id; - Nod : Node_Id; - Ent : Entity_Id; Clist : List_Id; Comp : Entity_Id; @@ -872,44 +1193,13 @@ package body Exp_Unst is Decl_ARECnP : Node_Id; -- Declaration nodes for the AREC entities we build - Uplevel_Entities : - array (1 .. List_Length (STJ.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; - - if Present (STJ.Urefs) then - Elmt := First_Elmt (STJ.Urefs); - while Present (Elmt) loop - Nod := Actual_Ref (Node (Elmt)); - Ent := Entity (Nod); - - 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); - Next_Elmt (Elmt); - end loop; - end if; - -- Build list of component declarations for ARECnT Clist := Empty_List; -- If we are in a subprogram that has a static link that - -- ias passed in (as indicated by ARECnF being deinfed), + -- is passed in (as indicated by ARECnF being defined), -- then include ARECnU : ARECnPT := ARECnF where n is -- one less than the current level and the entity ARECnPT -- comes from the enclosing subprogram. @@ -934,22 +1224,35 @@ package body Exp_Unst is -- Add components for uplevel referenced entities - for J in 1 .. Num_Uplevel_Entities loop - Comp := - Make_Defining_Identifier (Loc, - Chars => Upref_Name (Uplevel_Entities (J))); - - Set_Activation_Record_Component - (Uplevel_Entities (J), Comp); - - Append_To (Clist, - Make_Component_Declaration (Loc, - Defining_Identifier => Comp, - Component_Definition => - Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (Addr, Loc)))); - end loop; + if Present (STJ.Uents) then + declare + Elmt : Elmt_Id; + Uent : Entity_Id; + + begin + Elmt := First_Elmt (STJ.Uents); + while Present (Elmt) loop + Uent := Node (Elmt); + + Comp := + Make_Defining_Identifier (Loc, + Chars => Upref_Name (Uent, Clist)); + + Set_Activation_Record_Component + (Uent, Comp); + + Append_To (Clist, + Make_Component_Declaration (Loc, + Defining_Identifier => Comp, + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Addr, Loc)))); + + Next_Elmt (Elmt); + end loop; + end; + end if; -- Now we can insert the AREC declarations into the body @@ -1010,89 +1313,93 @@ package body Exp_Unst is -- newly created entities go in the right entity chain. -- We analyze with all checks suppressed (since we do - -- not expect any exceptions, and also we temporarily - -- turn off Unested_Subprogram_Mode to avoid trying to - -- mark uplevel references (not needed at this stage, - -- and in fact causes a bit of recursive chaos). + -- not expect any exceptions). Push_Scope (STJ.Ent); - Opt.Unnest_Subprogram_Mode := False; Analyze (Decl_ARECnT, Suppress => All_Checks); Analyze (Decl_ARECn, Suppress => All_Checks); Analyze (Decl_ARECnPT, Suppress => All_Checks); Analyze (Decl_ARECnP, Suppress => All_Checks); - Opt.Unnest_Subprogram_Mode := True; Pop_Scope; -- Next step, for each uplevel referenced entity, add - -- assignment operations to set the comoponent in the + -- assignment operations to set the component in the -- activation record. - for J in 1 .. Num_Uplevel_Entities loop + if Present (STJ.Uents) then declare - Ent : constant Entity_Id := Uplevel_Entities (J); - Loc : constant Source_Ptr := Sloc (Ent); - Dec : constant Node_Id := Declaration_Node (Ent); - Ins : Node_Id; - Asn : Node_Id; + Elmt : Elmt_Id; begin - -- For parameters, we insert the assignment right - -- after the declaration of ARECnP. For all other - -- entities, we insert the assignment immediately - -- after the declaration of the entity. - - -- Note: we don't need to mark the entity as being - -- aliased, because the address attribute will mark - -- it as Address_Taken, and that is good enough. - - if Is_Formal (Ent) then - Ins := Decl_ARECnP; - else - Ins := Dec; - end if; - - -- Build and insert the assignment: - -- ARECn.nam := nam'Address - - Asn := - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (STJ.ARECn, Loc), - Selector_Name => - New_Occurrence_Of - (Activation_Record_Component (Ent), - Loc)), - - Expression => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Ent, Loc), - Attribute_Name => Name_Address)); - - Insert_After (Ins, Asn); - - -- Analyze the assignment statement. We do not need - -- to establish the relevant scope stack entries - -- here, because we have already set the correct - -- entity references, so no name resolution is - -- required, and no new entities are created, so - -- we don't even need to set the current scope. - - -- We analyze with all checks suppressed (since - -- we do not expect any exceptions, and also we - -- temporarily turn off Unested_Subprogram_Mode - -- to avoid trying to mark uplevel references (not - -- needed at this stage, and in fact causes a bit - -- of recursive chaos). - - Opt.Unnest_Subprogram_Mode := False; - Analyze (Asn, Suppress => All_Checks); - Opt.Unnest_Subprogram_Mode := True; + Elmt := First_Elmt (STJ.Uents); + while Present (Elmt) loop + declare + Ent : constant Entity_Id := Node (Elmt); + Loc : constant Source_Ptr := Sloc (Ent); + Dec : constant Node_Id := + Declaration_Node (Ent); + Ins : Node_Id; + Asn : Node_Id; + + begin + -- For parameters, we insert the assignment + -- right after the declaration of ARECnP. + -- For all other entities, we insert + -- the assignment immediately after + -- the declaration of the entity. + + -- Note: we don't need to mark the entity + -- as being aliased, because the address + -- attribute will mark it as Address_Taken, + -- and that is good enough. + + if Is_Formal (Ent) then + Ins := Decl_ARECnP; + else + Ins := Dec; + end if; + + -- Build and insert the assignment: + -- ARECn.nam := nam'Address + + Asn := + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (STJ.ARECn, Loc), + Selector_Name => + New_Occurrence_Of + (Activation_Record_Component + (Ent), + Loc)), + + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Ent, Loc), + Attribute_Name => Name_Address)); + + Insert_After (Ins, Asn); + + -- Analyze the assignment statement. We do + -- not need to establish the relevant scope + -- stack entries here, because we have + -- already set the correct entity references, + -- so no name resolution is required, and no + -- new entities are created, so we don't even + -- need to set the current scope. + + -- We analyze with all checks suppressed + -- (since we do not expect any exceptions). + + Analyze (Asn, Suppress => All_Checks); + end; + + Next_Elmt (Elmt); + end loop; end; - end loop; + end if; end; end if; end; @@ -1104,204 +1411,141 @@ package body Exp_Unst is -- need all the AREC declarations generated, inserted, and analyzed so -- that the uplevel references can be successfully analyzed. - Uplev_Refs : for J in Subps.First .. Subps.Last loop + Uplev_Refs : for J in Urefs.First .. Urefs.Last loop declare - STJ : Subp_Entry renames Subps.Table (J); + UPJ : Uref_Entry renames Urefs.Table (J); begin - -- We are only interested in entries which have uplevel references - -- to deal with, as indicated by the Urefs list being present - - if Present (STJ.Urefs) then - - -- Process uplevel references for one subprogram - - Uplev_Refs_For_One_Subp : declare - Elmt : Elmt_Id; - - function Get_Real_Subp (Ent : Entity_Id) return Entity_Id; - -- The entity recorded as the enclosing subprogram for the - -- reference sometimes turns out to be a subprogram body. - -- This function gets the proper subprogram spec if needed. - - ------------------- - -- Get_Real_Subp -- - ------------------- - - function Get_Real_Subp (Ent : Entity_Id) return Entity_Id is - Nod : Node_Id; + -- Ignore type references, these are implicit references that do + -- not need rewriting (e.g. the appearence in a conversion). - begin - -- If we have a subprogram, return it - - if Is_Subprogram (Ent) then - return Ent; - - -- If we have a subprogram body, go to the body - - elsif Ekind (Ent) = E_Subprogram_Body then - Nod := Parent (Parent (Ent)); - pragma Assert (Nkind (Nod) = N_Subprogram_Body); - - if Acts_As_Spec (Nod) then - return Ent; - else - return Corresponding_Spec (Nod); - end if; - - -- Should not be any other possibilities - - else - raise Program_Error; - end if; - end Get_Real_Subp; - - -- Start of processing for Uplevel_References_For_One_Subp - - begin - -- Loop through uplevel references - - Elmt := First_Elmt (STJ.Urefs); - while Present (Elmt) loop - - -- Rewrite one reference - - Rewrite_One_Ref : declare - Ref : constant Node_Id := Actual_Ref (Node (Elmt)); - -- The reference to be rewritten + if Is_Type (UPJ.Ent) then + goto Continue; + end if; - Loc : constant Source_Ptr := Sloc (Ref); - -- Source location for the reference + -- Rewrite one reference - Ent : constant Entity_Id := Entity (Ref); - -- The referenced entity + Rewrite_One_Ref : declare + Loc : constant Source_Ptr := Sloc (UPJ.Ref); + -- Source location for the reference - Typ : constant Entity_Id := Etype (Ent); - -- The type of the referenced entity + Typ : constant Entity_Id := Etype (UPJ.Ent); + -- The type of the referenced entity - Atyp : constant Entity_Id := Get_Actual_Subtype (Ref); - -- The actual subtype of the reference + Atyp : constant Entity_Id := Get_Actual_Subtype (UPJ.Ref); + -- The actual subtype of the reference - Rsub : constant Entity_Id := - Get_Real_Subp (Node (Next_Elmt (Elmt))); - -- The enclosing subprogram for the reference + RS_Caller : constant SI_Type := Subp_Index (UPJ.Caller); + -- Subp_Index for caller containing reference - RSX : constant SI_Type := Subp_Index (Rsub); - -- Subp_Index for enclosing subprogram for ref + STJR : Subp_Entry renames Subps.Table (RS_Caller); + -- Subp_Entry for subprogram containing reference - STJR : Subp_Entry renames Subps.Table (RSX); - -- Subp_Entry for enclosing subprogram for ref + RS_Callee : constant SI_Type := Subp_Index (UPJ.Callee); + -- Subp_Index for subprogram containing referenced entity - Pfx : Node_Id; - Comp : Entity_Id; - SI : SI_Type; + STJE : Subp_Entry renames Subps.Table (RS_Callee); + -- Subp_Entry for subprogram containing referenced entity - begin - -- Ignore if no ARECnF entity for enclosing subprogram - -- which probably happens as a result of not properly - -- treating instance bodies. To be examined ??? + Pfx : Node_Id; + Comp : Entity_Id; + SI : SI_Type; - -- If this test is omitted, then the compilation of - -- freeze.adb and inline.adb fail in unnesting mode. + begin + -- Ignore if no ARECnF entity for enclosing subprogram which + -- probably happens as a result of not properly treating + -- instance bodies. To be examined ??? - if No (STJR.ARECnF) then - goto Continue; - end if; + -- If this test is omitted, then the compilation of + -- freeze.adb and inline.adb fail in unnesting mode. - -- Push the current scope, so that the pointer type - -- Tnn, and any subsidiary entities resulting from - -- the analysis of the rewritten reference, go in the - -- right entity chain. + if No (STJR.ARECnF) then + goto Continue; + end if; - Push_Scope (STJR.Ent); + -- Push the current scope, so that the pointer type Tnn, and + -- any subsidiary entities resulting from the analysis of the + -- rewritten reference, go in the right entity chain. - -- Now we need to rewrite the reference. We have a - -- reference is from level STJE.Lev to level STJ.Lev. - -- The general form of the rewritten reference for - -- entity X is: + Push_Scope (STJR.Ent); - -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X) + -- Now we need to rewrite the reference. We have a + -- reference is from level STJR.Lev to level STJE.Lev. + -- The general form of the rewritten reference for + -- entity X is: - -- where a,b,c,d .. m = - -- STJR.Lev - 1, STJ.Lev - 2, .. STJ.Lev + -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X) - pragma Assert (STJR.Lev > STJ.Lev); + -- where a,b,c,d .. m = + -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev - -- Compute the prefix of X. Here are examples to make - -- things clear (with parens to show groupings, the - -- prefix is everything except the .X at the end). + pragma Assert (STJR.Lev > STJE.Lev); - -- level 2 to level 1 + -- Compute the prefix of X. Here are examples to make things + -- clear (with parens to show groupings, the prefix is + -- everything except the .X at the end). - -- AREC1F.X + -- level 2 to level 1 - -- level 3 to level 1 + -- AREC1F.X - -- (AREC2F.AREC1U).X + -- level 3 to level 1 - -- level 4 to level 1 + -- (AREC2F.AREC1U).X - -- ((AREC3F.AREC2U).AREC1U).X + -- level 4 to level 1 - -- level 6 to level 2 + -- ((AREC3F.AREC2U).AREC1U).X - -- (((AREC5F.AREC4U).AREC3U).AREC2U).X + -- level 6 to level 2 - Pfx := New_Occurrence_Of (STJR.ARECnF, Loc); - SI := RSX; - for L in STJ.Lev .. STJR.Lev - 2 loop - SI := Enclosing_Subp (SI); - Pfx := - Make_Selected_Component (Loc, - Prefix => Pfx, - Selector_Name => - New_Occurrence_Of - (Subps.Table (SI).ARECnU, Loc)); - end loop; + -- (((AREC5F.AREC4U).AREC3U).AREC2U).X - -- Get activation record component (must exist) + Pfx := New_Occurrence_Of (STJR.ARECnF, Loc); + SI := RS_Caller; + for L in STJE.Lev .. STJR.Lev - 2 loop + SI := Enclosing_Subp (SI); + Pfx := + Make_Selected_Component (Loc, + Prefix => Pfx, + Selector_Name => + New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc)); + end loop; - Comp := Activation_Record_Component (Ent); - pragma Assert (Present (Comp)); + -- Get activation record component (must exist) - -- Do the replacement + Comp := Activation_Record_Component (UPJ.Ent); + pragma Assert (Present (Comp)); - Rewrite (Ref, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Atyp, Loc), - Attribute_Name => Name_Deref, - Expressions => New_List ( - Make_Selected_Component (Loc, - Prefix => Pfx, - Selector_Name => - New_Occurrence_Of (Comp, Loc))))); + -- Do the replacement - -- Analyze and resolve the new expression. We do not - -- need to establish the relevant scope stack entries - -- here, because we have already set all the correct - -- entity references, so no name resolution is needed. - -- We have already set the current scope, so that any - -- new entities created will be in the right scope. + Rewrite (UPJ.Ref, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Atyp, Loc), + Attribute_Name => Name_Deref, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Pfx, + Selector_Name => + New_Occurrence_Of (Comp, Loc))))); - -- We analyze with all checks suppressed (since we do - -- not expect any exceptions, and also we temporarily - -- turn off Unested_Subprogram_Mode to avoid trying to - -- mark uplevel references (not needed at this stage, - -- and in fact causes a bit of recursive chaos). + -- Analyze and resolve the new expression. We do not need to + -- establish the relevant scope stack entries here, because we + -- have already set all the correct entity references, so no + -- name resolution is needed. We have already set the current + -- scope, so that any new entities created will be in the right + -- scope. - Opt.Unnest_Subprogram_Mode := False; - Analyze_And_Resolve (Ref, Typ, Suppress => All_Checks); - Opt.Unnest_Subprogram_Mode := True; - Pop_Scope; - end Rewrite_One_Ref; + -- We analyze with all checks suppressed (since we do not + -- expect any exceptions) - <<Continue>> - Next_Elmt (Elmt); - Next_Elmt (Elmt); - end loop; - end Uplev_Refs_For_One_Subp; - end if; + Analyze_And_Resolve (UPJ.Ref, Typ, Suppress => All_Checks); + Pop_Scope; + end Rewrite_One_Ref; end; + + <<Continue>> + null; end loop Uplev_Refs; -- Finally, loop through all calls adding extra actual for the @@ -1316,8 +1560,8 @@ package body Exp_Unst is Adjust_One_Call : declare CTJ : Call_Entry renames Calls.Table (J); - STF : Subp_Entry renames Subps.Table (Subp_Index (CTJ.From)); - STT : Subp_Entry renames Subps.Table (Subp_Index (CTJ.To)); + STF : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Caller)); + STT : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Callee)); Loc : constant Source_Ptr := Sloc (CTJ.N); @@ -1344,7 +1588,7 @@ package body Exp_Unst is Extra := New_Occurrence_Of (STF.ARECnF, Loc); -- For a call that goes down a level, we pass a pointer - -- to the activation record constructed wtihin the caller + -- to the activation record constructed within the caller -- (which may be the outer level subprogram, but also may -- be a more deeply nested caller). @@ -1368,7 +1612,7 @@ package body Exp_Unst is pragma Assert (STT.Lev < STF.Lev); Extra := New_Occurrence_Of (STF.ARECnF, Loc); - SubX := Subp_Index (CTJ.From); + SubX := Subp_Index (CTJ.Caller); for K in reverse STT.Lev .. STF.Lev - 1 loop SubX := Enclosing_Subp (SubX); Extra := diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads index 3993086..9a6393c 100644 --- a/gcc/ada/exp_unst.ads +++ b/gcc/ada/exp_unst.ads @@ -529,23 +529,6 @@ package Exp_Unst is -- 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 diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index bab0b46..ba90379 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -30,6 +30,7 @@ with Checks; with CStand; with Debug; use Debug; with Elists; +with Exp_Ch6; with Exp_Dbug; with Fmap; with Fname.UF; @@ -90,6 +91,7 @@ begin Checks.Initialize; Sem_Warn.Initialize; Prep.Initialize; + Exp_Ch6.Initialize; if Generate_SCIL then SCIL_LL.Initialize; @@ -408,13 +410,6 @@ begin -- Cleanup processing after completing main analysis - -- Turn off unnesting of subprograms mode. This is not right - -- with respect to instantiations. What needs to happen is that - -- we do the unnesting AFTER the call to Instantiate_Bodies. We - -- will take care of that later ??? - - Opt.Unnest_Subprogram_Mode := False; - -- Comment needed for ASIS mode test and GNATprove mode test??? if Operating_Mode = Generate_Code @@ -444,6 +439,10 @@ begin Remove_Ignored_Ghost_Code; end if; + -- At this stage we can unnest subprogram bodies if required + + Exp_Ch6.Unnest_Subprograms; + -- List library units if requested if List_Units then diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 33c4be2..dcc3a85 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-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- -- @@ -57,6 +57,12 @@ with Ada.Text_IO; use Ada.Text_IO; with GNAT.OS_Lib; use GNAT.OS_Lib; procedure GNATCmd is + Gprbuild : constant String := "gprbuild"; + Gnatmake : constant String := "gnatmake"; + + Gprclean : constant String := "gprclean"; + Gnatclean : constant String := "gnatclean"; + Normal_Exit : exception; -- Raise this exception for normal program termination @@ -1166,7 +1172,6 @@ begin begin if The_Command = Stack then - -- Never call gnatstack with a prefix Program := new String'(Command_List (The_Command).Unixcmd.all); @@ -1174,6 +1179,40 @@ begin else Program := Program_Name (Command_List (The_Command).Unixcmd.all, "gnat"); + + -- If we want to invoke gnatmake/gnatclean with -P, then check if + -- gprbuild/gprclean is available; if it is, use gprbuild/gprclean + -- instead of gnatmake/gnatclean. + + if Program.all = Gnatmake or else Program.all = Gnatclean then + declare + Project_File_Used : Boolean := False; + Switch : String_Access; + + begin + for J in 1 .. Last_Switches.Last loop + Switch := Last_Switches.Table (J); + if Switch'Length >= 2 and then + Switch (Switch'First .. Switch'First + 1) = "-P" + then + Project_File_Used := True; + exit; + end if; + end loop; + + if Project_File_Used then + if Program.all = Gnatmake + and then Locate_Exec_On_Path (Gprbuild) /= null + then + Program := new String'(Gprbuild); + elsif Program.all = Gnatclean + and then Locate_Exec_On_Path (Gprclean) /= null + then + Program := new String'(Gprclean); + end if; + end if; + end; + end if; end if; -- For the tools where the GNAT driver processes the project files, diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 3b86280..7b87c2d 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1160,7 +1160,7 @@ package body Sem_Ch3 is if Is_Access_Type (Typ) and then Null_Exclusion_In_Return_Present (T_Def) then - Set_Etype (Desig_Type, + Set_Etype (Desig_Type, Create_Null_Excluding_Itype (T => Typ, Related_Nod => T_Def, diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 2a74e6f..9c564dd 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -5633,7 +5633,7 @@ package body Sem_Ch8 is end if; end if; - Check_Nested_Access (N, E); + Check_Nested_Access (E); end if; Set_Entity_Or_Discriminal (N, E); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0c176f0..bebb7db 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -32,7 +32,6 @@ with Elists; use Elists; 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; @@ -1547,9 +1546,9 @@ package body Sem_Util is Insert_Action (N, Decl); - -- If the context is a component declaration the subtype - -- declaration will be analyzed when the enclosing type is - -- frozen, otherwise do it now. + -- If the context is a component declaration the subtype declaration + -- will be analyzed when the enclosing type is frozen, otherwise do + -- it now. if Ekind (Current_Scope) /= E_Record_Type then Analyze (Decl); @@ -2872,18 +2871,16 @@ package body Sem_Util is -- Check_Nested_Access -- ------------------------- - procedure Check_Nested_Access (N : Node_Id; Ent : Entity_Id) is + procedure Check_Nested_Access (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? 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. + -- Currently only enabled for VM back-ends for efficiency - if (VM_Target /= No_VM or else Unnest_Subprogram_Mode) + if VM_Target /= No_VM + and then Ekind_In (Ent, E_Variable, E_Constant, E_Loop_Parameter) and then Scope (Ent) /= Empty and then not Is_Library_Level_Entity (Ent) @@ -2891,25 +2888,6 @@ package body Sem_Util is and then not Is_Imported (Ent) then - -- In both the VM case and in Unnest_Subprogram_Mode, we mark - -- variables, constants, and loop parameters. - - if Ekind_In (Ent, E_Variable, E_Constant, E_Loop_Parameter) then - null; - - -- In Unnest_Subprogram_Mode, we also mark types and formals - - elsif Unnest_Subprogram_Mode - and then (Is_Type (Ent) or else Is_Formal (Ent)) - then - null; - - -- All other cases, do not mark - - else - return; - end if; - -- Get current subprogram that is relevant if Is_Subprogram (Scop) @@ -2926,16 +2904,7 @@ package body Sem_Util is -- Set flag if uplevel reference if Enclosing /= Empty and then Enclosing /= Current_Subp then - 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; + Set_Has_Uplevel_Reference (Ent, True); end if; end if; end Check_Nested_Access; @@ -4949,7 +4918,7 @@ package body Sem_Util is -- Both names are selected_components, their prefixes are known to -- denote the same object, and their selector_names denote the same - -- component (RM 6.4.1(6.6/3)) + -- component (RM 6.4.1(6.6/3)). elsif Nkind (Obj1) = N_Selected_Component then return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) @@ -15223,7 +15192,7 @@ package body Sem_Util is end if; end if; - Check_Nested_Access (N, Ent); + Check_Nested_Access (Ent); end if; Kill_Checks (Ent); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index ca31b29..06239d2 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -308,12 +308,10 @@ package Sem_Util is -- remains in the Examiner (JB01-005). Note that the Examiner does not -- count package declarations in later declarative items. - procedure Check_Nested_Access (N : Node_Id; Ent : Entity_Id); + procedure Check_Nested_Access (Ent : Entity_Id); -- Check whether Ent denotes an entity declared in an uplevel scope, which - -- 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. + -- is accessed inside a nested procedure, and set Has_Uplevel_Reference + -- flag accordingly. This is currently only enabled for if on a VM target. procedure Check_No_Hidden_State (Id : Entity_Id); -- Determine whether object or state Id introduces a hidden state. If this |