mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-22 00:01:10 +08:00
Code Issues Packages Projects Releases Wiki Activity

cstand.adb, [...]: Remove obsolete VMS-specific code.

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

	* cstand.adb, einfo.adb, einfo.ads, errout.adb, exp_attr.adb,
	exp_prag.adb, frontend.adb, interfac.ads,
	par-prag.adb, s-auxdec.ads, s-filofl.ads, s-fishfl.ads, s-fvadfl.ads,
	s-fvaffl.ads, s-fvagfl.ads, s-vaflop.ads, sem_attr.adb, sem_attr.ads,
	sem_ch13.adb, sem_ch3.adb, sem_ch8.adb, sem_prag.adb, snames.adb-tmpl,
	snames.ads-tmpl: Remove obsolete VMS-specific code.

From-SVN: r213369
This commit is contained in:
Robert Dewar 2014-07-31 13:48:33 +00:00 committed by Arnaud Charlet
parent f9648959b4
commit ba0c6e4769
25 changed files with 124 additions and 1345 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/ada/ChangeLog
View File

@ -1,3 +1,12 @@
2014-07-31 Robert Dewar <dewar@adacore.com>
* cstand.adb, einfo.adb, einfo.ads, errout.adb, exp_attr.adb,
exp_prag.adb, frontend.adb, interfac.ads,
par-prag.adb, s-auxdec.ads, s-filofl.ads, s-fishfl.ads, s-fvadfl.ads,
s-fvaffl.ads, s-fvagfl.ads, s-vaflop.ads, sem_attr.adb, sem_attr.ads,
sem_ch13.adb, sem_ch3.adb, sem_ch8.adb, sem_prag.adb, snames.adb-tmpl,
snames.ads-tmpl: Remove obsolete VMS-specific code.
2014-07-31 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb, sem_ch13.adb: Minor reformatting.

5
gcc/ada/cstand.adb
View File

@ -2125,11 +2125,6 @@ package body CStand is
Exponent : constant Uint := Emax - Mantissa;
begin
-- Note: for the call from Cstand to initially create the types in
-- Standard, Float_Rep will never be VAX_Native. Circuitry in Sem_Vfpt
-- will adjust these types appropriately VAX_Native if a pragma
-- Float_Representation (VAX_Float) is used.
H := Make_Float_Literal (Stloc, Radix, Significand, Exponent);
L := Make_Float_Literal (Stloc, Radix, -Significand, Exponent);

20
gcc/ada/einfo.adb
View File

@ -7367,13 +7367,6 @@ package body Einfo is
when others => return No_Uint;
end case;
when VAX_Native =>
case Digs is
when 1 .. 9 => return 2**7 - 1;
when 10 .. 15 => return 2**10 - 1;
when others => return No_Uint;
end case;
when AAMP =>
return Uint_2 ** Uint_7 - Uint_1;
end case;
@ -7387,7 +7380,6 @@ package body Einfo is
begin
case Float_Rep (Id) is
when IEEE_Binary => return Uint_3 - Machine_Emax_Value (Id);
when VAX_Native => return -Machine_Emax_Value (Id);
when AAMP => return -Machine_Emax_Value (Id);
end case;
end Machine_Emin_Value;
@ -7410,14 +7402,6 @@ package body Einfo is
when others => return No_Uint;
end case;
when VAX_Native =>
case Digs is
when 1 .. 6 => return Uint_24;
when 7 .. 9 => return UI_From_Int (56);
when 10 .. 15 => return UI_From_Int (53);
when others => return No_Uint;
end case;
when AAMP =>
case Digs is
when 1 .. 6 => return Uint_24;
@ -7434,7 +7418,7 @@ package body Einfo is
function Machine_Radix_Value (Id : E) return U is
begin
case Float_Rep (Id) is
when IEEE_Binary | VAX_Native | AAMP =>
when IEEE_Binary | AAMP =>
return Uint_2;
end case;
end Machine_Radix_Value;
@ -8209,7 +8193,7 @@ package body Einfo is
function Vax_Float (Id : E) return B is
begin
return Is_Floating_Point_Type (Id) and then Float_Rep (Id) = VAX_Native;
return False;
end Vax_Float;
------------------------

15
gcc/ada/einfo.ads
View File

@ -2068,13 +2068,11 @@ package Einfo is
-- access to subprograms (JGNAT only). Set to Empty unless an export,
-- import, or interface name pragma has explicitly specified an external
-- name, in which case it references an N_String_Literal node for the
-- specified external name. In the case of exceptions, the field is set
-- by Import_Exception/Export_Exception (which can be used in OpenVMS
-- versions only). Note that if this field is Empty, and Is_Imported
-- or Is_Exported is set, then the default interface name is the name
-- of the entity, cased in a manner that is appropriate to the system
-- in use. Note that Interface_Name is ignored if an address clause
-- is present (since it is meaningless in this case).
-- specified external name. Note that if this field is Empty, and
-- Is_Imported or Is_Exported is set, then the default interface name
-- is the name of the entity, cased in a manner that is appropriate to
-- the system in use. Note that Interface_Name is ignored if an address
-- clause is present (since it is meaningless in this case).
--
-- An additional special case usage of this field is in JGNAT for
-- E_Component and E_Discriminant. JGNAT allows these entities to be
@ -6252,8 +6250,7 @@ package Einfo is
-----------------------------------
type Float_Rep_Kind is (
IEEE_Binary, -- IEEE 754p conform binary format
VAX_Native, -- VAX D, F, G or H format
IEEE_Binary, -- IEEE 754p conforming binary format
AAMP); -- AAMP format
---------------

69
gcc/ada/errout.adb
View File

@ -37,7 +37,6 @@ with Einfo; use Einfo;
with Erroutc; use Erroutc;
with Fname; use Fname;
with Gnatvsn; use Gnatvsn;
with Hostparm; use Hostparm;
with Lib; use Lib;
with Opt; use Opt;
with Nlists; use Nlists;
@ -190,14 +189,6 @@ package body Errout is
-- should have 'Class appended to its name (see Add_Class procedure), and
-- is otherwise unchanged.
procedure VMS_Convert;
-- This procedure has no effect if called when the host is not OpenVMS. If
-- the host is indeed OpenVMS, then the error message stored in Msg_Buffer
-- is scanned for appearances of switch names which need converting to
-- corresponding VMS qualifier names. See Gnames/Vnames table in Errout
-- spec for precise definition of the conversion that is performed by this
-- routine in OpenVMS mode.
function Warn_Insertion return String;
-- This is called for warning messages only (so Warning_Msg_Char is set)
-- and returns a corresponding string to use at the beginning of generated
@ -1678,11 +1669,6 @@ package body Errout is
-- error to make sure that *something* appears on standard error in
-- an error situation.
-- Formerly, only the "# errors" suffix was sent to stderr, whereas
-- "# lines:" appeared on stdout. This caused problems on VMS when
-- the stdout buffer was flushed, giving an extra line feed after
-- the prefix.
if Total_Errors_Detected + Warnings_Detected /= 0
and then not Brief_Output
and then (Verbose_Mode or Full_List)
@ -2331,9 +2317,7 @@ package body Errout is
-- Loop through file names to find matching one. This is a bit slow, but
-- we only do it in error situations so it is not so terrible. Note that
-- if the loop does not exit, then the desired case will be left set to
-- Mixed_Case, this can happen if the name was not in canonical form,
-- and gets canonicalized on VMS. Possibly we could fix this by
-- unconditionally canonicalizing these names ???
-- Mixed_Case, this can happen if the name was not in canonical form.
for J in 1 .. Last_Source_File loop
Get_Name_String (Full_Debug_Name (J));
@ -2980,8 +2964,6 @@ package body Errout is
Set_Msg_Char (C);
end case;
end loop;
VMS_Convert;
end Set_Msg_Text;
----------------
@ -3292,55 +3274,6 @@ package body Errout is
end if;
end Unwind_Internal_Type;
-----------------
-- VMS_Convert --
-----------------
procedure VMS_Convert is
P : Natural;
L : Natural;
N : Natural;
begin
if not OpenVMS then
return;
end if;
P := Msg_Buffer'First;
loop
if P >= Msglen then
return;
end if;
if Msg_Buffer (P) = '-' then
for G in Gnames'Range loop
L := Gnames (G)'Length;
-- See if we have "-ggg switch", where ggg is Gnames entry
if P + L + 7 <= Msglen
and then Msg_Buffer (P + 1 .. P + L) = Gnames (G).all
and then Msg_Buffer (P + L + 1 .. P + L + 7) = " switch"
then
-- Replace by "/vvv qualifier", where vvv is Vnames entry
N := Vnames (G)'Length;
Msg_Buffer (P + N + 11 .. Msglen + N - L + 3) :=
Msg_Buffer (P + L + 8 .. Msglen);
Msg_Buffer (P) := '/';
Msg_Buffer (P + 1 .. P + N) := Vnames (G).all;
Msg_Buffer (P + N + 1 .. P + N + 10) := " qualifier";
P := P + N + 10;
Msglen := Msglen + N - L + 3;
exit;
end if;
end loop;
end if;
P := P + 1;
end loop;
end VMS_Convert;
--------------------
-- Warn_Insertion --
--------------------

