mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-03 21:51:45 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2014-10-10  Robert Dewar  <dewar@adacore.com>

	* sem_ch7.adb, einfo.adb, einfo.ads, sem_prag.adb, sem_ch12.adb,
	freeze.adb, sem_util.adb, sem_res.adb, exp_ch6.adb, exp_ch13.adb,
	sem_ch6.adb, sem_cat.adb, sem_disp.adb
	(Is_Subprogram_Or_Generic_Subprogram): New primitive. Use this primitive
	throughout where appropriate.

2014-10-10  Bob Duff  <duff@adacore.com>

	* a-coinho-shared.ads: Minor reformatting.
	* s-traceb.adb: Minor clean up.

2014-10-10  Robert Dewar  <dewar@adacore.com>

	* ali.adb (Scan_ALI): Read and process new GP flag on ALI P line.
	* ali.ads (GNATprove_Mode): New component in ALI table.
	(GNATprove_Mode_Specified): New global.
	* gnatbind.adb (Gnatbind): Give fatal error if any file compiled
	in GNATProve mode.
	* lib-writ.ads, lib-writ.adb (GP): New flag on P line for
	GNATProve_Mode.

2014-10-10  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Build_Init_Procedure): Adding assertion.
	(Build_Init_Statement): Ensure that statements
	associated with the parent components are located at the beginning
	of the returned list of statements.

2014-10-10  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb (Inherit_Aspects_At_Freeze_Node): If the full
	view of a private type T that has a type invariant is a scalar
	or constrained array type, the base type created for the full
	view has the same type invariant.

From-SVN: r216074
This commit is contained in:
Arnaud Charlet 2014-10-10 14:21:19 +02:00
parent 1e3ed0fc93
commit b9696ffb6e
23 changed files with 170 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
gcc/ada/ChangeLog
View File

@ -1,3 +1,40 @@
2014-10-10 Robert Dewar <dewar@adacore.com>
* sem_ch7.adb, einfo.adb, einfo.ads, sem_prag.adb, sem_ch12.adb,
freeze.adb, sem_util.adb, sem_res.adb, exp_ch6.adb, exp_ch13.adb,
sem_ch6.adb, sem_cat.adb, sem_disp.adb
(Is_Subprogram_Or_Generic_Subprogram): New primitive. Use this primitive
throughout where appropriate.
2014-10-10 Bob Duff <duff@adacore.com>
* a-coinho-shared.ads: Minor reformatting.
* s-traceb.adb: Minor clean up.
2014-10-10 Robert Dewar <dewar@adacore.com>
* ali.adb (Scan_ALI): Read and process new GP flag on ALI P line.
* ali.ads (GNATprove_Mode): New component in ALI table.
(GNATprove_Mode_Specified): New global.
* gnatbind.adb (Gnatbind): Give fatal error if any file compiled
in GNATProve mode.
* lib-writ.ads, lib-writ.adb (GP): New flag on P line for
GNATProve_Mode.
2014-10-10 Javier Miranda <miranda@adacore.com>
* exp_ch3.adb (Build_Init_Procedure): Adding assertion.
(Build_Init_Statement): Ensure that statements
associated with the parent components are located at the beginning
of the returned list of statements.
2014-10-10 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Inherit_Aspects_At_Freeze_Node): If the full
view of a private type T that has a type invariant is a scalar
or constrained array type, the base type created for the full
view has the same type invariant.
2014-10-10 Robert Dewar <dewar@adacore.com>
* exp_util.ads, sem_ch12.adb, exp_util.adb, i-fortra.ads: Minor code

6
gcc/ada/a-coinho-shared.ads
View File

@ -29,12 +29,12 @@
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
-- Missing documentation: what is this unit all about??? From its name it
-- is some variation of a-coinho.ads/adb, but documentation needs to be
-- HERE explaining that ???
-- This is an optimized version of Indefinite_Holders using copy-on-write.
-- It is used on platforms that support atomic built-ins.
private with Ada.Finalization;
private with Ada.Streams;
private with System.Atomic_Counters;
generic

9
gcc/ada/ali.adb
View File

