Skip to content

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

[multiple changes] 

2011-08-30  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Add_Internal_Interface_Entities): If serious errors have
	been reported and a subprogram covering an interface primitive is not
	found then skip generating the internal entity. Done to avoid crashing
	the frontend.
	(Check_Abstract_Overriding): Change text of error of wrong formal of
	protected subprogram or entry. Done for consistency to emit exactly the
	same error reported by Check_Synchronized_Overriding. In addition, the
	error is restricted to protected types (bug found working on AI05-0090)

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

	* exp_aggr.adb, exp_ch11.adb, exp_prag.adb: Remove early exit during
	expansion in Alfa mode.
	* exp_ch6.adb, exp_ch6.ads (Expand_Actuals): Make subprogram public.
	* exp_light.adb, exp_light.ads: New package defining light expansion.
	* expander.adb (Expand): Call light expansion in Alfa mode
	* exp_ch6_light.adb, exp_ch6_light.ads: Light expansion of chapter 6
	constructs.
	* exp_ch7_light.adb, exp_ch7_light.ads: Light expansion of chapter 7
	constructs.
	* exp_attr_light.adb, exp_attr_light.ads: Light expansion of attributes
	* gnat1drv.adb (Adjust_Global_Switches): Comment

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

	* lib-xref-alfa.adb: Minor refactoring.

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

	* exp_ch9.adb (Expand_Entry_Barrier): Do not perform expansion in Alfa
	mode.
	* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not perform
	expansion in Alfa mode.
	* sem_ch9.adb (Analyze_Entry_Body): Do not perform expansion in Alfa
	mode.

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

	* debug_a.adb: Update comment.

