procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2017-01-23  Gary Dismukes  <dismukes@adacore.com>

	* a-calend.adb, prep.adb, debug.adb, prj.ads, prepcomp.adb,
	exp_disp.adb, s-imgrea.adb, g-socket.adb, g-socket.ads, sem_ch13.adb,
	prj-tree.ads: Minor spelling change for consistency (behaviour ->
	behavior).

2017-01-23  Ed Schonberg  <schonberg@adacore.com>

	* scng.adb (Scan): Use Ada version Ada_2020 to flag use of
	Target_Name.
	* par-ch4.adb (P_Primary): Ditto.
	* opt.ads: Add Ada_2020 (optimistically) to enumeration list of
	Ada_Version_Type.
	* switch-c.adb (Scan_Front_End_Switches): Recognize -gnat2020 for
	new Ada version Ada_2020.

2017-01-23  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_attr.adb (Expand_Loop_Entry_Attribute): Force the generation
	of a nominal type for the constant which captures the value of
	the attribute prefix. Various clean ups.
	* sem_attr.adb (Analyze_Attribute): Clean up the processing of
	'Loop_Entry.

2017-01-23  Yannick Moy  <moy@adacore.com>

	* sem_util.adb (Has_Enabled_Property): Treat
	protected objects and variables differently from other variables.

From-SVN: r244787
This commit is contained in:
Arnaud Charlet 2017-01-23 12:51:26 +01:00
parent 52b70b1bef
commit 0f83b0444c
15 changed files with 163 additions and 73 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
gcc/ada/ChangeLog
View file

@ -1,3 +1,8 @@
2017-01-23 Yannick Moy <moy@adacore.com>
* sem_util.adb (Has_Enabled_Property): Treat
protected objects and variables differently from other variables.
2017-01-23 Thomas Quinot <quinot@adacore.com>
* sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order):

2
gcc/ada/a-calend.adb
View file

@ -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- --

2
gcc/ada/debug.adb
View file

@ -558,7 +558,7 @@ package body Debug is
-- d.o Conservative elaboration order for indirect calls. This causes
-- P'Access to be treated as a call in more cases.
-- d.p In Ada 95 (or 83) mode, use original Ada 95 behaviour for the
-- d.p In Ada 95 (or 83) mode, use original Ada 95 behavior for the
-- interpretation of component clauses crossing byte boundaries when
-- using the non-default bit order (i.e. ignore AI95-0133).

105
gcc/ada/exp_attr.adb
View file

