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

[multiple changes]

Browse source 
2014-01-22  Robert Dewar  <dewar@adacore.com>

	* sem_aux.adb, sem_aux.ads, sem_ch3.adb (Has_Unconstrained_Elements):
	Moved to sem_aux.adb.

2014-01-22  Robert Dewar  <dewar@adacore.com>

	* vms_data.ads: Minor reformatting.

2014-01-22  Robert Dewar  <dewar@adacore.com>

	* debug.adb: Document messages affected by -gnatd.E including
	the new ones that relate to late definition of equality.
	* sem_ch6.adb (Check_Untagged_Equality): In Ada 2012 mode, if
	debug flag -gnatd.E is set, then generate warnings rather than
	errors.
	(Check_Untagged_Equality): In earlier versions of Ada,
	generate warnings if Warn_On_Ada_2012_Incompatibility flag is set.

2014-01-22  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb (Usage_Error): Output additional messages for
	unconstrained OUT parameters lacking an input dependency.

2014-01-22  Robert Dewar  <dewar@adacore.com>

	* sem_ch4.adb: Minor reformatting.

2014-01-22  Robert Dewar  <dewar@adacore.com>

	* restrict.ads: Minor reformatting.
	* sem_res.adb (Resolve_Call): Check for SPARK_05 restriction that
	forbids a call from within a subprogram to the same subprogram.

2014-01-22  Thomas Quinot  <quinot@adacore.com>

	* a-stream.ads (Read_SEA, Write_SEA): New subprograms, optimized
	stream attributes for Stream_Element_Array.
	* a-stream.adb (Read_SEA, Write_SEA): Bodies for the above.
	* rtsfind.adb (Check_CRT): Do not reject a reference to an entity
	defined in the current scope.

From-SVN: r206929
This commit is contained in:
Arnaud Charlet 2014-01-22 17:47:20 +01:00
parent d4129bfa7c
commit b2834fbd22
14 changed files with 354 additions and 84 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
gcc/ada/ChangeLog
View file

@ -1,3 +1,45 @@
2014-01-22 Robert Dewar <dewar@adacore.com>
* sem_aux.adb, sem_aux.ads, sem_ch3.adb (Has_Unconstrained_Elements):
Moved to sem_aux.adb.
2014-01-22 Robert Dewar <dewar@adacore.com>
* vms_data.ads: Minor reformatting.
2014-01-22 Robert Dewar <dewar@adacore.com>
* debug.adb: Document messages affected by -gnatd.E including
the new ones that relate to late definition of equality.
* sem_ch6.adb (Check_Untagged_Equality): In Ada 2012 mode, if
debug flag -gnatd.E is set, then generate warnings rather than
errors.
(Check_Untagged_Equality): In earlier versions of Ada,
generate warnings if Warn_On_Ada_2012_Incompatibility flag is set.
2014-01-22 Robert Dewar <dewar@adacore.com>
* sem_prag.adb (Usage_Error): Output additional messages for
unconstrained OUT parameters lacking an input dependency.
2014-01-22 Robert Dewar <dewar@adacore.com>
* sem_ch4.adb: Minor reformatting.
2014-01-22 Robert Dewar <dewar@adacore.com>
* restrict.ads: Minor reformatting.
* sem_res.adb (Resolve_Call): Check for SPARK_05 restriction that
forbids a call from within a subprogram to the same subprogram.
2014-01-22 Thomas Quinot <quinot@adacore.com>
* a-stream.ads (Read_SEA, Write_SEA): New subprograms, optimized
stream attributes for Stream_Element_Array.
* a-stream.adb (Read_SEA, Write_SEA): Bodies for the above.
* rtsfind.adb (Check_CRT): Do not reject a reference to an entity
defined in the current scope.
2014-01-22 Robert Dewar <dewar@adacore.com>
* debug.adb, exp_ch4.adb, erroutc.adb: Minor reformatting.

68
gcc/ada/a-stream.adb Normal file
View file