64
gcc/ada/exp_attr.adb
View File

@ -2255,70 +2255,6 @@ package body Exp_Attr is
end if;
end Alignment;
---------------
-- AST_Entry --
---------------
when Attribute_AST_Entry => AST_Entry : declare
Ttyp : Entity_Id;
T_Id : Node_Id;
Eent : Entity_Id;
Entry_Ref : Node_Id;
-- The reference to the entry or entry family
Index : Node_Id;
-- The index expression for an entry family reference, or
-- the Empty if Entry_Ref references a simple entry.
begin
if Nkind (Pref) = N_Indexed_Component then
Entry_Ref := Prefix (Pref);
Index := First (Expressions (Pref));
else
Entry_Ref := Pref;
Index := Empty;
end if;
-- Get expression for Task_Id and the entry entity
if Nkind (Entry_Ref) = N_Selected_Component then
T_Id :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Identity,
Prefix => Prefix (Entry_Ref));
Ttyp := Etype (Prefix (Entry_Ref));
Eent := Entity (Selector_Name (Entry_Ref));
else
T_Id :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Current_Task), Loc));
Eent := Entity (Entry_Ref);
-- We have to find the enclosing task to get the task type
-- There must be one, since we already validated this earlier
Ttyp := Current_Scope;
while not Is_Task_Type (Ttyp) loop
Ttyp := Scope (Ttyp);
end loop;
end if;
-- Now rewrite the attribute with a call to Create_AST_Handler
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Create_AST_Handler), Loc),
Parameter_Associations => New_List (
T_Id,
Entry_Index_Expression (Loc, Eent, Index, Ttyp))));
Analyze_And_Resolve (N, RTE (RE_AST_Handler));
end AST_Entry;
---------
-- Bit --
---------

179
gcc/ada/exp_prag.adb
View File

@ -41,14 +41,12 @@ with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Snames; use Snames;
with Stringt; use Stringt;
with Stand; use Stand;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Validsw; use Validsw;
@ -68,7 +66,6 @@ package body Exp_Prag is
procedure Expand_Pragma_Check (N : Node_Id);
procedure Expand_Pragma_Common_Object (N : Node_Id);
procedure Expand_Pragma_Import_Or_Interface (N : Node_Id);
procedure Expand_Pragma_Import_Export_Exception (N : Node_Id);
procedure Expand_Pragma_Inspection_Point (N : Node_Id);
procedure Expand_Pragma_Interrupt_Priority (N : Node_Id);
procedure Expand_Pragma_Loop_Variant (N : Node_Id);
@ -818,15 +815,9 @@ package body Exp_Prag is
when Pragma_Common_Object =>
Expand_Pragma_Common_Object (N);
when Pragma_Export_Exception =>
Expand_Pragma_Import_Export_Exception (N);
when Pragma_Import =>
Expand_Pragma_Import_Or_Interface (N);
when Pragma_Import_Exception =>
Expand_Pragma_Import_Export_Exception (N);
when Pragma_Inspection_Point =>
Expand_Pragma_Inspection_Point (N);
@ -1292,176 +1283,6 @@ package body Exp_Prag is
end if;
end Expand_Pragma_Import_Or_Interface;
-------------------------------------------
-- Expand_Pragma_Import_Export_Exception --
-------------------------------------------
-- For a VMS exception fix up the language field with "VMS" instead of
-- "Ada" (gigi needs this), create a constant that will be the value of
-- the VMS condition code and stuff the Interface_Name field with the
-- unexpanded name of the exception (if not already set). For a Ada
-- exception, just stuff the Interface_Name field with the unexpanded
-- name of the exception (if not already set).
procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is
begin
-- This pragma is only effective on OpenVMS systems, it was ignored on
-- non-VMS systems, and we need to ignore it here as well.
if not OpenVMS_On_Target then
return;
end if;
declare
Id : constant Entity_Id := Entity (Arg1 (N));
Call : constant Node_Id := Register_Exception_Call (Id);
Loc : constant Source_Ptr := Sloc (N);
begin
if Present (Call) then
declare
Excep_Internal : constant Node_Id := Make_Temporary (Loc, 'V');
Export_Pragma : Node_Id;
Excep_Alias : Node_Id;
Excep_Object : Node_Id;
Excep_Image : String_Id;
Exdata : List_Id;
Lang_Char : Node_Id;
Code : Node_Id;
begin
-- Compute the symbol for the code of the condition
if Present (Interface_Name (Id)) then
Excep_Image := Strval (Interface_Name (Id));
else
Get_Name_String (Chars (Id));
Set_All_Upper_Case;
Excep_Image := String_From_Name_Buffer;
end if;
Exdata := Component_Associations (Expression (Parent (Id)));
if Is_VMS_Exception (Id) then
Lang_Char := Next (First (Exdata));
-- Change the one-character language designator to 'V'
Rewrite (Expression (Lang_Char),
Make_Character_Literal (Loc,
Chars => Name_uV,
Char_Literal_Value =>
UI_From_Int (Character'Pos ('V'))));
Analyze (Expression (Lang_Char));
if Exception_Code (Id) /= No_Uint then
-- The code for the exception is present. Create a linker
-- alias to define the symbol.
Code :=
Unchecked_Convert_To (RTE (RE_Address),
Make_Integer_Literal (Loc,
Intval => Exception_Code (Id)));
-- Declare a dummy object
Excep_Object :=
Make_Object_Declaration (Loc,
Defining_Identifier => Excep_Internal,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc));
Insert_Action (N, Excep_Object);
Analyze (Excep_Object);
-- Clear severity bits
Start_String;
Store_String_Int
(UI_To_Int (Exception_Code (Id)) / 8 * 8);
-- Insert a pragma Linker_Alias to set the value of the
-- dummy object symbol.
Excep_Alias :=
Make_Pragma (Loc,
Chars => Name_Linker_Alias,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression =>
New_Occurrence_Of (Excep_Internal, Loc)),
Make_Pragma_Argument_Association (Loc,
Expression =>
Make_String_Literal (Loc, End_String))));
Insert_Action (N, Excep_Alias);
Analyze (Excep_Alias);
-- Insert a pragma Export to give a Linker_Name to the
-- dummy object.
Export_Pragma :=
Make_Pragma (Loc,
Chars => Name_Export,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Make_Identifier (Loc, Name_C)),
Make_Pragma_Argument_Association (Loc,
Expression =>
New_Occurrence_Of (Excep_Internal, Loc)),
Make_Pragma_Argument_Association (Loc,
Expression =>
Make_String_Literal (Loc, Excep_Image)),
Make_Pragma_Argument_Association (Loc,
Expression =>
Make_String_Literal (Loc, Excep_Image))));
Insert_Action (N, Export_Pragma);
Analyze (Export_Pragma);
else
Code :=
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Import_Address), Loc),
Parameter_Associations => New_List
(Make_String_Literal (Loc,
Strval => Excep_Image)));
end if;
-- Generate the call to Register_VMS_Exception
Rewrite (Call,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of
(RTE (RE_Register_VMS_Exception), Loc),
Parameter_Associations => New_List (
Code,
Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Id, Loc),
Attribute_Name => Name_Unrestricted_Access)))));
Analyze_And_Resolve (Code, RTE (RE_Address));
Analyze (Call);
end if;
if No (Interface_Name (Id)) then
Set_Interface_Name (Id,
Make_String_Literal
(Sloc => Loc,
Strval => Excep_Image));
end if;
end;
end if;
end;
end Expand_Pragma_Import_Export_Exception;
------------------------------------
-- Expand_Pragma_Inspection_Point --
------------------------------------

16
gcc/ada/frontend.adb
View File

@ -57,7 +57,6 @@ with Sem_Ch8; use Sem_Ch8;
with Sem_SCIL;
with Sem_Elab; use Sem_Elab;
with Sem_Prag; use Sem_Prag;
with Sem_VFpt; use Sem_VFpt;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
@ -191,21 +190,6 @@ begin
Config_Pragmas := Empty_List;
end if;
-- Check for VAX Float
if Targparm.VAX_Float_On_Target then
-- pragma Float_Representation (VAX_Float);
Opt.Float_Format := 'V';
-- pragma Long_Float (G_Float);
Opt.Float_Format_Long := 'G';
Set_Standard_Fpt_Formats;
end if;
-- Now deal with specified config pragmas files if there are any
if Opt.Config_File_Names /= null then