@ -1019,13 +1019,11 @@ package body Exp_Attr is
-- Local variables
Exprs : constant List_Id := Expressions (N);
Pref : constant Node_Id := Prefix (N);
Typ : constant Entity_Id := Etype (Pref);
Base_Typ : constant Entity_Id := Base_Type (Etype (Pref));
Exprs : constant List_Id := Expressions (N);
Aux_Decl : Node_Id;
Blk : Node_Id;
CW_Decl : Node_Id;
CW_Temp : Entity_Id;
CW_Typ : Entity_Id;
Decls : List_Id;
Installed : Boolean;
Loc : Source_Ptr;
@ -1048,10 +1046,10 @@ package body Exp_Attr is
Loop_Id := Entity (First (Exprs));
Loop_Stmt := Label_Construct (Parent (Loop_Id));
-- Climb the parent chain to find the nearest enclosing loop. Skip all
-- internally generated loops for quantified expressions and for
-- element iterators over multidimensional arrays: pragma applies to
-- source loop.
-- Climb the parent chain to find the nearest enclosing loop. Skip
-- all internally generated loops for quantified expressions and for
-- element iterators over multidimensional arrays because the pragma
-- applies to source loop.
else
Loop_Stmt := N;
@ -1350,49 +1348,68 @@ package body Exp_Attr is
-- Preserve the tag of the prefix by offering a specific view of the
-- class-wide version of the prefix.
if Is_Tagged_Type (Typ) then
if Is_Tagged_Type (Base_Typ) then
Tagged_Case : declare
CW_Temp : Entity_Id;
CW_Typ : Entity_Id;
-- Generate:
-- CW_Temp : constant Typ'Class := Typ'Class (Pref);
begin
-- Generate:
-- CW_Temp : constant Base_Typ'Class := Base_Typ'Class (Pref);
CW_Temp := Make_Temporary (Loc, 'T');
CW_Typ := Class_Wide_Type (Typ);
CW_Temp := Make_Temporary (Loc, 'T');
CW_Typ := Class_Wide_Type (Base_Typ);
CW_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => CW_Temp,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
Expression =>
Convert_To (CW_Typ, Relocate_Node (Pref)));
Append_To (Decls, CW_Decl);
Aux_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => CW_Temp,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
Expression =>
Convert_To (CW_Typ, Relocate_Node (Pref)));
Append_To (Decls, Aux_Decl);
-- Generate:
-- Temp : Typ renames Typ (CW_Temp);
-- Generate:
-- Temp : Base_Typ renames Base_Typ (CW_Temp);
Temp_Decl :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Temp_Id,
Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Name =>
Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)));
Append_To (Decls, Temp_Decl);
Temp_Decl :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Temp_Id,
Subtype_Mark => New_Occurrence_Of (Base_Typ, Loc),
Name =>
Convert_To (Base_Typ, New_Occurrence_Of (CW_Temp, Loc)));
Append_To (Decls, Temp_Decl);
end Tagged_Case;
-- Non-tagged case
-- Untagged case
else
CW_Decl := Empty;
Untagged_Case : declare
Temp_Expr : Node_Id;
-- Generate:
-- Temp : constant Typ := Pref;
begin
Aux_Decl := Empty;
Temp_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp_Id,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Relocate_Node (Pref));
Append_To (Decls, Temp_Decl);
-- Generate a nominal type for the constant when the prefix is of
-- a constrained type. This is achieved by setting the Etype of
-- the relocated prefix to its base type. Since the prefix is now
-- the initialization expression of the constant, its freezing
-- will produce a proper nominal type.
Temp_Expr := Relocate_Node (Pref);
Set_Etype (Temp_Expr, Base_Typ);
-- Generate:
-- Temp : constant Base_Typ := Pref;
Temp_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp_Id,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Base_Typ, Loc),
Expression => Temp_Expr);
Append_To (Decls, Temp_Decl);
end Untagged_Case;
end if;
-- Step 4: Analyze all bits
@ -1418,8 +1435,8 @@ package body Exp_Attr is
-- the declaration of the constant.
else
if Present (CW_Decl) then
Analyze (CW_Decl);
if Present (Aux_Decl) then
Analyze (Aux_Decl);
end if;
Analyze (Temp_Decl);

7
gcc/ada/opt.ads
View file

@ -101,6 +101,11 @@ package Opt is
-- GPRBUILD
-- Set to True by gprbuild when the version of GNAT is 5.03 or before.
Checksum_Accumulate_Limited_Checksum : Boolean := False;
-- Used to control the computation of the limited view of a package.
-- (Not currently used, possible optimization for ALI files of units
-- in limited with_clauses).
----------------------------------------------
-- Settings of Modes for Current Processing --
----------------------------------------------
@ -117,7 +122,7 @@ package Opt is
-- trying to specify other values will be ignored (in case of pragma
-- Ada_xxx) or generate an error (in case of -gnat83/95/xx switches).
type Ada_Version_Type is (Ada_83, Ada_95, Ada_2005, Ada_2012);
type Ada_Version_Type is (Ada_83, Ada_95, Ada_2005, Ada_2012, Ada_2020);
pragma Ordered (Ada_Version_Type);
-- Versions of Ada for Ada_Version below. Note that these are ordered,
-- so that tests like Ada_Version >= Ada_95 are legitimate and useful.

2
gcc/ada/par-ch4.adb
View file