@ -111,6 +111,7 @@ package body ALI is
Locking_Policy_Specified := ' ';
No_Normalize_Scalars_Specified := False;
No_Object_Specified := False;
GNATprove_Mode_Specified := False;
Normalize_Scalars_Specified := False;
Partition_Elaboration_Policy_Specified := ' ';
Queuing_Policy_Specified := ' ';
@ -875,6 +876,7 @@ package body ALI is
First_Sdep => No_Sdep_Id,
First_Specific_Dispatching => Specific_Dispatching.Last + 1,
First_Unit => No_Unit_Id,
GNATprove_Mode => False,
Last_Interrupt_State => Interrupt_States.Last,
Last_Sdep => No_Sdep_Id,
Last_Specific_Dispatching => Specific_Dispatching.Last,
@ -1089,6 +1091,13 @@ package body ALI is
ALIs.Table (Id).Partition_Elaboration_Policy :=
Partition_Elaboration_Policy_Specified;
-- Processing for GP
elsif C = 'G' then
Checkc ('P');
GNATprove_Mode_Specified := True;
ALIs.Table (Id).GNATprove_Mode := True;
-- Processing for Lx
elsif C = 'L' then

8
gcc/ada/ali.ads
View File

@ -176,6 +176,11 @@ package ALI is
-- always be set as well in this case. Not set if 'P' appears in
-- Ignore_Lines.
GNATprove_Mode : Boolean;
-- Set to True if ALI and object file produced in GNATprove_Mode as
-- signalled by GP appearing on the P line. Not set if 'P' appears in
-- Ignore_Lines.
No_Object : Boolean;
-- Set to True if no object file generated. Not set if 'P' appears in
-- Ignore_Lines.
@ -465,6 +470,9 @@ package ALI is
-- Set to False by Initialize_ALI. Set to True if Scan_ALI reads
-- a unit for which dynamic elaboration checking is enabled.
GNATprove_Mode_Specified : Boolean := False;
-- Set to True if an ali file was produced in GNATprove mode.
Initialize_Scalars_Used : Boolean := False;
-- Set True if an ali file contains the Initialize_Scalars flag

27
gcc/ada/einfo.adb
View File

@ -1129,8 +1129,7 @@ package body Einfo is
E_Package_Body,
E_Subprogram_Body,
E_Variable)
or else Is_Generic_Subprogram (Id)
or else Is_Subprogram (Id));
or else Is_Subprogram_Or_Generic_Subprogram (Id));
return Node34 (Id);
end Contract;
@ -3405,6 +3404,13 @@ package body Einfo is
return Ekind (Id) in Subprogram_Kind;
end Is_Subprogram;
function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B is
begin
return Ekind (Id) in Subprogram_Kind
or else
Ekind (Id) in Generic_Subprogram_Kind;
end Is_Subprogram_Or_Generic_Subprogram;
function Is_Task_Type (Id : E) return B is
begin
return Ekind (Id) in Task_Kind;
@ -3593,15 +3599,14 @@ package body Einfo is
begin
pragma Assert
(Ekind_In (Id, E_Entry,
E_Entry_Family,
E_Generic_Package,
E_Package,
E_Package_Body,
E_Subprogram_Body,
E_Variable,
E_Void)
or else Is_Generic_Subprogram (Id)
or else Is_Subprogram (Id));
E_Entry_Family,
E_Generic_Package,
E_Package,
E_Package_Body,
E_Subprogram_Body,
E_Variable,
E_Void)
or else Is_Subprogram_Or_Generic_Subprogram (Id));
Set_Node34 (Id, V);
end Set_Contract;

6
gcc/ada/einfo.ads
View File

@ -2974,6 +2974,10 @@ package Einfo is
-- Applies to all entities, true for function, procedure and operator
-- entities.
-- Is_Subprogram_Or_Generic_Subprogram
-- Applies to all entities, true for function procedure and operator
-- entities, and also for the corresponding generic entities.
-- Is_Synchronized_Interface (synthesized)
-- Defined in types that are interfaces. True if interface is declared
-- synchronized, task, or protected, or is derived from a synchronized
@ -6964,6 +6968,7 @@ package Einfo is
function Is_Scalar_Type (Id : E) return B;
function Is_Signed_Integer_Type (Id : E) return B;
function Is_Subprogram (Id : E) return B;
function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B;
function Is_Task_Type (Id : E) return B;
function Is_Type (Id : E) return B;
@ -8800,6 +8805,7 @@ package Einfo is
pragma Inline (Is_Base_Type);
pragma Inline (Is_Package_Or_Generic_Package);
pragma Inline (Is_Packed_Array);
pragma Inline (Is_Subprogram_Or_Generic_Subprogram);
pragma Inline (Is_Volatile);
pragma Inline (Is_Wrapper_Package);
pragma Inline (Known_RM_Size);

2
gcc/ada/exp_ch13.adb
View File

