exp_ch6.adb (Expand_N_Subprogram_Body): Avoid trying to unnest generic subprograms.
2015-03-04 Robert Dewar <dewar@adacore.com> * exp_ch6.adb (Expand_N_Subprogram_Body): Avoid trying to unnest generic subprograms. * exp_unst.adb (Check_Dynamic_Type): Handle record types properly (Note_Uplevel_Reference): Ignore uplevel references to non-types (Get_Level): Consider only subprograms, not blocks. (Visit_Node): Set proper condition for generating ARECnF entity. Ignore indirect calls. Ignore calls to subprograms outside our nest. (Unnest_Subprogram): Minor changes in dealing with ARECnF entity. (Add_Form_To_Spec): Properly set Last_Entity field. (Unnest_Subprogram): Set current subprogram scope for analyze calls. Handle case of no uplevel refs in outer subprogram Don't mark uplevel entities as aliased. Don't deal with calls with no ARECnF requirement. 2015-03-04 Robert Dewar <dewar@adacore.com> * s-valrea.adb (Scan_Real): Remove redundant tests from scaling loops. * s-imgdec.adb (Set_Decimal_Digits): Remove redundant Max operation in computing LZ. * sem_attr.adb: Minor typo fix From-SVN: r221177
This commit is contained in:
parent
b6a56408a6
commit
488f9623ba
|
@ -1,3 +1,27 @@
|
||||||
|
2015-03-04 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
|
* exp_ch6.adb (Expand_N_Subprogram_Body): Avoid trying to unnest
|
||||||
|
generic subprograms.
|
||||||
|
* exp_unst.adb (Check_Dynamic_Type): Handle record types properly
|
||||||
|
(Note_Uplevel_Reference): Ignore uplevel references to non-types
|
||||||
|
(Get_Level): Consider only subprograms, not blocks.
|
||||||
|
(Visit_Node): Set proper condition for generating ARECnF entity.
|
||||||
|
Ignore indirect calls. Ignore calls to subprograms
|
||||||
|
outside our nest.
|
||||||
|
(Unnest_Subprogram): Minor changes in dealing with ARECnF entity.
|
||||||
|
(Add_Form_To_Spec): Properly set Last_Entity field.
|
||||||
|
(Unnest_Subprogram): Set current subprogram scope for analyze calls.
|
||||||
|
Handle case of no uplevel refs in outer subprogram
|
||||||
|
Don't mark uplevel entities as aliased.
|
||||||
|
Don't deal with calls with no ARECnF requirement.
|
||||||
|
|
||||||
|
2015-03-04 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
|
* s-valrea.adb (Scan_Real): Remove redundant tests from scaling loops.
|
||||||
|
* s-imgdec.adb (Set_Decimal_Digits): Remove redundant Max
|
||||||
|
operation in computing LZ.
|
||||||
|
* sem_attr.adb: Minor typo fix
|
||||||
|
|
||||||
2015-03-04 Robert Dewar <dewar@adacore.com>
|
2015-03-04 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
* exp_ch7.adb: Minor reformatting.
|
* exp_ch7.adb: Minor reformatting.
|
||||||
|
|
|
@ -5345,7 +5345,19 @@ package body Exp_Ch6 is
|
||||||
-- with nested subprograms, do the unnesting operation now.
|
-- with nested subprograms, do the unnesting operation now.
|
||||||
|
|
||||||
if Opt.Unnest_Subprogram_Mode
|
if Opt.Unnest_Subprogram_Mode
|
||||||
and then Is_Library_Level_Entity (Spec_Id)
|
|
||||||
|
-- We are only interested in subprograms (not generic subprograms)
|
||||||
|
|
||||||
|
and then Is_Subprogram (Spec_Id)
|
||||||
|
|
||||||
|
-- Only deal with outer level subprograms. Nested subprograms are
|
||||||
|
-- handled as part of dealing with the outer level subprogram in
|
||||||
|
-- which they are nested.
|
||||||
|
|
||||||
|
and then Enclosing_Subprogram (Spec_Id) = Empty
|
||||||
|
|
||||||
|
-- We are only interested in subprograms that have nested subprograms
|
||||||
|
|
||||||
and then Has_Nested_Subprogram (Spec_Id)
|
and then Has_Nested_Subprogram (Spec_Id)
|
||||||
then
|
then
|
||||||
Unnest_Subprogram (Spec_Id, N);
|
Unnest_Subprogram (Spec_Id, N);
|
||||||
|
|
|
@ -33,8 +33,9 @@ with Nlists; use Nlists;
|
||||||
with Nmake; use Nmake;
|
with Nmake; use Nmake;
|
||||||
with Opt; use Opt;
|
with Opt; use Opt;
|
||||||
with Rtsfind; use Rtsfind;
|
with Rtsfind; use Rtsfind;
|
||||||
|
with Sinput; use Sinput;
|
||||||
with Sem; use Sem;
|
with Sem; use Sem;
|
||||||
with Sem_Aux; use Sem_Aux;
|
with Sem_Ch8; use Sem_Ch8;
|
||||||
with Sem_Mech; use Sem_Mech;
|
with Sem_Mech; use Sem_Mech;
|
||||||
with Sem_Res; use Sem_Res;
|
with Sem_Res; use Sem_Res;
|
||||||
with Sem_Util; use Sem_Util;
|
with Sem_Util; use Sem_Util;
|
||||||
|
@ -187,8 +188,8 @@ package body Exp_Unst is
|
||||||
|
|
||||||
begin
|
begin
|
||||||
C := First_Component_Or_Discriminant (T);
|
C := First_Component_Or_Discriminant (T);
|
||||||
while Present (T) loop
|
while Present (C) loop
|
||||||
if Check_Dynamic_Type (C) then
|
if Check_Dynamic_Type (Etype (C)) then
|
||||||
DT := True;
|
DT := True;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -269,6 +270,12 @@ package body Exp_Unst is
|
||||||
|
|
||||||
procedure Note_Uplevel_Reference (N : Node_Id; Subp : Entity_Id) is
|
procedure Note_Uplevel_Reference (N : Node_Id; Subp : Entity_Id) is
|
||||||
begin
|
begin
|
||||||
|
-- Nothing to do if reference has no entity field
|
||||||
|
|
||||||
|
if Nkind (N) not in N_Entity then
|
||||||
|
return;
|
||||||
|
end if;
|
||||||
|
|
||||||
-- Establish list if first call for Uplevel_References
|
-- Establish list if first call for Uplevel_References
|
||||||
|
|
||||||
if No (Uplevel_References (Subp)) then
|
if No (Uplevel_References (Subp)) then
|
||||||
|
@ -279,8 +286,7 @@ package body Exp_Unst is
|
||||||
-- the list. The first is the actual reference, the second is the
|
-- the list. The first is the actual reference, the second is the
|
||||||
-- enclosing subprogram at the point of reference
|
-- enclosing subprogram at the point of reference
|
||||||
|
|
||||||
Append_Elmt
|
Append_Elmt (N, Uplevel_References (Subp));
|
||||||
(N, Uplevel_References (Subp));
|
|
||||||
|
|
||||||
if Is_Subprogram (Current_Scope) then
|
if Is_Subprogram (Current_Scope) then
|
||||||
Append_Elmt (Current_Scope, Uplevel_References (Subp));
|
Append_Elmt (Current_Scope, Uplevel_References (Subp));
|
||||||
|
@ -349,6 +355,7 @@ package body Exp_Unst is
|
||||||
function Get_Level (Sub : Entity_Id) return Nat is
|
function Get_Level (Sub : Entity_Id) return Nat is
|
||||||
Lev : Nat;
|
Lev : Nat;
|
||||||
S : Entity_Id;
|
S : Entity_Id;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Lev := 1;
|
Lev := 1;
|
||||||
S := Sub;
|
S := Sub;
|
||||||
|
@ -356,7 +363,7 @@ package body Exp_Unst is
|
||||||
if S = Subp then
|
if S = Subp then
|
||||||
return Lev;
|
return Lev;
|
||||||
else
|
else
|
||||||
S := Enclosing_Dynamic_Scope (S);
|
S := Enclosing_Subprogram (S);
|
||||||
Lev := Lev + 1;
|
Lev := Lev + 1;
|
||||||
end if;
|
end if;
|
||||||
end loop;
|
end loop;
|
||||||
|
@ -407,7 +414,8 @@ package body Exp_Unst is
|
||||||
----------------
|
----------------
|
||||||
|
|
||||||
function Visit_Node (N : Node_Id) return Traverse_Result is
|
function Visit_Node (N : Node_Id) return Traverse_Result is
|
||||||
Ent : Entity_Id;
|
Ent : Entity_Id;
|
||||||
|
Csub : Entity_Id;
|
||||||
|
|
||||||
function Find_Current_Subprogram return Entity_Id;
|
function Find_Current_Subprogram return Entity_Id;
|
||||||
-- Finds the current subprogram containing the call N
|
-- Finds the current subprogram containing the call N
|
||||||
|
@ -439,14 +447,51 @@ package body Exp_Unst is
|
||||||
begin
|
begin
|
||||||
-- Record a call
|
-- 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)
|
||||||
Ent := Entity (Name (N));
|
|
||||||
Calls.Append ((N, Find_Current_Subprogram, Ent));
|
|
||||||
|
|
||||||
-- Record a subprogram
|
-- We are only interested in direct calls, not indirect calls
|
||||||
|
-- (where Name (N) is an explicit dereference) at least for now!
|
||||||
|
|
||||||
|
and then Nkind (Name (N)) in N_Has_Entity
|
||||||
|
then
|
||||||
|
Ent := Entity (Name (N));
|
||||||
|
|
||||||
|
-- We are only interested in calls to subprograms nested
|
||||||
|
-- within Subp. Calls to Subp itself or to subprograms that
|
||||||
|
-- are outside the nested structure do not affect us.
|
||||||
|
|
||||||
|
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;
|
||||||
|
|
||||||
|
-- Here we have a call to keep and analyze
|
||||||
|
|
||||||
|
else
|
||||||
|
Csub := Find_Current_Subprogram;
|
||||||
|
|
||||||
|
-- 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));
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
-- Record a subprogram. We record a subprogram body that acts as
|
||||||
|
-- a spec. Otherwise we record a subprogram declaration, providing
|
||||||
|
-- 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))
|
elsif (Nkind (N) = N_Subprogram_Body and then Acts_As_Spec (N))
|
||||||
or else Nkind (N) = N_Subprogram_Declaration
|
or else (Nkind (N) = N_Subprogram_Declaration
|
||||||
|
and then Present (Corresponding_Body (N)))
|
||||||
then
|
then
|
||||||
Subps.Increment_Last;
|
Subps.Increment_Last;
|
||||||
|
|
||||||
|
@ -463,6 +508,7 @@ package body Exp_Unst is
|
||||||
STJ.Bod := N;
|
STJ.Bod := N;
|
||||||
else
|
else
|
||||||
STJ.Bod := Parent (Parent (Corresponding_Body (N)));
|
STJ.Bod := Parent (Parent (Corresponding_Body (N)));
|
||||||
|
|
||||||
pragma Assert (Nkind (STJ.Bod) = N_Subprogram_Body);
|
pragma Assert (Nkind (STJ.Bod) = N_Subprogram_Body);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -552,14 +598,27 @@ package body Exp_Unst is
|
||||||
ARS : constant String := AREC_String (STJ.Lev);
|
ARS : constant String := AREC_String (STJ.Lev);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if STJ.Ent = Subp then
|
-- First we create the ARECnF entity for the additional formal
|
||||||
STJ.ARECnF := Empty;
|
-- for all subprograms requiring that an activation record pointer
|
||||||
else
|
-- 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
|
||||||
STJ.ARECnF :=
|
STJ.ARECnF :=
|
||||||
Make_Defining_Identifier (Loc,
|
Make_Defining_Identifier (Loc,
|
||||||
Chars => Name_Find_Str (AREC_String (STJ.Lev - 1) & "F"));
|
Chars => Name_Find_Str (AREC_String (STJ.Lev - 1) & "F"));
|
||||||
|
else
|
||||||
|
STJ.ARECnF := Empty;
|
||||||
end if;
|
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.
|
||||||
|
|
||||||
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
|
||||||
|
@ -580,8 +639,7 @@ package body Exp_Unst is
|
||||||
STJ.ARECnU := Empty;
|
STJ.ARECnU := Empty;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Define uplink component entity if inner nesting case and also
|
-- Define uplink component entity if inner nesting case
|
||||||
-- the extra formal entity.
|
|
||||||
|
|
||||||
if Has_Uplevel_Reference (STJ.Ent) and then STJ.Lev > 1 then
|
if Has_Uplevel_Reference (STJ.Ent) and then STJ.Lev > 1 then
|
||||||
declare
|
declare
|
||||||
|
@ -590,14 +648,10 @@ package body Exp_Unst is
|
||||||
STJ.ARECnU :=
|
STJ.ARECnU :=
|
||||||
Make_Defining_Identifier (Loc,
|
Make_Defining_Identifier (Loc,
|
||||||
Chars => Name_Find_Str (ARS1 & "U"));
|
Chars => Name_Find_Str (ARS1 & "U"));
|
||||||
STJ.ARECnF :=
|
|
||||||
Make_Defining_Identifier (Loc,
|
|
||||||
Chars => Name_Find_Str (ARS1 & "F"));
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
else
|
else
|
||||||
STJ.ARECnU := Empty;
|
STJ.ARECnU := Empty;
|
||||||
STJ.ARECnF := Empty;
|
|
||||||
end if;
|
end if;
|
||||||
end;
|
end;
|
||||||
end loop;
|
end loop;
|
||||||
|
@ -614,9 +668,10 @@ package body Exp_Unst is
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- First add the extra formal if needed. This applies to all
|
-- First add the extra formal if needed. This applies to all
|
||||||
-- nested subprograms that have uplevel references.
|
-- nested subprograms that require an activation record to be
|
||||||
|
-- passed, as indicated by ARECnF being defined.
|
||||||
|
|
||||||
if STJ.Lev > 1 and then Has_Uplevel_Reference (STJ.Ent) then
|
if Present (STJ.ARECnF) then
|
||||||
|
|
||||||
-- Here we need the extra formal. We do the expansion and
|
-- Here we need the extra formal. We do the expansion and
|
||||||
-- analysis of this manually, since it is fairly simple,
|
-- analysis of this manually, since it is fairly simple,
|
||||||
|
@ -649,6 +704,7 @@ package body Exp_Unst is
|
||||||
begin
|
begin
|
||||||
if No (First_Entity (Sub)) then
|
if No (First_Entity (Sub)) then
|
||||||
Set_First_Entity (Sub, F);
|
Set_First_Entity (Sub, F);
|
||||||
|
Set_Last_Entity (Sub, F);
|
||||||
|
|
||||||
else
|
else
|
||||||
declare
|
declare
|
||||||
|
@ -657,9 +713,14 @@ package body Exp_Unst is
|
||||||
if No (LastF) then
|
if No (LastF) then
|
||||||
Set_Next_Entity (F, First_Entity (Sub));
|
Set_Next_Entity (F, First_Entity (Sub));
|
||||||
Set_First_Entity (Sub, F);
|
Set_First_Entity (Sub, F);
|
||||||
|
|
||||||
else
|
else
|
||||||
Set_Next_Entity (F, Next_Entity (LastF));
|
Set_Next_Entity (F, Next_Entity (LastF));
|
||||||
Set_Next_Entity (LastF, F);
|
Set_Next_Entity (LastF, F);
|
||||||
|
|
||||||
|
if Last_Entity (Sub) = LastF then
|
||||||
|
Set_Last_Entity (Sub, F);
|
||||||
|
end if;
|
||||||
end if;
|
end if;
|
||||||
end;
|
end;
|
||||||
end if;
|
end if;
|
||||||
|
@ -760,11 +821,13 @@ package body Exp_Unst is
|
||||||
|
|
||||||
Clist := Empty_List;
|
Clist := Empty_List;
|
||||||
|
|
||||||
-- If not top level, include ARECnU : ARECnPT := ARECnF
|
-- If we are in a subprogram that has a static link that
|
||||||
-- where n is one less than the current level and the
|
-- ias passed in (as indicated by ARECnF being deinfed),
|
||||||
-- entity ARECnPT comes from the enclosing subprogram.
|
-- then 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 Present (STJ.ARECnF) then
|
||||||
declare
|
declare
|
||||||
STJE : Subp_Entry
|
STJE : Subp_Entry
|
||||||
renames Subps.Table (Enclosing_Subp (J));
|
renames Subps.Table (Enclosing_Subp (J));
|
||||||
|
@ -852,10 +915,12 @@ package body Exp_Unst is
|
||||||
New_List
|
New_List
|
||||||
(Decl_ARECnT, Decl_ARECn, Decl_ARECnPT, Decl_ARECnP));
|
(Decl_ARECnT, Decl_ARECn, Decl_ARECnPT, Decl_ARECnP));
|
||||||
|
|
||||||
-- Analyze the newly inserted declarations. Note that
|
-- Analyze the newly inserted declarations. Note that we
|
||||||
-- we do not need to establish the relevant scope stack
|
-- do not need to establish the whole scope stack, since
|
||||||
-- entries here, because we have already set the correct
|
-- we have already set all entity fields (so there will
|
||||||
-- entity references, so no name resolution is required.
|
-- be no searching of upper scopes to resolve names). But
|
||||||
|
-- we do set the scope of the current subprogram, so that
|
||||||
|
-- newly created entities go in the right entity chain.
|
||||||
|
|
||||||
-- We analyze with all checks suppressed (since we do
|
-- We analyze with all checks suppressed (since we do
|
||||||
-- not expect any exceptions, and also we temporarily
|
-- not expect any exceptions, and also we temporarily
|
||||||
|
@ -863,12 +928,14 @@ package body Exp_Unst is
|
||||||
-- mark uplevel references (not needed at this stage,
|
-- mark uplevel references (not needed at this stage,
|
||||||
-- and in fact causes a bit of recursive chaos).
|
-- and in fact causes a bit of recursive chaos).
|
||||||
|
|
||||||
|
Push_Scope (STJ.Ent);
|
||||||
Opt.Unnest_Subprogram_Mode := False;
|
Opt.Unnest_Subprogram_Mode := False;
|
||||||
Analyze (Decl_ARECnT, Suppress => All_Checks);
|
Analyze (Decl_ARECnT, Suppress => All_Checks);
|
||||||
Analyze (Decl_ARECn, Suppress => All_Checks);
|
Analyze (Decl_ARECn, Suppress => All_Checks);
|
||||||
Analyze (Decl_ARECnPT, Suppress => All_Checks);
|
Analyze (Decl_ARECnPT, Suppress => All_Checks);
|
||||||
Analyze (Decl_ARECnP, Suppress => All_Checks);
|
Analyze (Decl_ARECnP, Suppress => All_Checks);
|
||||||
Opt.Unnest_Subprogram_Mode := True;
|
Opt.Unnest_Subprogram_Mode := True;
|
||||||
|
Pop_Scope;
|
||||||
|
|
||||||
-- Next step, for each uplevel referenced entity, add
|
-- Next step, for each uplevel referenced entity, add
|
||||||
-- assignment operations to set the comoponent in the
|
-- assignment operations to set the comoponent in the
|
||||||
|
@ -883,14 +950,15 @@ package body Exp_Unst is
|
||||||
Asn : Node_Id;
|
Asn : Node_Id;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Set_Aliased_Present (Dec);
|
|
||||||
Set_Is_Aliased (Ent);
|
|
||||||
|
|
||||||
-- For parameters, we insert the assignment right
|
-- For parameters, we insert the assignment right
|
||||||
-- after the declaration of ARECnP. For all other
|
-- after the declaration of ARECnP. For all other
|
||||||
-- entities, we insert the assignment immediately
|
-- entities, we insert the assignment immediately
|
||||||
-- after the declaration of the entity.
|
-- 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
|
if Is_Formal (Ent) then
|
||||||
Ins := Decl_ARECnP;
|
Ins := Decl_ARECnP;
|
||||||
else
|
else
|
||||||
|
@ -917,11 +985,12 @@ package body Exp_Unst is
|
||||||
|
|
||||||
Insert_After (Ins, Asn);
|
Insert_After (Ins, Asn);
|
||||||
|
|
||||||
-- Analyze the assignment statement. Again, we do
|
-- Analyze the assignment statement. We do not need
|
||||||
-- not need to establish the relevant scope stack
|
-- to establish the relevant scope stack entries
|
||||||
-- entries here, because we have already set the
|
-- here, because we have already set the correct
|
||||||
-- correct entity references, so no name resolution
|
-- entity references, so no name resolution is
|
||||||
-- is required.
|
-- 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 analyze with all checks suppressed (since
|
||||||
-- we do not expect any exceptions, and also we
|
-- we do not expect any exceptions, and also we
|
||||||
|
@ -1010,6 +1079,13 @@ package body Exp_Unst is
|
||||||
SI : SI_Type;
|
SI : SI_Type;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
-- 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.
|
||||||
|
|
||||||
|
Push_Scope (STJR.Ent);
|
||||||
|
|
||||||
-- First insert declaration for pointer type
|
-- First insert declaration for pointer type
|
||||||
|
|
||||||
-- type Tnn is access all typ;
|
-- type Tnn is access all typ;
|
||||||
|
@ -1087,6 +1163,8 @@ package body Exp_Unst is
|
||||||
-- need to establish the relevant scope stack entries
|
-- need to establish the relevant scope stack entries
|
||||||
-- here, because we have already set all the correct
|
-- here, because we have already set all the correct
|
||||||
-- entity references, so no name resolution is needed.
|
-- 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.
|
||||||
|
|
||||||
-- We analyze with all checks suppressed (since we do
|
-- We analyze with all checks suppressed (since we do
|
||||||
-- not expect any exceptions, and also we temporarily
|
-- not expect any exceptions, and also we temporarily
|
||||||
|
@ -1097,6 +1175,7 @@ package body Exp_Unst is
|
||||||
Opt.Unnest_Subprogram_Mode := False;
|
Opt.Unnest_Subprogram_Mode := False;
|
||||||
Analyze_And_Resolve (Ref, Typ, Suppress => All_Checks);
|
Analyze_And_Resolve (Ref, Typ, Suppress => All_Checks);
|
||||||
Opt.Unnest_Subprogram_Mode := True;
|
Opt.Unnest_Subprogram_Mode := True;
|
||||||
|
Pop_Scope;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
<<Continue>>
|
<<Continue>>
|
||||||
|
@ -1114,130 +1193,139 @@ package body Exp_Unst is
|
||||||
Adjust_Calls : for J in Calls.First .. Calls.Last loop
|
Adjust_Calls : for J in Calls.First .. Calls.Last loop
|
||||||
|
|
||||||
-- Process a single call, we are only interested in a call to a
|
-- Process a single call, we are only interested in a call to a
|
||||||
-- subprogram that actually need a pointer to an activation record,
|
-- subprogram that actually needs a pointer to an activation record,
|
||||||
-- as indicated by the ARECnF entity being set. This excludes the
|
-- as indicated by the ARECnF entity being set. This excludes the
|
||||||
-- top level subprogram, and any subprogram not having uplevel refs.
|
-- top level subprogram, and any subprogram not having uplevel refs.
|
||||||
|
|
||||||
declare
|
Adjust_One_Call : declare
|
||||||
CTJ : Call_Entry renames Calls.Table (J);
|
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));
|
||||||
|
|
||||||
|
Loc : constant Source_Ptr := Sloc (CTJ.N);
|
||||||
|
|
||||||
|
Extra : Node_Id;
|
||||||
|
ExtraP : Node_Id;
|
||||||
|
SubX : SI_Type;
|
||||||
|
Act : Node_Id;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Has_Uplevel_Reference (CTJ.To) and then CTJ.To /= Subp then
|
if Present (STT.ARECnF) then
|
||||||
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));
|
|
||||||
|
|
||||||
Loc : constant Source_Ptr := Sloc (CTJ.N);
|
-- CTJ.N is a call to a subprogram which may require
|
||||||
|
-- a pointer to an activation record. The subprogram
|
||||||
|
-- containing the call is CTJ.From and the subprogram being
|
||||||
|
-- called is CTJ.To, so we have a call from level STF.Lev to
|
||||||
|
-- level STT.Lev.
|
||||||
|
|
||||||
Extra : Node_Id;
|
-- There are three possibilities:
|
||||||
ExtraP : Node_Id;
|
|
||||||
SubX : SI_Type;
|
|
||||||
Act : Node_Id;
|
|
||||||
|
|
||||||
begin
|
-- For a call to the same level, we just pass the activation
|
||||||
-- CTJ.N is a call to a subprogram which may require
|
-- record passed to the calling subprogram.
|
||||||
-- a pointer to an activation record. The subprogram
|
|
||||||
-- containing the call is CTJ.From and the subprogram being
|
|
||||||
-- called is CTJ.To, so we have a call from level STF.Lev to
|
|
||||||
-- level STT.Lev.
|
|
||||||
|
|
||||||
-- There are three possibilities:
|
if STF.Lev = STT.Lev then
|
||||||
|
Extra := New_Occurrence_Of (STF.ARECnF, Loc);
|
||||||
|
|
||||||
-- For a call to the same level, we just pass the activation
|
-- For a call that goes down a level, we pass a pointer
|
||||||
-- record passed to the calling subprogram.
|
-- to the activation record constructed wtihin the caller
|
||||||
|
-- (which may be the outer level subprogram, but also may
|
||||||
|
-- be a more deeply nested caller).
|
||||||
|
|
||||||
if STF.Lev = STT.Lev then
|
elsif STT.Lev = STF.Lev + 1 then
|
||||||
Extra := New_Occurrence_Of (STF.ARECnF, Loc);
|
Extra := New_Occurrence_Of (STF.ARECnP, Loc);
|
||||||
|
|
||||||
-- For a call that goes down a level, we pass a pointer
|
-- Otherwise we must have an upcall (STT.Lev < STF.LEV),
|
||||||
-- to the activation record constructed wtihin the caller
|
-- since it is not possible to do a downcall of more than
|
||||||
-- (which may be the outer level subprogram, but also may
|
-- one level.
|
||||||
-- be a more deeply nested caller).
|
|
||||||
|
|
||||||
elsif STT.Lev = STF.Lev + 1 then
|
-- For a call from level STF.Lev to level STT.Lev, we
|
||||||
Extra := New_Occurrence_Of (STF.ARECnP, Loc);
|
-- have to find the activation record needed by the
|
||||||
|
-- callee. This is as follows:
|
||||||
|
|
||||||
-- Otherwise we must have an upcall (STT.Lev < STF.LEV),
|
-- ARECaF.ARECbU.ARECcU....ARECm
|
||||||
-- since it is not possible to do a downcall of more than
|
|
||||||
-- one level.
|
|
||||||
|
|
||||||
-- For a call from level STF.Lev to level STT.Lev, we
|
-- where a,b,c .. m =
|
||||||
-- have to find the activation record needed by the
|
-- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
|
||||||
-- callee. This is as follows:
|
|
||||||
|
|
||||||
-- ARECaF.ARECbU.ARECcU....ARECm
|
else
|
||||||
|
pragma Assert (STT.Lev < STF.Lev);
|
||||||
|
|
||||||
-- where a,b,c .. m =
|
Extra := New_Occurrence_Of (STF.ARECnF, Loc);
|
||||||
-- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
|
SubX := Subp_Index (CTJ.From);
|
||||||
|
for K in reverse STT.Lev .. STF.Lev - 1 loop
|
||||||
|
SubX := Enclosing_Subp (SubX);
|
||||||
|
Extra :=
|
||||||
|
Make_Selected_Component (Loc,
|
||||||
|
Prefix => Extra,
|
||||||
|
Selector_Name =>
|
||||||
|
New_Occurrence_Of
|
||||||
|
(Subps.Table (SubX).ARECnU, Loc));
|
||||||
|
end loop;
|
||||||
|
end if;
|
||||||
|
|
||||||
else
|
-- Extra is the additional parameter to be added. Build a
|
||||||
pragma Assert (STT.Lev < STF.Lev);
|
-- parameter association that we can append to the actuals.
|
||||||
|
|
||||||
Extra := New_Occurrence_Of (STF.ARECnF, Loc);
|
ExtraP :=
|
||||||
SubX := Subp_Index (CTJ.From);
|
Make_Parameter_Association (Loc,
|
||||||
for K in reverse STT.Lev .. STF.Lev - 1 loop
|
Selector_Name =>
|
||||||
SubX := Enclosing_Subp (SubX);
|
New_Occurrence_Of (STT.ARECnF, Loc),
|
||||||
Extra :=
|
Explicit_Actual_Parameter => Extra);
|
||||||
Make_Selected_Component (Loc,
|
|
||||||
Prefix => Extra,
|
|
||||||
Selector_Name =>
|
|
||||||
New_Occurrence_Of
|
|
||||||
(Subps.Table (SubX).ARECnU, Loc));
|
|
||||||
end loop;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
-- Extra is the additional parameter to be added. Build a
|
if No (Parameter_Associations (CTJ.N)) then
|
||||||
-- parameter association that we can append to the actuals.
|
Set_Parameter_Associations (CTJ.N, Empty_List);
|
||||||
|
end if;
|
||||||
|
|
||||||
ExtraP :=
|
Append (ExtraP, Parameter_Associations (CTJ.N));
|
||||||
Make_Parameter_Association (Loc,
|
|
||||||
Selector_Name =>
|
|
||||||
New_Occurrence_Of (STT.ARECnF, Loc),
|
|
||||||
Explicit_Actual_Parameter => Extra);
|
|
||||||
|
|
||||||
if No (Parameter_Associations (CTJ.N)) then
|
-- We need to deal with the actual parameter chain as well.
|
||||||
Set_Parameter_Associations (CTJ.N, Empty_List);
|
-- The newly added parameter is always the last actual.
|
||||||
end if;
|
|
||||||
|
|
||||||
Append (ExtraP, Parameter_Associations (CTJ.N));
|
Act := First_Named_Actual (CTJ.N);
|
||||||
|
|
||||||
-- We need to deal with the actual parameter chain as well.
|
if No (Act) then
|
||||||
-- The newly added parameter is always the last actual.
|
Set_First_Named_Actual (CTJ.N, Extra);
|
||||||
|
|
||||||
Act := First_Named_Actual (CTJ.N);
|
-- Here we must follow the chain and append the new entry
|
||||||
|
|
||||||
if No (Act) then
|
else
|
||||||
Set_First_Named_Actual (CTJ.N, Extra);
|
loop
|
||||||
|
declare
|
||||||
|
PAN : Node_Id;
|
||||||
|
NNA : Node_Id;
|
||||||
|
|
||||||
-- Here we must follow the chain and append the new entry
|
begin
|
||||||
|
PAN := Parent (Act);
|
||||||
|
pragma Assert (Nkind (PAN) = N_Parameter_Association);
|
||||||
|
NNA := Next_Named_Actual (PAN);
|
||||||
|
|
||||||
else
|
if No (NNA) then
|
||||||
while Present (Next_Named_Actual (Act)) loop
|
Set_Next_Named_Actual (PAN, Extra);
|
||||||
Act := Next_Named_Actual (Act);
|
exit;
|
||||||
end loop;
|
end if;
|
||||||
|
|
||||||
Set_Next_Named_Actual (Act, Extra);
|
Act := NNA;
|
||||||
end if;
|
end;
|
||||||
|
end loop;
|
||||||
|
end if;
|
||||||
|
|
||||||
-- Analyze and resolve the new actual. We do not need to
|
-- Analyze and resolve the new actual. We do not need to
|
||||||
-- establish the relevant scope stack entries here, because
|
-- establish the relevant scope stack entries here, because
|
||||||
-- we have already set all the correct entity references, so
|
-- we have already set all the correct entity references, so
|
||||||
-- no name resolution is needed.
|
-- no name resolution is needed.
|
||||||
|
|
||||||
-- We analyze with all checks suppressed (since we do not
|
-- We analyze with all checks suppressed (since we do not
|
||||||
-- expect any exceptions, and also we temporarily turn off
|
-- expect any exceptions, and also we temporarily turn off
|
||||||
-- Unested_Subprogram_Mode to avoid trying to mark uplevel
|
-- Unested_Subprogram_Mode to avoid trying to mark uplevel
|
||||||
-- references (not needed at this stage, and in fact causes
|
-- references (not needed at this stage, and in fact causes
|
||||||
-- a bit of recursive chaos).
|
-- a bit of recursive chaos).
|
||||||
|
|
||||||
Opt.Unnest_Subprogram_Mode := False;
|
Opt.Unnest_Subprogram_Mode := False;
|
||||||
Analyze_And_Resolve
|
Analyze_And_Resolve
|
||||||
(Extra, Etype (STT.ARECnF), Suppress => All_Checks);
|
(Extra, Etype (STT.ARECnF), Suppress => All_Checks);
|
||||||
Opt.Unnest_Subprogram_Mode := True;
|
Opt.Unnest_Subprogram_Mode := True;
|
||||||
end;
|
|
||||||
end if;
|
end if;
|
||||||
end;
|
end Adjust_One_Call;
|
||||||
end loop Adjust_Calls;
|
end loop Adjust_Calls;
|
||||||
|
|
||||||
return;
|
return;
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- B o d y --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 1992-2009, 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- --
|
||||||
|
@ -319,9 +319,11 @@ package body System.Img_Dec is
|
||||||
DA : Natural := Digits_After_Point;
|
DA : Natural := Digits_After_Point;
|
||||||
-- Digits remaining to output after point
|
-- Digits remaining to output after point
|
||||||
|
|
||||||
LZ : constant Integer :=
|
LZ : constant Integer := Integer'Min (DA, -Digits_Before_Point);
|
||||||
Integer'Max (0, Integer'Min (DA, -Digits_Before_Point));
|
-- Number of leading zeroes after point. Note: there used to be
|
||||||
-- Number of leading zeroes after point
|
-- a Max of this result with zero, but that's redundant, since
|
||||||
|
-- we know DA is positive, and because of the test above, we
|
||||||
|
-- know that -Digits_Before_Point >= 0.
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Set_Zeroes (LZ);
|
Set_Zeroes (LZ);
|
||||||
|
|
|
@ -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- --
|
||||||
|
@ -347,9 +347,10 @@ package body System.Val_Real is
|
||||||
Scale := Scale - Maxpow;
|
Scale := Scale - Maxpow;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
if Scale > 0 then
|
-- Note that we still know that Scale > 0, since the loop
|
||||||
Uval := Uval * Powten (Scale);
|
-- above leaves Scale in the range 1 .. Maxpow.
|
||||||
end if;
|
|
||||||
|
Uval := Uval * Powten (Scale);
|
||||||
|
|
||||||
elsif Scale < 0 then
|
elsif Scale < 0 then
|
||||||
while (-Scale) > Maxpow loop
|
while (-Scale) > Maxpow loop
|
||||||
|
@ -357,9 +358,10 @@ package body System.Val_Real is
|
||||||
Scale := Scale + Maxpow;
|
Scale := Scale + Maxpow;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
if Scale < 0 then
|
-- Note that we still know that Scale < 0, since the loop
|
||||||
Uval := Uval / Powten (-Scale);
|
-- above leaves Scale in the range -Maxpow .. -1.
|
||||||
end if;
|
|
||||||
|
Uval := Uval / Powten (-Scale);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Here is where we check for a bad based number
|
-- Here is where we check for a bad based number
|
||||||
|
|
|
@ -247,7 +247,7 @@ package body Sem_Attr is
|
||||||
-- Common processing for attributes 'Old and 'Result. The routine checks
|
-- Common processing for attributes 'Old and 'Result. The routine checks
|
||||||
-- that the attribute appears in a postcondition-like aspect or pragma
|
-- that the attribute appears in a postcondition-like aspect or pragma
|
||||||
-- associated with a suitable subprogram or a body. Flag Legal is set
|
-- associated with a suitable subprogram or a body. Flag Legal is set
|
||||||
-- when the above criterias are met. Spec_Id denotes the entity of the
|
-- when the above criteria are met. Spec_Id denotes the entity of the
|
||||||
-- subprogram [body] or Empty if the attribute is illegal.
|
-- subprogram [body] or Empty if the attribute is illegal.
|
||||||
|
|
||||||
procedure Bad_Attribute_For_Predicate;
|
procedure Bad_Attribute_For_Predicate;
|
||||||
|
|
Loading…
Reference in New Issue