Skip to content

R
riscv-gcc-1
Commit a0347839 by Arnaud Charlet
Options

exp_ch9.adb, [...]: Minor reformatting. 

2011-08-30  Robert Dewar  <dewar@adacore.com>

	* exp_ch9.adb, s-tassta.adb, s-secsta.adb: Minor reformatting.

2011-08-30  Yannick Moy  <moy@adacore.com>

	* exp_ch6_light.adb, exp_ch6_light.ads, exp_attr_light.adb,
	exp_attr_light.ads, exp_ch7_light.adb, exp_ch7_light.ads,
	exp_light.adb, exp_light.ads, exp_prag.adb, expander.adb,
	gnat1drv.adb, exp_ch11.adb, exp_ch6.adb, exp_ch6.ads, exp_aggr.adb:
	Revert change which introduced files for "light"
	expansion, to be replaced by a single file for Alfa expansion.

From-SVN: r178316
parent 5b8ca141
Showing with 121 additions and 612 deletions
gcc/ada/ChangeLog
2011-08-30 Robert Dewar <dewar@adacore.com> 2011-08-30 Robert Dewar <dewar@adacore.com>
* exp_ch9.adb, s-tassta.adb, s-secsta.adb: Minor reformatting.
2011-08-30 Yannick Moy <moy@adacore.com>
* exp_ch6_light.adb, exp_ch6_light.ads, exp_attr_light.adb,
exp_attr_light.ads, exp_ch7_light.adb, exp_ch7_light.ads,
exp_light.adb, exp_light.ads, exp_prag.adb, expander.adb,
gnat1drv.adb, exp_ch11.adb, exp_ch6.adb, exp_ch6.ads, exp_aggr.adb:
Revert change which introduced files for "light"
expansion, to be replaced by a single file for Alfa expansion.
2011-08-30 Robert Dewar <dewar@adacore.com>
* opt.ads, s-soflin.adb, exp_ch9.adb, sem_res.adb: Update comment. * opt.ads, s-soflin.adb, exp_ch9.adb, sem_res.adb: Update comment.
Minor code reorg/reformatting. Minor code reorg/reformatting.
......
gcc/ada/exp_aggr.adb
...@@ -4664,6 +4664,12 @@ package body Exp_Aggr is ...@@ -4664,6 +4664,12 @@ package body Exp_Aggr is
Check_Same_Aggr_Bounds (N, 1); Check_Same_Aggr_Bounds (N, 1);
end if; end if;
-- In formal verification mode, leave the aggregate non-expanded
if ALFA_Mode then
return;
end if;
-- STEP 2 -- STEP 2
-- Here we test for is packed array aggregate that we can handle at -- Here we test for is packed array aggregate that we can handle at
......
gcc/ada/exp_attr_light.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ A T T R _ L I G H T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Exp_Attr; use Exp_Attr;
with Sinfo; use Sinfo;
with Snames; use Snames;
package body Exp_Attr_Light is
----------------------------------------
-- Expand_Light_N_Attribute_Reference --
----------------------------------------
procedure Expand_Light_N_Attribute_Reference (N : Node_Id) is
Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
begin
case Id is
when Attribute_Old |
Attribute_Result =>
Expand_N_Attribute_Reference (N);
when others =>
null;
end case;
end Expand_Light_N_Attribute_Reference;
end Exp_Attr_Light;
gcc/ada/exp_attr_light.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ A T T R _ L I G H T --
-- --
-- S p e c --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Light expand routines for attribute references
with Types; use Types;
package Exp_Attr_Light is
procedure Expand_Light_N_Attribute_Reference (N : Node_Id);
-- Expand attributes 'Old and 'Result only
end Exp_Attr_Light;
gcc/ada/exp_ch11.adb
...@@ -1673,6 +1673,7 @@ package body Exp_Ch11 is ...@@ -1673,6 +1673,7 @@ package body Exp_Ch11 is
if VM_Target = No_VM if VM_Target = No_VM
and then not CodePeer_Mode and then not CodePeer_Mode
and then not ALFA_Mode
and then Exception_Mechanism = Back_End_Exceptions and then Exception_Mechanism = Back_End_Exceptions
then then
return; return;
......
gcc/ada/exp_ch6.adb
...@@ -156,6 +156,36 @@ package body Exp_Ch6 is ...@@ -156,6 +156,36 @@ package body Exp_Ch6 is
-- the values are not changed for the call, we know immediately that -- the values are not changed for the call, we know immediately that
-- we have an infinite recursion. -- we have an infinite recursion.
procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id);
-- For each actual of an in-out or out parameter which is a numeric
-- (view) conversion of the form T (A), where A denotes a variable,
-- we insert the declaration:
--
-- Temp : T[ := T (A)];
--
-- prior to the call. Then we replace the actual with a reference to Temp,
-- and append the assignment:
--
-- A := TypeA (Temp);
--
-- after the call. Here TypeA is the actual type of variable A. For out
-- parameters, the initial declaration has no expression. If A is not an
-- entity name, we generate instead:
--
-- Var : TypeA renames A;
-- Temp : T := Var; -- omitting expression for out parameter.
-- ...
-- Var := TypeA (Temp);
--
-- For other in-out parameters, we emit the required constraint checks
-- before and/or after the call.
--
-- For all parameter modes, actuals that denote components and slices of
-- packed arrays are expanded into suitable temporaries.
--
-- For non-scalar objects that are possibly unaligned, add call by copy
-- code (copy in for IN and IN OUT, copy out for OUT and IN OUT).
procedure Expand_Ctrl_Function_Call (N : Node_Id); procedure Expand_Ctrl_Function_Call (N : Node_Id);
-- N is a function call which returns a controlled object. Transform the -- N is a function call which returns a controlled object. Transform the
-- call into a temporary which retrieves the returned object from the -- call into a temporary which retrieves the returned object from the
......
gcc/ada/exp_ch6.ads
...@@ -37,36 +37,6 @@ package Exp_Ch6 is ...@@ -37,36 +37,6 @@ package Exp_Ch6 is
procedure Expand_N_Subprogram_Body_Stub (N : Node_Id); procedure Expand_N_Subprogram_Body_Stub (N : Node_Id);
procedure Expand_N_Subprogram_Declaration (N : Node_Id); procedure Expand_N_Subprogram_Declaration (N : Node_Id);
procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id);
-- For each actual of an in-out or out parameter which is a numeric
-- (view) conversion of the form T (A), where A denotes a variable,
-- we insert the declaration:
--
-- Temp : T[ := T (A)];
--
-- prior to the call. Then we replace the actual with a reference to Temp,
-- and append the assignment:
--
-- A := TypeA (Temp);
--
-- after the call. Here TypeA is the actual type of variable A. For out
-- parameters, the initial declaration has no expression. If A is not an
-- entity name, we generate instead:
--
-- Var : TypeA renames A;
-- Temp : T := Var; -- omitting expression for out parameter.
-- ...
-- Var := TypeA (Temp);
--
-- For other in-out parameters, we emit the required constraint checks
-- before and/or after the call.
--
-- For all parameter modes, actuals that denote components and slices of
-- packed arrays are expanded into suitable temporaries.
--
-- For non-scalar objects that are possibly unaligned, add call by copy
-- code (copy in for IN and IN OUT, copy out for OUT and IN OUT).
procedure Expand_Call (N : Node_Id); procedure Expand_Call (N : Node_Id);
-- This procedure contains common processing for Expand_N_Function_Call, -- This procedure contains common processing for Expand_N_Function_Call,
-- Expand_N_Procedure_Statement, and Expand_N_Entry_Call. -- Expand_N_Procedure_Statement, and Expand_N_Entry_Call.
......
gcc/ada/exp_ch6_light.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ C H 6 _ L I G H T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Exp_Ch6; use Exp_Ch6;
with Exp_Dbug; use Exp_Dbug;
with Rtsfind; use Rtsfind;
with Sem_Aux; use Sem_Aux;
with Sem_Res; use Sem_Res;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Tbuild; use Tbuild;
package body Exp_Ch6_Light is
-----------------------
-- Local Subprograms --
-----------------------
procedure Expand_Simple_Function_Return (N : Node_Id);
-- Expand simple return from function
-----------------------
-- Expand_Light_Call --
-----------------------
procedure Expand_Light_Call (N : Node_Id) is
Call_Node : constant Node_Id := N;
Parent_Subp : Entity_Id;
Subp : Entity_Id;
begin
-- Ignore if previous error
if Nkind (Call_Node) in N_Has_Etype
and then Etype (Call_Node) = Any_Type
then
return;
end if;
-- Call using access to subprogram with explicit dereference
if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
Subp := Etype (Name (Call_Node));
Parent_Subp := Empty;
-- Case of call to simple entry, where the Name is a selected component
-- whose prefix is the task, and whose selector name is the entry name
elsif Nkind (Name (Call_Node)) = N_Selected_Component then
Subp := Entity (Selector_Name (Name (Call_Node)));
Parent_Subp := Empty;
-- Case of call to member of entry family, where Name is an indexed
-- component, with the prefix being a selected component giving the
-- task and entry family name, and the index being the entry index.
elsif Nkind (Name (Call_Node)) = N_Indexed_Component then
Subp := Entity (Selector_Name (Prefix (Name (Call_Node))));
Parent_Subp := Empty;
-- Normal case
else
Subp := Entity (Name (Call_Node));
Parent_Subp := Alias (Subp);
end if;
-- Various expansion activities for actuals are carried out
Expand_Actuals (N, Subp);
-- If the subprogram is a renaming, replace it in the call with the name
-- of the actual subprogram being called.
if Present (Parent_Subp) then
Parent_Subp := Ultimate_Alias (Parent_Subp);
-- The below setting of Entity is suspect, see F109-018 discussion???
Set_Entity (Name (Call_Node), Parent_Subp);
end if;
end Expand_Light_Call;
--------------------------------------------
-- Expand_Light_N_Simple_Return_Statement --
--------------------------------------------
procedure Expand_Light_N_Simple_Return_Statement (N : Node_Id) is
begin
-- Defend against previous errors (i.e. the return statement calls a
-- function that is not available in configurable runtime).
if Present (Expression (N))
and then Nkind (Expression (N)) = N_Empty
then
return;
end if;
-- Distinguish the function and non-function cases:
case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
when E_Function |
E_Generic_Function =>
Expand_Simple_Function_Return (N);
when E_Procedure |
E_Generic_Procedure |
E_Entry |
E_Entry_Family |
E_Return_Statement =>
-- Expand_Non_Function_Return (N);
null;
when others =>
raise Program_Error;
end case;
exception
when RE_Not_Available =>
return;
end Expand_Light_N_Simple_Return_Statement;
------------------------------------
-- Expand_Light_N_Subprogram_Body --
------------------------------------
procedure Expand_Light_N_Subprogram_Body (N : Node_Id) is
begin
Qualify_Entity_Names (N);
end Expand_Light_N_Subprogram_Body;
-----------------------------------
-- Expand_Simple_Function_Return --
-----------------------------------
procedure Expand_Simple_Function_Return (N : Node_Id) is
Scope_Id : constant Entity_Id :=
Return_Applies_To (Return_Statement_Entity (N));
-- The function we are returning from
R_Type : constant Entity_Id := Etype (Scope_Id);
-- The result type of the function
Exp : constant Node_Id := Expression (N);
pragma Assert (Present (Exp));
Exptyp : constant Entity_Id := Etype (Exp);
-- The type of the expression (not necessarily the same as R_Type)
begin
-- Check the result expression of a scalar function against the subtype
-- of the function by inserting a conversion. This conversion must
-- eventually be performed for other classes of types, but for now it's
-- only done for scalars.
-- ???
if Is_Scalar_Type (Exptyp) then
Rewrite (Exp, Convert_To (R_Type, Exp));
-- The expression is resolved to ensure that the conversion gets
-- expanded to generate a possible constraint check.
Analyze_And_Resolve (Exp, R_Type);
end if;
end Expand_Simple_Function_Return;
end Exp_Ch6_Light;
gcc/ada/exp_ch6_light.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ C H 6 _ L I G H T --
-- --
-- S p e c --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Light expand routines for chapter 6 constructs
with Types; use Types;
package Exp_Ch6_Light is
procedure Expand_Light_Call (N : Node_Id);
-- This procedure contains common processing for function and procedure
-- calls:
-- * expansion of actuals to introduce necessary temporaries
-- * replacement of renaming by subprogram renamed
procedure Expand_Light_N_Simple_Return_Statement (N : Node_Id);
-- Insert conversion on function return if necessary
procedure Expand_Light_N_Subprogram_Body (N : Node_Id);
-- Fully qualify names of enclosed entities
end Exp_Ch6_Light;
gcc/ada/exp_ch7_light.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ C H 7 _ L I G H T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Exp_Dbug; use Exp_Dbug;
package body Exp_Ch7_Light is
procedure Expand_Light_N_Package_Declaration (N : Node_Id) is
begin
Qualify_Entity_Names (N);
end Expand_Light_N_Package_Declaration;
end Exp_Ch7_Light;
gcc/ada/exp_ch7_light.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ C H 7 _ L I G H T --
-- --
-- S p e c --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Light expand routines for chapter 7 constructs
with Types; use Types;
package Exp_Ch7_Light is
procedure Expand_Light_N_Package_Declaration (N : Node_Id);
-- Fully qualify names of enclosed entities
end Exp_Ch7_Light;
gcc/ada/exp_ch9.adb
...@@ -11130,10 +11130,8 @@ package body Exp_Ch9 is ...@@ -11130,10 +11130,8 @@ package body Exp_Ch9 is
Prepend_To (Decls, Prepend_To (Decls,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Defining_Identifier => B,
B, Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
Object_Definition =>
New_Reference_To (Standard_Boolean, Loc)));
end if; end if;
-- Duration and mode processing -- Duration and mode processing
...@@ -11149,15 +11147,19 @@ package body Exp_Ch9 is ...@@ -11149,15 +11147,19 @@ package body Exp_Ch9 is
elsif Is_RTE (D_Type, RO_CA_Time) then elsif Is_RTE (D_Type, RO_CA_Time) then
D_Disc := Make_Integer_Literal (Loc, 1); D_Disc := Make_Integer_Literal (Loc, 1);
D_Conv := Make_Function_Call (Loc, D_Conv :=
New_Reference_To (RTE (RO_CA_To_Duration), Loc), Make_Function_Call (Loc,
New_List (New_Copy (Expression (D_Stat)))); Name => New_Reference_To (RTE (RO_CA_To_Duration), Loc),
Parameter_Associations =>
New_List (New_Copy (Expression (D_Stat))));
else pragma Assert (Is_RTE (D_Type, RO_RT_Time)); else pragma Assert (Is_RTE (D_Type, RO_RT_Time));
D_Disc := Make_Integer_Literal (Loc, 2); D_Disc := Make_Integer_Literal (Loc, 2);
D_Conv := Make_Function_Call (Loc, D_Conv :=
New_Reference_To (RTE (RO_RT_To_Duration), Loc), Make_Function_Call (Loc,
New_List (New_Copy (Expression (D_Stat)))); Name => New_Reference_To (RTE (RO_RT_To_Duration), Loc),
Parameter_Associations =>
New_List (New_Copy (Expression (D_Stat))));
end if; end if;
D := Make_Temporary (Loc, 'D'); D := Make_Temporary (Loc, 'D');
...@@ -11167,10 +11169,8 @@ package body Exp_Ch9 is ...@@ -11167,10 +11169,8 @@ package body Exp_Ch9 is
Append_To (Decls, Append_To (Decls,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Defining_Identifier => D,
D, Object_Definition => New_Reference_To (Standard_Duration, Loc)));
Object_Definition =>
New_Reference_To (Standard_Duration, Loc)));
M := Make_Temporary (Loc, 'M'); M := Make_Temporary (Loc, 'M');
...@@ -11179,22 +11179,17 @@ package body Exp_Ch9 is ...@@ -11179,22 +11179,17 @@ package body Exp_Ch9 is
Append_To (Decls, Append_To (Decls,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Defining_Identifier => M,
M, Object_Definition => New_Reference_To (Standard_Integer, Loc),
Object_Definition => Expression => D_Disc));
New_Reference_To (Standard_Integer, Loc),
Expression =>
D_Disc));
-- Do the assignment at this stage only because the evaluation of the -- Do the assignment at this stage only because the evaluation of the
-- expression must not occur before (see ACVC C97302A). -- expression must not occur before (see ACVC C97302A).
Append_To (Stmts, Append_To (Stmts,
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Name => New_Reference_To (D, Loc),
New_Reference_To (D, Loc), Expression => D_Conv));
Expression =>
D_Conv));
-- Parameter block processing -- Parameter block processing
...@@ -11211,8 +11206,8 @@ package body Exp_Ch9 is ...@@ -11211,8 +11206,8 @@ package body Exp_Ch9 is
K := Build_K (Loc, Decls, Obj); K := Build_K (Loc, Decls, Obj);
Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
P := Parameter_Block_Pack P :=
(Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
-- Dispatch table slot processing, generate: -- Dispatch table slot processing, generate:
-- S : Integer; -- S : Integer;
...@@ -11238,9 +11233,10 @@ package body Exp_Ch9 is ...@@ -11238,9 +11233,10 @@ package body Exp_Ch9 is
Append_To (Params, New_Copy_Tree (Obj)); Append_To (Params, New_Copy_Tree (Obj));
Append_To (Params, New_Reference_To (S, Loc)); Append_To (Params, New_Reference_To (S, Loc));
Append_To (Params, Make_Attribute_Reference (Loc, Append_To (Params,
Prefix => New_Reference_To (P, Loc), Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address)); Prefix => New_Reference_To (P, Loc),
Attribute_Name => Name_Address));
Append_To (Params, New_Reference_To (D, Loc)); Append_To (Params, New_Reference_To (D, Loc));
Append_To (Params, New_Reference_To (M, Loc)); Append_To (Params, New_Reference_To (M, Loc));
Append_To (Params, New_Reference_To (C, Loc)); Append_To (Params, New_Reference_To (C, Loc));
...@@ -11249,12 +11245,10 @@ package body Exp_Ch9 is ...@@ -11249,12 +11245,10 @@ package body Exp_Ch9 is
Append_To (Conc_Typ_Stmts, Append_To (Conc_Typ_Stmts,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => Name =>
New_Reference_To ( New_Reference_To
Find_Prim_Op (Etype (Etype (Obj)), (Find_Prim_Op
Name_uDisp_Timed_Select), (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc),
Loc), Parameter_Associations => Params));
Parameter_Associations =>
Params));
-- Generate: -- Generate:
-- if C = POK_Protected_Entry -- if C = POK_Protected_Entry
...@@ -11274,24 +11268,22 @@ package body Exp_Ch9 is ...@@ -11274,24 +11268,22 @@ package body Exp_Ch9 is
Append_To (Conc_Typ_Stmts, Append_To (Conc_Typ_Stmts,
Make_If_Statement (Loc, Make_If_Statement (Loc,
Condition => Condition =>
Make_Or_Else (Loc, Make_Or_Else (Loc,
Left_Opnd => Left_Opnd =>
Make_Op_Eq (Loc, Make_Op_Eq (Loc,
Left_Opnd => Left_Opnd => New_Reference_To (C, Loc),
New_Reference_To (C, Loc),
Right_Opnd => Right_Opnd =>
New_Reference_To (RTE ( New_Reference_To
RE_POK_Protected_Entry), Loc)), (RTE (RE_POK_Protected_Entry), Loc)),
Right_Opnd => Right_Opnd =>
Make_Op_Eq (Loc, Make_Op_Eq (Loc,
Left_Opnd => Left_Opnd => New_Reference_To (C, Loc),
New_Reference_To (C, Loc),
Right_Opnd => Right_Opnd =>
New_Reference_To (RTE (RE_POK_Task_Entry), Loc))), New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
Then_Statements => Then_Statements => Unpack));
Unpack));
end if; end if;
-- Generate: -- Generate:
...@@ -11317,33 +11309,30 @@ package body Exp_Ch9 is ...@@ -11317,33 +11309,30 @@ package body Exp_Ch9 is
Make_Or_Else (Loc, Make_Or_Else (Loc,
Left_Opnd => Left_Opnd =>
Make_Op_Eq (Loc, Make_Op_Eq (Loc,
Left_Opnd => Left_Opnd => New_Reference_To (C, Loc),
New_Reference_To (C, Loc),
Right_Opnd => Right_Opnd =>
New_Reference_To (RTE (RE_POK_Procedure), Loc)), New_Reference_To (RTE (RE_POK_Procedure), Loc)),
Right_Opnd => Right_Opnd =>
Make_Or_Else (Loc, Make_Or_Else (Loc,
Left_Opnd => Left_Opnd =>
Make_Op_Eq (Loc, Make_Op_Eq (Loc,
Left_Opnd => Left_Opnd => New_Reference_To (C, Loc),
New_Reference_To (C, Loc),
Right_Opnd => Right_Opnd =>
New_Reference_To (RTE ( New_Reference_To (RTE (
RE_POK_Protected_Procedure), Loc)), RE_POK_Protected_Procedure), Loc)),
Right_Opnd => Right_Opnd =>
Make_Op_Eq (Loc, Make_Op_Eq (Loc,
Left_Opnd => Left_Opnd => New_Reference_To (C, Loc),
New_Reference_To (C, Loc),
Right_Opnd => Right_Opnd =>
New_Reference_To (RTE ( New_Reference_To
RE_POK_Task_Procedure), Loc)))), (RTE (RE_POK_Task_Procedure), Loc)))),
Then_Statements => Then_Statements => New_List (E_Call)));
New_List (E_Call)));
Append_To (Conc_Typ_Stmts, Append_To (Conc_Typ_Stmts,
Make_If_Statement (Loc, Make_If_Statement (Loc,
Condition => New_Reference_To (B, Loc), Condition => New_Reference_To (B, Loc),
Then_Statements => N_Stats, Then_Statements => N_Stats,
Else_Statements => D_Stats)); Else_Statements => D_Stats));
...@@ -11363,18 +11352,13 @@ package body Exp_Ch9 is ...@@ -11363,18 +11352,13 @@ package body Exp_Ch9 is
Append_To (Stmts, Append_To (Stmts,
Make_If_Statement (Loc, Make_If_Statement (Loc,
Condition => Condition =>
Make_Op_Eq (Loc, Make_Op_Eq (Loc,
Left_Opnd => Left_Opnd => New_Reference_To (K, Loc),
New_Reference_To (K, Loc),
Right_Opnd => Right_Opnd =>
New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)), New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
Then_Statements => Lim_Typ_Stmts,
Then_Statements => Else_Statements => Conc_Typ_Stmts));
Lim_Typ_Stmts,
Else_Statements =>
Conc_Typ_Stmts));
else else
-- Skip assignments to temporaries created for in-out parameters. -- Skip assignments to temporaries created for in-out parameters.
...@@ -11391,7 +11375,7 @@ package body Exp_Ch9 is ...@@ -11391,7 +11375,7 @@ package body Exp_Ch9 is
Insert_Before (Stmt, Insert_Before (Stmt,
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => New_Reference_To (D, Loc), Name => New_Reference_To (D, Loc),
Expression => D_Conv)); Expression => D_Conv));
Call := Stmt; Call := Stmt;
...@@ -11451,8 +11435,9 @@ package body Exp_Ch9 is ...@@ -11451,8 +11435,9 @@ package body Exp_Ch9 is
Rewrite (Call, Rewrite (Call,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To ( Name =>
RTE (RE_Timed_Protected_Single_Entry_Call), Loc), New_Reference_To
(RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
Parameter_Associations => Params)); Parameter_Associations => Params));
when others => when others =>
...@@ -11477,14 +11462,14 @@ package body Exp_Ch9 is ...@@ -11477,14 +11462,14 @@ package body Exp_Ch9 is
Append_To (Stmts, Append_To (Stmts,
Make_Implicit_If_Statement (N, Make_Implicit_If_Statement (N,
Condition => New_Reference_To (B, Loc), Condition => New_Reference_To (B, Loc),
Then_Statements => E_Stats, Then_Statements => E_Stats,
Else_Statements => D_Stats)); Else_Statements => D_Stats));
end if; end if;
Rewrite (N, Rewrite (N,
Make_Block_Statement (Loc, Make_Block_Statement (Loc,
Declarations => Decls, Declarations => Decls,
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts))); Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
......
gcc/ada/exp_light.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ L I G H T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Exp_Attr_Light; use Exp_Attr_Light;
with Exp_Ch6_Light; use Exp_Ch6_Light;
with Exp_Ch7_Light; use Exp_Ch7_Light;
with Sinfo; use Sinfo;
package body Exp_Light is
------------------
-- Expand_Light --
------------------
procedure Expand_Light (N : Node_Id) is
begin
case Nkind (N) is
when N_Package_Declaration =>
Expand_Light_N_Package_Declaration (N);
when N_Simple_Return_Statement =>
Expand_Light_N_Simple_Return_Statement (N);
when N_Subprogram_Body =>
Expand_Light_N_Subprogram_Body (N);
when N_Function_Call |
N_Procedure_Call_Statement =>
Expand_Light_Call (N);
when N_Attribute_Reference =>
Expand_Light_N_Attribute_Reference (N);
when others =>
null;
end case;
end Expand_Light;
end Exp_Light;
gcc/ada/exp_light.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ L I G H T --
-- --
-- S p e c --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package implements a light expansion which is used in formal
-- verification mode. Instead of a complete expansion of nodes for code
-- generation, this light expansion targets generation of intermediate code
-- for formal verification.
-- Expand_Light is called directly by Expander.Expand.
-- Light expansion has three main objectives:
-- 1. Perform limited expansion to explicit some Ada rules and constructs
-- (translate 'Old and 'Result, replace renamings by renamed, insert
-- conversions, expand actuals in calls to introduce temporaries)
-- 2. Facilitate treatment for the formal verification back-end (fully
-- qualify names)
-- 3. Avoid the introduction of low-level code that is difficult to analyze
-- formally, as typically done in the full expansion for high-level
-- constructs (tasking, dispatching)
with Types; use Types;
package Exp_Light is
procedure Expand_Light (N : Node_Id);
end Exp_Light;
gcc/ada/exp_prag.adb
...@@ -321,6 +321,15 @@ package body Exp_Prag is ...@@ -321,6 +321,15 @@ package body Exp_Prag is
-- be an explicit conditional in the source, not an implicit if, so we -- be an explicit conditional in the source, not an implicit if, so we
-- do not call Make_Implicit_If_Statement. -- do not call Make_Implicit_If_Statement.
-- In formal verification mode, we keep the pragma check in the code,
-- and its enclosed expression is not expanded. This requires that no
-- transient scope is introduced for pragma check in this mode in
-- Exp_Ch7.Establish_Transient_Scope.
if ALFA_Mode then
return;
end if;
-- Case where we generate a direct raise -- Case where we generate a direct raise
if ((Debug_Flag_Dot_G if ((Debug_Flag_Dot_G
......
gcc/ada/gnat1drv.adb
...@@ -435,9 +435,8 @@ procedure Gnat1drv is ...@@ -435,9 +435,8 @@ procedure Gnat1drv is
Polling_Required := False; Polling_Required := False;
-- Set operating mode to Generate_Code, but full front-end expansion -- Set operating mode to Generate_Code to benefit from full front-end
-- is not desirable in ALFA mode, so a light expansion is performed -- expansion (e.g. default arguments).
-- instead.
Operating_Mode := Generate_Code; Operating_Mode := Generate_Code;
......
gcc/ada/s-secsta.adb
...@@ -33,6 +33,7 @@ pragma Compiler_Unit; ...@@ -33,6 +33,7 @@ pragma Compiler_Unit;
with System.Soft_Links; with System.Soft_Links;
with System.Parameters; with System.Parameters;
with Ada.Unchecked_Conversion; with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation; with Ada.Unchecked_Deallocation;
......
gcc/ada/s-tassta.adb
...@@ -1023,9 +1023,10 @@ package body System.Tasking.Stages is ...@@ -1023,9 +1023,10 @@ package body System.Tasking.Stages is
Secondary_Stack_Size : Secondary_Stack_Size :
constant SSE.Storage_Offset := constant SSE.Storage_Offset :=
Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size * Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
SSE.Storage_Offset (Parameters.Sec_Stack_Percentage) / 100; SSE.Storage_Offset (Parameters.Sec_Stack_Percentage) / 100;
Secondary_Stack : aliased SSE.Storage_Array (1 .. Secondary_Stack_Size); Secondary_Stack : aliased SSE.Storage_Array (1 .. Secondary_Stack_Size);
-- Actual area allocated for secondary stack
Secondary_Stack_Address : System.Address := Secondary_Stack'Address; Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
-- Address of secondary stack. In the fixed secondary stack case, this -- Address of secondary stack. In the fixed secondary stack case, this
...@@ -1086,6 +1087,8 @@ package body System.Tasking.Stages is ...@@ -1086,6 +1087,8 @@ package body System.Tasking.Stages is
end if; end if;
end Search_Fall_Back_Handler; end Search_Fall_Back_Handler;
-- Start of processing for Task_Wrapper
begin begin
pragma Assert (Self_ID.Deferral_Level = 1); pragma Assert (Self_ID.Deferral_Level = 1);
......
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