Skip to content

R
riscv-gcc-1
Commit 3830827c by Arnaud Charlet
Options

[multiple changes] 

2015-03-02  Robert Dewar  <dewar@adacore.com>

	* atree.ads, atree.adb (Uint24): New function
	(Set_Uint24): New procedure.
	* atree.h (Uint24): New macro for field access.
	* back_end.adb (Call_Back_End): For now, don't call back end
	if unnesting subprogs.
	* einfo.adb (Activation_Record_Component): New field
	(Subps_Index): New field.
	* einfo.ads (Activation_Record_Component): New field
	(Subps_Index): New field Minor reordering of comments into alpha order.
	* exp_unst.ads, exp_unst.adb: Continued development.

2015-03-02  Gary Dismukes  <dismukes@adacore.com>

	* exp_disp.ads: Minor reformatting.

2015-03-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb (Chain_Use_Clause): Do not chain use clause from
	ancestor to list of use clauses active in descendant unit if we
	are within the private part of an intervening parent, to prevent
	circularities in use clause list.

From-SVN: r221114
parent 024d33d8
Showing with 633 additions and 170 deletions
gcc/ada/ChangeLog
2015-03-02 Robert Dewar <dewar@adacore.com>
* atree.ads, atree.adb (Uint24): New function
(Set_Uint24): New procedure.
* atree.h (Uint24): New macro for field access.
* back_end.adb (Call_Back_End): For now, don't call back end
if unnesting subprogs.
* einfo.adb (Activation_Record_Component): New field
(Subps_Index): New field.
* einfo.ads (Activation_Record_Component): New field
(Subps_Index): New field Minor reordering of comments into alpha order.
* exp_unst.ads, exp_unst.adb: Continued development.
2015-03-02 Gary Dismukes <dismukes@adacore.com>
* exp_disp.ads: Minor reformatting.
2015-03-02 Ed Schonberg <schonberg@adacore.com>
* sem_ch8.adb (Chain_Use_Clause): Do not chain use clause from
ancestor to list of use clauses active in descendant unit if we
are within the private part of an intervening parent, to prevent
circularities in use clause list.
2015-03-02 Javier Miranda <miranda@adacore.com> 2015-03-02 Javier Miranda <miranda@adacore.com>
* exp_ch9.adb (Build_Corresponding_Record): Propagate type * exp_ch9.adb (Build_Corresponding_Record): Propagate type
......
gcc/ada/atree.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -3181,6 +3181,17 @@ package body Atree is ...@@ -3181,6 +3181,17 @@ package body Atree is
end if; end if;
end Uint22; end Uint22;
function Uint24 (N : Node_Id) return Uint is
pragma Assert (Nkind (N) in N_Entity);
U : constant Union_Id := Nodes.Table (N + 4).Field6;
begin
if U = 0 then
return Uint_0;
else
return From_Union (U);
end if;
end Uint24;
function Ureal3 (N : Node_Id) return Ureal is function Ureal3 (N : Node_Id) return Ureal is
begin begin
pragma Assert (N <= Nodes.Last); pragma Assert (N <= Nodes.Last);
...@@ -5786,6 +5797,12 @@ package body Atree is ...@@ -5786,6 +5797,12 @@ package body Atree is
Nodes.Table (N + 3).Field9 := To_Union (Val); Nodes.Table (N + 3).Field9 := To_Union (Val);
end Set_Uint22; end Set_Uint22;
procedure Set_Uint24 (N : Node_Id; Val : Uint) is
begin
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field6 := To_Union (Val);
end Set_Uint24;
procedure Set_Ureal3 (N : Node_Id; Val : Ureal) is procedure Set_Ureal3 (N : Node_Id; Val : Ureal) is
begin begin
pragma Assert (N <= Nodes.Last); pragma Assert (N <= Nodes.Last);
......
gcc/ada/atree.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1424,6 +1424,9 @@ package Atree is ...@@ -1424,6 +1424,9 @@ package Atree is
function Uint22 (N : Node_Id) return Uint; function Uint22 (N : Node_Id) return Uint;
pragma Inline (Uint22); pragma Inline (Uint22);
function Uint24 (N : Node_Id) return Uint;
pragma Inline (Uint24);
function Ureal3 (N : Node_Id) return Ureal; function Ureal3 (N : Node_Id) return Ureal;
pragma Inline (Ureal3); pragma Inline (Ureal3);
...@@ -2731,6 +2734,9 @@ package Atree is ...@@ -2731,6 +2734,9 @@ package Atree is
procedure Set_Uint22 (N : Node_Id; Val : Uint); procedure Set_Uint22 (N : Node_Id; Val : Uint);
pragma Inline (Set_Uint22); pragma Inline (Set_Uint22);
procedure Set_Uint24 (N : Node_Id; Val : Uint);
pragma Inline (Set_Uint24);
procedure Set_Ureal3 (N : Node_Id; Val : Ureal); procedure Set_Ureal3 (N : Node_Id; Val : Ureal);
pragma Inline (Set_Ureal3); pragma Inline (Set_Ureal3);
......
gcc/ada/atree.h
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Header File * * C Header File *
* * * *
* Copyright (C) 1992-2013, Free Software Foundation, Inc. * * Copyright (C) 1992-2015, Free Software Foundation, Inc. *
* * * *
* GNAT is free software; you can redistribute it and/or modify it under * * 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- * * terms of the GNU General Public License as published by the Free Soft- *
...@@ -535,6 +535,7 @@ extern Node_Id Current_Error_Node; ...@@ -535,6 +535,7 @@ extern Node_Id Current_Error_Node;
#define Uint16(N) ((Field16 (N) == 0) ? Uint_0 : Field16 (N)) #define Uint16(N) ((Field16 (N) == 0) ? Uint_0 : Field16 (N))
#define Uint17(N) ((Field17 (N) == 0) ? Uint_0 : Field17 (N)) #define Uint17(N) ((Field17 (N) == 0) ? Uint_0 : Field17 (N))
#define Uint22(N) ((Field22 (N) == 0) ? Uint_0 : Field22 (N)) #define Uint22(N) ((Field22 (N) == 0) ? Uint_0 : Field22 (N))
#define Uint24(N) ((Field24 (N) == 0) ? Uint_0 : Field24 (N))
#define Ureal3(N) Field3 (N) #define Ureal3(N) Field3 (N)
#define Ureal18(N) Field18 (N) #define Ureal18(N) Field18 (N)
......
gcc/ada/back_end.adb
...@@ -118,6 +118,12 @@ package body Back_End is ...@@ -118,6 +118,12 @@ package body Back_End is
return; return;
end if; end if;
-- Skip call if unnesting subprograms (temp for now ???)
if Opt.Unnest_Subprogram_Mode then
return;
end if;
-- The back end needs to know the maximum line number that can appear -- The back end needs to know the maximum line number that can appear
-- in a Sloc, in other words the maximum logical line number. -- in a Sloc, in other words the maximum logical line number.
......
gcc/ada/einfo.adb
...@@ -214,6 +214,7 @@ package body Einfo is ...@@ -214,6 +214,7 @@ package body Einfo is
-- Related_Expression Node24 -- Related_Expression Node24
-- Uplevel_References Elist24 -- Uplevel_References Elist24
-- Subps_Index Uint24
-- Interface_Alias Node25 -- Interface_Alias Node25
-- Interfaces Elist25 -- Interfaces Elist25
...@@ -251,6 +252,7 @@ package body Einfo is ...@@ -251,6 +252,7 @@ package body Einfo is
-- Derived_Type_Link Node31 -- Derived_Type_Link Node31
-- Thunk_Entity Node31 -- Thunk_Entity Node31
-- Activation_Record_Component Node31
-- SPARK_Pragma Node32 -- SPARK_Pragma Node32
-- No_Tagged_Streams_Pragma Node32 -- No_Tagged_Streams_Pragma Node32
...@@ -689,6 +691,17 @@ package body Einfo is ...@@ -689,6 +691,17 @@ package body Einfo is
return Elist16 (Implementation_Base_Type (Id)); return Elist16 (Implementation_Base_Type (Id));
end Access_Disp_Table; end Access_Disp_Table;
function Activation_Record_Component (Id : E) return E is
begin
pragma Assert (Ekind_In (Id, E_Constant,
E_In_Parameter,
E_In_Out_Parameter,
E_Loop_Parameter,
E_Out_Parameter,
E_Variable));
return Node31 (Id);
end Activation_Record_Component;
function Actual_Subtype (Id : E) return E is function Actual_Subtype (Id : E) return E is
begin begin
pragma Assert pragma Assert
...@@ -3139,6 +3152,12 @@ package body Einfo is ...@@ -3139,6 +3152,12 @@ package body Einfo is
return Node29 (Id); return Node29 (Id);
end Subprograms_For_Type; end Subprograms_For_Type;
function Subps_Index (Id : E) return U is
begin
pragma Assert (Is_Subprogram (Id));
return Uint24 (Id);
end Subps_Index;
function Suppress_Elaboration_Warnings (Id : E) return B is function Suppress_Elaboration_Warnings (Id : E) return B is
begin begin
return Flag148 (Id); return Flag148 (Id);
...@@ -3533,6 +3552,17 @@ package body Einfo is ...@@ -3533,6 +3552,17 @@ package body Einfo is
Set_Node22 (Id, V); Set_Node22 (Id, V);
end Set_Associated_Storage_Pool; end Set_Associated_Storage_Pool;
procedure Set_Activation_Record_Component (Id : E; V : E) is
begin
pragma Assert (Ekind_In (Id, E_Constant,
E_In_Parameter,
E_In_Out_Parameter,
E_Loop_Parameter,
E_Out_Parameter,
E_Variable));
Set_Node31 (Id, V);
end Set_Activation_Record_Component;
procedure Set_Actual_Subtype (Id : E; V : E) is procedure Set_Actual_Subtype (Id : E; V : E) is
begin begin
pragma Assert pragma Assert
...@@ -6091,6 +6121,12 @@ package body Einfo is ...@@ -6091,6 +6121,12 @@ package body Einfo is
Set_Node29 (Id, V); Set_Node29 (Id, V);
end Set_Subprograms_For_Type; end Set_Subprograms_For_Type;
procedure Set_Subps_Index (Id : E; V : U) is
begin
pragma Assert (Is_Subprogram (Id));
Set_Uint24 (Id, V);
end Set_Subps_Index;
procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True) is procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True) is
begin begin
Set_Flag148 (Id, V); Set_Flag148 (Id, V);
...@@ -9689,7 +9725,11 @@ package body Einfo is ...@@ -9689,7 +9725,11 @@ package body Einfo is
when E_Function | when E_Function |
E_Operator | E_Operator |
E_Procedure => E_Procedure =>
Write_Str ("Uplevel_References"); if Field24 (Id) in Uint_Range then
Write_Str ("Subps_Index");
else
Write_Str ("Uplevel_References");
end if;
when others => when others =>
Write_Str ("Field24???"); Write_Str ("Field24???");
...@@ -9899,6 +9939,14 @@ package body Einfo is ...@@ -9899,6 +9939,14 @@ package body Einfo is
when Type_Kind => when Type_Kind =>
Write_Str ("Derived_Type_Link"); Write_Str ("Derived_Type_Link");
when E_Constant |
E_In_Parameter |
E_In_Out_Parameter |
E_Loop_Parameter |
E_Out_Parameter |
E_Variable =>
Write_Str ("Activation_Record_Component");
when others => when others =>
Write_Str ("Field31??"); Write_Str ("Field31??");
end case; end case;
......
gcc/ada/einfo.ads
...@@ -353,6 +353,13 @@ package Einfo is ...@@ -353,6 +353,13 @@ package Einfo is
-- used to expand dispatching calls through the primary dispatch table. -- used to expand dispatching calls through the primary dispatch table.
-- For an untagged record, contains No_Elist. -- For an untagged record, contains No_Elist.
-- Activation_Record_Component (Node31)
-- Defined in E_Variable, E_Constant, E_Loop_Parameter, E_In_Parameter,
-- E_Out_Parameter, E_In_Out_Parameter nodes. Used only if we are in
-- Opt.Unnest_Subprogram_Mode, in which case for the case of an uplevel
-- referenced entity, this field contains the entity for the component
-- in the generated ARECnT activation record (Exp_Unst for details).
-- Actual_Subtype (Node17) -- Actual_Subtype (Node17)
-- Defined in variables, constants, and formal parameters. This is the -- Defined in variables, constants, and formal parameters. This is the
-- subtype imposed by the value of the object, as opposed to its nominal -- subtype imposed by the value of the object, as opposed to its nominal
...@@ -1163,24 +1170,6 @@ package Einfo is ...@@ -1163,24 +1170,6 @@ package Einfo is
-- Note one obscure case: for pragma Default_Storage_Pool (null), the -- Note one obscure case: for pragma Default_Storage_Pool (null), the
-- Etype of the N_Null node is Empty. -- Etype of the N_Null node is Empty.
-- Extra_Formal (Node15)
-- Defined in formal parameters in the non-generic case. Certain
-- parameters require extra implicit information to be passed (e.g. the
-- flag indicating if an unconstrained variant record argument is
-- constrained, and the accessibility level for access parameters. See
-- description of Extra_Constrained, Extra_Accessibility fields for
-- further details. Extra formal parameters are constructed to represent
-- these values, and chained to the end of the list of formals using the
-- Extra_Formal field (i.e. the Extra_Formal field of the last "real"
-- formal points to the first extra formal, and the Extra_Formal field of
-- each extra formal points to the next one, with Empty indicating the
-- end of the list of extra formals.
-- Extra_Formals (Node28)
-- Applies to subprograms and subprogram types, and also in entries
-- and entry families. Returns first extra formal of the subprogram
-- or entry. Returns Empty if there are no extra formals.
-- Extra_Accessibility (Node13) -- Extra_Accessibility (Node13)
-- Defined in formal parameters in the non-generic case. Normally Empty, -- Defined in formal parameters in the non-generic case. Normally Empty,
-- but if expansion is active, and a parameter is one for which a -- but if expansion is active, and a parameter is one for which a
...@@ -1214,6 +1203,24 @@ package Einfo is ...@@ -1214,6 +1203,24 @@ package Einfo is
-- must be retrieved through the entity designed by this field instead of -- must be retrieved through the entity designed by this field instead of
-- being computed. -- being computed.
-- Extra_Formal (Node15)
-- Defined in formal parameters in the non-generic case. Certain
-- parameters require extra implicit information to be passed (e.g. the
-- flag indicating if an unconstrained variant record argument is
-- constrained, and the accessibility level for access parameters). See
-- description of Extra_Constrained, Extra_Accessibility fields for
-- further details. Extra formal parameters are constructed to represent
-- these values, and chained to the end of the list of formals using the
-- Extra_Formal field (i.e. the Extra_Formal field of the last "real"
-- formal points to the first extra formal, and the Extra_Formal field of
-- each extra formal points to the next one, with Empty indicating the
-- end of the list of extra formals).
-- Extra_Formals (Node28)
-- Applies to subprograms and subprogram types, and also in entries
-- and entry families. Returns first extra formal of the subprogram
-- or entry. Returns Empty if there are no extra formals.
-- Finalization_Master (Node23) [root type only] -- Finalization_Master (Node23) [root type only]
-- Defined in access-to-controlled or access-to-class-wide types. The -- Defined in access-to-controlled or access-to-class-wide types. The
-- field contains the entity of the finalization master which handles -- field contains the entity of the finalization master which handles
...@@ -1261,7 +1268,7 @@ package Einfo is ...@@ -1261,7 +1268,7 @@ package Einfo is
-- N_Exit_Statement node with Empty marking the end of the list. -- N_Exit_Statement node with Empty marking the end of the list.
-- First_Formal (synthesized) -- First_Formal (synthesized)
-- Applies to subprograms and subprogram types, and also in entries -- Applies to subprograms and subprogram types, and also to entries
-- and entry families. Returns first formal of the subprogram or entry. -- and entry families. Returns first formal of the subprogram or entry.
-- The formals are the first entities declared in a subprogram or in -- The formals are the first entities declared in a subprogram or in
-- a subprogram type (the designated type of an Access_To_Subprogram -- a subprogram type (the designated type of an Access_To_Subprogram
...@@ -4121,6 +4128,12 @@ package Einfo is ...@@ -4121,6 +4128,12 @@ package Einfo is
-- for Predicate_Function, and clients will always use the latter two -- for Predicate_Function, and clients will always use the latter two
-- names to access entries in this list. -- names to access entries in this list.
-- 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) -- Suppress_Elaboration_Warnings (Flag148)
-- Defined in all entities, can be set only for subprogram entities and -- Defined in all entities, can be set only for subprogram entities and
-- for variables. If this flag is set then Sem_Elab will not generate -- for variables. If this flag is set then Sem_Elab will not generate
...@@ -4263,7 +4276,9 @@ package Einfo is ...@@ -4263,7 +4276,9 @@ package Einfo is
-- Defined in subprogram entities. Set only if Has_Uplevel_Reference is -- Defined in subprogram entities. Set only if Has_Uplevel_Reference is
-- set and if we are Unnest_Subprogram_Mode, otherwise undefined. Points -- set and if we are Unnest_Subprogram_Mode, otherwise undefined. Points
-- to a list of explicit uplevel references to entities declared in -- to a list of explicit uplevel references to entities declared in
-- the subprogram which need rewriting. See spec of Exp_Unst for details. -- 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) -- Used_As_Generic_Actual (Flag222)
-- Defined in all entities, set if the entity is used as an argument to -- Defined in all entities, set if the entity is used as an argument to
...@@ -5578,6 +5593,7 @@ package Einfo is ...@@ -5578,6 +5593,7 @@ package Einfo is
-- Initialization_Statements (Node28) -- Initialization_Statements (Node28)
-- BIP_Initialization_Call (Node29) -- BIP_Initialization_Call (Node29)
-- Last_Aggregate_Assignment (Node30) -- Last_Aggregate_Assignment (Node30)
-- Activation_Record_Component (Node31)
-- Linker_Section_Pragma (Node33) -- Linker_Section_Pragma (Node33)
-- Has_Alignment_Clause (Flag46) -- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86) -- Has_Atomic_Components (Flag86)
...@@ -5755,6 +5771,7 @@ package Einfo is ...@@ -5755,6 +5771,7 @@ package Einfo is
-- Inner_Instances (Elist23) (generic case only) -- Inner_Instances (Elist23) (generic case only)
-- Protection_Object (Node23) (for concurrent kind) -- Protection_Object (Node23) (for concurrent kind)
-- Uplevel_References (Elist24) (non-generic case only) -- Uplevel_References (Elist24) (non-generic case only)
-- Subps_Index (Uint24) (non-generic case only)
-- Interface_Alias (Node25) -- Interface_Alias (Node25)
-- Overridden_Operation (Node26) -- Overridden_Operation (Node26)
-- Wrapped_Entity (Node27) (non-generic case only) -- Wrapped_Entity (Node27) (non-generic case only)
...@@ -5868,6 +5885,7 @@ package Einfo is ...@@ -5868,6 +5885,7 @@ package Einfo is
-- Protected_Formal (Node22) -- Protected_Formal (Node22)
-- Extra_Constrained (Node23) -- Extra_Constrained (Node23)
-- Last_Assignment (Node26) (OUT, IN-OUT only) -- Last_Assignment (Node26) (OUT, IN-OUT only)
-- Activation_Record_Component (Node31)
-- Has_Initial_Value (Flag219) -- Has_Initial_Value (Flag219)
-- Is_Controlling_Formal (Flag97) -- Is_Controlling_Formal (Flag97)
-- Is_Only_Out_Parameter (Flag226) -- Is_Only_Out_Parameter (Flag226)
...@@ -5926,6 +5944,7 @@ package Einfo is ...@@ -5926,6 +5944,7 @@ package Einfo is
-- Last_Entity (Node20) -- Last_Entity (Node20)
-- Has_Nested_Subprogram (Flag282) -- Has_Nested_Subprogram (Flag282)
-- Uplevel_References (Elist24) -- Uplevel_References (Elist24)
-- Subps_Index (Uint24)
-- Overridden_Operation (Node26) -- Overridden_Operation (Node26)
-- Subprograms_For_Type (Node29) -- Subprograms_For_Type (Node29)
-- Linker_Section_Pragma (Node33) -- Linker_Section_Pragma (Node33)
...@@ -6058,6 +6077,7 @@ package Einfo is ...@@ -6058,6 +6077,7 @@ package Einfo is
-- Inner_Instances (Elist23) (generic case only) -- Inner_Instances (Elist23) (generic case only)
-- Protection_Object (Node23) (for concurrent kind) -- Protection_Object (Node23) (for concurrent kind)
-- Uplevel_References (Elist24) (non-generic case only) -- Uplevel_References (Elist24) (non-generic case only)
-- Subps_Index (Uint24) (non-generic case only)
-- Interface_Alias (Node25) -- Interface_Alias (Node25)
-- Overridden_Operation (Node26) (never for init proc) -- Overridden_Operation (Node26) (never for init proc)
-- Wrapped_Entity (Node27) (non-generic case only) -- Wrapped_Entity (Node27) (non-generic case only)
...@@ -6303,6 +6323,7 @@ package Einfo is ...@@ -6303,6 +6323,7 @@ package Einfo is
-- Initialization_Statements (Node28) -- Initialization_Statements (Node28)
-- BIP_Initialization_Call (Node29) -- BIP_Initialization_Call (Node29)
-- Last_Aggregate_Assignment (Node30) -- Last_Aggregate_Assignment (Node30)
-- Activation_Record_Component (Node31)
-- Linker_Section_Pragma (Node33) -- Linker_Section_Pragma (Node33)
-- Contract (Node34) -- Contract (Node34)
-- Has_Alignment_Clause (Flag46) -- Has_Alignment_Clause (Flag46)
...@@ -6568,6 +6589,7 @@ package Einfo is ...@@ -6568,6 +6589,7 @@ package Einfo is
function Abstract_States (Id : E) return L; function Abstract_States (Id : E) return L;
function Accept_Address (Id : E) return L; function Accept_Address (Id : E) return L;
function Access_Disp_Table (Id : E) return L; function Access_Disp_Table (Id : E) return L;
function Activation_Record_Component (Id : E) return E;
function Actual_Subtype (Id : E) return E; function Actual_Subtype (Id : E) return E;
function Address_Taken (Id : E) return B; function Address_Taken (Id : E) return B;
function Alias (Id : E) return E; function Alias (Id : E) return E;
...@@ -6987,6 +7009,7 @@ package Einfo is ...@@ -6987,6 +7009,7 @@ package Einfo is
function String_Literal_Length (Id : E) return U; function String_Literal_Length (Id : E) return U;
function String_Literal_Low_Bound (Id : E) return N; function String_Literal_Low_Bound (Id : E) return N;
function Subprograms_For_Type (Id : E) return E; function Subprograms_For_Type (Id : E) return E;
function Subps_Index (Id : E) return U;
function Suppress_Elaboration_Warnings (Id : E) return B; function Suppress_Elaboration_Warnings (Id : E) return B;
function Suppress_Initialization (Id : E) return B; function Suppress_Initialization (Id : E) return B;
function Suppress_Style_Checks (Id : E) return B; function Suppress_Style_Checks (Id : E) return B;
...@@ -7216,6 +7239,7 @@ package Einfo is ...@@ -7216,6 +7239,7 @@ package Einfo is
procedure Set_Abstract_States (Id : E; V : L); procedure Set_Abstract_States (Id : E; V : L);
procedure Set_Accept_Address (Id : E; V : L); procedure Set_Accept_Address (Id : E; V : L);
procedure Set_Access_Disp_Table (Id : E; V : L); procedure Set_Access_Disp_Table (Id : E; V : L);
procedure Set_Activation_Record_Component (Id : E; V : E);
procedure Set_Actual_Subtype (Id : E; V : E); procedure Set_Actual_Subtype (Id : E; V : E);
procedure Set_Address_Taken (Id : E; V : B := True); procedure Set_Address_Taken (Id : E; V : B := True);
procedure Set_Alias (Id : E; V : E); procedure Set_Alias (Id : E; V : E);
...@@ -7639,6 +7663,7 @@ package Einfo is ...@@ -7639,6 +7663,7 @@ package Einfo is
procedure Set_String_Literal_Length (Id : E; V : U); procedure Set_String_Literal_Length (Id : E; V : U);
procedure Set_String_Literal_Low_Bound (Id : E; V : N); procedure Set_String_Literal_Low_Bound (Id : E; V : N);
procedure Set_Subprograms_For_Type (Id : E; V : E); procedure Set_Subprograms_For_Type (Id : E; V : E);
procedure Set_Subps_Index (Id : E; V : U);
procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True); procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True);
procedure Set_Suppress_Initialization (Id : E; V : B := True); procedure Set_Suppress_Initialization (Id : E; V : B := True);
procedure Set_Suppress_Style_Checks (Id : E; V : B := True); procedure Set_Suppress_Style_Checks (Id : E; V : B := True);
...@@ -7980,6 +8005,7 @@ package Einfo is ...@@ -7980,6 +8005,7 @@ package Einfo is
pragma Inline (Abstract_States); pragma Inline (Abstract_States);
pragma Inline (Accept_Address); pragma Inline (Accept_Address);
pragma Inline (Access_Disp_Table); pragma Inline (Access_Disp_Table);
pragma Inline (Activation_Record_Component);
pragma Inline (Actual_Subtype); pragma Inline (Actual_Subtype);
pragma Inline (Address_Taken); pragma Inline (Address_Taken);
pragma Inline (Alias); pragma Inline (Alias);
...@@ -8443,6 +8469,7 @@ package Einfo is ...@@ -8443,6 +8469,7 @@ package Einfo is
pragma Inline (String_Literal_Length); pragma Inline (String_Literal_Length);
pragma Inline (String_Literal_Low_Bound); pragma Inline (String_Literal_Low_Bound);
pragma Inline (Subprograms_For_Type); pragma Inline (Subprograms_For_Type);
pragma Inline (Subps_Index);
pragma Inline (Suppress_Elaboration_Warnings); pragma Inline (Suppress_Elaboration_Warnings);
pragma Inline (Suppress_Initialization); pragma Inline (Suppress_Initialization);
pragma Inline (Suppress_Style_Checks); pragma Inline (Suppress_Style_Checks);
...@@ -8476,6 +8503,7 @@ package Einfo is ...@@ -8476,6 +8503,7 @@ package Einfo is
pragma Inline (Set_Abstract_States); pragma Inline (Set_Abstract_States);
pragma Inline (Set_Accept_Address); pragma Inline (Set_Accept_Address);
pragma Inline (Set_Access_Disp_Table); pragma Inline (Set_Access_Disp_Table);
pragma Inline (Set_Activation_Record_Component);
pragma Inline (Set_Actual_Subtype); pragma Inline (Set_Actual_Subtype);
pragma Inline (Set_Address_Taken); pragma Inline (Set_Address_Taken);
pragma Inline (Set_Alias); pragma Inline (Set_Alias);
...@@ -8894,6 +8922,7 @@ package Einfo is ...@@ -8894,6 +8922,7 @@ package Einfo is
pragma Inline (Set_String_Literal_Length); pragma Inline (Set_String_Literal_Length);
pragma Inline (Set_String_Literal_Low_Bound); pragma Inline (Set_String_Literal_Low_Bound);
pragma Inline (Set_Subprograms_For_Type); pragma Inline (Set_Subprograms_For_Type);
pragma Inline (Set_Subps_Index);
pragma Inline (Set_Suppress_Elaboration_Warnings); pragma Inline (Set_Suppress_Elaboration_Warnings);
pragma Inline (Set_Suppress_Initialization); pragma Inline (Set_Suppress_Initialization);
pragma Inline (Set_Suppress_Style_Checks); pragma Inline (Set_Suppress_Style_Checks);
......
gcc/ada/exp_disp.ads
...@@ -386,7 +386,7 @@ package Exp_Disp is ...@@ -386,7 +386,7 @@ package Exp_Disp is
procedure Set_DTC_Entity_Value (Tagged_Type : Entity_Id; Prim : Entity_Id); procedure Set_DTC_Entity_Value (Tagged_Type : Entity_Id; Prim : Entity_Id);
-- Set the definite value of the DTC_Entity value associated with a given -- Set the definite value of the DTC_Entity value associated with a given
-- primitive of a tagged type. For subprogram wrappers propagat the value -- primitive of a tagged type. For subprogram wrappers, propagate the value
-- to the wrapped subprogram. -- to the wrapped subprogram.
procedure Write_DT (Typ : Entity_Id); procedure Write_DT (Typ : Entity_Id);
......
gcc/ada/exp_unst.adb
...@@ -26,6 +26,7 @@ ...@@ -26,6 +26,7 @@
with Atree; use Atree; with Atree; use Atree;
with Einfo; use Einfo; with Einfo; use Einfo;
with Elists; use Elists; with Elists; use Elists;
with Exp_Util; use Exp_Util;
with Namet; use Namet; with Namet; use Namet;
with Nlists; use Nlists; with Nlists; use Nlists;
with Nmake; use Nmake; with Nmake; use Nmake;
...@@ -36,9 +37,84 @@ with Sinfo; use Sinfo; ...@@ -36,9 +37,84 @@ with Sinfo; use Sinfo;
with Snames; use Snames; with Snames; use Snames;
with Table; with Table;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
with Uintp; use Uintp;
package body Exp_Unst is package body Exp_Unst is
-- Tables used by Unnest_Subprogram
type Subp_Entry is record
Ent : Entity_Id;
-- Entity of the subprogram
Bod : Node_Id;
-- Subprogram_Body node for this subprogram
Lev : Nat;
-- Subprogram level (1 = outer subprogram (Subp argument), 2 = nested
-- immediately within this outer subprogram etc.)
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.
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.
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.
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.
end record;
subtype SI_Type is Nat;
package Subps is new Table.Table (
Table_Component_Type => Subp_Entry,
Table_Index_Type => SI_Type,
Table_Low_Bound => 1,
Table_Initial => 100,
Table_Increment => 200,
Table_Name => "Subps");
-- Records the subprograms in the nest whose outer subprogram is Subp
type Call_Entry is record
N : Node_Id;
-- The actual call
From : Entity_Id;
-- Entity of the subprogram containing the call
To : Entity_Id;
-- Entity of the subprogram called
end record;
package Calls is new Table.Table (
Table_Component_Type => Call_Entry,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 100,
Table_Increment => 200,
Table_Name => "Calls");
-- Records each call within the outer subprogram and all nested subprograms
-- that are to other subprograms nested within the outer subprogram. These
-- are the calls that may need an additional parameter.
------------------------------------- -------------------------------------
-- Check_Uplevel_Reference_To_Type -- -- Check_Uplevel_Reference_To_Type --
------------------------------------- -------------------------------------
...@@ -194,9 +270,20 @@ package body Exp_Unst is ...@@ -194,9 +270,20 @@ package body Exp_Unst is
Set_Uplevel_References (Subp, New_Elmt_List); Set_Uplevel_References (Subp, New_Elmt_List);
end if; end if;
-- Add new element to Uplevel_References -- 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
Append_Elmt
(N, Uplevel_References (Subp));
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;
Append_Elmt (N, Uplevel_References (Subp));
Set_Has_Uplevel_Reference (Entity (N)); Set_Has_Uplevel_Reference (Entity (N));
end Note_Uplevel_Reference; end Note_Uplevel_Reference;
...@@ -204,61 +291,23 @@ package body Exp_Unst is ...@@ -204,61 +291,23 @@ package body Exp_Unst is
-- Unnest_Subprogram -- -- Unnest_Subprogram --
----------------------- -----------------------
-- Tables used by Unnest_Subprogram
type Subp_Entry is record
Ent : Entity_Id;
-- Entity of the subprogram
Bod : Node_Id;
-- Subprogram_Body node for this subprogram
Lev : Nat;
-- Subprogram level (1 = outer subprogram (Subp argument), 2 = nested
-- immediately within this outer subprogram etc.)
end record;
package Subps is new Table.Table (
Table_Component_Type => Subp_Entry,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 100,
Table_Increment => 200,
Table_Name => "Subps");
-- Records the subprograms in the nest whose outer subprogram is Subp
type Call_Entry is record
N : Node_Id;
-- The actual call
From : Entity_Id;
-- Entity of the subprogram containing the call
To : Entity_Id;
-- Entity of the subprogram called
end record;
package Calls is new Table.Table (
Table_Component_Type => Call_Entry,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 100,
Table_Increment => 200,
Table_Name => "Calls");
-- Records each call within the outer subprogram and all nested subprograms
-- that are to other subprograms nested within the outer subprogram. These
-- are the calls that may need an additional parameter.
procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is
function Get_AREC_String (Lev : Pos) return String; function Get_AREC_String (Lev : Pos) return String;
-- Given a level value, 1, 2, ... returns the string AREC, AREC2, ... -- Given a level value, 1, 2, ... returns the string AREC, AREC2, ...
function Get_Enclosing_Subp (Subp : SI_Type) return SI_Type;
-- Subp is the index of a subprogram which has a Lev greater than 1.
-- This function returns the index of the enclosing subprogram which
-- will have a Lev value one less than this.
function Get_Level (Sub : Entity_Id) return Nat; function Get_Level (Sub : Entity_Id) return Nat;
-- Sub is either Subp itself, or a subprogram nested within Subp. This -- Sub is either Subp itself, or a subprogram nested within Subp. This
-- function returns the level of nesting (Subp = 1, subprograms that -- function returns the level of nesting (Subp = 1, subprograms that
-- are immediately nested within Subp = 2, etc). -- are immediately nested within Subp = 2, etc).
function Subp_Index (Sub : Entity_Id) return SI_Type;
-- Given the entity for a subprogram, return corresponding Subps index
--------------------- ---------------------
-- Get_AREC_String -- -- Get_AREC_String --
--------------------- ---------------------
...@@ -274,6 +323,20 @@ package body Exp_Unst is ...@@ -274,6 +323,20 @@ package body Exp_Unst is
end if; end if;
end Get_AREC_String; end Get_AREC_String;
------------------------
-- Get_Enclosing_Subp --
------------------------
function Get_Enclosing_Subp (Subp : SI_Type) return SI_Type is
STJ : Subp_Entry renames Subps.Table (Subp);
Ret : constant SI_Type :=
UI_To_Int (Subps_Index (Enclosing_Subprogram (STJ.Ent)));
begin
pragma Assert (STJ.Lev > 1);
pragma Assert (Subps.Table (Ret).Lev = STJ.Lev - 1);
return Ret;
end Get_Enclosing_Subp;
--------------- ---------------
-- Get_Level -- -- Get_Level --
--------------- ---------------
...@@ -294,6 +357,16 @@ package body Exp_Unst is ...@@ -294,6 +357,16 @@ package body Exp_Unst is
end loop; end loop;
end Get_Level; end Get_Level;
----------------
-- Subp_Index --
----------------
function Subp_Index (Sub : Entity_Id) return SI_Type is
begin
pragma Assert (Is_Subprogram (Sub));
return SI_Type (UI_To_Int (Subps_Index (Sub)));
end Subp_Index;
-- Start of processing for Unnest_Subprogram -- Start of processing for Unnest_Subprogram
begin begin
...@@ -309,7 +382,7 @@ package body Exp_Unst is ...@@ -309,7 +382,7 @@ package body Exp_Unst is
-- subprogram has a call to a subprogram requiring a static link, then -- subprogram has a call to a subprogram requiring a static link, then
-- the calling subprogram requires a static link. -- the calling subprogram requires a static link.
-- First step, populate the above tables -- First populate the above tables
Subps.Init; Subps.Init;
Calls.Init; Calls.Init;
...@@ -353,6 +426,8 @@ package body Exp_Unst is ...@@ -353,6 +426,8 @@ package body Exp_Unst is
-- Start of processing for Visit_Node -- Start of processing for Visit_Node
begin begin
-- Record a call
if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then
Ent := Entity (Name (N)); Ent := Entity (Name (N));
...@@ -360,19 +435,34 @@ package body Exp_Unst is ...@@ -360,19 +435,34 @@ package body Exp_Unst is
Calls.Append ((N, Find_Current_Subprogram, Ent)); Calls.Append ((N, Find_Current_Subprogram, Ent));
end if; end if;
elsif Nkind (N) = N_Subprogram_Body and then Acts_As_Spec (N) then -- Record a subprogram
Ent := Defining_Unit_Name (Specification (N));
Subps.Append elsif (Nkind (N) = N_Subprogram_Body and then Acts_As_Spec (N))
((Ent => Ent, or else Nkind (N) = N_Subprogram_Declaration
Bod => N, then
Lev => Get_Level (Ent))); Subps.Increment_Last;
elsif Nkind (N) = N_Subprogram_Declaration then declare
Ent := Defining_Unit_Name (Specification (N)); STJ : Subp_Entry renames Subps.Table (Subps.Last);
Subps.Append
((Ent => Ent, begin
Bod => Corresponding_Body (N), -- Set fields of Subp_Entry for new subprogram
Lev => Get_Level (Ent)));
STJ.Ent := Defining_Unit_Name (Specification (N));
STJ.Lev := Get_Level (STJ.Ent);
if Nkind (N) = N_Subprogram_Body then
STJ.Bod := N;
else
STJ.Bod := Corresponding_Body (N);
end if;
-- Capture Uplevel_References, and then set (uses the same
-- field), the Subps_Index value for this subprogram.
STJ.Urefs := Uplevel_References (STJ.Ent);
Set_Subps_Index (STJ.Ent, UI_From_Int (Int (Subps.Last)));
end;
end if; end if;
return OK; return OK;
...@@ -423,11 +513,71 @@ package body Exp_Unst is ...@@ -423,11 +513,71 @@ package body Exp_Unst is
end loop Outer; end loop Outer;
end Closure; end Closure;
-- Next step, process each subprogram in turn, inserting necessary -- Next step, create the entities for code we will insert. We do this
-- declarations for ARECxx types and variables for any subprogram -- at the start so that all the entities are defined, regardless of the
-- that has nested subprograms, and is uplevel referenced. -- order in which we do the code insertions.
for J in Subps.First .. Subps.Last loop
declare
STJ : Subp_Entry renames Subps.Table (J);
Loc : constant Source_Ptr := Sloc (STJ.Bod);
ARS : constant String := Get_AREC_String (STJ.Lev);
Arec_Decls : declare begin
if STJ.Ent = Subp then
STJ.ARECnF := Empty;
else
STJ.ARECnF :=
Make_Defining_Identifier (Loc,
Chars =>
Name_Find_Str (Get_AREC_String (STJ.Lev - 1) & "F"));
end if;
if Has_Nested_Subprogram (STJ.Ent)
and then Has_Uplevel_Reference (STJ.Ent)
then
STJ.ARECn :=
Make_Defining_Identifier (Loc, Name_Find_Str (ARS));
STJ.ARECnT :=
Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "T"));
STJ.ARECnPT :=
Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "PT"));
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 and also
-- the extra formal entity.
if Has_Uplevel_Reference (STJ.Ent) and then STJ.Lev > 1 then
declare
ARS1 : constant String := Get_AREC_String (STJ.Lev - 1);
begin
STJ.ARECnU :=
Make_Defining_Identifier (Loc,
Chars => Name_Find_Str (ARS1 & "U"));
STJ.ARECnF :=
Make_Defining_Identifier (Loc,
Chars => Name_Find_Str (ARS1 & "F"));
end;
else
STJ.ARECnU := Empty;
STJ.ARECnF := Empty;
end if;
end;
end loop;
-- Loop through subprograms
Subp_Loop : declare
Addr : constant Entity_Id := RTE (RE_Address); Addr : constant Entity_Id := RTE (RE_Address);
begin begin
...@@ -436,23 +586,30 @@ package body Exp_Unst is ...@@ -436,23 +586,30 @@ package body Exp_Unst is
STJ : Subp_Entry renames Subps.Table (J); STJ : Subp_Entry renames Subps.Table (J);
begin begin
-- We add AREC declarations for any subprogram that has at -- First add the extra formal if needed. This applies to all
-- least one nested subprogram, and has uplevel references. -- nested subprograms that have uplevel references.
if STJ.Lev > 1 and then Has_Uplevel_Reference (STJ.Ent) then
null; -- TBD???
end if;
-- Processing for subprograms that have at least one nested
-- subprogram, and have uplevel references.
if Has_Nested_Subprogram (STJ.Ent) if Has_Nested_Subprogram (STJ.Ent)
and then Has_Uplevel_Reference (STJ.Ent) and then Has_Uplevel_Reference (STJ.Ent)
then then
Add_AREC_Declarations : declare -- Local declarations for one such subprogram
declare
Loc : constant Source_Ptr := Sloc (STJ.Bod); Loc : constant Source_Ptr := Sloc (STJ.Bod);
ARS : constant String := Get_AREC_String (STJ.Lev);
Urefs : constant Elist_Id :=
Uplevel_References (STJ.Ent);
Elmt : Elmt_Id; Elmt : Elmt_Id;
Ent : Entity_Id; Ent : Entity_Id;
Clist : List_Id; Clist : List_Id;
Comp : Entity_Id;
Uplevel_Entities : Uplevel_Entities :
array (1 .. List_Length (Urefs)) of Entity_Id; array (1 .. List_Length (STJ.Urefs)) of Entity_Id;
Num_Uplevel_Entities : Nat; Num_Uplevel_Entities : Nat;
-- Uplevel_Entities (1 .. Num_Uplevel_Entities) contains -- Uplevel_Entities (1 .. Num_Uplevel_Entities) contains
-- a list (with no duplicates) of the entities for this -- a list (with no duplicates) of the entities for this
...@@ -465,7 +622,7 @@ package body Exp_Unst is ...@@ -465,7 +622,7 @@ package body Exp_Unst is
-- Uplevel_Reference_Noted to avoid duplicates. -- Uplevel_Reference_Noted to avoid duplicates.
Num_Uplevel_Entities := 0; Num_Uplevel_Entities := 0;
Elmt := First_Elmt (Urefs); Elmt := First_Elmt (STJ.Urefs);
while Present (Elmt) loop while Present (Elmt) loop
Ent := Entity (Node (Elmt)); Ent := Entity (Node (Elmt));
...@@ -476,38 +633,48 @@ package body Exp_Unst is ...@@ -476,38 +633,48 @@ package body Exp_Unst is
end if; end if;
Next_Elmt (Elmt); Next_Elmt (Elmt);
Next_Elmt (Elmt);
end loop; end loop;
-- Build list of component declarations for ARECnT -- Build list of component declarations for ARECnT
Clist := Empty_List; Clist := Empty_List;
-- If not top level, include ARECn : ARECnPT := ARECnP -- If not top level, include ARECnU : ARECnPT := ARECnF
-- where n is one less than the current level and the
-- entity ARECnPT comes from the enclosing subprogram.
if STJ.Lev > 1 then if STJ.Lev > 1 then
Append_To (Clist, declare
Make_Component_Declaration (Loc, STJE : Subp_Entry
Defining_Identifier => renames Subps.Table (Get_Enclosing_Subp (J));
Make_Defining_Identifier (Loc,
Chars => Name_Find_Str (ARS)), begin
Component_Definition => Append_To (Clist,
Make_Component_Definition (Loc, Make_Component_Declaration (Loc,
Subtype_Indication => Defining_Identifier => STJ.ARECnU,
Make_Identifier (Loc, Component_Definition =>
Chars => Name_Find_Str (ARS & "PT"))), Make_Component_Definition (Loc,
Expression => Subtype_Indication =>
Make_Identifier (Loc, New_Occurrence_Of (STJE.ARECnPT, Loc)),
Chars => Name_Find_Str (ARS & "P")))); Expression =>
New_Occurrence_Of (STJ.ARECnF, Loc)));
end;
end if; end if;
-- Add components for uplevel referenced entities -- Add components for uplevel referenced entities
for J in 1 .. Num_Uplevel_Entities loop for J in 1 .. Num_Uplevel_Entities loop
Comp :=
Make_Defining_Identifier (Loc,
Chars => Chars (Uplevel_Entities (J)));
Set_Activation_Record_Component
(Uplevel_Entities (J), Comp);
Append_To (Clist, Append_To (Clist,
Make_Component_Declaration (Loc, Make_Component_Declaration (Loc,
Defining_Identifier => Defining_Identifier => Comp,
Make_Defining_Identifier (Loc,
Chars => Chars (Uplevel_Entities (J))),
Component_Definition => Component_Definition =>
Make_Component_Definition (Loc, Make_Component_Definition (Loc,
Subtype_Indication => Subtype_Indication =>
...@@ -519,54 +686,210 @@ package body Exp_Unst is ...@@ -519,54 +686,210 @@ package body Exp_Unst is
Prepend_List_To (Declarations (STJ.Bod), Prepend_List_To (Declarations (STJ.Bod),
New_List ( New_List (
-- type ARECT is record .. end record; -- type ARECnT is record .. end record;
Make_Full_Type_Declaration (Loc, Make_Full_Type_Declaration (Loc,
Defining_Identifier => Defining_Identifier => STJ.ARECnT,
Make_Defining_Identifier (Loc,
Chars => Name_Find_Str (ARS & "T")),
Type_Definition => Type_Definition =>
Make_Record_Definition (Loc, Make_Record_Definition (Loc,
Component_List => Component_List =>
Make_Component_List (Loc, Make_Component_List (Loc,
Component_Items => Clist))), Component_Items => Clist))),
-- type ARECPT is access all ARECT; -- ARECn : aliased ARECnT;
Make_Object_Declaration (Loc,
Defining_Identifier => STJ.ARECn,
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (STJ.ARECnT, Loc)),
-- type ARECnPT is access all ARECnT;
Make_Full_Type_Declaration (Loc, Make_Full_Type_Declaration (Loc,
Defining_Identifier => Defining_Identifier => STJ.ARECnPT,
Make_Defining_Identifier (Loc, Type_Definition =>
Chars => Name_Find_Str (ARS & "PT")), Make_Access_To_Object_Definition (Loc,
Type_Definition => All_Present => True,
Make_Access_To_Object_Definition (Loc, Subtype_Indication =>
All_Present => True, New_Occurrence_Of (STJ.ARECnT, Loc))),
Subtype_Indication =>
Make_Identifier (Loc, -- ARECnP : constant ARECnPT := ARECn'Access;
Chars => Name_Find_Str (ARS & "T")))),
-- ARECP : constant ARECPT := AREC'Access;
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Defining_Identifier => STJ.ARECnP,
Make_Defining_Identifier (Loc,
Chars => Name_Find_Str (ARS & "P")),
Constant_Present => True, Constant_Present => True,
Object_Definition => Object_Definition =>
Make_Identifier (Loc, Name_Find_Str (ARS & "PT")), New_Occurrence_Of (STJ.ARECnPT, Loc),
Expression => Expression =>
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix =>
Make_Identifier (Loc, Name_Find_Str (ARS)), New_Occurrence_Of (STJ.ARECn, Loc),
Attribute_Name => Name_Access)))); Attribute_Name => Name_Access))));
end Add_AREC_Declarations;
-- Next step, for each uplevel referenced entity, add
-- assignment operations to set the comoponent in the
-- activation record.
for J in 1 .. Num_Uplevel_Entities loop
declare
Ent : constant Entity_Id := Uplevel_Entities (J);
Loc : constant Source_Ptr := Sloc (Ent);
Dec : constant Node_Id := Declaration_Node (Ent);
begin
Set_Aliased_Present (Dec);
Insert_After (Dec,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (STJ.ARECn, Loc),
Selector_Name =>
Make_Identifier (Loc, Chars (Ent))),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Ent, Loc),
Attribute_Name => Name_Address)));
end;
end loop;
-- Next step, process uplevel references
Uplev_Refs : declare
Elmt : Elmt_Id;
begin
-- Loop through uplevel references
Elmt := First_Elmt (STJ.Urefs);
while Present (Elmt) loop
declare
Ref : constant Node_Id := Node (Elmt);
-- The uplevel reference itself
Loc : constant Source_Ptr := Sloc (Ref);
-- Source location for the reference
Ent : constant Entity_Id := Entity (Ref);
-- The referenced entity
Typ : constant Entity_Id := Etype (Ent);
-- The type of the referenced entity
Rsub : constant Entity_Id :=
Node (Next_Elmt (Elmt));
-- The enclosing subprogram for the reference
RSX : constant SI_Type := Subp_Index (Rsub);
-- Subp_Index for enclosing subprogram for ref
STJR : Subp_Entry renames Subps.Table (RSX);
-- Subp_Entry for enclosing subprogram for ref
Tnn : constant Entity_Id :=
Make_Temporary
(Loc, 'T', Related_Node => Ref);
-- Local pointer type for reference
Pfx : Node_Id;
Comp : Entity_Id;
SI : SI_Type;
begin
-- First insert declaration for pointer type
-- type Tnn is access all typ;
Insert_Action (Ref,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Tnn,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Subtype_Indication =>
New_Occurrence_Of (Typ, Loc))));
-- Now we need to rewrite the reference. The
-- reference is from level STJE.Lev to level
-- STJ.Lev. The general form of the rewritten
-- reference for entity X is:
-- Tnn!(ARECaF.ARECbU.ARECcU.ARECdU
-- ....ARECm.X).all
-- where a,b,c,d .. m =
-- STJR.Lev - 1, STJ.Lev - 2, .. STJ.Lev
pragma Assert (STJR.Lev > STJ.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).
-- level 2 to level 1
-- AREC1F.X
-- level 3 to level 1
-- (AREC2F.AREC1U).X
-- level 4 to level 1
-- ((AREC3F.AREC2U).AREC1U).X
-- level 6 to level 2
-- (((AREC5F.AREC4U).AREC3U).AREC2U).X
Pfx := New_Occurrence_Of (STJR.ARECnF, Loc);
SI := RSX;
for L in STJ.Lev .. STJR.Lev - 2 loop
SI := Get_Enclosing_Subp (SI);
Pfx :=
Make_Selected_Component (Loc,
Prefix => Pfx,
Selector_Name =>
New_Occurrence_Of
(Subps.Table (SI).ARECnU, Loc));
end loop;
-- Get activation record component (must exist)
Comp := Activation_Record_Component (Ent);
pragma Assert (Present (Comp));
-- Do the replacement
Rewrite (Ref,
Make_Explicit_Dereference (Loc,
Prefix =>
Unchecked_Convert_To (Tnn,
Make_Selected_Component (Loc,
Prefix => Pfx,
Selector_Name =>
New_Occurrence_Of (Comp, Loc)))));
Next_Elmt (Elmt);
Next_Elmt (Elmt);
end;
end loop;
end Uplev_Refs;
end;
end if; end if;
end; end;
end loop; end loop;
end Arec_Decls; end Subp_Loop;
-- Finally, loop through all calls adding extra actual for the
-- activation record where it is required.
-- Next step, for each uplevel referenced entity, add assignment -- TBD ???
-- operations to set the corresponding AREC fields, and define
-- the PTR types.
return; return;
end Unnest_Subprogram; end Unnest_Subprogram;
......
gcc/ada/exp_unst.ads
...@@ -165,9 +165,6 @@ package Exp_Unst is ...@@ -165,9 +165,6 @@ package Exp_Unst is
-- since they will be accessed indirectly via an activation record as -- since they will be accessed indirectly via an activation record as
-- described below. -- described below.
-- For each such entity xxx we create an access type xxxPTR (forced to
-- single length in the unconstrained case).
-- An activation record is created containing system address values -- An activation record is created containing system address values
-- for each uplevel referenced entity in a given scope. In the example -- for each uplevel referenced entity in a given scope. In the example
-- given before, we would have: -- given before, we would have:
...@@ -177,8 +174,11 @@ package Exp_Unst is ...@@ -177,8 +174,11 @@ package Exp_Unst is
-- x : Address; -- x : Address;
-- rv : Address; -- rv : Address;
-- end record; -- end record;
-- type AREC1P is access all AREC1T;
-- AREC1 : AREC1T; -- AREC1 : aliased AREC1T;
-- type AREC1PT is access all AREC1T;
-- AREC1P : constant AREC1PT := AREC1'Access;
-- The fields of AREC1 are set at the point the corresponding entity -- The fields of AREC1 are set at the point the corresponding entity
-- is declared (immediately for parameters). -- is declared (immediately for parameters).
...@@ -188,8 +188,8 @@ package Exp_Unst is ...@@ -188,8 +188,8 @@ package Exp_Unst is
-- will use AREC2, AREC3, ... -- will use AREC2, AREC3, ...
-- For all subprograms nested immediately within the corresponding scope, -- For all subprograms nested immediately within the corresponding scope,
-- a parameter AREC1P is passed, and all calls to these routines have -- a parameter AREC1F is passed, and all calls to these routines have
-- AREC1 added as an additional formal. -- AREC1P added as an additional formal.
-- Now within the nested procedures, any reference to an uplevel entity -- Now within the nested procedures, any reference to an uplevel entity
-- xxx is replaced by Tnn!(AREC1.xxx).all (where ! represents a call -- xxx is replaced by Tnn!(AREC1.xxx).all (where ! represents a call
...@@ -216,11 +216,11 @@ package Exp_Unst is ...@@ -216,11 +216,11 @@ package Exp_Unst is
-- --
-- AREC1.b := b'Address; -- AREC1.b := b'Address;
-- --
-- procedure inner (bb : integer; AREC1P : AREC1PT); -- procedure inner (bb : integer; AREC1F : AREC1PT);
-- --
-- procedure inner2 (AREC1P : AREC1PT) is -- procedure inner2 (AREC1F : AREC1PT) is
-- begin -- begin
-- inner(5, AREC1P); -- inner(5, AREC1F);
-- end; -- end;
-- --
-- x : aliased integer := 77; -- x : aliased integer := 77;
...@@ -231,13 +231,13 @@ package Exp_Unst is ...@@ -231,13 +231,13 @@ package Exp_Unst is
-- rv : aliased Integer; -- rv : aliased Integer;
-- AREC1.rv := rv'Address; -- AREC1.rv := rv'Address;
-- --
-- procedure inner (bb : integer; AREC1P : AREC1PT) is -- procedure inner (bb : integer; AREC1F : AREC1PT) is
-- begin -- begin
-- type Tnn1 is access all Integer; -- type Tnn1 is access all Integer;
-- type Tnn2 is access all Integer; -- type Tnn2 is access all Integer;
-- type Tnn3 is access all Integer; -- type Tnn3 is access all Integer;
-- Tnn1!(AREC1P.x).all := -- Tnn1!(AREC1F.x).all :=
-- Tnn2!(AREC1P.rv).all + y + b + Tnn3!(AREC1P.b).all; -- Tnn2!(AREC1F.rv).all + y + b + Tnn3!(AREC1F.b).all;
-- end; -- end;
-- --
-- begin -- begin
...@@ -386,10 +386,10 @@ package Exp_Unst is ...@@ -386,10 +386,10 @@ package Exp_Unst is
-- end record; -- end record;
-- darecv : darec; -- darecv : darec;
-- --
-- function inner (b : integer; AREC1P : AREC1PT) return boolean is -- function inner (b : integer; AREC1F : AREC1PT) return boolean is
-- begin -- begin
-- type Tnn is access all Integer -- type Tnn is access all Integer
-- return b in x .. Tnn!(AREC1P.dynam_LAST).all -- return b in x .. Tnn!(AREC1F.dynam_LAST).all
-- and then darecv.b in 42 .. 73; -- and then darecv.b in 42 .. 73;
-- end inner; -- end inner;
-- --
...@@ -414,9 +414,9 @@ package Exp_Unst is ...@@ -414,9 +414,9 @@ package Exp_Unst is
-- approach described above for case 2, except that we need an activation -- approach described above for case 2, except that we need an activation
-- record at each nested level. Basically the rule is that any procedure -- record at each nested level. Basically the rule is that any procedure
-- that has nested procedures needs an activation record. When we do this, -- that has nested procedures needs an activation record. When we do this,
-- the inner activation records have a pointer to the immediately enclosing -- the inner activation records have a pointer (uplink) to the immediately
-- activation record, the normal arrangement of static links. The following -- enclosing activation record, the normal arrangement of static links. The
-- shows the full translation of this fourth case. -- following shows the full translation of this fourth case.
-- function case4x (x : integer) return integer is -- function case4x (x : integer) return integer is
-- type AREC1T is record -- type AREC1T is record
...@@ -430,10 +430,10 @@ package Exp_Unst is ...@@ -430,10 +430,10 @@ package Exp_Unst is
-- v1 : integer := x; -- v1 : integer := x;
-- AREC1.v1 := v1'Address; -- AREC1.v1 := v1'Address;
-- --
-- function inner1 (y : integer; AREC1P : ARECPT) return integer is -- function inner1 (y : integer; AREC1F : AREC1PT) return integer is
-- type AREC2T is record -- type AREC2T is record
-- AREC1 : AREC1PT := AREC1P; -- AREC1U : AREC1PT := AREC1F;
-- v2 : Address; -- v2 : Address;
-- end record; -- end record;
-- --
-- AREC2 : aliased AREC2T; -- AREC2 : aliased AREC2T;
...@@ -441,22 +441,22 @@ package Exp_Unst is ...@@ -441,22 +441,22 @@ package Exp_Unst is
-- AREC2P : constant AREC2PT := AREC2'Access; -- AREC2P : constant AREC2PT := AREC2'Access;
-- --
-- type Tnn1 is access all Integer; -- type Tnn1 is access all Integer;
-- v2 : integer := Tnn1!(AREC1P.v1).all {+} 1; -- v2 : integer := Tnn1!(AREC1F.v1).all {+} 1;
-- AREC2.v2 := v2'Address; -- AREC2.v2 := v2'Address;
-- --
-- function inner2 -- function inner2
-- (z : integer; AREC2P : AREC2PT) return integer -- (z : integer; AREC2F : AREC2PT) return integer
-- is -- is
-- begin -- begin
-- type Tnn1 is access all Integer; -- type Tnn1 is access all Integer;
-- type Tnn2 is access all Integer; -- type Tnn2 is access all Integer;
-- return integer(z {+} -- return integer(z {+}
-- Tnn1!(AREC2P.AREC1.v1).all {+} -- Tnn1!(AREC2F.AREC1U.v1).all {+}
-- Tnn2!(AREC2P.v2).all); -- Tnn2!(AREC2F.v2).all);
-- end inner2; -- end inner2;
-- begin -- begin
-- type Tnn is access all Integer; -- type Tnn is access all Integer;
-- return integer(y {+} inner2 (Tnn!(AREC1P.v1).all, AREC2P)); -- return integer(y {+} inner2 (Tnn!(AREC1F.v1).all, AREC2P));
-- end inner1; -- end inner1;
-- begin -- begin
-- return inner1 (x, AREC1P); -- return inner1 (x, AREC1P);
......
gcc/ada/sem_ch8.adb
...@@ -4026,6 +4026,15 @@ package body Sem_Ch8 is ...@@ -4026,6 +4026,15 @@ package body Sem_Ch8 is
if not In_Open_Scopes (Pack) then if not In_Open_Scopes (Pack) then
null; -- default as well null; -- default as well
-- If the use clause appears in an ancestor and we are in the
-- private part of the immediate parent, the use clauses are
-- already installed.
elsif Pack /= Scope (Current_Scope)
and then In_Private_Part (Scope (Current_Scope))
then
null;
else else
-- Find entry for parent unit in scope stack -- Find entry for parent unit in scope stack
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment