mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 13:30:58 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2015-05-26  Robert Dewar  <dewar@adacore.com>

	* sem_aggr.adb (Resolve_Array_Aggregate): Defend against
	bad bounds.
	* debug.adb: Document -gnatd.k.
	* erroutc.adb (Set_Msg_Insertion_Line_Number): Implement -gnatd.k.

2015-05-26  Robert Dewar  <dewar@adacore.com>

	* gnat1drv.adb (Gnat1drv): Provide new arguments for
	Get_Target_Parameters.
	* restrict.adb (Set_Restriction_No_Specification_Of_Aspect):
	new procedure.
	(Set_Restriction_No_Use_Of_Attribute): new procedure.
	* restrict.ads (Set_Restriction_No_Specification_Of_Aspect):
	new procedure.
	(Set_Restriction_No_Use_Of_Attribute): new procedure.
	* s-rident.ads (Integer_Parameter_Restrictions): New subtype.
	* targparm.adb (Get_Target_Parameters): Allow new restriction
	pragmas No_Specification_Of_Aspect No_Use_Of_Attribute
	No_Use_Of_Pragma.
	* targparm.ads: New parameters for Get_Target_Parameters.
	* tbuild.adb (Set_NOD): New name for Set_RND.
	(Set_NSA): New procedure.
	(Set_NUA): New procedure.
	(Set_NUP): New procedure.
	* tbuild.ads (Make_SC): Minor reformatting.
	(Set_NOD): New name for Set_RND.
	(Set_NSA, Set_NUA, Set_NUP): New procedure.

2015-05-26  Ed Schonberg  <schonberg@adacore.com>

	* a-stwise.adb (Find_Token): If source'first is not positive,
	an exception must be raised, as specified by RM 2005 A.4.3
	(68/1). This must be checked explicitly, given that run-time
	files are normally compiled without constraint checks.
	* a-stzsea.adb (Find_Token): Ditto.

2015-05-26  Ed Schonberg  <schonberg@adacore.com>

	* sem_util.ads sem_util.adb (Is_Current_Instance):  New predicate
	to fully implement RM 8.6 (17/3). which earlier only applied
	to synchronized types. Used to preanalyze aspects that include
	current instances of types, such as Predicate and Invariant.
	* sem_res.adb (Resolve_Entity_Name): Use Is_Current_Instance.
	* sem_ch13.adb (Add_Predicates): In ASIS mode, preserve original
	expression of aspect and analyze it to provide proper type
	information.

2015-05-26  Robert Dewar  <dewar@adacore.com>

	* rtsfind.ads: Add entries for RE_Exn[_Long]_Float.
	* s-exnllf.adb (Exn_Float): New function.
	(Exn_Long_Float): New function.
	(Exn_Long_Long_Float): Rewritten interface.
	(Exp): New name for what used to be Exn_Long_Long_Float.
	* s-exnllf.ads (Exn_Float): New function.
	(Exn_Long_Float): New function.

2015-05-26  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb (Find_Selected_Component): Do not emit an error
	on a selected component when the prefix is a type name that is
	a Current_Instance.
	* einfo.ads: Minor grammar fix.

2015-05-26  Doug Rupp  <rupp@adacore.com>

	* init.c [vxworks] (sysLib.h): Only for x86.

From-SVN: r223678
This commit is contained in:
Arnaud Charlet 2015-05-26 12:29:25 +02:00
parent 1b961de9db
commit 596b25f9a1
24 changed files with 628 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
gcc/ada/ChangeLog
View File