@ -0,0 +1,68 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . S T R E A M S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2013, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.IO_Exceptions;
package body Ada.Streams is
--------------
-- Read_SEA --
--------------
procedure Read_SEA
(S : access Root_Stream_Type'Class;
V : out Stream_Element_Array)
is
Last : Stream_Element_Offset;
begin
Read (S.all, V, Last);
if Last /= V'Last then
raise Ada.IO_Exceptions.End_Error;
end if;
end Read_SEA;
---------------
-- Write_SEA --
---------------
procedure Write_SEA
(S : access Root_Stream_Type'Class;
V : Stream_Element_Array)
is
begin
Write (S.all, V);
end Write_SEA;
end Ada.Streams;

19
gcc/ada/a-stream.ads
View file

@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . S T R E A M S --
-- A D A . S T R E A M S --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@ -66,4 +66,19 @@ private
type Root_Stream_Type is abstract tagged limited null record;
-- Stream attributes for Stream_Element_Array: trivially call the
-- corresponding stream primitive for the whole array, instead of doing
-- so element by element.
procedure Read_SEA
(S : access Root_Stream_Type'Class;
V : out Stream_Element_Array);
procedure Write_SEA
(S : access Root_Stream_Type'Class;
V : Stream_Element_Array);
for Stream_Element_Array'Read use Read_SEA;
for Stream_Element_Array'Write use Write_SEA;
end Ada.Streams;

14
gcc/ada/debug.adb
View file

@ -596,10 +596,16 @@ package body Debug is
-- d.E Turn selected errors into warnings. This debug switch causes a
-- specific set of error messages into warnings. Setting this switch
-- causes Opt.Error_To_Warning to be set to True. Right now the only
-- error affected is the case of overlapping subprogram parameters
-- which has become illegal in Ada 2012, but only generates a warning
-- in earlier versions of Ada.
-- causes Opt.Error_To_Warning to be set to True. The intention is
-- that this be used for messages representing upwards incompatible
-- changes to Ada 2012 that cause previously correct programs to be
-- treated as illegal now. The following cases are affected:
--
-- Errors relating to overlapping subprogram parameters for cases
-- other than IN OUT parameters to functions.
--
-- Errors relating to the new rules about not defining equality
-- too late so that composition of equality can be assured.
-- d.F Sets GNATprove_Mode to True. This allows debugging the frontend in
-- the special mode used by GNATprove.

2
gcc/ada/restrict.ads
View file

@ -254,7 +254,7 @@ package Restrict is
(Msg : String;
N : Node_Id;
Force : Boolean := False);
-- Node N represents a construct not allowed in formal mode. If this is
-- Node N represents a construct not allowed in SPARK_05 mode. If this is
-- a source node, or if the restriction is forced (Force = True), and
-- the SPARK_05 restriction is set, then an error is issued on N. Msg
-- is appended to the restriction failure message.

11
gcc/ada/rtsfind.adb
View file

@ -225,11 +225,18 @@ package body Rtsfind is
-- Entity is available
else
-- If in No_Run_Time mode and entity is not in one of the
-- specially permitted units, raise the exception.
-- If in No_Run_Time mode and entity is neither in the current unit
-- nor in one of the specially permitted units, raise the exception.
if No_Run_Time_Mode
and then not OK_No_Run_Time_Unit (U_Id)
-- If the entity being referenced is defined in the current scope,
-- using it is always fine as such usage can never introduce any
-- dependency on an additional unit.
-- Why do we need to do this test ???
and then Scope (Eid) /= Current_Scope
then
Entity_Not_Defined (E);
raise RE_Not_Available;

18
gcc/ada/sem_aux.adb
View file

@ -624,6 +624,24 @@ package body Sem_Aux is
return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
end Has_Rep_Pragma;
--------------------------------
-- Has_Unconstrained_Elements --
--------------------------------
function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is
U_T : constant Entity_Id := Underlying_Type (T);
begin
if No (U_T) then
return False;
elsif Is_Record_Type (U_T) then
return Has_Discriminants (U_T) and then not Is_Constrained (U_T);
elsif Is_Array_Type (U_T) then
return Has_Unconstrained_Elements (Component_Type (U_T));
else
return False;
end if;
end Has_Unconstrained_Elements;
---------------------
-- In_Generic_Body --
---------------------