11
gcc/ada/interfac.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2002-2014, 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 --
@ -152,19 +152,12 @@ package Interfaces is
pragma Import (Intrinsic, Rotate_Left);
pragma Import (Intrinsic, Rotate_Right);
-- IEEE Floating point types. Note that the form of these definitions
-- ensures that the work on VMS, even if the standard library is compiled
-- using a Float_Representation pragma for Vax_Float.
pragma Warnings (Off);
-- Turn off warnings for targets not providing IEEE floating-point types
-- IEEE Floating point types
type IEEE_Float_32 is digits 6;
pragma Float_Representation (IEEE_Float, IEEE_Float_32);
for IEEE_Float_32'Size use 32;
type IEEE_Float_64 is digits 15;
pragma Float_Representation (IEEE_Float, IEEE_Float_64);
for IEEE_Float_64'Size use 64;
-- If there is an IEEE extended float available on the machine, we assume

5
gcc/ada/par-prag.adb
View File

@ -1151,7 +1151,6 @@ begin
Pragma_Assertion_Policy |
Pragma_Assume |
Pragma_Assume_No_Invalid_Values |
Pragma_AST_Entry |
Pragma_All_Calls_Remote |
Pragma_Allow_Integer_Address |
Pragma_Annotate |
@ -1201,7 +1200,6 @@ begin
Pragma_Elaboration_Checks |
Pragma_Enable_Atomic_Synchronization |
Pragma_Export |
Pragma_Export_Exception |
Pragma_Export_Function |
Pragma_Export_Object |
Pragma_Export_Procedure |
@ -1213,14 +1211,12 @@ begin
Pragma_Favor_Top_Level |
Pragma_Fast_Math |
Pragma_Finalize_Storage_Only |
Pragma_Float_Representation |
Pragma_Global |
Pragma_Ident |
Pragma_Implementation_Defined |
Pragma_Implemented |
Pragma_Implicit_Packing |
Pragma_Import |
Pragma_Import_Exception |
Pragma_Import_Function |
Pragma_Import_Object |
Pragma_Import_Procedure |
@ -1252,7 +1248,6 @@ begin
Pragma_Linker_Section |
Pragma_Lock_Free |
Pragma_Locking_Policy |
Pragma_Long_Float |
Pragma_Loop_Invariant |
Pragma_Loop_Optimize |
Pragma_Loop_Variant |

14
gcc/ada/s-auxdec.ads
View File

@ -109,27 +109,15 @@ package System.Aux_DEC is
-- Floating point type declarations for VAX floating point data types
pragma Warnings (Off);
-- ??? needs comment
type F_Float is digits 6;
pragma Float_Representation (VAX_Float, F_Float);
type D_Float is digits 9;
pragma Float_Representation (Vax_Float, D_Float);
type G_Float is digits 15;
pragma Float_Representation (Vax_Float, G_Float);
-- We provide the type names, but these will be IEEE, not VMS format
-- Floating point type declarations for IEEE floating point data types
type IEEE_Single_Float is digits 6;
pragma Float_Representation (IEEE_Float, IEEE_Single_Float);
type IEEE_Double_Float is digits 15;
pragma Float_Representation (IEEE_Float, IEEE_Double_Float);
pragma Warnings (On);
Non_Ada_Error : exception;

5
gcc/ada/s-filofl.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -34,13 +34,14 @@
-- we can't just use Long_Float, since this may have been mapped to Vax_Float
-- using a Float_Representation configuration pragma.
-- TO BE RMOVED ???
with System.Fat_Gen;
package System.Fat_IEEE_Long_Float is
pragma Pure;
type Fat_IEEE_Long is digits 15;
pragma Float_Representation (IEEE_Float, Fat_IEEE_Long);
-- Note the only entity from this package that is accessed by Rtsfind
-- is the name of the package instantiation. Entities within this package

5
gcc/ada/s-fishfl.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005,2009 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -34,13 +34,14 @@
-- we can't just use Float, since this may have been mapped to Vax_Float
-- using a Float_Representation configuration pragma.
-- TO BE REMOVED ???
with System.Fat_Gen;
package System.Fat_IEEE_Short_Float is
pragma Pure;
type Fat_IEEE_Short is digits 6;
pragma Float_Representation (IEEE_Float, Fat_IEEE_Short);
-- Note the only entity from this package that is accessed by Rtsfind
-- is the name of the package instantiation. Entities within this package

9
gcc/ada/s-fvadfl.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005,2009 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -32,17 +32,14 @@
-- This package contains an instantiation of the floating-point attribute
-- runtime routines for VAX D-float for use on VMS targets.
-- TO BE REMOVED ???
with System.Fat_Gen;
package System.Fat_VAX_D_Float is
pragma Pure;
pragma Warnings (Off);
-- This unit is normally used only for VMS, but we compile it for other
-- targets for the convenience of testing vms code using -gnatdm.
type Fat_VAX_D is digits 9;
pragma Float_Representation (VAX_Float, Fat_VAX_D);
-- Note the only entity from this package that is accessed by Rtsfind
-- is the name of the package instantiation. Entities within this package

9
gcc/ada/s-fvaffl.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005,2009 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -32,17 +32,14 @@
-- This package contains an instantiation of the floating-point attribute
-- runtime routines for VAX F-float for use on VMS targets.
-- TO BE REMOVED ???
with System.Fat_Gen;
package System.Fat_VAX_F_Float is
pragma Pure;
pragma Warnings (Off);
-- This unit is normally used only for VMS, but we compile it for other
-- targets for the convenience of testing vms code using -gnatdm.
type Fat_VAX_F is digits 6;
pragma Float_Representation (VAX_Float, Fat_VAX_F);
-- Note the only entity from this package that is accessed by Rtsfind
-- is the name of the package instantiation. Entities within this package

9
gcc/ada/s-fvagfl.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005,2009 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -32,17 +32,14 @@
-- This package contains an instantiation of the floating-point attribute
-- runtime routines for VAX F-float for use on VMS targets.
-- TO BE REMOVED ???
with System.Fat_Gen;
package System.Fat_VAX_G_Float is
pragma Pure;
pragma Warnings (Off);
-- This unit is normally used only for VMS, but we compile it for other
-- targets for the convenience of testing vms code using -gnatdm.
type Fat_VAX_G is digits 15;
pragma Float_Representation (VAX_Float, Fat_VAX_G);
-- Note the only entity from this package that is accessed by Rtsfind
-- is the name of the package instantiation. Entities within this package

25
gcc/ada/s-vaflop.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1997-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1997-2014, 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- --
@ -30,34 +30,17 @@
------------------------------------------------------------------------------
-- This package contains runtime routines for handling the non-IEEE
-- floating-point formats used on the Vax and the Alpha.
-- floating-point formats used on the Vax.
-- TO BE REMOVED ???
package System.Vax_Float_Operations is
pragma Warnings (Off);
-- Suppress warnings if not on Alpha/VAX
type D is digits 9;
pragma Float_Representation (VAX_Float, D);
-- D Float type on Vax
type G is digits 15;
pragma Float_Representation (VAX_Float, G);
-- G Float type on Vax
type F is digits 6;
pragma Float_Representation (VAX_Float, F);
-- F Float type on Vax
type S is digits 6;
pragma Float_Representation (IEEE_Float, S);
-- IEEE short
type T is digits 15;
pragma Float_Representation (IEEE_Float, T);
-- IEEE long
pragma Warnings (On);
type Q is range -2 ** 63 .. +(2 ** 63 - 1);
-- 64-bit signed integer

167
gcc/ada/sem_attr.adb
View File