@ -1,3 +1,73 @@
2015-05-26 Robert Dewar <dewar@adacore.com>
* sem_aggr.adb (Resolve_Array_Aggregate): Defend against
bad bounds.
* debug.adb: Document -gnatd.k.
* erroutc.adb (Set_Msg_Insertion_Line_Number): Implement -gnatd.k.
2015-05-26 Robert Dewar <dewar@adacore.com>
* gnat1drv.adb (Gnat1drv): Provide new arguments for
Get_Target_Parameters.
* restrict.adb (Set_Restriction_No_Specification_Of_Aspect):
new procedure.
(Set_Restriction_No_Use_Of_Attribute): new procedure.
* restrict.ads (Set_Restriction_No_Specification_Of_Aspect):
new procedure.
(Set_Restriction_No_Use_Of_Attribute): new procedure.
* s-rident.ads (Integer_Parameter_Restrictions): New subtype.
* targparm.adb (Get_Target_Parameters): Allow new restriction
pragmas No_Specification_Of_Aspect No_Use_Of_Attribute
No_Use_Of_Pragma.
* targparm.ads: New parameters for Get_Target_Parameters.
* tbuild.adb (Set_NOD): New name for Set_RND.
(Set_NSA): New procedure.
(Set_NUA): New procedure.
(Set_NUP): New procedure.
* tbuild.ads (Make_SC): Minor reformatting.
(Set_NOD): New name for Set_RND.
(Set_NSA, Set_NUA, Set_NUP): New procedure.
2015-05-26 Ed Schonberg <schonberg@adacore.com>
* a-stwise.adb (Find_Token): If source'first is not positive,
an exception must be raised, as specified by RM 2005 A.4.3
(68/1). This must be checked explicitly, given that run-time
files are normally compiled without constraint checks.
* a-stzsea.adb (Find_Token): Ditto.
2015-05-26 Ed Schonberg <schonberg@adacore.com>
* sem_util.ads sem_util.adb (Is_Current_Instance): New predicate
to fully implement RM 8.6 (17/3). which earlier only applied
to synchronized types. Used to preanalyze aspects that include
current instances of types, such as Predicate and Invariant.
* sem_res.adb (Resolve_Entity_Name): Use Is_Current_Instance.
* sem_ch13.adb (Add_Predicates): In ASIS mode, preserve original
expression of aspect and analyze it to provide proper type
information.
2015-05-26 Robert Dewar <dewar@adacore.com>
* rtsfind.ads: Add entries for RE_Exn[_Long]_Float.
* s-exnllf.adb (Exn_Float): New function.
(Exn_Long_Float): New function.
(Exn_Long_Long_Float): Rewritten interface.
(Exp): New name for what used to be Exn_Long_Long_Float.
* s-exnllf.ads (Exn_Float): New function.
(Exn_Long_Float): New function.
2015-05-26 Ed Schonberg <schonberg@adacore.com>
* sem_ch8.adb (Find_Selected_Component): Do not emit an error
on a selected component when the prefix is a type name that is
a Current_Instance.
* einfo.ads: Minor grammar fix.
2015-05-26 Doug Rupp <rupp@adacore.com>
* init.c [vxworks] (sysLib.h): Only for x86.
2015-05-26 Doug Rupp <rupp@adacore.com>
* init-vxsim.c (CPU): define as __VXSIM_CPU__

16
gcc/ada/a-stwise.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, 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- --
@ -252,8 +252,18 @@ package body Ada.Strings.Wide_Search is
-- Here if no token found
First := Source'First;
Last := 0;
-- RM 2005 A.4.3 (68/1) specifies that an exception must be raised if
-- Source'First is not positive and is assigned to First. Formulation
-- is slightly different in RM 2012, but the intent seems similar, so
-- we check explicitly for that condition.
if Source'First not in Positive then
raise Constraint_Error;
else
First := Source'First;
Last := 0;
end if;
end Find_Token;
-----------

16
gcc/ada/a-stzsea.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, 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- --
@ -253,8 +253,18 @@ package body Ada.Strings.Wide_Wide_Search is
-- Here if no token found
First := Source'First;
Last := 0;
-- RM 2005 A.4.3 (68/1) specifies that an exception must be raised if
-- Source'First is not positive and is assigned to First. Formulation
-- is slightly different in RM 2012, but the intent seems similar, so
-- we check explicitly for that condition.
if Source'First not in Positive then
raise Constraint_Error;
else
First := Source'First;
Last := 0;
end if;
end Find_Token;
-----------

5
gcc/ada/debug.adb
View File

@ -101,7 +101,7 @@ package body Debug is
-- d.h Minimize the creation of public internal symbols for concatenation
-- d.i Ignore Warnings pragmas
-- d.j Generate listing of frontend inlined calls
-- d.k
-- d.k Kill referenced run-time library unit line numbers
-- d.l Use Ada 95 semantics for limited function returns
-- d.m For -gnatl, print full source only for main unit
-- d.n Print source file names
@ -534,6 +534,9 @@ package body Debug is
-- be used in particular to disable Warnings (Off) to check if any of
-- these statements are inappropriate.
-- d.k If an error message contains a reference to a location in an
-- internal unit, then suppress the line number in this reference.
-- d.j Generate listing of frontend inlined calls and inline calls passed
-- to the backend. This is useful to locate skipped calls that must be
-- inlined by the frontend.

2
gcc/ada/einfo.ads
View File

@ -3952,7 +3952,7 @@ package Einfo is
-- end and zero is a legitimate value for a type with one value.
-- Root_Type (synthesized)
-- Applies to all type entities. For class-wide types, return the root
-- Applies to all type entities. For class-wide types, returns the root
-- type of the class covered by the CW type, otherwise returns the
-- ultimate derivation ancestor of the given type. This function
-- preserves the view, i.e. the Root_Type of a partial view is the

20
gcc/ada/erroutc.adb
View File

