Skip to content

R
riscv-gcc-1
Commit 42f11e4c by Arnaud Charlet
Options

[multiple changes] 

2016-05-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_prag.adb, comperr.adb: Minor reformatting.

2016-05-02  Ed Schonberg  <schonberg@adacore.com>

	* exp_pakd.adb (Rj_Unchecked_Convert_To): Do not perform an
	unchecked conversion if the source size is 0 (indicating that
	its RM size is unknown). This will happen with packed arrays of
	non-discrete types, in which case the component type is known
	to match.

2016-05-02  Arnaud Charlet  <charlet@adacore.com>

	* debug.adb: Reserve -gnatd.V.

2016-05-02  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Process_Full_View): Remove from visibility
	wrappers of synchronized types to avoid spurious errors with
	their wrapped entity.
	* exp_ch9.adb (Build_Wrapper_Spec): Do not generate the wrapper
	if no interface primitive is covered by the subprogram and this is
	not a primitive declared between two views; see Process_Full_View.
	(Build_Protected_Sub_Specification): Link the dispatching
	subprogram with its original non-dispatching protected subprogram
	since their names differ.
	(Expand_N_Protected_Type_Declaration):
	If a protected subprogram overrides an interface primitive then
	do not build a wrapper if it was already built.
	* einfo.ads, einfo.adb (Original_Protected_Subprogram): New attribute.
	* sem_ch4.adb (Names_Match): New subprogram.
	* sem_ch6.adb (Check_Synchronized_Overriding): Moved
	to library level and defined in the public part of the
	package to invoke it from Exp_Ch9.Build_Wrapper_Spec
	(Has_Matching_Entry_Or_Subprogram): New subprogram.
	(Report_Conflict): New subprogram.