@ -528,7 +528,7 @@ package body Exp_Ch13 is
and then
(Is_Entry (E_Scope)
or else (Is_Subprogram (E_Scope)
and then Is_Protected_Type (Scope (E_Scope)))
and then Is_Protected_Type (Scope (E_Scope)))
or else Is_Task_Type (E_Scope))
then
null;

64
gcc/ada/exp_ch3.adb
View File

@ -2372,7 +2372,15 @@ package body Exp_Ch3 is
-- generated.
if not Is_Interface (Etype (Rec_Ent)) then
Prepend_To (Body_Stmts, Remove_Head (Stmts));
declare
First_Stmt : constant Node_Id := Remove_Head (Stmts);
begin
pragma Assert
(Nkind (First_Stmt) = N_Procedure_Call_Statement
and then
Is_Init_Proc (Name (First_Stmt)));
Prepend_To (Body_Stmts, First_Stmt);
end;
end if;
Append_List_To (Body_Stmts, Stmts);
@ -2655,15 +2663,16 @@ package body Exp_Ch3 is
---------------------------
function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
Checks : constant List_Id := New_List;
Actions : List_Id := No_List;
Comp_Loc : Source_Ptr;
Counter_Id : Entity_Id := Empty;
Decl : Node_Id;
Has_POC : Boolean;
Id : Entity_Id;
Stmts : List_Id;
Typ : Entity_Id;
Checks : constant List_Id := New_List;
Actions : List_Id := No_List;
Comp_Loc : Source_Ptr;
Counter_Id : Entity_Id := Empty;
Decl : Node_Id;
Has_POC : Boolean;
Id : Entity_Id;
Parent_Stmts : List_Id;
Stmts : List_Id;
Typ : Entity_Id;
procedure Increment_Counter (Loc : Source_Ptr);
-- Generate an "increment by one" statement for the current counter
@ -2727,6 +2736,7 @@ package body Exp_Ch3 is
return New_List (Make_Null_Statement (Loc));
end if;
Parent_Stmts := New_List;
Stmts := New_List;
-- Loop through visible declarations of task types and protected
@ -2956,22 +2966,30 @@ package body Exp_Ch3 is
end if;
if Present (Checks) then
Append_List_To (Stmts, Checks);
if Chars (Id) = Name_uParent then
Append_List_To (Parent_Stmts, Checks);
else
Append_List_To (Stmts, Checks);
end if;
end if;
if Present (Actions) then
Append_List_To (Stmts, Actions);
if Chars (Id) = Name_uParent then
Append_List_To (Parent_Stmts, Actions);
-- Preserve the initialization state in the current counter
else
Append_List_To (Stmts, Actions);
if Chars (Id) /= Name_uParent
and then Needs_Finalization (Typ)
then
if No (Counter_Id) then
Make_Counter (Comp_Loc);
-- Preserve the initialization state in the current
-- counter
if Needs_Finalization (Typ) then
if No (Counter_Id) then
Make_Counter (Comp_Loc);
end if;
Increment_Counter (Comp_Loc);
end if;
Increment_Counter (Comp_Loc);
end if;
end if;
end if;
@ -2979,6 +2997,12 @@ package body Exp_Ch3 is
Next_Non_Pragma (Decl);
end loop;
-- The parent field must be initialized first because variable
-- size components of the parent affect the location of all the
-- new components.
Prepend_List_To (Stmts, Parent_Stmts);
-- Set up tasks and protected object support. This needs to be done
-- before any component with a per-object access discriminant
-- constraint, or any variant part (which may contain such

5
gcc/ada/exp_ch6.adb
View File

@ -5825,9 +5825,8 @@ package body Exp_Ch6 is
Defining_Identifier
(First (Parameter_Specifications (Parent (Corr))));
if Is_Subprogram (Proc)
and then Proc /= Corr
then
if Is_Subprogram (Proc) and then Proc /= Corr then
-- Protected function or procedure
Set_Entity (Rec, Param);

1
gcc/ada/freeze.adb
View File

@ -1703,7 +1703,6 @@ package body Freeze is
E := From;
while Present (E) loop
if Is_Subprogram (E) then
if not Default_Expressions_Processed (E) then
Process_Default_Expressions (E, After);
end if;

7
gcc/ada/gnatbind.adb
View File

@ -776,6 +776,13 @@ begin
raise Unrecoverable_Error;
end if;
-- Quit with message if we had a GNATprove file
if GNATprove_Mode_Specified then
Error_Msg ("one or more files compiled in GNATprove mode");
raise Unrecoverable_Error;
end if;
-- Output list of ALI files in closure
if Output_ALI_List then

4
gcc/ada/lib-writ.adb
View File

@ -1153,6 +1153,10 @@ package body Lib.Writ is
end if;
end if;
if GNATprove_Mode then
Write_Info_Str (" GP");
end if;
if Partition_Elaboration_Policy /= ' ' then
Write_Info_Str (" E");
Write_Info_Char (Partition_Elaboration_Policy);

7
gcc/ada/lib-writ.ads
View File

@ -192,6 +192,9 @@ package Lib.Writ is
-- the units in this file, where x is the first character
-- (upper case) of the policy name (e.g. 'C' for Concurrent).
-- GP Set if this compilation was done in GNATprove mode, either
-- from direct use of GNATprove, or from use of -gnatdF.
-- Lx A valid Locking_Policy pragma applies to all the units in
-- this file, where x is the first character (upper case) of
-- the policy name (e.g. 'C' for Ceiling_Locking).
@ -200,7 +203,9 @@ package Lib.Writ is
-- were not compiled to produce an object. This can occur as a
-- result of the use of -gnatc, or if no object can be produced
-- (e.g. when a package spec is compiled instead of the body,
-- or a subunit on its own).
-- or a subunit on its own). Note that in GNATprove mode, we
-- do produce an object. The object is not suitable for binding
-- and linking, but we do not set NO, instead we set GP.
-- NR No_Run_Time. Indicates that a pragma No_Run_Time applies
-- to all units in the file.