@ -34,6 +34,7 @@ with Casing; use Casing;
with Csets; use Csets;
with Debug; use Debug;
with Err_Vars; use Err_Vars;
with Fname; use Fname;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
@ -1035,6 +1036,8 @@ package body Erroutc is
procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
Sindex_Loc : Source_File_Index;
Sindex_Flag : Source_File_Index;
Fname : File_Name_Type;
Int_File : Boolean;
procedure Set_At;
-- Outputs "at " unless last characters in buffer are " from ". Certain
@ -1083,22 +1086,25 @@ package body Erroutc is
if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
Set_At;
Get_Name_String
(Reference_Name (Get_Source_File_Index (Loc)));
Fname := Reference_Name (Get_Source_File_Index (Loc));
Int_File := Is_Internal_File_Name (Fname);
Get_Name_String (Fname);
Set_Msg_Name_Buffer;
Set_Msg_Char (':');
if not (Int_File and Debug_Flag_Dot_K) then
Set_Msg_Char (':');
Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
end if;
-- If in current file, add text "at line "
else
Set_At;
Set_Msg_Str ("line ");
Int_File := False;
Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
end if;
-- Output line number for reference
Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
-- Deal with the instantiation case. We may have a reference to,
-- e.g. a type, that is declared within a generic template, and
-- what we are really referring to is the occurrence in an instance.

9
gcc/ada/gnat1drv.adb
View File

@ -954,13 +954,20 @@ begin
System_Source_File_Index := S;
end if;
-- Call to get target parameters. Note that the actual interface
-- routines in Tbuild here. They can't be in this procedure
-- because of accessibility issues.
Targparm.Get_Target_Parameters
(System_Text => Source_Text (S),
Source_First => Source_First (S),
Source_Last => Source_Last (S),
Make_Id => Tbuild.Make_Id'Access,
Make_SC => Tbuild.Make_SC'Access,
Set_RND => Tbuild.Set_RND'Access);
Set_NOD => Tbuild.Set_NOD'Access,
Set_NSA => Tbuild.Set_NSA'Access,
Set_NUA => Tbuild.Set_NUA'Access,
Set_NUP => Tbuild.Set_NUP'Access);
-- Acquire configuration pragma information from Targparm

8
gcc/ada/init.c
View File

@ -1694,15 +1694,17 @@ __gnat_install_handler ()
__gnat_handler_installed = 1;
}
/*******************/
/* VxWorks Section */
/*******************/
/*************************************/
/* VxWorks Section (including Vx653) */
/*************************************/
#elif defined(__vxworks)
#include <signal.h>
#include <taskLib.h>
#if defined (i386) || defined (__i386__)
#include <sysLib.h>
#endif
#ifndef __RTP__
#include <intLib.h>

27
gcc/ada/restrict.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, 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- --
@ -23,7 +23,6 @@
-- --
------------------------------------------------------------------------------
with Aspects; use Aspects;
with Atree; use Atree;
with Casing; use Casing;
with Einfo; use Einfo;
@ -35,7 +34,6 @@ with Lib; use Lib;
with Opt; use Opt;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Uname; use Uname;
@ -111,6 +109,8 @@ package body Restrict is
No_Use_Of_Pragma : array (Pragma_Id) of Source_Ptr :=
(others => No_Location);
-- Source location of pragma No_Use_Of_Pragma for given pragma, a value
-- of Sysstem_Location indicates occurrence in system.ads.
No_Use_Of_Pragma_Warning : array (Pragma_Id) of Boolean :=
(others => False);
@ -1569,6 +1569,13 @@ package body Restrict is
No_Specification_Of_Aspect_Set := True;
end Set_Restriction_No_Specification_Of_Aspect;
procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id) is
begin
No_Specification_Of_Aspects (A_Id) := System_Location;
No_Specification_Of_Aspect_Warning (A_Id) := False;
No_Specification_Of_Aspect_Set := True;
end Set_Restriction_No_Specification_Of_Aspect;
-----------------------------------------
-- Set_Restriction_No_Use_Of_Attribute --
-----------------------------------------
@ -1588,6 +1595,13 @@ package body Restrict is
end if;
end Set_Restriction_No_Use_Of_Attribute;
procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id) is
begin
No_Use_Of_Attribute_Set := True;
No_Use_Of_Attribute (A_Id) := System_Location;
No_Use_Of_Attribute_Warning (A_Id) := False;
end Set_Restriction_No_Use_Of_Attribute;
--------------------------------------
-- Set_Restriction_No_Use_Of_Pragma --
--------------------------------------
@ -1607,6 +1621,13 @@ package body Restrict is
end if;
end Set_Restriction_No_Use_Of_Pragma;
procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id) is
begin
No_Use_Of_Pragma_Set := True;
No_Use_Of_Pragma_Warning (A_Id) := False;
No_Use_Of_Pragma (A_Id) := System_Location;
end Set_Restriction_No_Use_Of_Pragma;
--------------------------------
-- Check_SPARK_05_Restriction --
--------------------------------

