Skip to content

R
riscv-gcc-1
Commit 5f3ab6fb by Arnaud Charlet
Options

s-atacco.ads, [...]: Protect use of 'Constrained by warnings on/off... 

	* s-atacco.ads, a-direio.adb: Protect use of 'Constrained by warnings
	on/off, since this is an obsolescent feature, for which we now generate
	a warning.

	* sem_attr.adb (Analyze_Attribute, case Constrained): Issue warning if
	warning mode is set and obsolescent usage of this attribute occurs.
	(Resolve_Access, case 'Access): Note that GNAT uses the context type to
	disambiguate overloaded prefixes, in accordance with AI-235. GNAT code
	predates, and partly motivates, the adoption of the AI.
	Implement new Ada 2005 attribute Mod

	* exp_attr.adb (Expand_N_Attribute_Reference): Implement Ada 2005
	attribute Mod.

	* par-ch4.adb (P_Name): In Ada 2005 mode, recognize new attribute Mod

	* snames.h, snames.ads, snames.adb: Add entry for No_Dependence for
	pragma restrictions.
	New entry for Ada 2005 attribute Mod.

	* par-prag.adb:
	Add recognition of new pragma Restrictions No_Dependence
	Recognize restriction No_Obsolescent_Features at parse time

	* bcheck.adb: Add circuitry for checking for consistency of
	No_Dependence restrictions.

	* lib-writ.ads, lib-writ.adb: Output new R lines for No_Dependence
	restrictions.

	* restrict.ads, restrict.adb: Add subprograms to deal with
	No_Dependence restrictions.

	* rtsfind.adb: Check that implicit with's do not violate No_Dependence
	restrictions.

	* sem_ch3.adb, sem_ch11.adb, sem_ch13.adb, lib-xref.adb,
	sem_attr.adb: Add check for new restriction No_Obsolescent_Features

	* scn.ads, prj-err.ads, prj-err.adb, ali-util.adb, gprep.adb: Add new
	dummy parameter to scng instantiation.
	Needed for new restriction No_Obsolescent_Features

	* scn.adb: (Obsolescent_Check): New procedure
	Needed for new restriction No_Obsolescent_Features

	* scng.ads, scng.adb: Always allow wide characters in Ada 2005 mode, as
	specified by AI-285, needed for implementation of AI-388 (adding greek
	pi to Ada.Numerics).
	Add new generic formal to scng, needed for new restriction
	No_Obsolescent_Features.

	* s-rident.ads: Add new restriction No_Obsolescent_Features.

	* ali.ads, ali.adb: Adjustments for reading new No_Dependence
	restrictions lines.
	(Scan_ALI): When finding an unexpected character on an R line, raise
	exception Bad_R_Line, instead of calling Fatal_Error, so that, when
	Ignore_Errors is True, default restrictions are set and scanning of the
	ALI file continues with the next line. Also, when Bad_R_Line is raised
	and Ignore_Errors is True, skip to the end of le line.

	* sem_ch10.adb: Check that explicit with's do not violate
	No_Dependence restrictions.
	(Install_Withed_Unit): Add code to implement AI-377 and diagnose
	illegal context clauses containing child units of instance.

	* sem_prag.adb: Processing and checking for new No_Dependence
	restrictions.
	(Analyze_Pragma, case Psect_Object): Call Check_Arg_Is_External_Name to
	analyze and check the External argument.

	* a-numeri.ads: Add greek letter pi as alternative spelling of Pi

From-SVN: r92829
parent b1c1e25c
Showing with 866 additions and 152 deletions
gcc/ada/a-direio.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
......@@ -183,9 +183,15 @@ package body Ada.Direct_IO is
-- For a non-constrained variant record type, we read into an
-- intermediate buffer, since we may have the case of discriminated
-- records where a discriminant check is required, and we may need
-- to assign only part of the record buffer originally written
-- to assign only part of the record buffer originally written.
-- Note: we have to turn warnings on/off because this use of
-- the Constrained attribute is an obsolescent feature.
pragma Warnings (Off);
if not Element_Type'Constrained then
pragma Warnings (On);
declare
Buf : Element_Type;
......@@ -205,7 +211,13 @@ package body Ada.Direct_IO is
begin
-- Same processing for unconstrained case as above
-- Note: we have to turn warnings on/off because this use of
-- the Constrained attribute is an obsolescent feature.
pragma Warnings (Off);
if not Element_Type'Constrained then
pragma Warnings (On);
declare
Buf : Element_Type;
......
gcc/ada/a-numeri.ads
......@@ -22,7 +22,12 @@ pragma Pure (Numerics);
Pi : constant :=
3.14159_26535_89793_23846_26433_83279_50288_41971_69399_37511;
["03C0"] : constant := Pi;
-- This is the greek letter Pi. Note that it is conforming to have this
-- present even in Ada 95 mode, because there is no way for a normal mode
-- Ada 95 program to reference this identifier in any case.
e : constant :=
2.71828_18284_59045_23536_02874_71352_66249_77572_47093_69996;
2.71828_18284_59045_23536_02874_71352_66249_77572_47093_69996;
end Ada.Numerics;
gcc/ada/ali-util.adb
......@@ -53,7 +53,9 @@ package body ALI.Util is
procedure Error_Msg_SP (Msg : String);
-- Instantiation of Styleg, needed to instantiate Scng
procedure Obsolescent_Check (S : Source_Ptr);
-- Instantiation of Styleg, needed to instantiate Scng
package Style is new Styleg
(Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP);
......@@ -62,7 +64,8 @@ package body ALI.Util is
-- Get_File_Checksum).
package Scanner is new Scng
(Post_Scan, Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP, Style);
(Post_Scan, Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP,
Obsolescent_Check, Style);
type Header_Num is range 0 .. 1_000;
......@@ -200,6 +203,16 @@ package body ALI.Util is
Interfaces.Reset;
end Initialize_ALI_Source;
-----------------------
-- Obsolescent_Check --
-----------------------
procedure Obsolescent_Check (S : Source_Ptr) is
pragma Warnings (Off, S);
begin
null;
end Obsolescent_Check;
---------------
-- Post_Scan --
---------------
......
gcc/ada/ali.adb
......@@ -84,6 +84,7 @@ package body ALI is
-- Initialize all tables
ALIs.Init;
No_Deps.Init;
Units.Init;
Withs.Init;
Sdep.Init;
......@@ -199,7 +200,7 @@ package body ALI is
-- quote.
function Get_Nat return Nat;
-- Skip blanks, then scan out an unsigned integer value in Nat range.
-- Skip blanks, then scan out an unsigned integer value in Nat range
function Get_Stamp return Time_Stamp_Type;
-- Skip blanks, then scan out a time stamp
......@@ -212,7 +213,7 @@ package body ALI is
-- at end of line). Also skips past any following blank lines.
procedure Skip_Line;
-- Skip rest of current line and any following blank lines.
-- Skip rest of current line and any following blank lines
procedure Skip_Space;
-- Skip past white space (blanks or horizontal tab)
......@@ -948,7 +949,7 @@ package body ALI is
C := Getc;
Check_Unknown_Line;
-- Acquire restrictions line
-- Acquire first restrictions line
while C /= 'R' loop
if Ignore_Errors then
......@@ -974,7 +975,7 @@ package body ALI is
-- Save cumulative restrictions in case we have a fatal error
Bad_R_Line : exception;
-- Signal bad restrictions line
-- Signal bad restrictions line (raised on unexpected character)
begin
Checkc (' ');
......@@ -998,7 +999,7 @@ package body ALI is
null;
when others =>
Fatal_Error;
raise Bad_R_Line;
end case;
end loop;
......@@ -1031,7 +1032,7 @@ package body ALI is
end;
when others =>
Fatal_Error;
raise Bad_R_Line;
end case;
-- Acquire restrictions violations information
......@@ -1078,7 +1079,7 @@ package body ALI is
end if;
when others =>
Fatal_Error;
raise Bad_R_Line;
end case;
end loop;
......@@ -1095,6 +1096,7 @@ package body ALI is
if Ignore_Errors then
Cumulative_Restrictions := Save_R;
ALIs.Table (Id).Restrictions := Restrictions_Initial;
Skip_Eol;
-- In normal mode, this is a fatal error
......@@ -1105,9 +1107,23 @@ package body ALI is
end Scan_Restrictions;
end if;
-- Acquire 'I' lines if present
-- Acquire additional restrictions (No_Dependence) lines if present
C := Getc;
while C = 'R' loop
if Ignore ('R') then
Skip_Line;
else
Skip_Space;
No_Deps.Append ((Id, Get_Name));
end if;
Skip_Eol;
C := Getc;
end loop;
-- Acquire 'I' lines if present
Check_Unknown_Line;
while C = 'I' loop
......
gcc/ada/ali.ads
......@@ -581,6 +581,29 @@ package ALI is
Hash => SHash,
Equal => SEq);
-------------------------
-- No_Dependency Table --
-------------------------
-- Each R line for a No_Dependency Restriction generates an entry in
-- this No_Dependency table.
type No_Dep_Record is record
ALI_File : ALI_Id;
-- ALI File containing tne entry
No_Dep_Unit : Name_Id;
-- Id for names table entry including entire name, including periods.
end record;
package No_Deps is new Table.Table (
Table_Component_Type => No_Dep_Record,
Table_Index_Type => Integer,
Table_Low_Bound => 0,
Table_Initial => 200,
Table_Increment => 400,
Table_Name => "No_Deps");
------------------------------------
-- Sdep (Source Dependency) Table --
------------------------------------
......@@ -807,7 +830,7 @@ package ALI is
--------------------------------------
procedure Initialize_ALI;
-- Initialize the ALI tables. Also resets all switch values to defaults.
-- Initialize the ALI tables. Also resets all switch values to defaults
function Scan_ALI
(F : File_Name_Type;
......
gcc/ada/bcheck.adb
......@@ -56,8 +56,12 @@ package body Bcheck is
procedure Check_Consistent_Zero_Cost_Exception_Handling;
procedure Consistency_Error_Msg (Msg : String);
-- Produce an error or a warning message, depending on whether
-- an inconsistent configuration is permitted or not.
-- Produce an error or a warning message, depending on whether an
-- inconsistent configuration is permitted or not.
function Same_Unit (U1 : Name_Id; U2 : Name_Id) return Boolean;
-- Used to compare two unit names for No_Dependence checks. U1 is in
-- standard unit name format, and U2 is in literal form with periods.
------------------------------------
-- Check_Consistent_Configuration --
......@@ -539,8 +543,65 @@ package body Bcheck is
end loop;
end if;
end loop;
-- Now deal with No_Dependence indications. Note that we put the loop
-- through entries in the no dependency table first, since this loop
-- is most often empty (no such pragma Restrictions in use).
for ND in No_Deps.First .. No_Deps.Last loop
declare
ND_Unit : constant Name_Id := No_Deps.Table (ND).No_Dep_Unit;
begin
for J in ALIs.First .. ALIs.Last loop
declare
A : ALIs_Record renames ALIs.Table (J);
begin
for K in A.First_Unit .. A.Last_Unit loop
declare
U : Unit_Record renames Units.Table (K);
begin
for L in U.First_With .. U.Last_With loop
if Same_Unit (Withs.Table (L).Uname, ND_Unit) then
Error_Msg_Name_1 := U.Uname;
Error_Msg_Name_2 := ND_Unit;
Consistency_Error_Msg
("unit & violates restriction " &
"No_Dependence => %");
end if;
end loop;
end;
end loop;
end;
end loop;
end;
end loop;
end Check_Consistent_Restrictions;
---------------
-- Same_Unit --
---------------
function Same_Unit (U1 : Name_Id; U2 : Name_Id) return Boolean is
begin
-- Note, the string U1 has a terminating %s or %b, U2 does not
if Length_Of_Name (U1) - 2 = Length_Of_Name (U2) then
Get_Name_String (U1);
declare
U1_Str : constant String := Name_Buffer (1 .. Name_Len - 2);
begin
Get_Name_String (U2);
return U1_Str = Name_Buffer (1 .. Name_Len);
end;
else
return False;
end if;
end Same_Unit;
---------------------------------------------------
-- Check_Consistent_Zero_Cost_Exception_Handling --
---------------------------------------------------
......
gcc/ada/exp_attr.adb
......@@ -2324,6 +2324,87 @@ package body Exp_Attr is
Analyze_And_Resolve (N, Typ);
end Mantissa;
---------
-- Mod --
---------
when Attribute_Mod => Mod_Case : declare
Arg : constant Node_Id := Relocate_Node (First (Exprs));
Hi : constant Node_Id := Type_High_Bound (Etype (Arg));
Modv : constant Uint := Modulus (Btyp);
begin
-- This is not so simple. The issue is what type to use for the
-- computation of the modular value.
-- The easy case is when the modulus value is within the bounds
-- of the signed integer type of the argument. In this case we can
-- just do the computation in that signed integer type, and then
-- do an ordinary conversion to the target type.
if Modv <= Expr_Value (Hi) then
Rewrite (N,
Convert_To (Btyp,
Make_Op_Mod (Loc,
Left_Opnd => Arg,
Right_Opnd => Make_Integer_Literal (Loc, Modv))));
-- Here we know that the modulus is larger than type'Last of the
-- integer type. There are three possible cases to consider:
-- a) The integer value is non-negative. In this case, it is
-- returned as the result (since it is less than the modulus).
-- b) The integer value is negative. In this case, we know that
-- the result is modulus + value, where the value might be as
-- small as -modulus. The trouble is what type do we use to do
-- this subtraction. No type will do, since modulus can be as
-- big as 2**64, and no integer type accomodates this value.
-- Let's do a bit of algebra
-- modulus + value
-- = modulus - (-value)
-- = (modulus - 1) - (-value - 1)
-- Now modulus - 1 is certainly in range of the modular type.
-- -value is in the range 1 .. modulus, so -value -1 is in the
-- range 0 .. modulus-1 which is in range of the modular type.
-- Furthermore, (-value - 1) can be expressed as -(value + 1)
-- which we can compute using the integer base type.
else
Rewrite (N,
Make_Conditional_Expression (Loc,
Expressions => New_List (
Make_Op_Ge (Loc,
Left_Opnd => Duplicate_Subexpr (Arg),
Right_Opnd => Make_Integer_Literal (Loc, 0)),
Convert_To (Btyp,
Duplicate_Subexpr_No_Checks (Arg)),
Make_Op_Subtract (Loc,
Left_Opnd =>
Make_Integer_Literal (Loc,
Intval => Modv - 1),
Right_Opnd =>
Convert_To (Btyp,
Make_Op_Minus (Loc,
Right_Opnd =>
Make_Op_Add (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Arg),
Right_Opnd =>
Make_Integer_Literal (Loc,
Intval => 1))))))));
end if;
Analyze_And_Resolve (N, Btyp);
end Mod_Case;
-----------
-- Model --
-----------
......
gcc/ada/gprep.adb
......@@ -82,6 +82,9 @@ package body GPrep is
procedure Display_Copyright;
-- Display the copyright notice
procedure Obsolescent_Check (S : Source_Ptr);
-- Null procedure, needed by instantiation of Scng below
procedure Post_Scan;
-- Null procedure, needed by instantiation of Scng below
......@@ -91,6 +94,7 @@ package body GPrep is
Errutil.Error_Msg_S,
Errutil.Error_Msg_SC,
Errutil.Error_Msg_SP,
Obsolescent_Check,
Errutil.Style);
-- The scanner for the preprocessor
......@@ -298,6 +302,17 @@ package body GPrep is
New_Line (Outfile.all);
end New_EOL_To_Outfile;
-----------------------
-- Obsolescent_Check --
-----------------------
procedure Obsolescent_Check (S : Source_Ptr) is
pragma Warnings (Off, S);
begin
null;
end Obsolescent_Check;
---------------
-- Post_Scan --
---------------
......
gcc/ada/lib-writ.adb
......@@ -53,6 +53,14 @@ with System.WCh_Con; use System.WCh_Con;
package body Lib.Writ is
-----------------------
-- Local Subprograms --
-----------------------
procedure Write_Unit_Name (N : Node_Id);
-- Used to write out the unit name for R (pragma Restriction) lines
-- for uses of Restriction (No_Dependence => unit-name).
----------------------------------
-- Add_Preprocessing_Dependency --
----------------------------------
......@@ -940,7 +948,7 @@ package body Lib.Writ is
end if;
end loop;
-- Output restrictions line
-- Output first restrictions line
Write_Info_Initiate ('R');
Write_Info_Char (' ');
......@@ -987,6 +995,19 @@ package body Lib.Writ is
Write_Info_EOL;
-- Output R lines for No_Dependence entries
for J in No_Dependence.First .. No_Dependence.Last loop
if In_Extended_Main_Source_Unit (No_Dependence.Table (J).Unit)
and then not No_Dependence.Table (J).Warn
then
Write_Info_Initiate ('R');
Write_Info_Char (' ');
Write_Unit_Name (No_Dependence.Table (J).Unit);
Write_Info_EOL;
end if;
end loop;
-- Output interrupt state lines
for J in Interrupt_States.First .. Interrupt_States.Last loop
......@@ -1099,7 +1120,23 @@ package body Lib.Writ is
Output_References;
Write_Info_Terminate;
Close_Output_Library_Info;
end Write_ALI;
---------------------
-- Write_Unit_Name --
---------------------
procedure Write_Unit_Name (N : Node_Id) is
begin
if Nkind (N) = N_Identifier then
Write_Info_Name (Chars (N));
else
pragma Assert (Nkind (N) = N_Selected_Component);
Write_Unit_Name (Prefix (N));
Write_Info_Char ('.');
Write_Unit_Name (Selector_Name (N));
end if;
end Write_Unit_Name;
end Lib.Writ;
gcc/ada/lib-writ.ads
......@@ -254,7 +254,7 @@ package Lib.Writ is
-- -- R Restrictions --
-- ---------------------
-- The R line records the status of restrictions generated by pragma
-- The first R line records the status of restrictions generated by pragma
-- Restrictions encountered, as well as information on what the compiler
-- has been able to determine with respect to restrictions violations.
-- The format is:
......@@ -343,6 +343,16 @@ package Lib.Writ is
-- signal a fatal error if it is missing. This means that future
-- changes to the ALI file format must retain the R line.
-- Subsequent R lines are present only if pragma Restriction No_Dependence
-- is used. There is one such line for each such pragma appearing in the
-- extended main unit. The format is
-- R unit_name
-- Here the unit name is in all lower case. The components of the unit
-- name are separated by periods. The names themselves are in encoded
-- form, as documented in Namet.
-- ------------------------
-- -- I Interrupt States --
-- ------------------------
......
gcc/ada/lib-xref.adb
......@@ -32,6 +32,8 @@ with Lib.Util; use Lib.Util;
with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
......@@ -259,6 +261,10 @@ package body Lib.Xref is
begin
pragma Assert (Nkind (E) in N_Entity);
if E = Standard_ASCII then
Check_Restriction (No_Obsolescent_Features, N);
end if;
-- Never collect references if not in main source unit. However,
-- we omit this test if Typ is 'e' or 'k', since these entries are
-- really structural, and it is useful to have them in units
......
gcc/ada/par-ch4.adb
......@@ -425,6 +425,9 @@ package body Ch4 is
elsif Token = Tok_Access then
Attr_Name := Name_Access;
elsif Token = Tok_Mod and then Ada_Version = Ada_05 then
Attr_Name := Name_Mod;
elsif Apostrophe_Should_Be_Semicolon then
Expr_Form := EF_Name;
return Name_Node;
......
gcc/ada/par-prag.adb
......@@ -32,6 +32,8 @@
with Fname.UF; use Fname.UF;
with Osint; use Osint;
with Rident; use Rident;
with Restrict; use Restrict;
with Stringt; use Stringt;
with Stylesw; use Stylesw;
with Uintp; use Uintp;
......@@ -41,6 +43,7 @@ separate (Par)
function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
Pragma_Name : constant Name_Id := Chars (Pragma_Node);
Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pragma_Name);
Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node);
Arg_Count : Nat;
Arg_Node : Node_Id;
......@@ -83,6 +86,14 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
-- Same as Check_Optional_Identifier, except that the name is required
-- to be present and to match the given Id value.
procedure Process_Restrictions_Or_Restriction_Warnings;
-- Common processing for Restrictions and Restriction_Warnings pragmas.
-- This routine only processes the case of No_Obsolescent_Features,
-- which is the only restriction that has syntactic effects. No general
-- error checking is done, since this will be done in Sem_Prag. The
-- other case processed is pragma Restrictions No_Dependence, since
-- otherwise this is done too late.
----------
-- Arg1 --
----------
......@@ -196,9 +207,40 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
end if;
end Check_Required_Identifier;
----------
-- Prag --
----------
--------------------------------------------------
-- Process_Restrictions_Or_Restriction_Warnings --
--------------------------------------------------
procedure Process_Restrictions_Or_Restriction_Warnings is
Arg : Node_Id;
Id : Name_Id;
Expr : Node_Id;
begin
Arg := Arg1;
while Present (Arg) loop
Id := Chars (Arg);
Expr := Expression (Arg);
if Id = No_Name
and then Nkind (Expr) = N_Identifier
and then Get_Restriction_Id (Chars (Expr)) = No_Obsolescent_Features
then
Set_Restriction (No_Obsolescent_Features, Pragma_Node);
Restriction_Warnings (No_Obsolescent_Features) :=
Prag_Id = Pragma_Restriction_Warnings;
elsif Id = Name_No_Dependence then
Set_Restriction_No_Dependence
(Unit => Expr,
Warn => Prag_Id = Pragma_Restriction_Warnings);
end if;
Next (Arg);
end loop;
end Process_Restrictions_Or_Restriction_Warnings;
-- Start if processing for Prag
begin
Error_Msg_Name_1 := Pragma_Name;
......@@ -207,7 +249,7 @@ begin
-- it is a semantic error, not a syntactic one (we have already checked
-- the syntax for the unrecognized pragma as required by (RM 2.8(11)).
if not Is_Pragma_Name (Chars (Pragma_Node)) then
if Prag_Id = Unknown_Pragma then
return Pragma_Node;
end if;
......@@ -234,7 +276,7 @@ begin
-- Remaining processing is pragma dependent
case Get_Pragma_Id (Pragma_Name) is
case Prag_Id is
------------
-- Ada_83 --
......@@ -369,6 +411,38 @@ begin
List_Pragmas.Increment_Last;
List_Pragmas.Table (List_Pragmas.Last) := (Page, Semi);
------------------
-- Restrictions --
------------------
-- pragma Restrictions (RESTRICTION {, RESTRICTION});
-- RESTRICTION ::=
-- restriction_IDENTIFIER
-- | restriction_parameter_IDENTIFIER => EXPRESSION
-- We process the case of No_Obsolescent_Features, since this has
-- a syntactic effect that we need to detect at parse time (the use
-- of replacement characters such as colon for pound sign).
when Pragma_Restrictions =>
Process_Restrictions_Or_Restriction_Warnings;
--------------------------
-- Restriction_Warnings --
--------------------------
-- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
-- RESTRICTION ::=
-- restriction_IDENTIFIER
-- | restriction_parameter_IDENTIFIER => EXPRESSION
-- See above comment for pragma Restrictions
when Pragma_Restriction_Warnings =>
Process_Restrictions_Or_Restriction_Warnings;
----------------------------------------------------------
-- Source_File_Name and Source_File_Name_Project (GNAT) --
----------------------------------------------------------
......@@ -1003,8 +1077,6 @@ begin
Pragma_Queuing_Policy |
Pragma_Remote_Call_Interface |
Pragma_Remote_Types |
Pragma_Restrictions |
Pragma_Restriction_Warnings |
Pragma_Restricted_Run_Time |
Pragma_Ravenscar |
Pragma_Reviewable |
......
gcc/ada/prj-err.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 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- --
......@@ -31,6 +31,16 @@ with Stringt; use Stringt;
package body Prj.Err is
-----------------------
-- Obsolescent_Check --
-----------------------
procedure Obsolescent_Check (S : Source_Ptr) is
pragma Warnings (Off, S);
begin
null;
end Obsolescent_Check;
---------------
-- Post_Scan --
---------------
......
gcc/ada/prj-err.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 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- --
......@@ -58,12 +58,12 @@ package Prj.Err is
-- file before using any of the other routines in the package.
procedure Finalize (Source_Type : String := "project")
renames Errutil.Finalize;
renames Errutil.Finalize;
-- Finalize processing of error messages for one file and output message
-- indicating the number of detected errors.
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr)
renames Errutil.Error_Msg;
renames Errutil.Error_Msg;
-- Output a message at specified location.
procedure Error_Msg_S (Msg : String) renames Errutil.Error_Msg_S;
......@@ -85,16 +85,20 @@ package Prj.Err is
-- Instantiation of the generic style package, needed for the instantiation
-- of the generic scanner below.
procedure Obsolescent_Check (S : Source_Ptr);
-- Dummy null procedure for Scng instantiation
procedure Post_Scan;
-- Convert an Ada operator symbol into a standard string
package Scanner is new Scng
(Post_Scan => Post_Scan,
Error_Msg => Error_Msg,
Error_Msg_S => Error_Msg_S,
Error_Msg_SC => Error_Msg_SC,
Error_Msg_SP => Error_Msg_SP,
Style => Style);
(Post_Scan => Post_Scan,
Error_Msg => Error_Msg,
Error_Msg_S => Error_Msg_S,
Error_Msg_SC => Error_Msg_SC,
Error_Msg_SP => Error_Msg_SP,
Obsolescent_Check => Obsolescent_Check,
Style => Style);
-- Instantiation of the generic scanner
end Prj.Err;
gcc/ada/restrict.adb
......@@ -61,6 +61,10 @@ package body Restrict is
-- in the Names table, and this table will be locked if we are
-- generating a message from gigi.
function Same_Unit (U1, U2 : Node_Id) return Boolean;
-- Returns True iff U1 and U2 represent the same library unit. Used for
-- handling of No_Dependence => Unit restriction case.
function Suppress_Restriction_Message (N : Node_Id) return Boolean;
-- N is the node for a possible restriction violation message, but
-- the message is to be suppressed if this is an internal file and
......@@ -302,6 +306,36 @@ package body Restrict is
end if;
end Check_Restriction;
-------------------------------------
-- Check_Restriction_No_Dependence --
-------------------------------------
procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is
DU : Node_Id;
begin
for J in No_Dependence.First .. No_Dependence.Last loop
DU := No_Dependence.Table (J).Unit;
if Same_Unit (U, DU) then
Error_Msg_Sloc := Sloc (DU);
Error_Msg_Node_1 := DU;
if No_Dependence.Table (J).Warn then
Error_Msg
("?violation of restriction `No_Dependence '='> &`#",
Sloc (Err));
else
Error_Msg
("|violation of restriction `No_Dependence '='> &`#",
Sloc (Err));
end if;
return;
end if;
end loop;
end Check_Restriction_No_Dependence;
----------------------------------------
-- Cunit_Boolean_Restrictions_Restore --
----------------------------------------
......@@ -496,6 +530,31 @@ package body Restrict is
Error_Msg_N (B (1 .. P), N);
end Restriction_Msg;
---------------
-- Same_Unit --
---------------
function Same_Unit (U1, U2 : Node_Id) return Boolean is
begin
if Nkind (U1) = N_Identifier then
return Nkind (U2) = N_Identifier and then Chars (U1) = Chars (U2);
elsif Nkind (U2) = N_Identifier then
return False;
elsif (Nkind (U1) = N_Selected_Component
or else Nkind (U1) = N_Expanded_Name)
and then
(Nkind (U2) = N_Selected_Component
or else Nkind (U2) = N_Expanded_Name)
then
return Same_Unit (Prefix (U1), Prefix (U2))
and then Same_Unit (Selector_Name (U1), Selector_Name (U2));
else
return False;
end if;
end Same_Unit;
------------------------------
-- Set_Profile_Restrictions --
------------------------------
......@@ -612,6 +671,38 @@ package body Restrict is
end if;
end Set_Restriction;
-----------------------------------
-- Set_Restriction_No_Dependence --
-----------------------------------
procedure Set_Restriction_No_Dependence
(Unit : Node_Id;
Warn : Boolean)
is
begin
-- Loop to check for duplicate entry
for J in No_Dependence.First .. No_Dependence.Last loop
-- Case of entry already in table
if Same_Unit (Unit, No_Dependence.Table (J).Unit) then
-- Error has precedence over warning
if not Warn then
No_Dependence.Table (J).Warn := False;
end if;
return;
end if;
end loop;
-- Entry is in table
No_Dependence.Append ((Unit, Warn));
end Set_Restriction_No_Dependence;
----------------------------------
-- Suppress_Restriction_Message --
----------------------------------
......
gcc/ada/restrict.ads
......@@ -27,6 +27,7 @@
-- This package deals with the implementation of the Restrictions pragma
with Rident; use Rident;
with Table;
with Types; use Types;
with Uintp; use Uintp;
......@@ -132,6 +133,33 @@ package Restrict is
No_Elaboration_Code => True,
others => False);
-- The following table records entries made by Restrictions pragmas
-- that specify a parameter for No_Dependence. Each such pragma makes
-- an entry in this table.
-- Note: we have chosen to implement this restriction in the "syntactic"
-- form, where we do not check that the named package is a language defined
-- package, but instead we allow arbitrary package names. The discussion of
-- this issue is not complete in the ARG, but the sense seems to be leaning
-- in this direction, which makes more sense to us, since it is much more
-- useful, and much easier to implement.
type ND_Entry is record
Unit : Node_Id;
-- The unit parameter from the No_Dependence pragma
Warn : Boolean;
-- True if from Restriction_Warnings, False if from Restrictions
end record;
package No_Dependence is new Table.Table (
Table_Component_Type => ND_Entry,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => 200,
Table_Increment => 200,
Table_Name => "Name_No_Dependence");
-----------------
-- Subprograms --
-----------------
......@@ -162,6 +190,11 @@ package Restrict is
-- violation. If the exact count is not known, V is left at its
-- default value of -1 which indicates an unknown count.
procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id);
-- Called when a dependence on a unit is created (either implicitly, or by
-- an explicit WITH clause). U is a node for the unit involved, and Err
-- is the node to which an error will be attached if necessary.
procedure Check_Elaboration_Code_Allowed (N : Node_Id);
-- Tests to see if elaboration code is allowed by the current restrictions
-- settings. This function is called by Gigi when it needs to define
......@@ -241,6 +274,12 @@ package Restrict is
-- Similar to the above, except that this is used for the case of a
-- parameter restriction, and the corresponding value V is given.
procedure Set_Restriction_No_Dependence
(Unit : Node_Id;
Warn : Boolean);
-- Sets given No_Dependence restriction in table if not there already.
-- Warn is True if from Restriction_Warnings, False if from Restrictions.
function Tasking_Allowed return Boolean;
pragma Inline (Tasking_Allowed);
-- Tests to see if tasking operations are allowed by the current
......
gcc/ada/rtsfind.adb
......@@ -40,6 +40,7 @@ with Nlists; use Nlists;
with Nmake; use Nmake;
with Output; use Output;
with Opt; use Opt;
with Restrict; use Restrict;
with Sem; use Sem;
with Sem_Ch7; use Sem_Ch7;
with Sem_Util; use Sem_Util;
......@@ -1007,6 +1008,7 @@ package body Rtsfind is
Mark_Rewrite_Insertion (Withn);
Append (Withn, Context_Items (Cunit (Current_Sem_Unit)));
Check_Restriction_No_Dependence (Name (Withn), Current_Error_Node);
end;
end if;
......
gcc/ada/s-atacco.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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 --
......@@ -46,7 +46,12 @@ pragma Preelaborate (Address_To_Access_Conversions);
"Object is unconstrained array type" & ASCII.LF &
"To_Pointer results may not have bounds");
xyz : Boolean := Object'Constrained;
-- Capture constrained status, suppressing warnings, since this is
-- an obsolescent feature to use Constrained in this way (RM J.4).
pragma Warnings (Off);
Xyz : Boolean := Object'Constrained;
pragma Warnings (On);
type Object_Pointer is access all Object;
for Object_Pointer'Size use Standard'Address_Size;
......
gcc/ada/s-rident.ads
......@@ -116,6 +116,7 @@ package System.Rident is
No_Implementation_Pragmas, -- GNAT
No_Implementation_Restrictions, -- GNAT
No_Elaboration_Code, -- GNAT
No_Obsolescent_Features, -- Ada 2005 AI-368
-- The following cases require a parameter value
......@@ -166,7 +167,7 @@ package System.Rident is
-- All restrictions (excluding only Not_A_Restriction_Id)
subtype All_Boolean_Restrictions is Restriction_Id range
Simple_Barriers .. No_Elaboration_Code;
Simple_Barriers .. No_Obsolescent_Features;
-- All restrictions which do not take a parameter
subtype Partition_Boolean_Restrictions is All_Boolean_Restrictions range
......@@ -177,7 +178,7 @@ package System.Rident is
-- case of Boolean restrictions.
subtype Cunit_Boolean_Restrictions is All_Boolean_Restrictions range
Immediate_Reclamation .. No_Elaboration_Code;
Immediate_Reclamation .. No_Obsolescent_Features;
-- Boolean restrictions that are not checked for partition consistency
-- and that thus apply only to the current unit. Note that for these
-- restrictions, the compiler does not apply restrictions found in
......
gcc/ada/scn.adb
......@@ -28,6 +28,8 @@ with Atree; use Atree;
with Csets; use Csets;
with Namet; use Namet;
with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
with Scans; use Scans;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
......@@ -321,6 +323,20 @@ package body Scn is
end loop;
end Initialize_Scanner;
-----------------------
-- Obsolescent_Check --
-----------------------
procedure Obsolescent_Check (S : Source_Ptr) is
begin
-- This is a pain in the neck case, since we normally need a node to
-- call Check_Restrictions, and all we have is a source pointer. The
-- easiest thing is to construct a dummy node. A bit kludgy, but this
-- is a marginal case. It's not worth trying to do things more cleanly.
Check_Restriction (No_Obsolescent_Features, New_Node (N_Empty, S));
end Obsolescent_Check;
------------------------------
-- Scan_Reserved_Identifier --
------------------------------
......
gcc/ada/scn.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
......@@ -48,6 +48,10 @@ package Scn is
-- Determines the casing style of the current token, which is
-- either a keyword or an identifier. See also package Casing.
procedure Obsolescent_Check (S : Source_Ptr);
-- Called to handle pragma restrictions check for usage of obsolescent
-- character replacements during the scan.
procedure Post_Scan;
pragma Inline (Post_Scan);
-- Create nodes for tokens: Char_Literal, Identifier, Real_Literal,
......@@ -69,12 +73,13 @@ package Scn is
-- generic package Scng with routines appropriate to the compiler
package Scanner is new Scng
(Post_Scan => Post_Scan,
Error_Msg => Error_Msg,
Error_Msg_S => Error_Msg_S,
Error_Msg_SC => Error_Msg_SC,
Error_Msg_SP => Error_Msg_SP,
Style => Style.Style_Inst);
(Post_Scan => Post_Scan,
Error_Msg => Error_Msg,
Error_Msg_S => Error_Msg_S,
Error_Msg_SC => Error_Msg_SC,
Error_Msg_SP => Error_Msg_SP,
Obsolescent_Check => Obsolescent_Check,
Style => Style.Style_Inst);
procedure Scan renames Scanner.Scan;
-- Scan scans out the next token, and advances the scan state accordingly
......
gcc/ada/scng.adb
......@@ -226,7 +226,7 @@ package body Scng is
Initialize_Checksum;
-- Do not call Scan, otherwise the License stuff does not work in Scn.
-- Do not call Scan, otherwise the License stuff does not work in Scn
end Initialize_Scanner;
......@@ -550,13 +550,18 @@ package body Scng is
or else
Source (Scan_Ptr + 1) in 'a' .. 'z'))
then
if C = ':' and then Warn_On_Obsolescent_Feature then
Error_Msg_S
("use of "":"" is an obsolescent feature ('R'M 'J.2(3))?");
Error_Msg_S
("\use ""'#"" instead?");
if C = ':' then
Obsolescent_Check (Scan_Ptr);
if Warn_On_Obsolescent_Feature then
Error_Msg_S
("use of "":"" is an obsolescent feature ('R'M 'J.2(3))?");
Error_Msg_S
("\use ""'#"" instead?");
end if;
end if;
Accumulate_Checksum (C);
Base_Char := C;
UI_Base := UI_Int_Value;
......@@ -1498,6 +1503,8 @@ package body Scng is
-- Percent starting a string literal
when '%' =>
Obsolescent_Check (Token_Ptr);
if Warn_On_Obsolescent_Feature then
Error_Msg_S
("use of ""'%"" is an obsolescent feature ('R'M 'J.2(4))?");
......@@ -1695,6 +1702,7 @@ package body Scng is
when '!' => Exclamation_Case : begin
Accumulate_Checksum ('!');
Obsolescent_Check (Token_Ptr);
if Warn_On_Obsolescent_Feature then
Error_Msg_S
......@@ -2043,7 +2051,11 @@ package body Scng is
-- in particular allows bracket or other notation
-- to be used for upper half letters.
if Identifier_Character_Set /= 'w' then
-- Wide characters are always allowed in Ada 2005
if Identifier_Character_Set /= 'w'
and then Ada_Version < Ada_05
then
Error_Msg
("wide character not allowed in identifier", Sptr);
end if;
......
gcc/ada/scng.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
......@@ -50,6 +50,10 @@ generic
with procedure Error_Msg_SP (Msg : String);
-- Output a message at the start of the previous token
with procedure Obsolescent_Check (S : Source_Ptr);
-- Called when one of the obsolescent character replacements is
-- used with S pointing to the character in question.
with package Style is new Styleg
(Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP);
-- Instantiation of Styleg with the same error reporting routines
......
gcc/ada/sem_attr.adb
......@@ -259,6 +259,9 @@ package body Sem_Attr is
procedure Check_Library_Unit;
-- Verify that prefix of attribute N is a library unit
procedure Check_Modular_Integer_Type;
-- Verify that prefix of attribute N is a modular integer type
procedure Check_Not_Incomplete_Type;
-- Check that P (the prefix of the attribute) is not an incomplete
-- type or a private type for which no full view has been given.
......@@ -1074,6 +1077,20 @@ package body Sem_Attr is
end if;
end Check_Library_Unit;
--------------------------------
-- Check_Modular_Integer_Type --
--------------------------------
procedure Check_Modular_Integer_Type is
begin
Check_Type;
if not Is_Modular_Integer_Type (P_Type) then
Error_Attr
("prefix of % attribute must be modular integer type", P);
end if;
end Check_Modular_Integer_Type;
-------------------------------
-- Check_Not_Incomplete_Type --
-------------------------------
......@@ -2197,6 +2214,13 @@ package body Sem_Attr is
-- Case from RM J.4(2) of constrained applied to private type
if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
Check_Restriction (No_Obsolescent_Features, N);
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("constrained for private type is an " &
"obsolescent feature ('R'M 'J.4)?", N);
end if;
-- If we are within an instance, the attribute must be legal
-- because it was valid in the generic unit. Ditto if this is
......@@ -2897,6 +2921,21 @@ package body Sem_Attr is
Resolve (E2, P_Base_Type);
Set_Etype (N, P_Base_Type);
---------
-- Mod --
---------
when Attribute_Mod =>
-- Note: this attribute is only allowed in Ada 2005 mode, but
-- we do not need to test that here, since Mod is only recognized
-- as an attribute name in Ada 2005 mode during the parse.
Check_E1;
Check_Modular_Integer_Type;
Resolve (E1, Any_Integer);
Set_Etype (N, P_Base_Type);
-----------
-- Model --
-----------
......@@ -2944,12 +2983,7 @@ package body Sem_Attr is
when Attribute_Modulus =>
Check_E0;
Check_Type;
if not Is_Modular_Integer_Type (P_Type) then
Error_Attr ("prefix of % attribute must be modular type", P);
end if;
Check_Modular_Integer_Type;
Set_Etype (N, Universal_Integer);
--------------------
......@@ -5412,10 +5446,19 @@ package body Sem_Attr is
Fold_Ureal
(N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
else
Fold_Uint (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static);
Fold_Uint
(N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static);
end if;
end Min;
---------
-- Mod --
---------
when Attribute_Mod =>
Fold_Uint
(N, UI_Mod (Expr_Value (E1), Modulus (P_Base_Type)), Static);
-----------
-- Model --
-----------
......@@ -6678,14 +6721,18 @@ package body Sem_Attr is
elsif Is_Overloaded (P) then
-- Use the designated type of the context to disambiguate
-- Use the designated type of the context to disambiguate
-- Note that this was not strictly conformant to Ada 95,
-- but was the implementation adopted by most Ada 95 compilers.
-- The use of the context type to resolve an Access attribute
-- reference is now mandated in AI-235 for Ada 2005.
declare
Index : Interp_Index;
It : Interp;
begin
Get_First_Interp (P, Index, It);
while Present (It.Typ) loop
if Covers (Designated_Type (Typ), It.Typ) then
Resolve (P, It.Typ);
......
gcc/ada/sem_ch10.adb
......@@ -1668,6 +1668,7 @@ package body Sem_Ch10 is
end if;
U := Unit (Library_Unit (N));
Check_Restriction_No_Dependence (Name (N), N);
Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit));
-- Following checks are skipped for dummy packages (those supplied
......@@ -3628,6 +3629,77 @@ package body Sem_Ch10 is
if Ekind (Uname) = E_Package then
Set_From_With_Type (Uname, False);
end if;
-- Ada 2005 (AI-377): it is illegal for a with_clause to name a child
-- unit if there is a visible homograph for it declared in the same
-- declarative region. This pathological case can only arise when an
-- instance I1 of a generic unit G1 has an explicit child unit I1.G2,
-- G1 has a generic child also named G2, and the context includes with_
-- clauses for both I1.G2 and for G1.G2, making an implicit declaration
-- of I1.G2 visible as well.
if Is_Child_Unit (Uname)
and then Is_Visible_Child_Unit (Uname)
and then Ada_Version >= Ada_05
then
declare
Decl1 : constant Node_Id := Unit_Declaration_Node (P);
Decl2 : Node_Id;
P2 : Entity_Id;
U2 : Entity_Id;
begin
U2 := Homonym (Uname);
while Present (U2) loop
P2 := Scope (U2);
Decl2 := Unit_Declaration_Node (P2);
if Is_Child_Unit (U2)
and then Is_Visible_Child_Unit (U2)
then
if Is_Generic_Instance (P)
and then Nkind (Decl1) = N_Package_Declaration
and then Generic_Parent (Specification (Decl1)) = P2
then
Error_Msg_N ("illegal with_clause", With_Clause);
Error_Msg_N
("\child unit has visible homograph" &
" ('R'M 8.3(26), 10.1.1(19))",
With_Clause);
exit;
elsif Is_Generic_Instance (P2)
and then Nkind (Decl2) = N_Package_Declaration
and then Generic_Parent (Specification (Decl2)) = P
then
-- With_clause for child unit of instance appears before
-- in the context. We want to place the error message on
-- it, not on the generic child unit itself.
declare
Prev_Clause : Node_Id;
begin
Prev_Clause := First (List_Containing (With_Clause));
while Entity (Name (Prev_Clause)) /= U2 loop
Next (Prev_Clause);
end loop;
pragma Assert (Present (Prev_Clause));
Error_Msg_N ("illegal with_clause", Prev_Clause);
Error_Msg_N
("\child unit has visible homograph" &
" ('R'M 8.3(26), 10.1.1(19))",
Prev_Clause);
exit;
end;
end if;
end if;
U2 := Homonym (U2);
end loop;
end;
end if;
end Install_Withed_Unit;
-------------------
......
gcc/ada/sem_ch11.adb
......@@ -240,14 +240,16 @@ package body Sem_Ch11 is
else
if Present (Renamed_Entity (Entity (Id))) then
if Entity (Id) = Standard_Numeric_Error
and then Warn_On_Obsolescent_Feature
then
Error_Msg_N
("Numeric_Error is an " &
"obsolescent feature ('R'M 'J.6(1))?", Id);
Error_Msg_N
("\use Constraint_Error instead?", Id);
if Entity (Id) = Standard_Numeric_Error then
Check_Restriction (No_Obsolescent_Features, Id);
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("Numeric_Error is an " &
"obsolescent feature ('R'M 'J.6(1))?", Id);
Error_Msg_N
("\use Constraint_Error instead?", Id);
end if;
end if;
end if;
......
gcc/ada/sem_ch13.adb
------------------------------------------------------------------------------
-- --
-- c --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ C H 1 3 --
......@@ -34,6 +34,8 @@ with Lib; use Lib;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
......@@ -203,6 +205,8 @@ package body Sem_Ch13 is
procedure Analyze_At_Clause (N : Node_Id) is
begin
Check_Restriction (No_Obsolescent_Features, N);
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("at clause is an obsolescent feature ('R'M 'J.7(2))?", N);
......@@ -355,6 +359,8 @@ package body Sem_Ch13 is
("\?only one task can be declared of this type", N);
end if;
Check_Restriction (No_Obsolescent_Features, N);
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("attaching interrupt to task entry is an " &
......@@ -1187,6 +1193,8 @@ package body Sem_Ch13 is
begin
if Is_Task_Type (U_Ent) then
Check_Restriction (No_Obsolescent_Features, N);
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("storage size clause for task is an " &
......@@ -1955,6 +1963,8 @@ package body Sem_Ch13 is
pragma Warnings (Off, Mod_Val);
begin
Check_Restriction (No_Obsolescent_Features, Mod_Clause (N));
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("mod clause is an obsolescent feature ('R'M 'J.8)?", N);
......
gcc/ada/sem_ch3.adb
......@@ -8188,6 +8188,8 @@ package body Sem_Ch3 is
-- Digits constraint present
if Nkind (C) = N_Digits_Constraint then
Check_Restriction (No_Obsolescent_Features, C);
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("subtype digits constraint is an " &
......@@ -8389,6 +8391,8 @@ package body Sem_Ch3 is
-- Delta constraint present
if Nkind (C) = N_Delta_Constraint then
Check_Restriction (No_Obsolescent_Features, C);
if Warn_On_Obsolescent_Feature then
Error_Msg_S
("subtype delta constraint is an " &
......
gcc/ada/sem_prag.adb
......@@ -3506,6 +3506,10 @@ package body Sem_Prag is
-- Process_Restrictions_Or_Restriction_Warnings --
--------------------------------------------------
-- Note: some of the simple identifier cases were handled in par-prag,
-- but it is harmless (and more straightforward) to simply handle all
-- cases here, even if it means we repeat a bit of work in some cases.
procedure Process_Restrictions_Or_Restriction_Warnings is
Arg : Node_Id;
R_Id : Restriction_Id;
......@@ -3513,10 +3517,33 @@ package body Sem_Prag is
Expr : Node_Id;
Val : Uint;
procedure Check_Unit_Name (N : Node_Id);
-- Checks unit name parameter for No_Dependence. Returns if it has
-- an appropriate form, otherwise raises pragma argument error.
procedure Set_Warning (R : All_Restrictions);
-- If this is a Restriction_Warnings pragma, set warning flag,
-- otherwise reset the flag.
---------------------
-- Check_Unit_Name --
---------------------
procedure Check_Unit_Name (N : Node_Id) is
begin
if Nkind (N) = N_Selected_Component then
Check_Unit_Name (Prefix (N));
Check_Unit_Name (Selector_Name (N));
elsif Nkind (N) = N_Identifier then
return;
else
Error_Pragma_Arg
("wrong form for unit name for No_Dependence", N);
end if;
end Check_Unit_Name;
-----------------
-- Set_Warning --
-----------------
......@@ -3577,7 +3604,13 @@ package body Sem_Prag is
Scope_Suppress := (others => True);
end if;
-- Case of restriction identifier present
-- Case of No_Dependence => unit-name. Note that the parser
-- already made the necessary entry in the No_Dependence table.
elsif Id = Name_No_Dependence then
Check_Unit_Name (Expr);
-- All other cases of restriction identifier present
else
R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
......@@ -8543,6 +8576,7 @@ package body Sem_Prag is
end if;
if Present (External) then
Check_Arg_Is_External_Name (External);
Check_Too_Long (External);
end if;
......
gcc/ada/snames.adb
......@@ -356,15 +356,16 @@ package body Snames is
"name#" &
"nca#" &
"no#" &
"on#" &
"parameter_types#" &
"reference#" &
"no_dependence#" &
"no_dynamic_attachment#" &
"no_dynamic_interrupts#" &
"no_requeue#" &
"no_requeue_statements#" &
"no_task_attributes#" &
"no_task_attributes_package#" &
"on#" &
"parameter_types#" &
"reference#" &
"restricted#" &
"result_mechanism#" &
"result_type#" &
......@@ -449,6 +450,7 @@ package body Snames is
"max_size_in_storage_elements#" &
"maximum_alignment#" &
"mechanism_code#" &
"mod#" &
"model_emin#" &
"model_epsilon#" &
"model_mantissa#" &
......@@ -569,7 +571,6 @@ package body Snames is
"is#" &
"limited#" &
"loop#" &
"mod#" &
"new#" &
"not#" &
"null#" &
......
gcc/ada/snames.h
......@@ -101,84 +101,85 @@ extern unsigned char Get_Attribute_Id (int);
#define Attr_Max_Size_In_Storage_Elements 53
#define Attr_Maximum_Alignment 54
#define Attr_Mechanism_Code 55
#define Attr_Model_Emin 56
#define Attr_Model_Epsilon 57
#define Attr_Model_Mantissa 58
#define Attr_Model_Small 59
#define Attr_Modulus 60
#define Attr_Null_Parameter 61
#define Attr_Object_Size 62
#define Attr_Partition_ID 63
#define Attr_Passed_By_Reference 64
#define Attr_Pool_Address 65
#define Attr_Pos 66
#define Attr_Position 67
#define Attr_Range 68
#define Attr_Range_Length 69
#define Attr_Round 70
#define Attr_Safe_Emax 71
#define Attr_Safe_First 72
#define Attr_Safe_Large 73
#define Attr_Safe_Last 74
#define Attr_Safe_Small 75
#define Attr_Scale 76
#define Attr_Scaling 77
#define Attr_Signed_Zeros 78
#define Attr_Size 79
#define Attr_Small 80
#define Attr_Storage_Size 81
#define Attr_Storage_Unit 82
#define Attr_Tag 83
#define Attr_Target_Name 84
#define Attr_Terminated 85
#define Attr_To_Address 86
#define Attr_Type_Class 87
#define Attr_UET_Address 88
#define Attr_Unbiased_Rounding 89
#define Attr_Unchecked_Access 90
#define Attr_Unconstrained_Array 91
#define Attr_Universal_Literal_String 92
#define Attr_Unrestricted_Access 93
#define Attr_VADS_Size 94
#define Attr_Val 95
#define Attr_Valid 96
#define Attr_Value_Size 97
#define Attr_Version 98
#define Attr_Wide_Character_Size 99
#define Attr_Wide_Width 100
#define Attr_Width 101
#define Attr_Word_Size 102
#define Attr_Mod 56
#define Attr_Model_Emin 57
#define Attr_Model_Epsilon 58
#define Attr_Model_Mantissa 59
#define Attr_Model_Small 60
#define Attr_Modulus 61
#define Attr_Null_Parameter 62
#define Attr_Object_Size 63
#define Attr_Partition_ID 64
#define Attr_Passed_By_Reference 65
#define Attr_Pool_Address 66
#define Attr_Pos 67
#define Attr_Position 68
#define Attr_Range 69
#define Attr_Range_Length 70
#define Attr_Round 71
#define Attr_Safe_Emax 72
#define Attr_Safe_First 73
#define Attr_Safe_Large 74
#define Attr_Safe_Last 75
#define Attr_Safe_Small 76
#define Attr_Scale 77
#define Attr_Scaling 78
#define Attr_Signed_Zeros 79
#define Attr_Size 80
#define Attr_Small 81
#define Attr_Storage_Size 82
#define Attr_Storage_Unit 83
#define Attr_Tag 84
#define Attr_Target_Name 85
#define Attr_Terminated 86
#define Attr_To_Address 87
#define Attr_Type_Class 88
#define Attr_UET_Address 89
#define Attr_Unbiased_Rounding 90
#define Attr_Unchecked_Access 91
#define Attr_Unconstrained_Array 92
#define Attr_Universal_Literal_String 93
#define Attr_Unrestricted_Access 94
#define Attr_VADS_Size 95
#define Attr_Val 96
#define Attr_Valid 97
#define Attr_Value_Size 98
#define Attr_Version 99
#define Attr_Wide_Character_Size 100
#define Attr_Wide_Width 101
#define Attr_Width 102
#define Attr_Word_Size 103
#define Attr_Adjacent 103
#define Attr_Ceiling 104
#define Attr_Copy_Sign 105
#define Attr_Floor 106
#define Attr_Fraction 107
#define Attr_Image 108
#define Attr_Input 109
#define Attr_Machine 110
#define Attr_Max 111
#define Attr_Min 112
#define Attr_Model 113
#define Attr_Pred 114
#define Attr_Remainder 115
#define Attr_Rounding 116
#define Attr_Succ 117
#define Attr_Truncation 118
#define Attr_Value 119
#define Attr_Wide_Image 120
#define Attr_Wide_Value 121
#define Attr_Adjacent 104
#define Attr_Ceiling 105
#define Attr_Copy_Sign 106
#define Attr_Floor 107
#define Attr_Fraction 108
#define Attr_Image 109
#define Attr_Input 110
#define Attr_Machine 111
#define Attr_Max 112
#define Attr_Min 113
#define Attr_Model 114
#define Attr_Pred 115
#define Attr_Remainder 116
#define Attr_Rounding 117
#define Attr_Succ 118
#define Attr_Truncation 119
#define Attr_Value 120
#define Attr_Wide_Image 121
#define Attr_Wide_Value 122
#define Attr_Output 122
#define Attr_Read 123
#define Attr_Write 124
#define Attr_Output 123
#define Attr_Read 124
#define Attr_Write 125
#define Attr_Elab_Body 125
#define Attr_Elab_Spec 126
#define Attr_Storage_Pool 127
#define Attr_Elab_Body 126
#define Attr_Elab_Spec 127
#define Attr_Storage_Pool 128
#define Attr_Base 128
#define Attr_Class 129
#define Attr_Base 129
#define Attr_Class 130
/* Define the function to check if a Name_Id value is a valid pragma */
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment