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.
2014-07-31 Arnaud Charlet <charlet@adacore.com>
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);
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;
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;
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;
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;
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;
------------------------
-- 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
-----------------------------------
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
---------------
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;
-- 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
-- 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)
-- 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));
Set_Msg_Char (C);
end case;
end loop;
-
- VMS_Convert;
end Set_Msg_Text;
----------------
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 --
--------------------
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 --
---------
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;
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);
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);
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 --
------------------------------------
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;
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
-- --
-- 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 --
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
Pragma_Assertion_Policy |
Pragma_Assume |
Pragma_Assume_No_Invalid_Values |
- Pragma_AST_Entry |
Pragma_All_Calls_Remote |
Pragma_Allow_Integer_Address |
Pragma_Annotate |
Pragma_Elaboration_Checks |
Pragma_Enable_Atomic_Synchronization |
Pragma_Export |
- Pragma_Export_Exception |
Pragma_Export_Function |
Pragma_Export_Object |
Pragma_Export_Procedure |
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 |
Pragma_Linker_Section |
Pragma_Lock_Free |
Pragma_Locking_Policy |
- Pragma_Long_Float |
Pragma_Loop_Invariant |
Pragma_Loop_Optimize |
Pragma_Loop_Variant |
-- 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;
-- --
-- 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- --
-- 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
-- --
-- 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- --
-- 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
-- --
-- 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- --
-- 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
-- --
-- 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- --
-- 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
-- --
-- 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- --
-- 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
-- --
-- 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- --
------------------------------------------------------------------------------
-- 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.
-package System.Vax_Float_Operations is
+-- TO BE REMOVED ???
- pragma Warnings (Off);
- -- Suppress warnings if not on Alpha/VAX
+package System.Vax_Float_Operations is
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
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
-- 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;
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;
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 --
-----------------------------
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 --
-----------------------------
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 --
------------------
-- --
-- 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- --
-- 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 --
---------
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
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!",
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
-- 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;
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
-- 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
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;
-- 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
-- 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;
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));
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 --
-------------------------------------------------
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
-- 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 --
-------------------------
("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
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);
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;
--------------------------
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;
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 --
------------------------------------------------------------------
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 --
---------------------
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 --
------------
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;
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 --
---------------------
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 --
-------------------
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
-
- --------------------
- -- Check_Too_Long --
- --------------------
+ procedure Check_Arg (Arg : Node_Id);
+ -- Checks that argument is either a string literal or an
+ -- identifier, and posts error message if not.
- 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
("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
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
-- 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,
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,
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,
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,
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;
---------------------------
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
-- 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
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
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
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
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 + $;
Attribute_Alignment,
Attribute_Asm_Input,
Attribute_Asm_Output,
- Attribute_AST_Entry,
Attribute_Atomic_Always_Lock_Free,
Attribute_Bit,
Attribute_Bit_Order,
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,
Pragma_Elaborate_All,
Pragma_Elaborate_Body,
Pragma_Export,
- Pragma_Export_Exception,
Pragma_Export_Function,
Pragma_Export_Object,
Pragma_Export_Procedure,
Pragma_Implementation_Defined,
Pragma_Implemented,
Pragma_Import,
- Pragma_Import_Exception,
Pragma_Import_Function,
Pragma_Import_Object,
Pragma_Import_Procedure,
-- 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,
-- 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
-- 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
projects / platform / upstream / linaro-gcc.git / commitdiff