21
gcc/ada/restrict.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, 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- --
@ -25,11 +25,13 @@
-- This package deals with the implementation of the Restrictions pragma
with Namet; use Namet;
with Rident; use Rident;
with Aspects; use Aspects;
with Namet; use Namet;
with Rident; use Rident;
with Snames; use Snames;
with Table;
with Types; use Types;
with Uintp; use Uintp;
with Types; use Types;
with Uintp; use Uintp;
package Restrict is
@ -463,6 +465,9 @@ package Restrict is
-- case of a Restriction_Warnings pragma specifying this restriction and
-- False for a Restrictions pragma specifying this restriction.
procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id);
-- Version used by Get_Target_Parameters (via Tbuild)
procedure Set_Restriction_No_Use_Of_Attribute
(N : Node_Id;
Warning : Boolean);
@ -470,6 +475,9 @@ package Restrict is
-- No_Use_Of_Attribute. Caller has verified that this is a valid attribute
-- designator.
procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id);
-- Version used by Get_Target_Parameters (via Tbuild)
procedure Set_Restriction_No_Use_Of_Entity
(Entity : Node_Id;
Warn : Boolean;
@ -488,6 +496,9 @@ package Restrict is
-- N is the node id for the identifier in a pragma Restrictions for
-- No_Use_Of_Pragma. Caller has verified that this is a valid pragma id.
procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id);
-- Version used in call from Get_Target_Parameters (via Tbuild).
function Tasking_Allowed return Boolean;
pragma Inline (Tasking_Allowed);
-- Tests if tasking operations are allowed by the current restrictions

6
gcc/ada/rtsfind.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, 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- --
@ -863,6 +863,8 @@ package Rtsfind is
RE_Exn_Integer, -- System.Exn_Int
RE_Exn_Float, -- System.Exn_LLF
RE_Exn_Long_Float, -- System.Exn_LLF
RE_Exn_Long_Long_Float, -- System.Exn_LLF
RE_Exn_Long_Long_Integer, -- System.Exn_LLI
@ -2098,6 +2100,8 @@ package Rtsfind is
RE_Exn_Integer => System_Exn_Int,
RE_Exn_Float => System_Exn_LLF,
RE_Exn_Long_Float => System_Exn_LLF,
RE_Exn_Long_Long_Float => System_Exn_LLF,
RE_Exn_Long_Long_Integer => System_Exn_LLI,

99
gcc/ada/s-exnllf.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, 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- --
@ -29,8 +29,76 @@
-- --
------------------------------------------------------------------------------
-- Note: the reason for treating exponents in the range 0 .. 4 specially is
-- to ensure identical results to the static inline expansion in the case of
-- a compile time known exponent in this range. The use of Float'Machine and
-- Long_Float'Machine is to avoid unwanted extra precision in the results.
package body System.Exn_LLF is
function Exp
(Left : Long_Long_Float;
Right : Integer) return Long_Long_Float;
-- Common routine used if Right not in 0 .. 4
---------------
-- Exn_Float --
---------------
function Exn_Float
(Left : Float;
Right : Integer) return Float
is
Temp : Float;
begin
case Right is
when 0 =>
return 1.0;
when 1 =>
return Left;
when 2 =>
return Float'Machine (Left * Left);
when 3 =>
return Float'Machine (Left * Left * Left);
when 4 =>
Temp := Float'Machine (Left * Left);
return Float'Machine (Temp * Temp);
when others =>
return
Float'Machine
(Float (Exp (Long_Long_Float (Left), Right)));
end case;
end Exn_Float;
--------------------
-- Exn_Long_Float --
--------------------
function Exn_Long_Float
(Left : Long_Float;
Right : Integer) return Long_Float
is
Temp : Long_Float;
begin
case Right is
when 0 =>
return 1.0;
when 1 =>
return Left;
when 2 =>
return Long_Float'Machine (Left * Left);
when 3 =>
return Long_Float'Machine (Left * Left * Left);
when 4 =>
Temp := Long_Float'Machine (Left * Left);
return Long_Float'Machine (Temp * Temp);
when others =>
return
Long_Float'Machine
(Long_Float (Exp (Long_Long_Float (Left), Right)));
end case;
end Exn_Long_Float;
-------------------------
-- Exn_Long_Long_Float --
-------------------------
@ -38,6 +106,33 @@ package body System.Exn_LLF is
function Exn_Long_Long_Float
(Left : Long_Long_Float;
Right : Integer) return Long_Long_Float
is
Temp : Long_Long_Float;
begin
case Right is
when 0 =>
return 1.0;
when 1 =>
return Left;
when 2 =>
return Left * Left;
when 3 =>
return Left * Left * Left;
when 4 =>
Temp := Left * Left;
return Temp * Temp;
when others =>
return Exp (Left, Right);
end case;
end Exn_Long_Long_Float;
---------
-- Exp --
---------
function Exp
(Left : Long_Long_Float;
Right : Integer) return Long_Long_Float
is
Result : Long_Long_Float := 1.0;
Factor : Long_Long_Float := Left;
@ -91,6 +186,6 @@ package body System.Exn_LLF is
return 1.0 / Result;
end;
end if;
end Exn_Long_Long_Float;
end Exp;
end System.Exn_LLF;