4
gcc/ada/sem_aux.ads
View file

@ -246,6 +246,10 @@ package Sem_Aux is
-- the given names then True is returned, otherwise False indicates that no
-- matching entry was found.
function Has_Unconstrained_Elements (T : Entity_Id) return Boolean;
-- True if T has discriminants and is unconstrained, or is an array type
-- whose element type Has_Unconstrained_Elements.
function In_Generic_Body (Id : Entity_Id) return Boolean;
-- Determine whether entity Id appears inside a generic body

23
gcc/ada/sem_ch3.adb
View file

@ -2991,11 +2991,6 @@ package body Sem_Ch3 is
-- or a variant record type is encountered, Check_Restrictions is called
-- indicating the count is unknown.
function Has_Unconstrained_Elements (T : Entity_Id) return Boolean;
-- True if T has discriminants and is unconstrained, or is an array
-- type whose element type Has_Unconstrained_Elements. Shouldn't this
-- be in sem_util???
-----------------
-- Count_Tasks --
-----------------
@ -3050,24 +3045,6 @@ package body Sem_Ch3 is
end if;
end Count_Tasks;
--------------------------------
-- Has_Unconstrained_Elements --
--------------------------------
function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is
U_T : constant Entity_Id := Underlying_Type (T);
begin
if No (U_T) then
return False;
elsif Is_Record_Type (U_T) then
return Has_Discriminants (U_T) and then not Is_Constrained (U_T);
elsif Is_Array_Type (U_T) then
return Has_Unconstrained_Elements (Component_Type (U_T));
else
return False;
end if;
end Has_Unconstrained_Elements;
-- Start of processing for Analyze_Object_Declaration
begin

16
gcc/ada/sem_ch4.adb
View file

@ -1045,14 +1045,14 @@ package body Sem_Ch4 is
and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type
and then
(not Name_Denotes_Function
or else Nkind (N) = N_Procedure_Call_Statement
or else
(Nkind (Parent (N)) /= N_Explicit_Dereference
and then Is_Entity_Name (Nam)
and then No (First_Formal (Entity (Nam)))
and then not
Is_Array_Type (Etype (Designated_Type (Etype (Nam))))
and then Present (Actuals)))
or else Nkind (N) = N_Procedure_Call_Statement
or else
(Nkind (Parent (N)) /= N_Explicit_Dereference
and then Is_Entity_Name (Nam)
and then No (First_Formal (Entity (Nam)))
and then not
Is_Array_Type (Etype (Designated_Type (Etype (Nam))))
and then Present (Actuals)))
then
Nam_Ent := Designated_Type (Etype (Nam));
Insert_Explicit_Dereference (Nam);

159
gcc/ada/sem_ch6.adb
View file