@ -2798,7 +2798,7 @@ package body Ch4 is
Scan; -- past minus
when Tok_At_Sign => -- AI12-0125 : target_name
if not Extensions_Allowed then
if Ada_Version < Ada_2020 then
Error_Msg_SC ("target name is an Ada 2020 extension");
Error_Msg_SC ("\compile with -gnatX");
end if;

2
gcc/ada/prepcomp.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2003-2014, Free Software Foundation, Inc. --
-- Copyright (C) 2003-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- --

2
gcc/ada/prj-tree.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
-- Copyright (C) 2001-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- --

2
gcc/ada/prj.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2001-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- --

2
gcc/ada/s-imgrea.adb
View file

@ -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- --

2
gcc/ada/scng.adb
View file

@ -1612,7 +1612,7 @@ package body Scng is
end if;
when '@' =>
if not Extensions_Allowed then
if Ada_Version < Ada_2020 then
Error_Illegal_Character;
Scan_Ptr := Scan_Ptr + 1;

30
gcc/ada/sem_attr.adb
View file

@ -4295,13 +4295,13 @@ package body Sem_Attr is
-- Local variables
Context : constant Node_Id := Parent (N);
Attr : Node_Id;
Enclosing_Loop : Node_Id;
Loop_Id : Entity_Id := Empty;
Scop : Entity_Id;
Stmt : Node_Id;
Enclosing_Pragma : Node_Id := Empty;
Context : constant Node_Id := Parent (N);
Attr : Node_Id;
Encl_Loop : Node_Id;
Encl_Prag : Node_Id := Empty;
Loop_Id : Entity_Id := Empty;
Scop : Entity_Id;
Stmt : Node_Id;
-- Start of processing for Loop_Entry
@ -4419,7 +4419,7 @@ package body Sem_Attr is
Name_Assert_And_Cut,
Name_Assume)
then
Enclosing_Pragma := Original_Node (Stmt);
Encl_Prag := Original_Node (Stmt);
-- Locate the enclosing loop (if any). Note that Ada 2012 array
-- iteration may be expanded into several nested loops, we are
@ -4431,14 +4431,14 @@ package body Sem_Attr is
and then Comes_From_Source (Original_Node (Stmt))
and then Nkind (Original_Node (Stmt)) = N_Loop_Statement
then
Enclosing_Loop := Stmt;
Encl_Loop := Stmt;
-- The original attribute reference may lack a loop name. Use
-- the name of the enclosing loop because it is the related
-- loop.
if No (Loop_Id) then
Loop_Id := Entity (Identifier (Enclosing_Loop));
Loop_Id := Entity (Identifier (Encl_Loop));
end if;
exit;
@ -4467,7 +4467,7 @@ package body Sem_Attr is
then
null;
elsif No (Enclosing_Pragma) then
elsif No (Encl_Prag) then
Error_Attr ("attribute% must appear within appropriate pragma", N);
end if;
@ -4504,8 +4504,8 @@ package body Sem_Attr is
then
null;
elsif Present (Enclosing_Loop)
and then Entity (Identifier (Enclosing_Loop)) /= Loop_Id
elsif Present (Encl_Loop)
and then Entity (Identifier (Encl_Loop)) /= Loop_Id
then
Error_Attr_P
("prefix of attribute % that applies to outer loop must denote "
@ -4521,9 +4521,7 @@ package body Sem_Attr is
-- early transformation also avoids the generation of a useless loop
-- entry constant.
if Present (Enclosing_Pragma)
and then Is_Ignored (Enclosing_Pragma)
then
if Present (Encl_Prag) and then Is_Ignored (Encl_Prag) then
Rewrite (N, Relocate_Node (P));
Preanalyze_And_Resolve (N);

6
gcc/ada/sem_ch13.adb
View file

@ -81,7 +81,7 @@ package body Sem_Ch13 is
-----------------------
procedure Adjust_Record_For_Reverse_Bit_Order_Ada_95 (R : Entity_Id);
-- Helper routine providing the original (pre-AI95-0133) behaviour for
-- Helper routine providing the original (pre-AI95-0133) behavior for
-- Adjust_Record_For_Reverse_Bit_Order.
procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint);
@ -364,9 +364,9 @@ package body Sem_Ch13 is
SSU : constant Uint := UI_From_Int (System_Storage_Unit);
begin
-- Processing here used to depend on Ada version: the behaviour was
-- Processing here used to depend on Ada version: the behavior was
-- changed by AI95-0133. However this AI is a Binding interpretation,
-- so we now implement it even in Ada 95 mode. The original behaviour
-- so we now implement it even in Ada 95 mode. The original behavior
-- from unamended Ada 95 is still available for compatibility under
-- debugging switch -gnatd.