12
gcc/ada/s-exnllf.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, 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- --
@ -29,11 +29,19 @@
-- --
------------------------------------------------------------------------------
-- Long_Long_Float exponentiation (checks off)
-- [Long_[Long_]]Float exponentiation (checks off)
package System.Exn_LLF is
pragma Pure;
function Exn_Float
(Left : Float;
Right : Integer) return Float;
function Exn_Long_Float
(Left : Long_Float;
Right : Integer) return Long_Float;
function Exn_Long_Long_Float
(Left : Long_Long_Float;
Right : Integer) return Long_Long_Float;

7
gcc/ada/s-rident.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, 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- --
@ -255,6 +255,11 @@ package System.Rident is
No_Specification_Of_Aspect .. Max_Storage_At_Blocking;
-- All restrictions that take a parameter
subtype Integer_Parameter_Restrictions is
Restriction_Id range
Max_Protected_Entries .. Max_Storage_At_Blocking;
-- All restrictions taking an integer parameter
subtype Checked_Parameter_Restrictions is
All_Parameter_Restrictions range
Max_Protected_Entries .. Max_Entry_Queue_Length;

20
gcc/ada/sem_aggr.adb
View File

@ -2304,6 +2304,16 @@ package body Sem_Aggr is
if Others_Present then
Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
-- Abandon processing if either bound is already signalled as
-- an error (prevents junk cascaded messages and blow ups).
if Nkind (Aggr_Low) = N_Error
or else
Nkind (Aggr_High) = N_Error
then
return False;
end if;
-- No others clause present
else
@ -2314,6 +2324,16 @@ package body Sem_Aggr is
if Others_Allowed then
Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
-- Abandon processing if either bound is already signalled
-- as an error (stop junk cascaded messages and blow ups).
if Nkind (Aggr_Low) = N_Error
or else
Nkind (Aggr_High) = N_Error
then
return False;
end if;
-- If others allowed, and no others present, then the array
-- should cover all index values. If it does not, we will
-- get a length check warning, but there is two cases where

20
gcc/ada/sem_ch13.adb
View File

@ -8437,17 +8437,20 @@ package body Sem_Ch13 is
begin
Ritem := First_Rep_Item (Typ);
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
and then Pragma_Name (Ritem) = Name_Predicate
then
-- Acquire arguments
-- Acquire arguments. The expression itself is copied for use
-- in the predicate function, to preserve the orignal version
-- for ASIS use.
Arg1 := First (Pragma_Argument_Associations (Ritem));
Arg2 := Next (Arg1);
Arg1 := Get_Pragma_Arg (Arg1);
Arg2 := Get_Pragma_Arg (Arg2);
Arg2 := New_Copy_Tree (Get_Pragma_Arg (Arg2));
-- See if this predicate pragma is for the current type or for
-- its full view. A predicate on a private completion is placed
@ -8472,9 +8475,20 @@ package body Sem_Ch13 is
if From_Aspect_Specification (Ritem) then
declare
Aitem : Node_Id;
Aitem : Node_Id;
Orig_Expr : constant Node_Id :=
Expression (Corresponding_Aspect (Ritem));
begin
-- For ASIS use, perform semantic analysis of the
-- original predicate expression, which is otherwise
-- not utilized.
if ASIS_Mode then
Preanalyze_And_Resolve (Orig_Expr);
end if;
-- Loop to find corresponding aspect, note that this
-- must be present given the pragma is marked delayed.

7
gcc/ada/sem_ch8.adb
View File

@ -6950,6 +6950,13 @@ package body Sem_Ch8 is
if P_Name = Any_Id then
null;
-- It is not an error if the prefix is the current instance of
-- type name, e.g. the expression of a type aspect, when it is
-- analyzed for ASIS use.
elsif Is_Entity_Name (P) and then Is_Current_Instance (P) then
null;
elsif Ekind (P_Name) = E_Void then
Premature_Usage (P);

14
gcc/ada/sem_res.adb
View File