10
gcc/ada/s-traceb.adb
View File

@ -38,16 +38,6 @@ pragma Compiler_Unit_Warning;
package body System.Traceback is
-- procedure Call_Chain
-- (Traceback : System.Address;
-- Max_Len : Natural;
-- Len : out Natural;
-- Exclude_Min : System.Address := System.Null_Address;
-- Exclude_Max : System.Address := System.Null_Address;
-- Skip_Frames : Natural := 1);
-- -- Same as the exported version, but takes Traceback as an Address
-- ???See declaration in the spec for why this is temporarily commented out.
------------------
-- C_Call_Chain --
------------------

4
gcc/ada/sem_cat.adb
View File

@ -615,9 +615,7 @@ package body Sem_Cat is
E := Current_Scope;
loop
if Is_Subprogram (E)
or else
Is_Generic_Subprogram (E)
if Is_Subprogram_Or_Generic_Subprogram (E)
or else
Is_Concurrent_Type (E)
then

6
gcc/ada/sem_ch12.adb
View File

@ -3543,9 +3543,7 @@ package body Sem_Ch12 is
else
E := First_Entity (Gen_Unit);
while Present (E) loop
if Is_Subprogram (E)
and then Is_Inlined (E)
then
if Is_Subprogram (E) and then Is_Inlined (E) then
return True;
end if;
@ -6558,7 +6556,7 @@ package body Sem_Ch12 is
if Ekind (Scop) = E_Generic_Package
or else (Is_Subprogram (Scop)
and then Nkind (Unit_Declaration_Node (Scop)) =
and then Nkind (Unit_Declaration_Node (Scop)) =
N_Generic_Subprogram_Declaration)
then
Elmt := First_Elmt (Inner_Instances (Inner));

9
gcc/ada/sem_ch13.adb
View File

@ -10705,6 +10705,15 @@ package body Sem_Ch13 is
if Class_Present (Get_Rep_Item (Typ, Name_Invariant)) then
Set_Has_Inheritable_Invariants (Typ);
end if;
-- If the full view of the type is a scalar type or array type, the
-- implicit base type created for it has the same invariant.
elsif Has_Invariants (Typ) and then Base_Type (Typ) /= Typ
and then not Has_Invariants (Base_Type (Typ))
then
Set_Has_Invariants (Base_Type (Typ));
Set_Invariant_Procedure (Base_Type (Typ), Invariant_Procedure (Typ));
end if;
-- Volatile

2
gcc/ada/sem_ch6.adb
View File

@ -8406,7 +8406,7 @@ package body Sem_Ch6 is
procedure List_Inherited_Pre_Post_Aspects (E : Entity_Id) is
begin
if Opt.List_Inherited_Aspects
and then (Is_Subprogram (E) or else Is_Generic_Subprogram (E))
and then Is_Subprogram_Or_Generic_Subprogram (E)
then
declare
Inherited : constant Subprogram_List := Inherited_Subprograms (E);

4
gcc/ada/sem_ch7.adb
View File