@ -193,7 +193,10 @@ package body Sem_Ch6 is
-- must appear before the type is frozen, and have the same visibility as
-- that of the type. This procedure checks that this rule is met, and
-- otherwise emits an error on the subprogram declaration and a warning
-- on the earlier freeze point if it is easy to locate.
-- on the earlier freeze point if it is easy to locate. In Ada 2012 mode,
-- this routine outputs errors (or warnings if -gnatd.E is set). In earlier
-- versions of Ada, warnings are output if Warn_On_Ada_2012_Incompatibility
-- is set, otherwise the call has no effect.
procedure Enter_Overloaded_Entity (S : Entity_Id);
-- This procedure makes S, a new overloaded entity, into the first visible
@ -8198,63 +8201,140 @@ package body Sem_Ch6 is
Obj_Decl : Node_Id;
begin
if Nkind (Decl) = N_Subprogram_Declaration
and then Is_Record_Type (Typ)
and then not Is_Tagged_Type (Typ)
-- This check applies only if we have a subprogram declaration with a
-- non-tagged record type.
if Nkind (Decl) /= N_Subprogram_Declaration
or else not Is_Record_Type (Typ)
or else Is_Tagged_Type (Typ)
then
-- If the type is not declared in a package, or if we are in the
-- body of the package or in some other scope, the new operation is
-- not primitive, and therefore legal, though suspicious. If the
-- type is a generic actual (sub)type, the operation is not primitive
-- either because the base type is declared elsewhere.
return;
end if;
if Is_Frozen (Typ) then
if Ekind (Scope (Typ)) /= E_Package
or else Scope (Typ) /= Current_Scope
then
null;
-- In Ada 2012 case, we will output errors or warnings depending on
-- the setting of debug flag -gnatd.E.
elsif Is_Generic_Actual_Type (Typ) then
null;
if Ada_Version >= Ada_2012 then
Error_Msg_Warn := Debug_Flag_Dot_EE;
elsif In_Package_Body (Scope (Typ)) then
-- In earlier versions of Ada, nothing to do unless we are warning on
-- Ada 2012 incompatibilities (Warn_On_Ada_2012_Incompatibility set).
else
if not Warn_On_Ada_2012_Compatibility then
return;
end if;
end if;
-- Cases where the type has already been frozen
if Is_Frozen (Typ) then
-- If the type is not declared in a package, or if we are in the body
-- of the package or in some other scope, the new operation is not
-- primitive, and therefore legal, though suspicious. Should we
-- generate a warning in this case ???
if Ekind (Scope (Typ)) /= E_Package
or else Scope (Typ) /= Current_Scope
then
return;
-- If the type is a generic actual (sub)type, the operation is not
-- primitive either because the base type is declared elsewhere.
elsif Is_Generic_Actual_Type (Typ) then
return;
-- Here we have a definite error of declaration after freezing
else
if Ada_Version >= Ada_2012 then
Error_Msg_NE
("equality operator must be declared "
& "before type& is frozen", Eq_Op, Typ);
Error_Msg_N
("\move declaration to package spec", Eq_Op);
("equality operator must be declared before type& is "
& "frozen (RM 4.5.2 (9.8)) (Ada 2012)<<", Eq_Op, Typ);
-- In Ada 2012 mode with error turned to warning, output one
-- more warning to warn that the equality operation may not
-- compose. This is the consequence of ignoring the error.
if Error_Msg_Warn then
Error_Msg_N ("\equality operation may not compose??", Eq_Op);
end if;
else
Error_Msg_NE
("equality operator must be declared "
& "before type& is frozen", Eq_Op, Typ);
("equality operator must be declared before type& is "
& "frozen (RM 4.5.2 (9.8)) (Ada 2012)?y?", Eq_Op, Typ);
end if;
-- If we are in the package body, we could just move the
-- declaration to the package spec, so add a message saying that.
if In_Package_Body (Scope (Typ)) then
if Ada_Version >= Ada_2012 then
Error_Msg_N
("\move declaration to package spec<<", Eq_Op);
else
Error_Msg_N
("\move declaration to package spec (Ada 2012)?y?", Eq_Op);
end if;
-- Otherwise try to find the freezing point
else
Obj_Decl := Next (Parent (Typ));
while Present (Obj_Decl) and then Obj_Decl /= Decl loop
if Nkind (Obj_Decl) = N_Object_Declaration
and then Etype (Defining_Identifier (Obj_Decl)) = Typ
then
Error_Msg_NE
("type& is frozen by declaration??", Obj_Decl, Typ);
Error_Msg_N
("\an equality operator cannot be declared after this "
& "point (RM 4.5.2 (9.8)) (Ada 2012))??", Obj_Decl);
-- Freezing point, output warnings
if Ada_Version >= Ada_2012 then
Error_Msg_NE
("type& is frozen by declaration??", Obj_Decl, Typ);
Error_Msg_N
("\an equality operator cannot be declared after "
& "this point??",
Obj_Decl);
else
Error_Msg_NE
("type& is frozen by declaration (Ada 2012)?y?",
Obj_Decl, Typ);
Error_Msg_N
("\an equality operator cannot be declared after "
& "this point (Ada 2012)?y?",
Obj_Decl);
end if;
exit;
end if;
Next (Obj_Decl);
end loop;
end if;
elsif not In_Same_List (Parent (Typ), Decl)
and then not Is_Limited_Type (Typ)
then
-- This makes it illegal to have a primitive equality declared in
-- the private part if the type is visible.
Error_Msg_N ("equality operator appears too late", Eq_Op);
end if;
-- Here if type is not frozen yet. It is illegal to have a primitive
-- equality declared in the private part if the type is visible.
elsif not In_Same_List (Parent (Typ), Decl)
and then not Is_Limited_Type (Typ)
then
-- Shouldn't we give an RM reference here???
if Ada_Version >= Ada_2012 then
Error_Msg_N
("equality operator appears too late<<", Eq_Op);
else
Error_Msg_N
("equality operator appears too late (Ada 2012)?y?", Eq_Op);
end if;
-- No error detected
else
return;
end if;
end Check_Untagged_Equality;
@ -10796,10 +10876,7 @@ package body Sem_Ch6 is
and then not Is_Dispatching_Operation (S)
then
Make_Inequality_Operator (S);
if Ada_Version >= Ada_2012 then
Check_Untagged_Equality (S);
end if;
Check_Untagged_Equality (S);
end if;
end New_Overloaded_Entity;