From-SVN: r178304
parent 996c8821
Showing with 613 additions and 60 deletions
gcc/ada/ChangeLog
2011-08-30 Javier Miranda <miranda@adacore.com>
* sem_ch3.adb (Add_Internal_Interface_Entities): If serious errors have
been reported and a subprogram covering an interface primitive is not
found then skip generating the internal entity. Done to avoid crashing
the frontend.
(Check_Abstract_Overriding): Change text of error of wrong formal of
protected subprogram or entry. Done for consistency to emit exactly the
same error reported by Check_Synchronized_Overriding. In addition, the
error is restricted to protected types (bug found working on AI05-0090)
2011-08-30 Yannick Moy <moy@adacore.com>
* exp_aggr.adb, exp_ch11.adb, exp_prag.adb: Remove early exit during
expansion in Alfa mode.
* exp_ch6.adb, exp_ch6.ads (Expand_Actuals): Make subprogram public.
* exp_light.adb, exp_light.ads: New package defining light expansion.
* expander.adb (Expand): Call light expansion in Alfa mode
* exp_ch6_light.adb, exp_ch6_light.ads: Light expansion of chapter 6
constructs.
* exp_ch7_light.adb, exp_ch7_light.ads: Light expansion of chapter 7
constructs.
* exp_attr_light.adb, exp_attr_light.ads: Light expansion of attributes
* gnat1drv.adb (Adjust_Global_Switches): Comment
2011-08-30 Yannick Moy <moy@adacore.com>
* lib-xref-alfa.adb: Minor refactoring.
2011-08-30 Yannick Moy <moy@adacore.com>
* exp_ch9.adb (Expand_Entry_Barrier): Do not perform expansion in Alfa
mode.
* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not perform
expansion in Alfa mode.
* sem_ch9.adb (Analyze_Entry_Body): Do not perform expansion in Alfa
mode.
2011-08-30 Robert Dewar <dewar@adacore.com>
* debug_a.adb: Update comment.
2011-08-30 Robert Dewar <dewar@adacore.com> 2011-08-30 Robert Dewar <dewar@adacore.com>
* exp_ch5.adb, sem_ch3.adb, sem_ch5.adb, einfo.adb, checks.adb, * exp_ch5.adb, sem_ch3.adb, sem_ch5.adb, einfo.adb, checks.adb,
......
gcc/ada/debug_a.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2011, 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- --
...@@ -75,6 +75,8 @@ package body Debug_A is ...@@ -75,6 +75,8 @@ package body Debug_A is
-- Now push the new element -- Now push the new element
-- Why is this done unconditionally???
Debug_A_Depth := Debug_A_Depth + 1; Debug_A_Depth := Debug_A_Depth + 1;
if Debug_A_Depth <= Max_Node_Ids then if Debug_A_Depth <= Max_Node_Ids then
...@@ -101,6 +103,8 @@ package body Debug_A is ...@@ -101,6 +103,8 @@ package body Debug_A is
-- We look down the stack to find something with a decent Sloc. (If -- We look down the stack to find something with a decent Sloc. (If
-- we find nothing, just leave it unchanged which is not so terrible) -- we find nothing, just leave it unchanged which is not so terrible)
-- This seems nasty overhead for the normal case ???
for J in reverse 1 .. Integer'Min (Max_Node_Ids, Debug_A_Depth) loop for J in reverse 1 .. Integer'Min (Max_Node_Ids, Debug_A_Depth) loop
if Sloc (Node_Ids (J)) > No_Location then if Sloc (Node_Ids (J)) > No_Location then
Current_Error_Node := Node_Ids (J); Current_Error_Node := Node_Ids (J);
......
gcc/ada/exp_aggr.adb
...@@ -4664,12 +4664,6 @@ package body Exp_Aggr is ...@@ -4664,12 +4664,6 @@ 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 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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,7 +1673,6 @@ package body Exp_Ch11 is ...@@ -1673,7 +1673,6 @@ 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,36 +156,6 @@ package body Exp_Ch6 is ...@@ -156,36 +156,6 @@ 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,6 +37,36 @@ package Exp_Ch6 is ...@@ -37,6 +37,36 @@ 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 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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
...@@ -5206,7 +5206,9 @@ package body Exp_Ch9 is ...@@ -5206,7 +5206,9 @@ package body Exp_Ch9 is
-- barrier just as a protected function, and discard the protected -- barrier just as a protected function, and discard the protected
-- version of it because it is never called. -- version of it because it is never called.
if Expander_Active then if Expander_Active
and then not ALFA_Mode
then
B_F := Build_Barrier_Function (N, Ent, Prot); B_F := Build_Barrier_Function (N, Ent, Prot);
Func := Barrier_Function (Ent); Func := Barrier_Function (Ent);
Set_Corresponding_Spec (B_F, Func); Set_Corresponding_Spec (B_F, Func);
...@@ -5245,6 +5247,7 @@ package body Exp_Ch9 is ...@@ -5245,6 +5247,7 @@ package body Exp_Ch9 is
-- within the function. -- within the function.
if Expander_Active if Expander_Active
and then not ALFA_Mode
and then Scope (Entity (Cond)) /= Func and then Scope (Entity (Cond)) /= Func
then then
Set_Declarations (B_F, Empty_List); Set_Declarations (B_F, Empty_List);
......
gcc/ada/exp_light.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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,15 +321,6 @@ package body Exp_Prag is ...@@ -321,15 +321,6 @@ 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,8 +435,9 @@ procedure Gnat1drv is ...@@ -435,8 +435,9 @@ procedure Gnat1drv is
Polling_Required := False; Polling_Required := False;
-- Set operating mode to Generate_Code to benefit from full front-end -- Set operating mode to Generate_Code, but full front-end expansion
-- expansion (e.g. default arguments). -- is not desirable in ALFA mode, so a light expansion is performed
-- instead.
Operating_Mode := Generate_Code; Operating_Mode := Generate_Code;
......
gcc/ada/lib-xref-alfa.adb
...@@ -158,7 +158,7 @@ package body ALFA is ...@@ -158,7 +158,7 @@ package body ALFA is
Table_Name => "Drefs"); Table_Name => "Drefs");
-- Table of cross-references for reads and writes through explicit -- Table of cross-references for reads and writes through explicit
-- dereferences, that are output as reads/writes to the special variable -- dereferences, that are output as reads/writes to the special variable
-- "HEAP". These references are added to the regular references when -- "Heap". These references are added to the regular references when
-- computing ALFA cross-references. -- computing ALFA cross-references.
----------------------- -----------------------
...@@ -543,7 +543,7 @@ package body ALFA is ...@@ -543,7 +543,7 @@ package body ALFA is
end loop; end loop;
-- Add dereferences to the set of regular references, by creating a -- Add dereferences to the set of regular references, by creating a
-- special "HEAP" variable for these special references. -- special "Heap" variable for these special references.
Name_Len := Name_Of_Heap_Variable'Length; Name_Len := Name_Of_Heap_Variable'Length;
Name_Buffer (1 .. Name_Len) := Name_Of_Heap_Variable; Name_Buffer (1 .. Name_Len) := Name_Of_Heap_Variable;
...@@ -559,8 +559,10 @@ package body ALFA is ...@@ -559,8 +559,10 @@ package body ALFA is
Set_Has_Fully_Qualified_Name (Heap); Set_Has_Fully_Qualified_Name (Heap);
for J in Drefs.First .. Drefs.Last loop for J in Drefs.First .. Drefs.Last loop
Xrefs.Increment_Last; Xrefs.Append (Drefs.Table (J));
Xrefs.Table (Xrefs.Last) := Drefs.Table (J);
-- Set entity at this point with newly created "Heap" variable
Xrefs.Table (Xrefs.Last).Ent := Heap; Xrefs.Table (Xrefs.Last).Ent := Heap;
Nrefs := Nrefs + 1; Nrefs := Nrefs + 1;
...@@ -1047,7 +1049,7 @@ package body ALFA is ...@@ -1047,7 +1049,7 @@ package body ALFA is
Ref_Scope := Enclosing_Subprogram_Or_Package (N); Ref_Scope := Enclosing_Subprogram_Or_Package (N);
-- Entity is filled later on with the special "HEAP" variable -- Entity is filled later on with the special "Heap" variable
Drefs.Table (Indx).Ent := Empty; Drefs.Table (Indx).Ent := Empty;
...@@ -1055,7 +1057,7 @@ package body ALFA is ...@@ -1055,7 +1057,7 @@ package body ALFA is
Drefs.Table (Indx).Loc := Ref; Drefs.Table (Indx).Loc := Ref;
Drefs.Table (Indx).Typ := Typ; Drefs.Table (Indx).Typ := Typ;
-- It is as if the special "HEAP" was defined in every scope where it -- It is as if the special "Heap" was defined in every scope where it
-- is referenced. -- is referenced.
Drefs.Table (Indx).Eun := Get_Source_Unit (Ref); Drefs.Table (Indx).Eun := Get_Source_Unit (Ref);
......
gcc/ada/sem_ch3.adb
...@@ -1609,6 +1609,10 @@ package body Sem_Ch3 is ...@@ -1609,6 +1609,10 @@ package body Sem_Ch3 is
(Tagged_Type => Tagged_Type, (Tagged_Type => Tagged_Type,
Iface_Prim => Iface_Prim); Iface_Prim => Iface_Prim);
if No (Prim) and then Serious_Errors_Detected > 0 then
goto Continue;
end if;
pragma Assert (Present (Prim)); pragma Assert (Present (Prim));
-- Ada 2012 (AI05-0197): If the name of the covering primitive -- Ada 2012 (AI05-0197): If the name of the covering primitive
...@@ -1669,6 +1673,7 @@ package body Sem_Ch3 is ...@@ -1669,6 +1673,7 @@ package body Sem_Ch3 is
Set_Has_Delayed_Freeze (New_Subp); Set_Has_Delayed_Freeze (New_Subp);
end if; end if;
<<Continue>>
Next_Elmt (Elmt); Next_Elmt (Elmt);
end loop; end loop;
...@@ -9163,13 +9168,16 @@ package body Sem_Ch3 is ...@@ -9163,13 +9168,16 @@ package body Sem_Ch3 is
if Ekind (First_Formal (Subp)) = E_In_Parameter if Ekind (First_Formal (Subp)) = E_In_Parameter
and then Ekind (Subp) /= E_Function and then Ekind (Subp) /= E_Function
then then
if not Is_Predefined_Dispatching_Operation (Subp) then if not Is_Predefined_Dispatching_Operation (Subp)
and then Is_Protected_Type
(Corresponding_Concurrent_Type (T))
then
Error_Msg_NE Error_Msg_NE
("first formal of & must be of mode `OUT`, " & ("first formal of & must be of mode `OUT`, " &
"`IN OUT` or access-to-variable", T, Subp); "`IN OUT` or access-to-variable", T, Subp);
Error_Msg_N Error_Msg_N
("\to be overridden by protected procedure or " & ("\in order to be overridden by protected procedure "
"entry (RM 9.4(11.9/2))", T); & "or entry (RM 9.4(11.9/2))", T);
end if; end if;
-- Some other kind of overriding failure -- Some other kind of overriding failure
...@@ -17437,7 +17445,7 @@ package body Sem_Ch3 is ...@@ -17437,7 +17445,7 @@ package body Sem_Ch3 is
-- Ada 2005 (AI-251): The partial view shall be a descendant of -- Ada 2005 (AI-251): The partial view shall be a descendant of
-- an interface type if and only if the full type is descendant -- an interface type if and only if the full type is descendant
-- of the interface type (AARM 7.3 (7.3/2). -- of the interface type (AARM 7.3 (7.3/2)).
Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
......
gcc/ada/sem_ch6.adb
...@@ -2700,6 +2700,7 @@ package body Sem_Ch6 is ...@@ -2700,6 +2700,7 @@ package body Sem_Ch6 is
-- references entities which were created during regular expansion. -- references entities which were created during regular expansion.
if Expander_Active if Expander_Active
and then not ALFA_Mode
and then Comes_From_Source (N) and then Comes_From_Source (N)
and then Present (Prot_Typ) and then Present (Prot_Typ)
and then Present (Spec_Id) and then Present (Spec_Id)
......
gcc/ada/sem_ch9.adb
...@@ -728,6 +728,7 @@ package body Sem_Ch9 is ...@@ -728,6 +728,7 @@ package body Sem_Ch9 is
-- entry family index (if applicable). -- entry family index (if applicable).
if Expander_Active if Expander_Active
and then not ALFA_Mode
and then Is_Protected_Type (P_Type) and then Is_Protected_Type (P_Type)
then then
Install_Private_Data_Declarations Install_Private_Data_Declarations
......
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