From-SVN: r235739
parent 331e5015
Showing with 208 additions and 59 deletions
gcc/ada/ChangeLog
2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
* exp_prag.adb, comperr.adb: Minor reformatting.
2016-05-02 Ed Schonberg <schonberg@adacore.com>
* exp_pakd.adb (Rj_Unchecked_Convert_To): Do not perform an
unchecked conversion if the source size is 0 (indicating that
its RM size is unknown). This will happen with packed arrays of
non-discrete types, in which case the component type is known
to match.
2016-05-02 Arnaud Charlet <charlet@adacore.com>
* debug.adb: Reserve -gnatd.V.
2016-05-02 Javier Miranda <miranda@adacore.com>
* sem_ch3.adb (Process_Full_View): Remove from visibility
wrappers of synchronized types to avoid spurious errors with
their wrapped entity.
* exp_ch9.adb (Build_Wrapper_Spec): Do not generate the wrapper
if no interface primitive is covered by the subprogram and this is
not a primitive declared between two views; see Process_Full_View.
(Build_Protected_Sub_Specification): Link the dispatching
subprogram with its original non-dispatching protected subprogram
since their names differ.
(Expand_N_Protected_Type_Declaration):
If a protected subprogram overrides an interface primitive then
do not build a wrapper if it was already built.
* einfo.ads, einfo.adb (Original_Protected_Subprogram): New attribute.
* sem_ch4.adb (Names_Match): New subprogram.
* sem_ch6.adb (Check_Synchronized_Overriding): Moved
to library level and defined in the public part of the
package to invoke it from Exp_Ch9.Build_Wrapper_Spec
(Has_Matching_Entry_Or_Subprogram): New subprogram.
(Report_Conflict): New subprogram.
2016-05-02 Jerome Lambourg <lambourg@adacore.com>
* s-unstyp.ads: Code cleanups.
......
gcc/ada/comperr.adb
......@@ -467,8 +467,9 @@ package body Comperr is
Main := Unit (Cunit (Main_Unit));
case Nkind (Main) is
when N_Subprogram_Declaration | N_Subprogram_Body |
N_Package_Declaration =>
when N_Package_Declaration |
N_Subprogram_Body |
N_Subprogram_Declaration =>
Unit_Name := Defining_Unit_Name (Specification (Main));
when N_Package_Body =>
......
gcc/ada/debug.adb
......@@ -139,7 +139,7 @@ package body Debug is
-- d.S Force Optimize_Alignment (Space)
-- d.T Force Optimize_Alignment (Time)
-- d.U Ignore indirect calls for static elaboration
-- d.V
-- d.V Do not verify validity of SCIL files (CodePeer mode)
-- d.W Print out debugging information for Walk_Library_Items
-- d.X Old treatment of indexing aspects
-- d.Y
......@@ -686,6 +686,12 @@ package body Debug is
-- reverts to the behavior of earlier compilers, which ignored
-- indirect calls.
-- d.V Do not verify the validity of SCIL files (CodePeer mode). When
-- generating SCIL files for CodePeer, by default we verify that the
-- SCIL is well formed before saving it on disk. This switch can be
-- used to disable this checking, either to improve speed or to shut
-- down a false positive detected during the verification.
-- d.W Print out debugging information for Walk_Library_Items, including
-- the order in which units are walked. This is primarily for use in
-- debugging CodePeer mode.
......
gcc/ada/einfo.adb
......@@ -274,6 +274,7 @@ package body Einfo is
-- SPARK_Pragma Node40
-- Original_Protected_Subprogram Node41
-- SPARK_Aux_Pragma Node41
---------------------------------------------
......@@ -2837,6 +2838,11 @@ package body Einfo is
return Node21 (Id);
end Original_Array_Type;
function Original_Protected_Subprogram (Id : E) return N is
begin
return Node41 (Id);
end Original_Protected_Subprogram;
function Original_Record_Component (Id : E) return E is
begin
pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant));
......@@ -5900,6 +5906,12 @@ package body Einfo is
Set_Node21 (Id, V);
end Set_Original_Array_Type;
procedure Set_Original_Protected_Subprogram (Id : E; V : N) is
begin
pragma Assert (Ekind_In (Id, E_Procedure, E_Function));
Set_Node41 (Id, V);
end Set_Original_Protected_Subprogram;
procedure Set_Original_Record_Component (Id : E; V : E) is
begin
pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant));
......@@ -10483,6 +10495,10 @@ package body Einfo is
E_Task_Type =>
Write_Str ("SPARK_Aux_Pragma");
when E_Function |
E_Procedure =>
Write_Str ("Original_Protected_Subprogram");
when others =>
Write_Str ("Field41??");
end case;
......
gcc/ada/einfo.ads
......@@ -3647,6 +3647,11 @@ package Einfo is
-- points to the original array type for which this is the packed
-- array implementation type.
-- Original_Protected_Subprogram (Node41)
-- Defined in functions and procedures. Set only on internally built
-- dispatching subprograms of protected types to reference their original
-- non-dispatching protected subprogram since their names differ.
-- Original_Record_Component (Node22)
-- Defined in components, including discriminants. The usage depends
-- on whether the record is a base type and whether it is tagged.
......@@ -5923,6 +5928,7 @@ package Einfo is
-- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39)
-- SPARK_Pragma (Node40)
-- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- Default_Expressions_Processed (Flag108)
......@@ -6234,6 +6240,7 @@ package Einfo is
-- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39)
-- SPARK_Pragma (Node40)
-- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- Delay_Cleanups (Flag114)
......@@ -7127,6 +7134,7 @@ package Einfo is
function Optimize_Alignment_Time (Id : E) return B;
function Original_Access_Type (Id : E) return E;
function Original_Array_Type (Id : E) return E;
function Original_Protected_Subprogram (Id : E) return N;
function Original_Record_Component (Id : E) return E;
function Overlays_Constant (Id : E) return B;
function Overridden_Operation (Id : E) return E;
......@@ -7801,6 +7809,7 @@ package Einfo is
procedure Set_Optimize_Alignment_Time (Id : E; V : B := True);
procedure Set_Original_Access_Type (Id : E; V : E);
procedure Set_Original_Array_Type (Id : E; V : E);
procedure Set_Original_Protected_Subprogram (Id : E; V : N);
procedure Set_Original_Record_Component (Id : E; V : E);
procedure Set_Overlays_Constant (Id : E; V : B := True);
procedure Set_Overridden_Operation (Id : E; V : E);
......@@ -8628,6 +8637,7 @@ package Einfo is
pragma Inline (Optimize_Alignment_Time);
pragma Inline (Original_Access_Type);
pragma Inline (Original_Array_Type);
pragma Inline (Original_Protected_Subprogram);
pragma Inline (Original_Record_Component);
pragma Inline (Overlays_Constant);
pragma Inline (Overridden_Operation);
......@@ -9093,6 +9103,7 @@ package Einfo is
pragma Inline (Set_Optimize_Alignment_Time);
pragma Inline (Set_Original_Access_Type);
pragma Inline (Set_Original_Array_Type);
pragma Inline (Set_Original_Protected_Subprogram);
pragma Inline (Set_Original_Record_Component);
pragma Inline (Set_Overlays_Constant);
pragma Inline (Set_Overridden_Operation);
......
gcc/ada/exp_ch9.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
......@@ -2443,13 +2443,6 @@ package body Exp_Ch9 is
Obj_Typ : Entity_Id;
Formals : List_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Subp_Id);
First_Param : Node_Id;
Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
Iface_Op : Entity_Id;
Iface_Op_Elmt : Elmt_Id;
function Overriding_Possible
(Iface_Op : Entity_Id;
Wrapper : Entity_Id) return Boolean;
......@@ -2631,6 +2624,16 @@ package body Exp_Ch9 is
return New_Formals;
end Replicate_Formals;
-- Local variables
Loc : constant Source_Ptr := Sloc (Subp_Id);
First_Param : Node_Id := Empty;
Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
Iface_Op : Entity_Id;
Iface_Op_Elmt : Elmt_Id;
Overridden_Subp : Entity_Id;
-- Start of processing for Build_Wrapper_Spec
begin
......@@ -2638,17 +2641,24 @@ package body Exp_Ch9 is
pragma Assert (Is_Tagged_Type (Obj_Typ));
-- Check if this subprogram has a profile that matches some interface
-- primitive
Check_Synchronized_Overriding (Subp_Id, Overridden_Subp);
if Present (Overridden_Subp) then
First_Param :=
First (Parameter_Specifications (Parent (Overridden_Subp)));
-- An entry or a protected procedure can override a routine where the
-- controlling formal is either IN OUT, OUT or is of access-to-variable
-- type. Since the wrapper must have the exact same signature as that of
-- the overridden subprogram, we try to find the overriding candidate
-- and use its controlling formal.
First_Param := Empty;
-- Check every implemented interface
if Present (Interfaces (Obj_Typ)) then
elsif Present (Interfaces (Obj_Typ)) then
Iface_Elmt := First_Elmt (Interfaces (Obj_Typ));
Search : while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
......@@ -2684,40 +2694,14 @@ package body Exp_Ch9 is
end loop Search;
end if;
-- Ada 2012 (AI05-0090-1): If no interface primitive is covered by
-- this subprogram and this is not a primitive declared between two
-- views then force the generation of a wrapper. As an optimization,
-- previous versions of the frontend avoid generating the wrapper;
-- however, the wrapper facilitates locating and reporting an error
-- when a duplicate declaration is found later. See example in
-- AI05-0090-1.
-- Do not generate the wrapper if no interface primitive is covered by
-- the subprogram and it is not a primitive declared declared between
-- two views (see Process_Full_View).
if No (First_Param)
and then not Is_Private_Primitive_Subprogram (Subp_Id)
then
if Is_Task_Type
(Corresponding_Concurrent_Type (Obj_Typ))
then
First_Param :=
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
In_Present => True,
Out_Present => False,
Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc));
-- For entries and procedures of protected types the mode of
-- the controlling argument must be in-out.
else
First_Param :=
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => Name_uO),
In_Present => True,
Out_Present => (Ekind (Subp_Id) /= E_Function),
Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc));
end if;
return Empty;
end if;
declare
......@@ -4229,6 +4213,15 @@ package body Exp_Ch9 is
Make_Defining_Identifier (Loc,
Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode)));
-- Reference the original non-dispatching subprogram since the analysis
-- of the object.operation notation may need its original name (see
-- Sem_Ch4.Names_Match).
if Mode = Dispatching_Mode then
Set_Ekind (New_Id, Ekind (Def_Id));
Set_Original_Protected_Subprogram (New_Id, Def_Id);
end if;
-- The unprotected operation carries the user code, and debugging
-- information must be generated for it, even though this spec does
-- not come from source. It is also convenient to allow gdb to step
......@@ -9653,22 +9646,50 @@ package body Exp_Ch9 is
Current_Node := Sub;
-- Generate an overriding primitive operation specification for
-- this subprogram if the protected type implements an interface.
-- this subprogram if the protected type implements an interface
-- and Build_Wrapper_Spec did not not generate its wrapper.
if Ada_Version >= Ada_2005
and then
Present (Interfaces (Corresponding_Record_Type (Prot_Typ)))
then
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
(Comp, Prot_Typ, Dispatching_Mode));
declare
Prim_Elmt : Elmt_Id;
Prim_Op : Node_Id;
Found : Boolean := False;
Insert_After (Current_Node, Sub);
Analyze (Sub);
begin
Prim_Elmt :=
First_Elmt
(Primitive_Operations
(Corresponding_Record_Type (Prot_Typ)));
Current_Node := Sub;
while Present (Prim_Elmt) loop
Prim_Op := Node (Prim_Elmt);
if Is_Primitive_Wrapper (Prim_Op)
and then (Wrapped_Entity (Prim_Op))
= Defining_Entity (Specification (Comp))
then
Found := True;
exit;
end if;
Next_Elmt (Prim_Elmt);
end loop;
if not Found then
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
(Comp, Prot_Typ, Dispatching_Mode));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Current_Node := Sub;
end if;
end;
end if;
-- If a pragma Interrupt_Handler applies, build and add a call to
......
gcc/ada/exp_pakd.adb
......@@ -2298,9 +2298,12 @@ package body Exp_Pakd is
-- convert to a modular type of the source length, since otherwise, on
-- a big-endian machine, we get left-justification. We do it for little-
-- endian machines as well, because there might be junk bits that are
-- not cleared if the type is not numeric.
-- not cleared if the type is not numeric. This can be done only if the
-- source siz is different from 0 (i.e. known), otherwise we must trust
-- the type declarations (case of non-discrete components).
if Source_Siz /= Target_Siz
if Source_Siz /= 0
and then Source_Siz /= Target_Siz
and then not Is_Discrete_Type (Source_Typ)
then
Src := Unchecked_Convert_To (RTE (Bits_Id (Source_Siz)), Src);
......
gcc/ada/exp_prag.adb
......@@ -884,8 +884,8 @@ package body Exp_Prag is
Set_Expression (Decl, Pref);
Analyze (Decl);
-- Otherwise add an assignment statement to temporary
-- using prefix as RHS.
-- Otherwise add an assignment statement to temporary using
-- prefix as RHS.
else
Analyze (Decl);
......
gcc/ada/sem_ch3.adb
......@@ -19835,6 +19835,13 @@ package body Sem_Ch3 is
Curr_Nod := Wrap_Spec;
Analyze (Wrap_Spec);
-- Remove the wrapper from visibility to avoid
-- spurious conflict with the wrapped entity.
Set_Is_Immediately_Visible
(Defining_Entity (Specification (Wrap_Spec)),
False);
end if;
Next_Elmt (Prim_Elmt);
......
gcc/ada/sem_ch4.adb
......@@ -8817,6 +8817,15 @@ package body Sem_Ch4 is
-- is visible a direct call to it will dispatch to the private one,
-- which is therefore a valid candidate.
function Names_Match
(Obj_Type : Entity_Id;
Prim_Op : Entity_Id;
Subprog : Entity_Id) return Boolean;
-- Return True if the names of Prim_Op and Subprog match. If Obj_Type
-- is a protected type then compare also the original name of Prim_Op
-- with the name of Subprog (since the expander may have added a
-- prefix to its original name --see Exp_Ch9.Build_Selected_Name).
function Valid_First_Argument_Of (Op : Entity_Id) return Boolean;
-- Verify that the prefix, dereferenced if need be, is a valid
-- controlling argument in a call to Op. The remaining actuals
......@@ -8993,6 +9002,34 @@ package body Sem_Ch4 is
and then not Is_Hidden (Visible_Op);
end Is_Private_Overriding;
-----------------
-- Names_Match --
-----------------
function Names_Match
(Obj_Type : Entity_Id;
Prim_Op : Entity_Id;
Subprog : Entity_Id) return Boolean is
begin
-- Common case: exact match
if Chars (Prim_Op) = Chars (Subprog) then
return True;
-- For protected type primitives the expander may have built the
-- name of the dispatching primitive prepending the type name to
-- avoid conflicts with the name of the protected subprogram (see
-- Exp_Ch9.Build_Selected_Name).
elsif Is_Protected_Type (Obj_Type) then
return Present (Original_Protected_Subprogram (Prim_Op))
and then Chars (Original_Protected_Subprogram (Prim_Op))
= Chars (Subprog);
end if;
return False;
end Names_Match;
-----------------------------
-- Valid_First_Argument_Of --
-----------------------------
......@@ -9059,7 +9096,7 @@ package body Sem_Ch4 is
while Present (Elmt) loop
Prim_Op := Node (Elmt);
if Chars (Prim_Op) = Chars (Subprog)
if Names_Match (Obj_Type, Prim_Op, Subprog)
and then Present (First_Formal (Prim_Op))
and then Valid_First_Argument_Of (Prim_Op)
and then
......
gcc/ada/sem_ch6.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
......@@ -122,6 +122,15 @@ package Sem_Ch6 is
-- formal access-to-subprogram type, indicating that mapping of types
-- is needed.
procedure Check_Synchronized_Overriding
(Def_Id : Entity_Id;
Overridden_Subp : out Entity_Id);
-- First determine if Def_Id is an entry or a subprogram either defined
-- in the scope of a task or protected type, or is a primitive of such
-- a type. Check whether Def_Id overrides a subprogram of an interface
-- implemented by the synchronized type, return the overridden entity
-- or Empty.
procedure Check_Type_Conformant
(New_Id : Entity_Id;
Old_Id : Entity_Id;
......
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