@ -6991,18 +6991,12 @@ package body Sem_Res is
Set_Entity_With_Checks (N, E);
Eval_Entity_Name (N);
-- Case of subtype name appearing as an operand in expression
-- Case of (sub)type name appearing in a context where an expression
-- is expected. This is legal if occurrence is a current instance.
-- See RM 8.6 (17/3).
elsif Is_Type (E) then
-- Allow use of subtype if it is a concurrent type where we are
-- currently inside the body. This will eventually be expanded into a
-- call to Self (for tasks) or _object (for protected objects). Any
-- other use of a subtype is invalid.
if Is_Concurrent_Type (E)
and then In_Open_Scopes (E)
then
if Is_Current_Instance (N) then
null;
-- Any other use is an error

40
gcc/ada/sem_util.adb
View File

@ -10951,6 +10951,46 @@ package body Sem_Util is
and then Is_Imported (Entity (Name (N)));
end Is_CPP_Constructor_Call;
-------------------------
-- Is_Current_Instance --
-------------------------
function Is_Current_Instance (N : Node_Id) return Boolean is
Typ : constant Entity_Id := Entity (N);
P : Node_Id;
begin
-- Simplest case : entity is a concurrent type and we are currently
-- inside the body. This will eventually be expanded into a
-- call to Self (for tasks) or _object (for protected objects).
if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then
return True;
else
-- Check whether the context is a (sub)type declaration for the
-- type entity.
P := Parent (N);
while Present (P) loop
if Nkind_In (P, N_Full_Type_Declaration,
N_Private_Type_Declaration,
N_Subtype_Declaration)
and then Comes_From_Source (P)
and then Defining_Entity (P) = Typ
then
return True;
end if;
P := Parent (P);
end loop;
end if;
-- In any other context this is not a current occurence
return False;
end Is_Current_Instance;
--------------------
-- Is_Declaration --
--------------------

6
gcc/ada/sem_util.ads
View File