46
gcc/ada/sem_prag.adb
View file

@ -1114,11 +1114,57 @@ package body Sem_Prag is
-----------------
procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is
Typ : constant Entity_Id := Etype (Item_Id);
begin
-- Input case
if Is_Input then
Error_Msg_NE
("item & must appear in at least one input list of aspect "
& "Depends", Item, Item_Id);
-- Case of OUT parameter for which Is_Input is set
if Nkind (Item) = N_Defining_Identifier
and then Ekind (Item) = E_Out_Parameter
then
-- One case is an unconstrained array where the bounds
-- must be read, if we have this case, output a message
-- indicating why the OUT parameter is read.
if Is_Array_Type (Typ)
and then not Is_Constrained (Typ)
then
Error_Msg_NE
("\& is an unconstrained array type, so bounds must be "
& "read", Item, Typ);
-- Another case is an unconstrained discriminated record
-- type where the constrained flag must be read (and if
-- set, the discriminants). Again output a message.
elsif Is_Record_Type (Typ)
and then Has_Discriminants (Typ)
and then not Is_Constrained (Typ)
then
Error_Msg_NE
("\& is an unconstrained discriminated record type",
Item, Typ);
Error_Msg_N
("\constrained flag and possible discriminants must be "
& "read", Item);
-- Not clear if there are other cases. Anyway, we will
-- simply ignore any other cases.
else
null;
end if;
end if;
-- Output case
else
Error_Msg_NE
("item & must appear in exactly one output list of aspect "

13
gcc/ada/sem_res.adb
View file

@ -5279,8 +5279,7 @@ package body Sem_Res is
is
Subp_Alias : constant Entity_Id := Alias (S);
begin
return S = E
or else (Present (Subp_Alias) and then Subp_Alias = E);
return S = E or else (Present (Subp_Alias) and then Subp_Alias = E);
end Same_Or_Aliased_Subprograms;
-- Start of processing for Resolve_Call
@ -5630,6 +5629,16 @@ package body Sem_Res is
if Comes_From_Source (N) then
Scop := Current_Scope;
-- Check violation of SPARK_05 restriction which does not permit
-- a subprogram body to contain a call to the subprogram directly.
if Restriction_Check_Required (SPARK_05)
and then Same_Or_Aliased_Subprograms (Nam, Scop)
then
Check_SPARK_Restriction
("subprogram may not contain direct call to itself", N);
end if;
-- Issue warning for possible infinite recursion in the absence
-- of the No_Recursion restriction.

3
gcc/ada/vms_data.ads
View file

@ -3368,7 +3368,8 @@ package VMS_Data is
-- switch -gnat??. See below for list of these
-- equivalent switch names.
--
-- NOTAG_WARNINGS Turns off warning tag output (default setting).
-- NOTAG_WARNINGS Turns off warning tag output (default
-- setting).
--
-- The remaining entries control individual warning categories. If one
-- of these options is preceded by NO (e.g. NOAVOID_GAPS), then the