64
gcc/ada/sem_util.adb
View file

@ -9118,6 +9118,10 @@ package body Sem_Util is
(Item_Id : Entity_Id;
Property : Name_Id) return Boolean
is
function Protected_Object_Has_Enabled_Property return Boolean;
-- Determine whether a protected object denoted by Item_Id has the
-- property enabled.
function State_Has_Enabled_Property return Boolean;
-- Determine whether a state denoted by Item_Id has the property enabled
@ -9125,6 +9129,44 @@ package body Sem_Util is
-- Determine whether a variable denoted by Item_Id has the property
-- enabled.
-------------------------------------------
-- Protected_Object_Has_Enabled_Property --
-------------------------------------------
function Protected_Object_Has_Enabled_Property return Boolean is
Constits : constant Elist_Id := Part_Of_Constituents (Item_Id);
Constit_Elmt : Elmt_Id;
Constit_Id : Entity_Id;
begin
-- Protected objects always have the properties Async_Readers and
-- Async_Writers. (SPARK RM 7.1.2(16))
if Property = Name_Async_Readers
or else Property = Name_Async_Writers
then
return True;
-- Protected objects that have Part_Of components also inherit
-- their properties Effective_Reads and Effective_Writes. (SPARK
-- RM 7.1.2(16))
elsif Present (Constits) then
Constit_Elmt := First_Elmt (Constits);
while Present (Constit_Elmt) loop
Constit_Id := Node (Constit_Elmt);
if Has_Enabled_Property (Constit_Id, Property) then
return True;
end if;
Next_Elmt (Constit_Elmt);
end loop;
end if;
return False;
end Protected_Object_Has_Enabled_Property;
--------------------------------
-- State_Has_Enabled_Property --
--------------------------------
@ -9302,7 +9344,19 @@ package body Sem_Util is
-- The implicit case lacks all property pragmas
elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
return True;
-- A variable of a protected type only has the properties
-- Async_Readers and Async_Writers. It cannot have Part_Of
-- components (only protected objects can), hence it cannot
-- inherit their properties Effective_Reads and Effective_Writes.
-- (SPARK RM 7.1.2(16))
if Is_Protected_Type (Etype (Item_Id)) then
return Property = Name_Async_Readers
or else Property = Name_Async_Writers;
else
return True;
end if;
else
return False;
@ -9321,6 +9375,14 @@ package body Sem_Util is
elsif Ekind (Item_Id) = E_Variable then
return Variable_Has_Enabled_Property;
-- By default, protected objects only have the properties Async_Readers
-- and Async_Writers. If they have Part_Of components, they also inherit
-- their properties Effective_Reads and Effective_Writes. (SPARK RM
-- 7.1.2(16))
elsif Ekind (Item_Id) = E_Protected_Object then
return Protected_Object_Has_Enabled_Property;
-- Otherwise a property is enabled when the related item is effectively
-- volatile.

3
gcc/ada/switch-c.adb
View file

@ -1502,6 +1502,9 @@ package body Switch.C is
elsif Switch_Chars (Ptr .. Ptr + 3) = "2012" then
Ada_Version := Ada_2012;
elsif Switch_Chars (Ptr .. Ptr + 3) = "2020" then
Ada_Version := Ada_2020;
else
Bad_Switch ("-gnat" & Switch_Chars (Ptr .. Ptr + 3));
end if;