@ -1237,6 +1237,12 @@ package Sem_Util is
-- First determine whether type T is an interface and then check whether
-- it is of protected, synchronized or task kind.
function Is_Current_Instance (N : Node_Id) return Boolean;
-- Predicate is true if N legally denotes a type name within its own
-- declaration. Prior to Ada 2012 this covered only synchronized type
-- declarations. In Ada2012 it also covers type and subtype declarations
-- with aspects: Invariant, Predicate, and Default_Initial_Condition.
function Is_Declaration (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a declaration

170
gcc/ada/targparm.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1999-2015, 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- --
@ -154,7 +154,10 @@ package body Targparm is
procedure Get_Target_Parameters
(Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
Set_RND : Set_RND_Type := null)
Set_NOD : Set_NOD_Type := null;
Set_NSA : Set_NSA_Type := null;
Set_NUA : Set_NUA_Type := null;
Set_NUP : Set_NUP_Type := null)
is
Text : Source_Buffer_Ptr;
Hi : Source_Ptr;
@ -181,7 +184,10 @@ package body Targparm is
Source_Last => Hi,
Make_Id => Make_Id,
Make_SC => Make_SC,
Set_RND => Set_RND);
Set_NOD => Set_NOD,
Set_NSA => Set_NSA,
Set_NUA => Set_NUA,
Set_NUP => Set_NUP);
end Get_Target_Parameters;
-- Version where caller supplies system.ads text
@ -192,7 +198,10 @@ package body Targparm is
Source_Last : Source_Ptr;
Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
Set_RND : Set_RND_Type := null)
Set_NOD : Set_NOD_Type := null;
Set_NSA : Set_NSA_Type := null;
Set_NUA : Set_NUA_Type := null;
Set_NUP : Set_NUP_Type := null)
is
P : Source_Ptr;
-- Scans source buffer containing source of system.ads
@ -203,6 +212,48 @@ package body Targparm is
Result : Boolean;
-- Records boolean from system line
OK : Boolean;
-- Status result from Set_NUP/NSA/NUA call
PR_Start : Source_Ptr;
-- Pointer to ( following pragma Restrictions
procedure Collect_Name;
-- Scan a name starting at System_Text (P), and put Name in Name_Buffer,
-- with Name_Len being length, folded to lower case. On return P points
-- just past the last character (which should be a right paren).
------------------
-- Collect_Name --
------------------
procedure Collect_Name is
begin
Name_Len := 0;
loop
if System_Text (P) in 'a' .. 'z'
or else
System_Text (P) = '_'
or else
System_Text (P) in '0' .. '9'
then
Name_Buffer (Name_Len + 1) := System_Text (P);
elsif System_Text (P) in 'A' .. 'Z' then
Name_Buffer (Name_Len + 1) :=
Character'Val (Character'Pos (System_Text (P)) + 32);
else
exit;
end if;
P := P + 1;
Name_Len := Name_Len + 1;
end loop;
end Collect_Name;
-- Start of processing for Get_Target_Parameters
begin
if Parameters_Obtained then
return;
@ -261,6 +312,9 @@ package body Targparm is
elsif System_Text (P .. P + 20) = "pragma Restrictions (" then
P := P + 21;
PR_Start := P - 1;
-- Boolean restrictions
Rloop : for K in All_Boolean_Restrictions loop
declare
@ -285,7 +339,9 @@ package body Targparm is
null;
end loop Rloop;
Ploop : for K in All_Parameter_Restrictions loop
-- Restrictions taking integer parameter
Ploop : for K in Integer_Parameter_Restrictions loop
declare
Rname : constant String :=
All_Parameter_Restrictions'Image (K);
@ -400,23 +456,119 @@ package body Targparm is
P := P + 1;
end loop;
Set_RND (Unit);
Set_NOD (Unit);
goto Line_Loop_Continue;
end;
-- No_Specification_Of_Aspect case
elsif System_Text (P .. P + 29) = "No_Specification_Of_Aspect => "
then
P := P + 30;
-- Skip this processing (and simply ignore the pragma), if
-- caller did not supply the subprogram we need to process
-- such lines.
if Set_NSA = null then
goto Line_Loop_Continue;
end if;
-- We have scanned
-- "pragma Restrictions (No_Specification_Of_Aspect =>"
Collect_Name;
if System_Text (P) /= ')' then
goto Bad_Restrictions_Pragma;
else
Set_NSA (Name_Find, OK);
if OK then
goto Line_Loop_Continue;
else
goto Bad_Restrictions_Pragma;
end if;
end if;
-- No_Use_Of_Attribute case
elsif System_Text (P .. P + 22) = "No_Use_Of_Attribute => " then
P := P + 23;
-- Skip this processing (and simply ignore No_Use_Of_Attribute
-- lines) if caller did not supply the subprogram we need to
-- process such lines.
if Set_NUA = null then
goto Line_Loop_Continue;
end if;
-- We have scanned
-- "pragma Restrictions (No_Use_Of_Attribute =>"
Collect_Name;
if System_Text (P) /= ')' then
goto Bad_Restrictions_Pragma;
else
Set_NUA (Name_Find, OK);
if OK then
goto Line_Loop_Continue;
else
goto Bad_Restrictions_Pragma;
end if;
end if;
-- No_Use_Of_Pragma case
elsif System_Text (P .. P + 19) = "No_Use_Of_Pragma => " then
P := P + 20;
-- Skip this processing (and simply ignore No_Use_Of_Pragma
-- lines) if caller did not supply the subprogram we need to
-- process such lines.
if Set_NUP = null then
goto Line_Loop_Continue;
end if;
-- We have scanned
-- "pragma Restrictions (No_Use_Of_Pragma =>"
Collect_Name;
if System_Text (P) /= ')' then
goto Bad_Restrictions_Pragma;
else
Set_NUP (Name_Find, OK);
if OK then
goto Line_Loop_Continue;
else
goto Bad_Restrictions_Pragma;
end if;
end if;
end if;
-- Here if unrecognizable restrictions pragma form
<<Bad_Restrictions_Pragma>>
Set_Standard_Error;
Write_Line
("fatal error: system.ads is incorrectly formatted");
Write_Str ("unrecognized or incorrect restrictions pragma: ");
while System_Text (P) /= ')'
and then
System_Text (P) /= ASCII.LF
P := PR_Start;
loop
exit when System_Text (P) = ASCII.LF;
Write_Char (System_Text (P));
exit when System_Text (P) = ')';
P := P + 1;
end loop;

43
gcc/ada/targparm.ads
View File