@ -536,18 +536,6 @@ package body Sem_Attr is
end if;
end;
-- Allow Address if the prefix is a reference to the AST_Entry
-- attribute. If expansion is active, the attribute will be
-- replaced by a function call, and address will work fine and
-- get the proper value, but if expansion is not active, then
-- the check here allows proper semantic analysis of the reference.
elsif Nkind (P) = N_Attribute_Reference
and then Attribute_Name (P) = Name_AST_Entry
then
Rewrite (N,
New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
-- Object is OK
elsif Is_Object_Reference (P) then
@ -2514,7 +2502,7 @@ package body Sem_Attr is
-- parameterless call. Entry attributes are handled specially below.
if Is_Entity_Name (P)
and then not Nam_In (Aname, Name_Count, Name_Caller, Name_AST_Entry)
and then not Nam_In (Aname, Name_Count, Name_Caller)
then
Check_Parameterless_Call (P);
end if;
@ -2522,10 +2510,10 @@ package body Sem_Attr is
if Is_Overloaded (P) then
-- Ada 2005 (AI-345): Since protected and task types have
-- primitive entry wrappers, the attributes Count, Caller and
-- AST_Entry require a context check
-- primitive entry wrappers, the attributes Count, and Caller
-- require a context check
if Nam_In (Aname, Name_Count, Name_Caller, Name_AST_Entry) then
if Nam_In (Aname, Name_Count, Name_Caller) then
declare
Count : Natural := 0;
I : Interp_Index;
@ -2697,129 +2685,6 @@ package body Sem_Attr is
Set_Etype (N, RTE (RE_Asm_Output_Operand));
---------------
-- AST_Entry --
---------------
when Attribute_AST_Entry => AST_Entry : declare
Ent : Entity_Id;
Pref : Node_Id;
Ptyp : Entity_Id;
Indexed : Boolean;
-- Indicates if entry family index is present. Note the coding
-- here handles the entry family case, but in fact it cannot be
-- executed currently, because pragma AST_Entry does not permit
-- the specification of an entry family.
procedure Bad_AST_Entry;
-- Signal a bad AST_Entry pragma
function OK_Entry (E : Entity_Id) return Boolean;
-- Checks that E is of an appropriate entity kind for an entry
-- (i.e. E_Entry if Index is False, or E_Entry_Family if Index
-- is set True for the entry family case). In the True case,
-- makes sure that Is_AST_Entry is set on the entry.
-------------------
-- Bad_AST_Entry --
-------------------
procedure Bad_AST_Entry is
begin
Error_Attr_P ("prefix for % attribute must be task entry");
end Bad_AST_Entry;
--------------
-- OK_Entry --
--------------
function OK_Entry (E : Entity_Id) return Boolean is
Result : Boolean;
begin
if Indexed then
Result := (Ekind (E) = E_Entry_Family);
else
Result := (Ekind (E) = E_Entry);
end if;
if Result then
if not Is_AST_Entry (E) then
Error_Msg_Name_2 := Aname;
Error_Attr ("% attribute requires previous % pragma", P);
end if;
end if;
return Result;
end OK_Entry;
-- Start of processing for AST_Entry
begin
Check_VMS (N);
Check_E0;
-- Deal with entry family case
if Nkind (P) = N_Indexed_Component then
Pref := Prefix (P);
Indexed := True;
else
Pref := P;
Indexed := False;
end if;
Ptyp := Etype (Pref);
if Ptyp = Any_Type or else Error_Posted (Pref) then
return;
end if;
-- If the prefix is a selected component whose prefix is of an
-- access type, then introduce an explicit dereference.
-- ??? Could we reuse Check_Dereference here?
if Nkind (Pref) = N_Selected_Component
and then Is_Access_Type (Ptyp)
then
Rewrite (Pref,
Make_Explicit_Dereference (Sloc (Pref),
Relocate_Node (Pref)));
Analyze_And_Resolve (Pref, Designated_Type (Ptyp));
end if;
-- Prefix can be of the form a.b, where a is a task object
-- and b is one of the entries of the corresponding task type.
if Nkind (Pref) = N_Selected_Component
and then OK_Entry (Entity (Selector_Name (Pref)))
and then Is_Object_Reference (Prefix (Pref))
and then Is_Task_Type (Etype (Prefix (Pref)))
then
null;
-- Otherwise the prefix must be an entry of a containing task,
-- or of a variable of the enclosing task type.
else
if Nkind_In (Pref, N_Identifier, N_Expanded_Name) then
Ent := Entity (Pref);
if not OK_Entry (Ent)
or else not In_Open_Scopes (Scope (Ent))
then
Bad_AST_Entry;
end if;
else
Bad_AST_Entry;
end if;
end if;
Set_Etype (N, RTE (RE_AST_Handler));
end AST_Entry;
-----------------------------
-- Atomic_Always_Lock_Free --
-----------------------------
@ -7858,20 +7723,6 @@ package body Sem_Attr is
end if;
end Alignment_Block;
---------------
-- AST_Entry --
---------------
-- Can only be folded in No_Ast_Handler case
when Attribute_AST_Entry =>
if not Is_AST_Entry (P_Entity) then
Rewrite (N,
New_Occurrence_Of (RTE (RE_No_AST_Handler), Loc));
else
null;
end if;
-----------------------------
-- Atomic_Always_Lock_Free --
-----------------------------
@ -10837,16 +10688,6 @@ package body Sem_Attr is
end if;
end Address_Attribute;
---------------
-- AST_Entry --
---------------
-- Prefix of the AST_Entry attribute is an entry name which must
-- not be resolved, since this is definitely not an entry call.
when Attribute_AST_Entry =>
null;
------------------
-- Body_Version --
------------------

19
gcc/ada/sem_attr.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -89,23 +89,6 @@ package Sem_Attr is
-- Machine_Code to construct machine instructions. See documentation
-- in package Machine_Code in file s-maccod.ads.
---------------
-- AST_Entry --
---------------
Attribute_AST_Entry => True,
-- E'Ast_Entry, where E is a task entry, yields a value of the
-- predefined type System.DEC.AST_Handler, that enables the given
-- entry to be called when an AST occurs. If the name to which the
-- attribute applies has not been specified with the pragma AST_Entry,
-- the attribute returns the value No_Ast_Handler, and no AST occurs.
-- If the entry is for a task that is not callable (T'Callable False),
-- the exception program error is raised. If an AST occurs for an
-- entry of a task that is terminated, the program is erroneous.
--
-- The attribute AST_Entry is supported only in OpenVMS versions
-- of GNAT. It will be rejected as illegal in other GNAT versions.
---------
-- Bit --
---------

18
gcc/ada/sem_ch13.adb
View File

@ -10875,19 +10875,10 @@ package body Sem_Ch13 is
then
return 0;
-- Access types. Normally an access type cannot have a size smaller
-- than the size of System.Address. The exception is on VMS, where
-- we have short and long addresses, and it is possible for an access
-- type to have a short address size (and thus be less than the size
-- of System.Address itself). We simply skip the check for VMS, and
-- leave it to the back end to do the check.
-- Access types (cannot have size smaller than System.Address)
elsif Is_Access_Type (T) then
if OpenVMS_On_Target then
return 0;
else
return System_Address_Size;
end if;
return System_Address_Size;
-- Floating-point types
@ -12588,13 +12579,10 @@ package body Sem_Ch13 is
and then Convention (Target) /= Convention (Source)
and then Warn_On_Unchecked_Conversion
then
-- Give warnings for subprogram pointers only on most targets. The
-- exception is VMS, where data pointers can have different lengths
-- depending on the pointer convention.
-- Give warnings for subprogram pointers only on most targets
if Is_Access_Subprogram_Type (Target)
or else Is_Access_Subprogram_Type (Source)
or else OpenVMS_On_Target
then
Error_Msg_N
("?z?conversion between pointers with different conventions!",

9
gcc/ada/sem_ch3.adb
View File

@ -16004,15 +16004,6 @@ package body Sem_Ch3 is
return False;
end if;
-- Avoid types not matching pragma Float_Representation, if present
if (Opt.Float_Format = 'I' and then Float_Rep (E) /= IEEE_Binary)
or else
(Opt.Float_Format = 'V' and then Float_Rep (E) /= VAX_Native)
then
return False;
end if;
-- Check for matching range, if specified
if Present (Spec) then

57
gcc/ada/sem_ch8.adb
View File

@ -3388,12 +3388,11 @@ package body Sem_Ch8 is
-- This procedure is called in the context of subprogram renaming, and
-- thus the attribute must be one that is a subprogram. All of those
-- have at least one formal parameter, with the exceptions of AST_Entry
-- (which is a real oddity, it is odd that this can be renamed at all)
-- and the GNAT attribute 'Img, which GNAT treats as renameable.
-- have at least one formal parameter, with the exceptions of the GNAT
-- attribute 'Img, which GNAT treats as renameable.
if not Is_Non_Empty_List (Parameter_Specifications (Spec)) then
if Aname /= Name_AST_Entry and then Aname /= Name_Img then
if Aname /= Name_Img then
Error_Msg_N
("subprogram renaming an attribute must have formals", N);
return;
@ -3463,46 +3462,18 @@ package body Sem_Ch8 is
end if;
end if;
-- AST_Entry is an odd case. It doesn't really make much sense to allow
-- it to be renamed, but that's the DEC rule, so we have to do it right.
-- The point is that the AST_Entry call should be made now, and what the
-- function will return is the returned value.
-- Rewrite attribute node to have a list of expressions corresponding to
-- the subprogram formals. A renaming declaration is not a freeze point,
-- and the analysis of the attribute reference should not freeze the
-- type of the prefix. We use the original node in the renaming so that
-- its source location is preserved, and checks on stream attributes are
-- properly applied.
-- Note that there is no Expr_List in this case anyway
Attr_Node := Relocate_Node (Nam);
Set_Expressions (Attr_Node, Expr_List);
if Aname = Name_AST_Entry then
declare
Ent : constant Entity_Id := Make_Temporary (Loc, 'R', Nam);
Decl : Node_Id;
begin
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Ent,
Object_Definition =>
New_Occurrence_Of (RTE (RE_AST_Handler), Loc),
Expression => Nam,
Constant_Present => True);
Set_Assignment_OK (Decl, True);
Insert_Action (N, Decl);
Attr_Node := Make_Identifier (Loc, Chars (Ent));
end;
-- For all other attributes, we rewrite the attribute node to have
-- a list of expressions corresponding to the subprogram formals.
-- A renaming declaration is not a freeze point, and the analysis of
-- the attribute reference should not freeze the type of the prefix.
-- We use the original node in the renaming so that its source location
-- is preserved, and checks on stream attributes are properly applied.
else
Attr_Node := Relocate_Node (Nam);
Set_Expressions (Attr_Node, Expr_List);
Set_Must_Not_Freeze (Attr_Node);
Set_Must_Not_Freeze (Prefix (Nam));
end if;
Set_Must_Not_Freeze (Attr_Node);
Set_Must_Not_Freeze (Prefix (Nam));
-- Case of renaming a function
@ -3547,7 +3518,7 @@ package body Sem_Ch8 is
-- In case of tagged types we add the body of the generated function to
-- the freezing actions of the type (because in the general case such
-- type is still not frozen). We exclude from this processing generic
-- formal subprograms found in instantiations and AST_Entry renamings.
-- formal subprograms found in instantiations.
-- We must exclude VM targets and restricted run-time libraries because
-- entity AST_Handler is defined in package System.Aux_Dec which is not

643
gcc/ada/sem_prag.adb
View File

@ -68,7 +68,6 @@ with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_VFpt; use Sem_VFpt;
with Sem_Warn; use Sem_Warn;
with Stand; use Stand;
with Sinfo; use Sinfo;
@ -125,8 +124,7 @@ package body Sem_Prag is
-- If the External parameter is given as an identifier (or there is no
-- External parameter, so that the Internal identifier is used), then
-- the external name is the characters of the identifier, translated
-- to all upper case letters for OpenVMS versions of GNAT, and to all
-- lower case letters for all other versions
-- to all lower case letters.
-- Note: the external name specified or implied by any of these special
-- Import_xxx or Export_xxx pragmas override an external or link name
@ -3227,16 +3225,6 @@ package body Sem_Prag is
-- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
-- Name_Suppress for Disable and Name_Unsuppress for Enable.
procedure Process_Extended_Import_Export_Exception_Pragma
(Arg_Internal : Node_Id;
Arg_External : Node_Id;
Arg_Form : Node_Id;
Arg_Code : Node_Id);
-- Common processing for the pragmas Import/Export_Exception. The three
-- arguments correspond to the three named parameters of the pragma. An
-- argument is empty if the corresponding parameter is not present in
-- the pragma.
procedure Process_Extended_Import_Export_Object_Pragma
(Arg_Internal : Node_Id;
Arg_External : Node_Id;
@ -6880,14 +6868,10 @@ package body Sem_Prag is
elsif Is_Convention_Name (Cname) then
C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
-- In DEC VMS, it seems that there is an undocumented feature that
-- any unrecognized convention is treated as the default, which for
-- us is convention C. It does not seem so terrible to do this
-- unconditionally, silently in the VMS case, and with a warning
-- in the non-VMS case.
-- Otherwise warn on unrecognized convention
else
if Warn_On_Export_Import and not OpenVMS_On_Target then
if Warn_On_Export_Import then
Error_Msg_N
("??unrecognized convention name, C assumed",
Get_Pragma_Arg (Arg1));
@ -7168,69 +7152,6 @@ package body Sem_Prag is
Analyze (N);
end Process_Disable_Enable_Atomic_Sync;
-----------------------------------------------------
-- Process_Extended_Import_Export_Exception_Pragma --
-----------------------------------------------------
procedure Process_Extended_Import_Export_Exception_Pragma
(Arg_Internal : Node_Id;
Arg_External : Node_Id;
Arg_Form : Node_Id;
Arg_Code : Node_Id)
is
Def_Id : Entity_Id;
Code_Val : Uint;
begin
if not OpenVMS_On_Target then
Error_Pragma
("??pragma% ignored (applies only to Open'V'M'S)");
end if;
Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
Def_Id := Entity (Arg_Internal);
if Ekind (Def_Id) /= E_Exception then
Error_Pragma_Arg
("pragma% must refer to declared exception", Arg_Internal);
end if;
Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
if Present (Arg_Form) then
Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
end if;
if Present (Arg_Form)
and then Chars (Arg_Form) = Name_Ada
then
null;
else
Set_Is_VMS_Exception (Def_Id);
Set_Exception_Code (Def_Id, No_Uint);
end if;
if Present (Arg_Code) then
if not Is_VMS_Exception (Def_Id) then
Error_Pragma_Arg
("Code option for pragma% not allowed for Ada case",
Arg_Code);
end if;
Check_Arg_Is_OK_Static_Expression (Arg_Code, Any_Integer);
Code_Val := Expr_Value (Arg_Code);
if not UI_Is_In_Int_Range (Code_Val) then
Error_Pragma_Arg
("Code option for pragma% must be in 32-bit range",
Arg_Code);
else
Set_Exception_Code (Def_Id, Code_Val);
end if;
end if;
end Process_Extended_Import_Export_Exception_Pragma;
-------------------------------------------------
-- Process_Extended_Import_Export_Internal_Arg --
-------------------------------------------------
@ -9445,13 +9366,15 @@ package body Sem_Prag is
Set_Is_Public (E);
Set_Is_Statically_Allocated (E);
-- Warn if the corresponding W flag is set and the pragma comes
-- from source. The latter may not be true e.g. on VMS where we
-- expand export pragmas for exception codes associated with
-- imported or exported exceptions. We do not want to generate
-- a warning for something that the user did not write.
-- Warn if the corresponding W flag is set
if Warn_On_Export_Import
-- Only do this for something that was in the source. Not
-- clear if this can be False now (there used for sure to
-- be cases on VMS where it was False), but anyway the test
-- is harmless if not needed, so it is retained.
and then Comes_From_Source (Arg)
then
Error_Msg_NE
@ -9645,27 +9568,10 @@ package body Sem_Prag is
-- form created by the parser.
procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
Class : Node_Id;
Param : Node_Id;
Mech_Name_Id : Name_Id;
procedure Bad_Class;
pragma No_Return (Bad_Class);
-- Signal bad descriptor class name
procedure Bad_Mechanism;
pragma No_Return (Bad_Mechanism);
-- Signal bad mechanism name
---------------
-- Bad_Class --
---------------
procedure Bad_Class is
begin
Error_Pragma_Arg ("unrecognized descriptor class name", Class);
end Bad_Class;
-------------------------
-- Bad_Mechanism_Value --
-------------------------
@ -9683,8 +9589,7 @@ package body Sem_Prag is
("mechanism for & has already been set", Mech_Name, Ent);
end if;
-- MECHANISM_NAME ::= value | reference | descriptor |
-- short_descriptor
-- MECHANISM_NAME ::= value | reference
if Nkind (Mech_Name) = N_Identifier then
if Chars (Mech_Name) = Name_Value then
@ -9695,24 +9600,6 @@ package body Sem_Prag is
Set_Mechanism (Ent, By_Reference);
return;
elsif Chars (Mech_Name) = Name_Descriptor then
Check_VMS (Mech_Name);
-- Descriptor => Short_Descriptor if pragma was given
if Short_Descriptors then
Set_Mechanism (Ent, By_Short_Descriptor);
else
Set_Mechanism (Ent, By_Descriptor);
end if;
return;
elsif Chars (Mech_Name) = Name_Short_Descriptor then
Check_VMS (Mech_Name);
Set_Mechanism (Ent, By_Short_Descriptor);
return;
elsif Chars (Mech_Name) = Name_Copy then
Error_Pragma_Arg
("bad mechanism name, Value assumed", Mech_Name);
@ -9721,141 +9608,9 @@ package body Sem_Prag is
Bad_Mechanism;
end if;
-- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
-- short_descriptor (CLASS_NAME)
-- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
-- Note: this form is parsed as an indexed component
elsif Nkind (Mech_Name) = N_Indexed_Component then
Class := First (Expressions (Mech_Name));
if Nkind (Prefix (Mech_Name)) /= N_Identifier
or else
not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor,
Name_Short_Descriptor)
or else Present (Next (Class))
then
Bad_Mechanism;
else
Mech_Name_Id := Chars (Prefix (Mech_Name));
-- Change Descriptor => Short_Descriptor if pragma was given
if Mech_Name_Id = Name_Descriptor
and then Short_Descriptors
then
Mech_Name_Id := Name_Short_Descriptor;
end if;
end if;
-- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
-- short_descriptor (Class => CLASS_NAME)
-- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
-- Note: this form is parsed as a function call
elsif Nkind (Mech_Name) = N_Function_Call then
Param := First (Parameter_Associations (Mech_Name));
if Nkind (Name (Mech_Name)) /= N_Identifier
or else
not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor,
Name_Short_Descriptor)
or else Present (Next (Param))
or else No (Selector_Name (Param))
or else Chars (Selector_Name (Param)) /= Name_Class
then
Bad_Mechanism;
else
Class := Explicit_Actual_Parameter (Param);
Mech_Name_Id := Chars (Name (Mech_Name));
end if;
else
Bad_Mechanism;
end if;
-- Fall through here with Class set to descriptor class name
Check_VMS (Mech_Name);
if Nkind (Class) /= N_Identifier then
Bad_Class;
elsif Mech_Name_Id = Name_Descriptor
and then Chars (Class) = Name_UBS
then
Set_Mechanism (Ent, By_Descriptor_UBS);
elsif Mech_Name_Id = Name_Descriptor
and then Chars (Class) = Name_UBSB
then
Set_Mechanism (Ent, By_Descriptor_UBSB);
elsif Mech_Name_Id = Name_Descriptor
and then Chars (Class) = Name_UBA
then
Set_Mechanism (Ent, By_Descriptor_UBA);
elsif Mech_Name_Id = Name_Descriptor
and then Chars (Class) = Name_S
then
Set_Mechanism (Ent, By_Descriptor_S);
elsif Mech_Name_Id = Name_Descriptor
and then Chars (Class) = Name_SB
then
Set_Mechanism (Ent, By_Descriptor_SB);
elsif Mech_Name_Id = Name_Descriptor
and then Chars (Class) = Name_A
then
Set_Mechanism (Ent, By_Descriptor_A);
elsif Mech_Name_Id = Name_Descriptor
and then Chars (Class) = Name_NCA
then
Set_Mechanism (Ent, By_Descriptor_NCA);
elsif Mech_Name_Id = Name_Short_Descriptor
and then Chars (Class) = Name_UBS
then
Set_Mechanism (Ent, By_Short_Descriptor_UBS);
elsif Mech_Name_Id = Name_Short_Descriptor
and then Chars (Class) = Name_UBSB
then
Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
elsif Mech_Name_Id = Name_Short_Descriptor
and then Chars (Class) = Name_UBA
then
Set_Mechanism (Ent, By_Short_Descriptor_UBA);
elsif Mech_Name_Id = Name_Short_Descriptor
and then Chars (Class) = Name_S
then
Set_Mechanism (Ent, By_Short_Descriptor_S);
elsif Mech_Name_Id = Name_Short_Descriptor
and then Chars (Class) = Name_SB
then
Set_Mechanism (Ent, By_Short_Descriptor_SB);
elsif Mech_Name_Id = Name_Short_Descriptor
and then Chars (Class) = Name_A
then
Set_Mechanism (Ent, By_Short_Descriptor_A);
elsif Mech_Name_Id = Name_Short_Descriptor
and then Chars (Class) = Name_NCA
then
Set_Mechanism (Ent, By_Short_Descriptor_NCA);
else
Bad_Class;
end if;
end Set_Mechanism_Value;
--------------------------
@ -11092,9 +10847,10 @@ package body Sem_Prag is
Check_Arg_Count (0);
-- If Address is a private type, then set the flag to allow
-- integer address values. If Address is not private (e.g. on
-- VMS, where it is an integer type), then this pragma has no
-- purpose, so it is simply ignored.
-- integer address values. If Address is not private, then
-- this pragma has no purpose, so it is simply ignored. Not
-- clear if there are any such targets now (VMS used to be
-- one such, but leave test in for the future anyway).
if Opt.Address_Is_Private then
Opt.Allow_Integer_Address := True;
@ -11566,63 +11322,6 @@ package body Sem_Prag is
Analyze (N);
end Attribute_Definition;
---------------
-- AST_Entry --
---------------
-- pragma AST_Entry (entry_IDENTIFIER);
when Pragma_AST_Entry => AST_Entry : declare
Ent : Node_Id;
begin
GNAT_Pragma;
Check_VMS (N);
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_Local_Name (Arg1);
Ent := Entity (Get_Pragma_Arg (Arg1));
-- Note: the implementation of the AST_Entry pragma could handle
-- the entry family case fine, but for now we are consistent with
-- the DEC rules, and do not allow the pragma, which of course
-- has the effect of also forbidding the attribute.
if Ekind (Ent) /= E_Entry then
Error_Pragma_Arg
("pragma% argument must be simple entry name", Arg1);
elsif Is_AST_Entry (Ent) then
Error_Pragma_Arg
("duplicate % pragma for entry", Arg1);
elsif Has_Homonym (Ent) then
Error_Pragma_Arg
("pragma% argument cannot specify overloaded entry", Arg1);
else
declare
FF : constant Entity_Id := First_Formal (Ent);
begin
if Present (FF) then
if Present (Next_Formal (FF)) then
Error_Pragma_Arg
("entry for pragma% can have only one argument",
Arg1);
elsif Parameter_Mode (FF) /= E_In_Parameter then
Error_Pragma_Arg
("entry parameter for pragma% must have mode IN",
Arg1);
end if;
end if;
end;
Set_Is_AST_Entry (Ent);
end if;
end AST_Entry;
------------------------------------------------------------------
-- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
------------------------------------------------------------------
@ -13857,48 +13556,6 @@ package body Sem_Prag is
end if;
end Export;
----------------------
-- Export_Exception --
----------------------
-- pragma Export_Exception (
-- [Internal =>] LOCAL_NAME
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Form =>] Ada | VMS]
-- [, [Code =>] static_integer_EXPRESSION]);
when Pragma_Export_Exception => Export_Exception : declare
Args : Args_List (1 .. 4);
Names : constant Name_List (1 .. 4) := (
Name_Internal,
Name_External,
Name_Form,
Name_Code);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Form : Node_Id renames Args (3);
Code : Node_Id renames Args (4);
begin
GNAT_Pragma;
if Inside_A_Generic then
Error_Pragma ("pragma% cannot be used for generic entities");
end if;
Gather_Associations (Names, Args);
Process_Extended_Import_Export_Exception_Pragma (
Arg_Internal => Internal,
Arg_External => External,
Arg_Form => Form,
Arg_Code => Code);
if not Is_VMS_Exception (Entity (Internal)) then
Set_Exported (Entity (Internal), Internal);
end if;
end Export_Exception;
---------------------
-- Export_Function --
---------------------
@ -14388,106 +14045,6 @@ package body Sem_Prag is
end if;
end Finalize_Storage;
--------------------------
-- Float_Representation --
--------------------------
-- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
-- FLOAT_REP ::= VAX_Float | IEEE_Float
when Pragma_Float_Representation => Float_Representation : declare
Argx : Node_Id;
Digs : Nat;
Ent : Entity_Id;
begin
GNAT_Pragma;
if Arg_Count = 1 then
Check_Valid_Configuration_Pragma;
else
Check_Arg_Count (2);
Check_Optional_Identifier (Arg2, Name_Entity);
Check_Arg_Is_Local_Name (Arg2);
end if;
Check_No_Identifier (Arg1);
Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
if not OpenVMS_On_Target then
if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
Error_Pragma
("??pragma% ignored (applies only to Open'V'M'S)");
end if;
return;
end if;
-- One argument case
if Arg_Count = 1 then
if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
if Opt.Float_Format = 'I' then
Error_Pragma ("'I'E'E'E format previously specified");
end if;
Opt.Float_Format := 'V';
else
if Opt.Float_Format = 'V' then
Error_Pragma ("'V'A'X format previously specified");
end if;
Opt.Float_Format := 'I';
end if;
Set_Standard_Fpt_Formats;
-- Two argument case
else
Argx := Get_Pragma_Arg (Arg2);
if not Is_Entity_Name (Argx)
or else not Is_Floating_Point_Type (Entity (Argx))
then
Error_Pragma_Arg
("second argument of% pragma must be floating-point type",
Arg2);
end if;
Ent := Entity (Argx);
Digs := UI_To_Int (Digits_Value (Ent));
-- Two arguments, VAX_Float case
if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
case Digs is
when 6 => Set_F_Float (Ent);
when 9 => Set_D_Float (Ent);
when 15 => Set_G_Float (Ent);
when others =>
Error_Pragma_Arg
("wrong digits value, must be 6,9 or 15", Arg2);
end case;
-- Two arguments, IEEE_Float case
else
case Digs is
when 6 => Set_IEEE_Short (Ent);
when 15 => Set_IEEE_Long (Ent);
when others =>
Error_Pragma_Arg
("wrong digits value, must be 6 or 15", Arg2);
end case;
end if;
end if;
end Float_Representation;
------------
-- Global --
------------
@ -14630,25 +14187,6 @@ package body Sem_Prag is
end if;
else
-- In VMS, the effect of IDENT is achieved by passing
-- --identification=name as a --for-linker switch.
if OpenVMS_On_Target then
Start_String;
Store_String_Chars
("--for-linker=--identification=");
String_To_Name_Buffer (Strval (Str));
Store_String_Chars (Name_Buffer (1 .. Name_Len));
-- Only the last processed IDENT is saved. The main
-- purpose is so an IDENT associated with a main
-- procedure will be used in preference to an IDENT
-- associated with a with'd package.
Replace_Linker_Option_String
(End_String, "--for-linker=--identification=");
end if;
Set_Ident_String (Current_Sem_Unit, Str);
end if;
@ -14845,49 +14383,6 @@ package body Sem_Prag is
Check_At_Most_N_Arguments (4);
Process_Import_Or_Interface;
----------------------
-- Import_Exception --
----------------------
-- pragma Import_Exception (
-- [Internal =>] LOCAL_NAME
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Form =>] Ada | VMS]
-- [, [Code =>] static_integer_EXPRESSION]);
when Pragma_Import_Exception => Import_Exception : declare
Args : Args_List (1 .. 4);
Names : constant Name_List (1 .. 4) := (
Name_Internal,
Name_External,
Name_Form,
Name_Code);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Form : Node_Id renames Args (3);
Code : Node_Id renames Args (4);
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
if Present (External) and then Present (Code) then
Error_Pragma
("cannot give both External and Code options for pragma%");
end if;
Process_Extended_Import_Export_Exception_Pragma (
Arg_Internal => Internal,
Arg_External => External,
Arg_Form => Form,
Arg_Code => Code);
if not Is_VMS_Exception (Entity (Internal)) then
Set_Imported (Entity (Internal));
end if;
end Import_Exception;
---------------------
-- Import_Function --
---------------------
@ -16692,65 +16187,6 @@ package body Sem_Prag is
end if;
end;
----------------
-- Long_Float --
----------------
-- pragma Long_Float (D_Float | G_Float);
when Pragma_Long_Float => Long_Float : declare
begin
GNAT_Pragma;
Check_Valid_Configuration_Pragma;
Check_Arg_Count (1);
Check_No_Identifier (Arg1);
Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
if not OpenVMS_On_Target then
Error_Pragma ("??pragma% ignored (applies only to Open'V'M'S)");
end if;
-- D_Float case
if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
if Opt.Float_Format_Long = 'G' then
Error_Pragma_Arg
("G_Float previously specified", Arg1);
elsif Current_Sem_Unit /= Main_Unit
and then Opt.Float_Format_Long /= 'D'
then
Error_Pragma_Arg
("main unit not compiled with pragma Long_Float (D_Float)",
"\pragma% must be used consistently for whole partition",
Arg1);
else
Opt.Float_Format_Long := 'D';
end if;
-- G_Float case (this is the default, does not need overriding)
else
if Opt.Float_Format_Long = 'D' then
Error_Pragma ("D_Float previously specified");
elsif Current_Sem_Unit /= Main_Unit
and then Opt.Float_Format_Long /= 'G'
then
Error_Pragma_Arg
("main unit not compiled with pragma Long_Float (G_Float)",
"\pragma% must be used consistently for whole partition",
Arg1);
else
Opt.Float_Format_Long := 'G';
end if;
end if;
Set_Standard_Fpt_Formats;
end Long_Float;
-------------------
-- Loop_Optimize --
-------------------
@ -18807,37 +18243,24 @@ package body Sem_Prag is
Def_Id : Entity_Id;
procedure Check_Too_Long (Arg : Node_Id);
-- Posts message if the argument is an identifier with more
-- than 31 characters, or a string literal with more than
-- 31 characters, and we are operating under VMS
procedure Check_Arg (Arg : Node_Id);
-- Checks that argument is either a string literal or an
-- identifier, and posts error message if not.
--------------------
-- Check_Too_Long --
--------------------
procedure Check_Too_Long (Arg : Node_Id) is
X : constant Node_Id := Original_Node (Arg);
---------------
-- Check_Arg --
---------------
procedure Check_Arg (Arg : Node_Id) is
begin
if not Nkind_In (X, N_String_Literal, N_Identifier) then
if not Nkind_In (Original_Node (Arg),
N_String_Literal,
N_Identifier)
then
Error_Pragma_Arg
("inappropriate argument for pragma %", Arg);
end if;
if OpenVMS_On_Target then
if (Nkind (X) = N_String_Literal
and then String_Length (Strval (X)) > 31)
or else
(Nkind (X) = N_Identifier
and then Length_Of_Name (Chars (X)) > 31)
then
Error_Pragma_Arg
("argument for pragma % is longer than 31 characters",
Arg);
end if;
end if;
end Check_Too_Long;
end Check_Arg;
-- Start of processing for Common_Object/Psect_Object
@ -18853,7 +18276,7 @@ package body Sem_Prag is
("pragma% must designate an object", Internal);
end if;
Check_Too_Long (Internal);
Check_Arg (Internal);
if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
Error_Pragma_Arg
@ -18906,12 +18329,11 @@ package body Sem_Prag is
end if;
if Present (Size) then
Check_Too_Long (Size);
Check_Arg (Size);
end if;
if Present (External) then
Check_Arg_Is_External_Name (External);
Check_Too_Long (External);
end if;
-- If all error tests pass, link pragma on to the rep item chain
@ -25350,8 +24772,7 @@ package body Sem_Prag is
-- 99 special processing required (e.g. for pragma Check)
Sig_Flags : constant array (Pragma_Id) of Int :=
(Pragma_AST_Entry => -1,
Pragma_Abort_Defer => -1,
(Pragma_Abort_Defer => -1,
Pragma_Abstract_State => -1,
Pragma_Ada_83 => -1,
Pragma_Ada_95 => -1,
@ -25416,7 +24837,6 @@ package body Sem_Prag is
Pragma_Eliminate => -1,
Pragma_Enable_Atomic_Synchronization => -1,
Pragma_Export => -1,
Pragma_Export_Exception => -1,
Pragma_Export_Function => -1,
Pragma_Export_Object => -1,
Pragma_Export_Procedure => -1,
@ -25429,14 +24849,12 @@ package body Sem_Prag is
Pragma_External_Name_Casing => -1,
Pragma_Fast_Math => -1,
Pragma_Finalize_Storage_Only => 0,
Pragma_Float_Representation => 0,
Pragma_Global => -1,
Pragma_Ident => -1,
Pragma_Implementation_Defined => -1,
Pragma_Implemented => -1,
Pragma_Implicit_Packing => 0,
Pragma_Import => +2,
Pragma_Import_Exception => 0,
Pragma_Import_Function => 0,
Pragma_Import_Object => 0,
Pragma_Import_Procedure => 0,
@ -25469,7 +24887,6 @@ package body Sem_Prag is
Pragma_List => -1,
Pragma_Lock_Free => -1,
Pragma_Locking_Policy => -1,
Pragma_Long_Float => -1,
Pragma_Loop_Invariant => -1,
Pragma_Loop_Optimize => -1,
Pragma_Loop_Variant => -1,

52
gcc/ada/snames.adb-tmpl
View File

@ -217,33 +217,30 @@ package body Snames is
function Get_Pragma_Id (N : Name_Id) return Pragma_Id is
begin
if N = Name_AST_Entry then
return Pragma_AST_Entry;
elsif N = Name_CPU then
return Pragma_CPU;
elsif N = Name_Dispatching_Domain then
return Pragma_Dispatching_Domain;
elsif N = Name_Fast_Math then
return Pragma_Fast_Math;
elsif N = Name_Interface then
return Pragma_Interface;
elsif N = Name_Interrupt_Priority then
return Pragma_Interrupt_Priority;
elsif N = Name_Lock_Free then
return Pragma_Lock_Free;
elsif N = Name_Priority then
return Pragma_Priority;
elsif N = Name_Relative_Deadline then
return Pragma_Relative_Deadline;
elsif N = Name_Storage_Size then
return Pragma_Storage_Size;
elsif N = Name_Storage_Unit then
return Pragma_Storage_Unit;
elsif N not in First_Pragma_Name .. Last_Pragma_Name then
return Unknown_Pragma;
else
return Pragma_Id'Val (N - First_Pragma_Name);
end if;
case N is
when Name_CPU =>
return Pragma_CPU;
when Name_Dispatching_Domain =>
return Pragma_Dispatching_Domain;
when Name_Fast_Math =>
return Pragma_Fast_Math;
when Name_Interface =>
return Pragma_Interface;
when Name_Interrupt_Priority =>
return Pragma_Interrupt_Priority;
when Name_Lock_Free =>
return Pragma_Lock_Free;
when Name_Priority =>
return Pragma_Priority;
when Name_Storage_Size =>
return Pragma_Storage_Size;
when Name_Storage_Unit =>
return Pragma_Storage_Unit;
when First_Pragma_Name .. Last_Pragma_Name =>
return Pragma_Id'Val (N - First_Pragma_Name);
when others =>
return Unknown_Pragma;
end case;
end Get_Pragma_Id;
---------------------------
@ -449,7 +446,6 @@ package body Snames is
function Is_Pragma_Name (N : Name_Id) return Boolean is
begin
return N in First_Pragma_Name .. Last_Pragma_Name
or else N = Name_AST_Entry
or else N = Name_CPU
or else N = Name_Dispatching_Domain
or else N = Name_Fast_Math

35
gcc/ada/snames.ads-tmpl
View File

@ -405,13 +405,11 @@ package Snames is
-- Fast_Math.
Name_Favor_Top_Level : constant Name_Id := N + $; -- GNAT
Name_Float_Representation : constant Name_Id := N + $; -- GNAT
Name_Implicit_Packing : constant Name_Id := N + $; -- GNAT
Name_Initialize_Scalars : constant Name_Id := N + $; -- GNAT
Name_Interrupt_State : constant Name_Id := N + $; -- GNAT
Name_License : constant Name_Id := N + $; -- GNAT
Name_Locking_Policy : constant Name_Id := N + $;
Name_Long_Float : constant Name_Id := N + $; -- VMS
Name_Loop_Optimize : constant Name_Id := N + $; -- GNAT
Name_No_Run_Time : constant Name_Id := N + $; -- GNAT
Name_No_Strict_Aliasing : constant Name_Id := N + $; -- GNAT
@ -457,12 +455,6 @@ package Snames is
Name_Abort_Defer : constant Name_Id := N + $; -- GNAT
Name_Abstract_State : constant Name_Id := N + $; -- GNAT
Name_All_Calls_Remote : constant Name_Id := N + $;
-- Note: AST_Entry is not in this list because its name matches the name of
-- the corresponding attribute. However, it is included in the definition
-- of the type Pragma_Id, and the functions Get_Pragma_Id and Is_Pragma_Id
-- correctly recognize and process Name_AST_Entry.
Name_Assert : constant Name_Id := N + $; -- Ada 05
Name_Assert_And_Cut : constant Name_Id := N + $; -- GNAT
Name_Async_Readers : constant Name_Id := N + $; -- GNAT
@ -499,7 +491,6 @@ package Snames is
Name_Elaborate_All : constant Name_Id := N + $;
Name_Elaborate_Body : constant Name_Id := N + $;
Name_Export : constant Name_Id := N + $;
Name_Export_Exception : constant Name_Id := N + $; -- VMS
Name_Export_Function : constant Name_Id := N + $; -- GNAT
Name_Export_Object : constant Name_Id := N + $; -- GNAT
Name_Export_Procedure : constant Name_Id := N + $; -- GNAT
@ -512,7 +503,6 @@ package Snames is
Name_Implementation_Defined : constant Name_Id := N + $; -- GNAT
Name_Implemented : constant Name_Id := N + $; -- Ada 12
Name_Import : constant Name_Id := N + $;
Name_Import_Exception : constant Name_Id := N + $; -- VMS
Name_Import_Function : constant Name_Id := N + $; -- GNAT
Name_Import_Object : constant Name_Id := N + $; -- GNAT
Name_Import_Procedure : constant Name_Id := N + $; -- GNAT
@ -838,7 +828,6 @@ package Snames is
Name_Alignment : constant Name_Id := N + $;
Name_Asm_Input : constant Name_Id := N + $; -- GNAT
Name_Asm_Output : constant Name_Id := N + $; -- GNAT
Name_AST_Entry : constant Name_Id := N + $; -- VMS
Name_Atomic_Always_Lock_Free : constant Name_Id := N + $; -- GNAT
Name_Bit : constant Name_Id := N + $; -- GNAT
Name_Bit_Order : constant Name_Id := N + $;
@ -1468,7 +1457,6 @@ package Snames is
Attribute_Alignment,
Attribute_Asm_Input,
Attribute_Asm_Output,
Attribute_AST_Entry,
Attribute_Atomic_Always_Lock_Free,
Attribute_Bit,
Attribute_Bit_Order,
@ -1761,13 +1749,11 @@ package Snames is
Pragma_Extensions_Allowed,
Pragma_External_Name_Casing,
Pragma_Favor_Top_Level,
Pragma_Float_Representation,
Pragma_Implicit_Packing,
Pragma_Initialize_Scalars,
Pragma_Interrupt_State,
Pragma_License,
Pragma_Locking_Policy,
Pragma_Long_Float,
Pragma_Loop_Optimize,
Pragma_No_Run_Time,
Pragma_No_Strict_Aliasing,
@ -1841,7 +1827,6 @@ package Snames is
Pragma_Elaborate_All,
Pragma_Elaborate_Body,
Pragma_Export,
Pragma_Export_Exception,
Pragma_Export_Function,
Pragma_Export_Object,
Pragma_Export_Procedure,
@ -1854,7 +1839,6 @@ package Snames is
Pragma_Implementation_Defined,
Pragma_Implemented,
Pragma_Import,
Pragma_Import_Exception,
Pragma_Import_Function,
Pragma_Import_Object,
Pragma_Import_Procedure,
@ -1953,7 +1937,6 @@ package Snames is
-- special processing required to deal with the fact that their names
-- match existing attribute names.
Pragma_AST_Entry,
Pragma_CPU,
Pragma_Dispatching_Domain,
Pragma_Fast_Math,
@ -2046,12 +2029,12 @@ package Snames is
-- Test to see if the name N is the name of an operator symbol
function Is_Pragma_Name (N : Name_Id) return Boolean;
-- Test to see if the name N is the name of a recognized pragma. Note that
-- pragmas AST_Entry, CPU, Dispatching_Domain, Fast_Math,
-- Interrupt_Priority, Lock_Free, Priority, Storage_Size, and Storage_Unit
-- are recognized as pragmas by this function even though their names are
-- separate from the other pragma names. For this reason, clients should
-- always use this function, rather than do range tests on Name_Id values.
-- Test to see if the name N is the name of a recognized pragma. Note
-- that pragmas CPU, Dispatching_Domain, Fast_Math, Interrupt_Priority,
-- Lock_Free, Priority, Storage_Size, and Storage_Unit are recognized
-- as pragmas by this function even though their names are separate from
-- the other pragma names. For this reason, clients should always use
-- this function, rather than do range tests on Name_Id values.
function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean;
-- Test to see if the name N is the name of a recognized configuration
@ -2091,10 +2074,8 @@ package Snames is
-- Returns Id of pragma corresponding to given name. Returns Unknown_Pragma
-- if N is not a name of a known (Ada defined or GNAT-specific) pragma.
-- Note that the function also works correctly for names of pragmas that
-- are not included in the main list of pragma Names (AST_Entry, CPU,
-- Dispatching_Domain, Interrupt_Priority, Lock_Free, Priority,
-- Storage_Size, and Storage_Unit (e.g. Name_Storage_Size returns
-- Pragma_Storage_Size).
-- are not included in the main list of pragma Names (e.g. Name_CPU returns
-- Pragma_CPU).
function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id;
-- Returns Id of queuing policy corresponding to given name. It is an error