@ -2808,7 +2808,7 @@ package body Sem_Ch7 is
-- Body required if subprogram
elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then
elsif Is_Subprogram_Or_Generic_Subprogram (P) then
return True;
-- Treat a block as requiring a body
@ -2937,7 +2937,7 @@ package body Sem_Ch7 is
-- Body required if subprogram
elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then
elsif Is_Subprogram_Or_Generic_Subprogram (P) then
Error_Msg_N ("info: & requires body (subprogram case)?Y?", P);
-- Body required if generic parent has Elaborate_Body

10
gcc/ada/sem_disp.adb
View File

@ -2098,10 +2098,7 @@ package body Sem_Disp is
and then
Is_Interface (Find_Dispatching_Type (Parent_Op)));
if Is_Subprogram (Parent_Op)
or else
Is_Generic_Subprogram (Parent_Op)
then
if Is_Subprogram_Or_Generic_Subprogram (Parent_Op) then
Store_IS (Parent_Op);
end if;
end loop;
@ -2134,10 +2131,7 @@ package body Sem_Disp is
-- The following test eliminates some odd cases in which
-- Ekind (Prim) is Void, to be investigated further ???
if not (Is_Subprogram (Prim)
or else
Is_Generic_Subprogram (Prim))
then
if not Is_Subprogram_Or_Generic_Subprogram (Prim) then
null;
-- For [generic] subprogram, look at interface alias

21
gcc/ada/sem_prag.adb
View File

@ -6736,10 +6736,9 @@ package body Sem_Prag is
("dispatching subprogram# cannot use Stdcall convention!",
Arg1);
-- Subprogram is allowed, but not a generic subprogram
-- Subprograms are not allowed
elsif not Is_Subprogram (E)
and then not Is_Generic_Subprogram (E)
elsif not Is_Subprogram_Or_Generic_Subprogram (E)
-- A variable is OK
@ -7016,8 +7015,7 @@ package body Sem_Prag is
-- For Intrinsic, a subprogram is required
if C = Convention_Intrinsic
and then not Is_Subprogram (E)
and then not Is_Generic_Subprogram (E)
and then not Is_Subprogram_Or_Generic_Subprogram (E)
then
Error_Pragma_Arg
("second argument of pragma% must be a subprogram", Arg2);
@ -7025,9 +7023,7 @@ package body Sem_Prag is
-- Deal with non-subprogram cases
if not Is_Subprogram (E)
and then not Is_Generic_Subprogram (E)
then
if not Is_Subprogram_Or_Generic_Subprogram (E) then
Set_Convention_From_Pragma (E);
if Is_Type (E) then
@ -7885,9 +7881,8 @@ package body Sem_Prag is
end if;
end if;
elsif Is_Subprogram (Def_Id)
or else Is_Generic_Subprogram (Def_Id)
then
elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
-- If the name is overloaded, pragma applies to all of the denoted
-- entities in the same declarative part, unless the pragma comes
-- from an aspect specification or was generated by the compiler
@ -7909,9 +7904,7 @@ package body Sem_Prag is
-- If it is not a subprogram, it must be in an outer scope and
-- pragma does not apply.
elsif not Is_Subprogram (Def_Id)
and then not Is_Generic_Subprogram (Def_Id)
then
elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
null;
-- The pragma does not apply to primitives of interfaces

4
gcc/ada/sem_res.adb
View File

@ -4289,9 +4289,7 @@ package body Sem_Res is
then
Error_Msg_N ("class-wide argument not allowed here!", A);
if Is_Subprogram (Nam)
and then Comes_From_Source (Nam)
then
if Is_Subprogram (Nam) and then Comes_From_Source (Nam) then
Error_Msg_Node_2 := F_Typ;
Error_Msg_NE
("& is not a dispatching operation of &!", A, Nam);

5
gcc/ada/sem_util.adb
View File

@ -4321,7 +4321,7 @@ package body Sem_Util is
function Current_Subprogram return Entity_Id is
Scop : constant Entity_Id := Current_Scope;
begin
if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
if Is_Subprogram_Or_Generic_Subprogram (Scop) then
return Scop;
else
return Enclosing_Subprogram (Scop);
@ -16491,8 +16491,7 @@ package body Sem_Util is
while not Comes_From_Source (Val_Actual)
and then Nkind (Val_Actual) in N_Entity
and then (Ekind (Val_Actual) = E_Enumeration_Literal
or else Is_Subprogram (Val_Actual)
or else Is_Generic_Subprogram (Val_Actual))
or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual))
and then Present (Alias (Val_Actual))
loop
Val_Actual := Alias (Val_Actual);