@ -615,28 +615,53 @@ package Targparm is
-- selected component with Sloc value System_Location and given Prefix
-- (Pre) and Selector (Sel) values.
type Set_RND_Type is access procedure (Unit : Node_Id);
type Set_NOD_Type is access procedure (Unit : Node_Id);
-- Parameter type for Get_Target_Parameters that records a Restriction
-- No_Dependence for the given unit (identifier or selected component).
type Set_NSA_Type is access procedure (Asp : Name_Id; OK : out Boolean);
-- Parameter type for Get_Target_Parameters that records a Restriction
-- No_Specificaztion_Of_Aspect. Asp is the pragma name. OK is set True
-- if this is an OK aspect name, and False if it is not an aspect name.
type Set_NUA_Type is access procedure (Attr : Name_Id; OK : out Boolean);
-- Parameter type for Get_Target_Parameters that records a Restriction
-- No_Use_Of_Attribute. Prag is the attribute name. OK is set True if
-- this is an OK attribute name, and False if it is not an attribute name.
type Set_NUP_Type is access procedure (Prag : Name_Id; OK : out Boolean);
-- Parameter type for Get_Target_Parameters that records a Restriction
-- No_Use_Of_Pragma. Prag is the pragma name. OK is set True if this is
-- an OK pragma name, and False if it is not a recognized pragma name.
procedure Get_Target_Parameters
(System_Text : Source_Buffer_Ptr;
Source_First : Source_Ptr;
Source_Last : Source_Ptr;
Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
Set_RND : Set_RND_Type := null);
-- Called at the start of execution to obtain target parameters from
-- the source of package System. The parameters provide the source
-- text to be scanned (in System_Text (Source_First .. Source_Last)).
-- if the three subprograms are left at their default value of null,
-- Get_Target_Parameters will ignore pragma Restrictions No_Dependence
-- lines, otherwise it will use these three subprograms to record them.
Set_NOD : Set_NOD_Type := null;
Set_NSA : Set_NSA_Type := null;
Set_NUA : Set_NUA_Type := null;
Set_NUP : Set_NUP_Type := null);
-- Called at the start of execution to obtain target parameters from the
-- source of package System. The parameters provide the source text to be
-- scanned (in System_Text (Source_First .. Source_Last)). if the three
-- subprograms Make_Id, Make_SC, and Set_NOD are left at their default
-- value of null, Get_Target_Parameters will ignore pragma Restrictions
-- No_Dependence lines, otherwise it will use these three subprograms to
-- record them. Similarly if Set_NUP is left at its default value of null,
-- then any occurrences of pragma Restrictions (No_Use_Of_Pragma => XXX)
-- will be ignored, otherwise it will use this procedure to record the
-- pragma. Similarly for the NSA and NUA cases.
procedure Get_Target_Parameters
(Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
Set_RND : Set_RND_Type := null);
Set_NOD : Set_NOD_Type := null;
Set_NSA : Set_NSA_Type := null;
Set_NUA : Set_NUA_Type := null;
Set_NUP : Set_NUP_Type := null);
-- This version reads in system.ads using Osint. The idea is that the
-- caller uses the first version if they have to read system.ads anyway
-- (e.g. the compiler) and uses this simpler interface if system.ads is

52
gcc/ada/tbuild.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, 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- --
@ -24,6 +24,7 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Aspects; use Aspects;
with Csets; use Csets;
with Einfo; use Einfo;
with Elists; use Elists;
@ -779,13 +780,56 @@ package body Tbuild is
end OK_Convert_To;
-------------
-- Set_RND --
-- Set_NOD --
-------------
procedure Set_RND (Unit : Node_Id) is
procedure Set_NOD (Unit : Node_Id) is
begin
Set_Restriction_No_Dependence (Unit, Warn => False);
end Set_RND;
end Set_NOD;
-------------
-- Set_NSA --
-------------
procedure Set_NSA (Asp : Name_Id; OK : out Boolean) is
Asp_Id : constant Aspect_Id := Get_Aspect_Id (Asp);
begin
if Asp_Id = No_Aspect then
OK := False;
else
OK := True;
Set_Restriction_No_Specification_Of_Aspect (Asp_Id);
end if;
end Set_NSA;
-------------
-- Set_NUA --
-------------
procedure Set_NUA (Attr : Name_Id; OK : out Boolean) is
begin
if Is_Attribute_Name (Attr) then
OK := True;
Set_Restriction_No_Use_Of_Attribute (Get_Attribute_Id (Attr));
else
OK := False;
end if;
end Set_NUA;
-------------
-- Set_NUP --
-------------
procedure Set_NUP (Prag : Name_Id; OK : out Boolean) is
begin
if Is_Pragma_Name (Prag) then
OK := True;
Set_Restriction_No_Use_Of_Pragma (Get_Pragma_Id (Prag));
else
OK := False;
end if;
end Set_NUP;
--------------------------
-- Unchecked_Convert_To --

9
gcc/ada/tbuild.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, 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- --
@ -347,9 +347,12 @@ package Tbuild is
function Make_Id (Str : Text_Buffer) return Node_Id;
function Make_SC (Pre, Sel : Node_Id) return Node_Id;
procedure Set_RND (Unit : Node_Id);
procedure Set_NOD (Unit : Node_Id);
procedure Set_NSA (Asp : Name_Id; OK : out Boolean);
procedure Set_NUA (Attr : Name_Id; OK : out Boolean);
procedure Set_NUP (Prag : Name_Id; OK : out Boolean);
-- Subprograms for call to Get_Target_Parameters in Gnat1drv, see spec
-- of package Targparm for full description of these three subprograms.
-- of package Targparm for full description of these four subprograms.
-- These have to be declared at the top level of a package (accessibility
-- issues), and Gnat1drv is a procedure, so they can't go there.