OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

gnatchop.adb, [...]: Minor reformatting. 

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

	* gnatchop.adb, gnatcmd.adb, make.adb, mlib-prj.adb, bindgen.adb,
	mlib.ads, butil.adb, clean.adb, binde.adb, gnatls.adb, gnatname.adb,
	osint.adb, krunch.adb: Minor reformatting.

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

	* inline.adb, inline.ads, fe.h, einfo.adb, einfo.ads, sem_util.adb,
	sem_util.ads, exp_ch4.adb, exp_ch11.adb, exp_ch6.adb, cstand.adb,
	sem_mech.adb, sem_ch6.adb, sem_ch8.adb, sem_ch11.adb, snames.ads-tmpl:
	Remove VMS-specific code.

From-SVN: r213414
This commit is contained in:
Robert Dewar 2014-08-01 08:17:20 +00:00 committed by Arnaud Charlet
parent 62883e6b17
commit ea0c8cfb98
30 changed files with 144 additions and 557 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/ada/ChangeLog
View File

@ -1,3 +1,16 @@
2014-08-01 Robert Dewar <dewar@adacore.com>
* gnatchop.adb, gnatcmd.adb, make.adb, mlib-prj.adb, bindgen.adb,
mlib.ads, butil.adb, clean.adb, binde.adb, gnatls.adb, gnatname.adb,
osint.adb, krunch.adb: Minor reformatting.
2014-08-01 Robert Dewar <dewar@adacore.com>
* inline.adb, inline.ads, fe.h, einfo.adb, einfo.ads, sem_util.adb,
sem_util.ads, exp_ch4.adb, exp_ch11.adb, exp_ch6.adb, cstand.adb,
sem_mech.adb, sem_ch6.adb, sem_ch8.adb, sem_ch11.adb, snames.ads-tmpl:
Remove VMS-specific code.
2014-08-01 Arnaud Charlet <charlet@adacore.com>
* binde.adb, bindgen.adb, butil.adb, clean.adb, gnatbind.adb,

7
gcc/ada/binde.adb
View File

@ -1085,8 +1085,7 @@ package body Binde is
-- Output warning if -p used with no -gnatE units
if Pessimistic_Elab_Order
and not Dynamic_Elaboration_Checks_Specified
if Pessimistic_Elab_Order and not Dynamic_Elaboration_Checks_Specified
then
Error_Msg ("?use of -p switch questionable");
Error_Msg ("?since all units compiled with static elaboration model");
@ -1105,7 +1104,6 @@ package body Binde is
-- Initialize the no predecessor list
No_Pred := No_Unit_Id;
for U in UNR.First .. UNR.Last loop
if UNR.Table (U).Num_Pred = 0 then
UNR.Table (U).Nextnp := No_Pred;
@ -1216,8 +1214,7 @@ package body Binde is
-- interfaces to stand-alone libraries.
if not Units.Table (U).SAL_Interface then
for
W in Units.Table (U).First_With .. Units.Table (U).Last_With
for W in Units.Table (U).First_With .. Units.Table (U).Last_With
loop
if Withs.Table (W).Sfile /= No_File
and then (not Withs.Table (W).SAL_Interface)

26
gcc/ada/bindgen.adb
View File

@ -321,16 +321,16 @@ package body Bindgen is
-- Move routine for sorting linker options
procedure Resolve_Binder_Options;
-- Set the value of With_GNARL.
-- Set the value of With_GNARL
procedure Set_Char (C : Character);
-- Set given character in Statement_Buffer at the Last + 1 position
-- and increment Last by one to reflect the stored character.
procedure Set_Int (N : Int);
-- Set given value in decimal in Statement_Buffer with no spaces
-- starting at the Last + 1 position, and updating Last past the value.
-- A minus sign is output for a negative value.
-- Set given value in decimal in Statement_Buffer with no spaces starting
-- at the Last + 1 position, and updating Last past the value. A minus sign
-- is output for a negative value.
procedure Set_Boolean (B : Boolean);
-- Set given boolean value in Statement_Buffer at the Last + 1 position
@ -340,9 +340,9 @@ package body Bindgen is
-- Initializes contents of IS_Pragma_Settings table from ALI table
procedure Set_Main_Program_Name;
-- Given the main program name in Name_Buffer (length in Name_Len)
-- generate the name of the routine to be used in the call. The name
-- is generated starting at Last + 1, and Last is updated past it.
-- Given the main program name in Name_Buffer (length in Name_Len) generate
-- the name of the routine to be used in the call. The name is generated
-- starting at Last + 1, and Last is updated past it.
procedure Set_Name_Buffer;
-- Set the value stored in positions 1 .. Name_Len of the Name_Buffer
@ -355,9 +355,9 @@ package body Bindgen is
-- Last + 1 position, and updating last past the string value.
procedure Set_String_Replace (S : String);
-- Replaces the last S'Length characters in the Statement_Buffer with
-- the characters of S. The caller must ensure that these characters do
-- in fact exist in the Statement_Buffer.
-- Replaces the last S'Length characters in the Statement_Buffer with the
-- characters of S. The caller must ensure that these characters do in fact
-- exist in the Statement_Buffer.
type Qualification_Mode is (Dollar_Sign, Dot, Double_Underscores);
@ -368,9 +368,9 @@ package body Bindgen is
-- underscores (__), a dollar sign ($) or left as is.
procedure Set_Unit_Number (U : Unit_Id);
-- Sets unit number (first unit is 1, leading zeroes output to line
-- up all output unit numbers nicely as required by the value, and
-- by the total number of units.
-- Sets unit number (first unit is 1, leading zeroes output to line up all
-- output unit numbers nicely as required by the value, and by the total
-- number of units.
procedure Write_Statement_Buffer;
-- Write out contents of statement buffer up to Last, and reset Last to 0

80
gcc/ada/butil.adb
View File

@ -37,10 +37,9 @@ package body Butil is
function Is_Internal_Unit return Boolean is
begin
return Is_Predefined_Unit
or else (Name_Len > 4
and then (Name_Buffer (1 .. 5) = "gnat%"
or else
Name_Buffer (1 .. 5) = "gnat."));
or else (Name_Len > 4 and then (Name_Buffer (1 .. 5) = "gnat%"
or else
Name_Buffer (1 .. 5) = "gnat."));
end Is_Internal_Unit;
------------------------
@ -51,54 +50,25 @@ package body Butil is
-- is that it would drag too much junk into the binder.
function Is_Predefined_Unit return Boolean is
L : Natural renames Name_Len;
B : String renames Name_Buffer;
begin
return (Name_Len > 3
and then Name_Buffer (1 .. 4) = "ada.")
or else (Name_Len > 6
and then Name_Buffer (1 .. 7) = "system.")
or else (Name_Len > 10
and then Name_Buffer (1 .. 11) = "interfaces.")
or else (Name_Len > 3
and then Name_Buffer (1 .. 4) = "ada%")
or else (Name_Len > 8
and then Name_Buffer (1 .. 9) = "calendar%")
or else (Name_Len > 9
and then Name_Buffer (1 .. 10) = "direct_io%")
or else (Name_Len > 10
and then Name_Buffer (1 .. 11) = "interfaces%")
or else (Name_Len > 13
and then Name_Buffer (1 .. 14) = "io_exceptions%")
or else (Name_Len > 12
and then Name_Buffer (1 .. 13) = "machine_code%")
or else (Name_Len > 13
and then Name_Buffer (1 .. 14) = "sequential_io%")
or else (Name_Len > 6
and then Name_Buffer (1 .. 7) = "system%")
or else (Name_Len > 7
and then Name_Buffer (1 .. 8) = "text_io%")
or else (Name_Len > 20
and then Name_Buffer (1 .. 21) = "unchecked_conversion%")
or else (Name_Len > 22
and then Name_Buffer (1 .. 23) = "unchecked_deallocation%")
or else (Name_Len > 4
and then Name_Buffer (1 .. 5) = "gnat%")
or else (Name_Len > 4
and then Name_Buffer (1 .. 5) = "gnat.");
return (L > 3 and then B (1 .. 4) = "ada.")
or else (L > 6 and then B (1 .. 7) = "system.")
or else (L > 10 and then B (1 .. 11) = "interfaces.")
or else (L > 3 and then B (1 .. 4) = "ada%")
or else (L > 8 and then B (1 .. 9) = "calendar%")
or else (L > 9 and then B (1 .. 10) = "direct_io%")
or else (L > 10 and then B (1 .. 11) = "interfaces%")
or else (L > 13 and then B (1 .. 14) = "io_exceptions%")
or else (L > 12 and then B (1 .. 13) = "machine_code%")
or else (L > 13 and then B (1 .. 14) = "sequential_io%")
or else (L > 6 and then B (1 .. 7) = "system%")
or else (L > 7 and then B (1 .. 8) = "text_io%")
or else (L > 20 and then B (1 .. 21) = "unchecked_conversion%")
or else (L > 22 and then B (1 .. 23) = "unchecked_deallocation%")
or else (L > 4 and then B (1 .. 5) = "gnat%")
or else (L > 4 and then B (1 .. 5) = "gnat.");
end Is_Predefined_Unit;
----------------
@ -111,7 +81,7 @@ package body Butil is
declare
U1_Name : constant String (1 .. Name_Len) :=
Name_Buffer (1 .. Name_Len);
Name_Buffer (1 .. Name_Len);
Min_Length : Natural;
begin
@ -123,10 +93,10 @@ package body Butil is
Min_Length := U1_Name'Last;
end if;
for I in 1 .. Min_Length loop
if U1_Name (I) > Name_Buffer (I) then
for J in 1 .. Min_Length loop
if U1_Name (J) > Name_Buffer (J) then
return False;
elsif U1_Name (I) < Name_Buffer (I) then
elsif U1_Name (J) < Name_Buffer (J) then
return True;
end if;
end loop;

8
gcc/ada/clean.adb
View File

@ -55,8 +55,8 @@ with GNAT.OS_Lib; use GNAT.OS_Lib;
package body Clean is
Initialized : Boolean := False;
-- Set to True by the first call to Initialize.
-- To avoid reinitialization of some packages.
-- Set to True by the first call to Initialize to avoid reinitialization
-- of some packages.
-- Suffixes of various files
@ -66,10 +66,10 @@ package body Clean is
Object_Suffix : constant String := Get_Target_Object_Suffix.all;
Debug_Suffix : constant String := ".dg";
Repinfo_Suffix : constant String := ".rep";
-- Suffix of representation info files.
-- Suffix of representation info files
B_Start : constant String := "b~";
-- Prefix of binder generated file, and number of actual characters used.
-- Prefix of binder generated file, and number of actual characters used
Project_Tree : constant Project_Tree_Ref :=
new Project_Tree_Data (Is_Root_Tree => True);

19
gcc/ada/cstand.adb
View File

@ -467,10 +467,9 @@ package body CStand is
procedure Build_Exception (S : Standard_Entity_Type) is
begin
Set_Ekind (Standard_Entity (S), E_Exception);
Set_Etype (Standard_Entity (S), Standard_Exception_Type);
Set_Exception_Code (Standard_Entity (S), Uint_0);
Set_Is_Public (Standard_Entity (S), True);
Set_Ekind (Standard_Entity (S), E_Exception);
Set_Etype (Standard_Entity (S), Standard_Exception_Type);
Set_Is_Public (Standard_Entity (S), True);
Decl :=
Make_Exception_Declaration (Stloc,
@ -1590,7 +1589,6 @@ package body CStand is
E_Id := Standard_Entity (S_Numeric_Error);
Set_Ekind (E_Id, E_Exception);
Set_Exception_Code (E_Id, Uint_0);
Set_Etype (E_Id, Standard_Exception_Type);
Set_Is_Public (E_Id);
Set_Renamed_Entity (E_Id, Standard_Entity (S_Constraint_Error));
@ -1607,12 +1605,11 @@ package body CStand is
-- Abort_Signal is an entity that does not get made visible
Abort_Signal := New_Standard_Entity;
Set_Chars (Abort_Signal, Name_uAbort_Signal);
Set_Ekind (Abort_Signal, E_Exception);
Set_Exception_Code (Abort_Signal, Uint_0);
Set_Etype (Abort_Signal, Standard_Exception_Type);
Set_Scope (Abort_Signal, Standard_Standard);
Set_Is_Public (Abort_Signal, True);
Set_Chars (Abort_Signal, Name_uAbort_Signal);
Set_Ekind (Abort_Signal, E_Exception);
Set_Etype (Abort_Signal, Standard_Exception_Type);
Set_Scope (Abort_Signal, Standard_Standard);
Set_Is_Public (Abort_Signal, True);
Decl :=
Make_Exception_Declaration (Stloc,
Defining_Identifier => Abort_Signal);

46
gcc/ada/einfo.adb
View File

@ -195,7 +195,6 @@ package body Einfo is
-- Component_Size Uint22
-- Corresponding_Remote_Type Node22
-- Enumeration_Rep_Expr Node22
-- Exception_Code Uint22
-- Original_Record_Component Node22
-- Private_View Node22
-- Protected_Formal Node22
@ -412,8 +411,6 @@ package body Einfo is
-- Is_Generic_Instance Flag130
-- No_Pool_Assigned Flag131
-- Is_AST_Entry Flag132
-- Is_VMS_Exception Flag133
-- Is_Optional_Parameter Flag134
-- Has_Aliased_Components Flag135
-- No_Strict_Aliasing Flag136
@ -574,6 +571,9 @@ package body Einfo is
-- (unused) Flag2
-- (unused) Flag3
-- (unused) Flag132
-- (unused) Flag133
-- (unused) Flag275
-- (unused) Flag276
-- (unused) Flag277
@ -1182,12 +1182,6 @@ package body Einfo is
return Uint12 (Id);
end Esize;
function Exception_Code (Id : E) return Uint is
begin
pragma Assert (Ekind (Id) = E_Exception);
return Uint22 (Id);
end Exception_Code;
function Extra_Accessibility (Id : E) return E is
begin
pragma Assert
@ -1901,12 +1895,6 @@ package body Einfo is
return Flag15 (Id);
end Is_Aliased;
function Is_AST_Entry (Id : E) return B is
begin
pragma Assert (Is_Entry (Id));
return Flag132 (Id);
end Is_AST_Entry;
function Is_Asynchronous (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Procedure or else Is_Type (Id));
@ -2420,11 +2408,6 @@ package body Einfo is
return Flag116 (Id);
end Is_Visible_Lib_Unit;
function Is_VMS_Exception (Id : E) return B is
begin
return Flag133 (Id);
end Is_VMS_Exception;
function Is_Volatile (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
@ -3931,12 +3914,6 @@ package body Einfo is
Set_Uint12 (Id, V);
end Set_Esize;
procedure Set_Exception_Code (Id : E; V : U) is
begin
pragma Assert (Ekind (Id) = E_Exception);
Set_Uint22 (Id, V);
end Set_Exception_Code;
procedure Set_Extra_Accessibility (Id : E; V : E) is
begin
pragma Assert
@ -4677,12 +4654,6 @@ package body Einfo is
Set_Flag15 (Id, V);
end Set_Is_Aliased;
procedure Set_Is_AST_Entry (Id : E; V : B := True) is
begin
pragma Assert (Is_Entry (Id));
Set_Flag132 (Id, V);
end Set_Is_AST_Entry;
procedure Set_Is_Asynchronous (Id : E; V : B := True) is
begin
pragma Assert
@ -5227,12 +5198,6 @@ package body Einfo is
Set_Flag116 (Id, V);
end Set_Is_Visible_Lib_Unit;
procedure Set_Is_VMS_Exception (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Exception);
Set_Flag133 (Id, V);
end Set_Is_VMS_Exception;
procedure Set_Is_Volatile (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
@ -8353,7 +8318,6 @@ package body Einfo is
W ("In_Package_Body", Flag48 (Id));
W ("In_Private_Part", Flag45 (Id));
W ("In_Use", Flag8 (Id));
W ("Is_AST_Entry", Flag132 (Id));
W ("Is_Abstract_Subprogram", Flag19 (Id));
W ("Is_Abstract_Type", Flag146 (Id));
W ("Is_Local_Anonymous_Access", Flag194 (Id));
@ -8454,7 +8418,6 @@ package body Einfo is
W ("Is_Unchecked_Union", Flag117 (Id));
W ("Is_Underlying_Record_View", Flag246 (Id));
W ("Is_Unsigned_Type", Flag144 (Id));
W ("Is_VMS_Exception", Flag133 (Id));
W ("Is_Valued_Procedure", Flag127 (Id));
W ("Is_Visible_Formal", Flag206 (Id));
W ("Is_Visible_Lib_Unit", Flag116 (Id));
@ -9307,9 +9270,6 @@ package body Einfo is
when E_Enumeration_Literal =>
Write_Str ("Enumeration_Rep_Expr");
when E_Exception =>
Write_Str ("Exception_Code");
when E_Record_Type_With_Private |
E_Record_Subtype_With_Private |
E_Private_Type |

36
gcc/ada/einfo.ads
View File

@ -1148,13 +1148,6 @@ package Einfo is
-- Note one obscure case: for pragma Default_Storage_Pool (null), the
-- Etype of the N_Null node is Empty.
-- Exception_Code (Uint22)
-- Defined in exception entities. Set to zero unless either an
-- Import_Exception or Export_Exception pragma applies to the
-- pragma and specifies a Code value. See description of these
-- pragmas for details. Note that this field is relevant only if
-- Is_VMS_Exception is set.
-- Extra_Formal (Node15)
-- Defined in formal parameters in the non-generic case. Certain
-- parameters require extra implicit information to be passed (e.g. the
@ -2146,13 +2139,6 @@ package Einfo is
-- carry the keyword aliased, and on record components that have the
-- keyword. For Ada 2012, also applies to formal parameters.
-- Is_AST_Entry (Flag132)
-- Defined in entry entities. Set if a valid pragma AST_Entry applies
-- to the entry. This flag can only be set in OpenVMS versions of GNAT.
-- Note: we also allow the flag to appear in entry families, but given
-- the current implementation of the pragma AST_Entry, this flag will
-- always be False in entry families.
-- Is_Atomic (Flag85)
-- Defined in all type entities, and also in constants, components and
-- variables. Set if a pragma Atomic or Shared applies to the entity.
@ -3060,12 +3046,6 @@ package Einfo is
-- a separate flag must be used to indicate whether the names are visible
-- by selected notation, or not.
-- Is_VMS_Exception (Flag133)
-- Defined in all entities. Set only for exception entities where the
-- exception was specified in an Import_Exception or Export_Exception
-- pragma with the VMS option for Form. See description of these pragmas
-- for details. This flag can only be set in OpenVMS versions of GNAT.
-- Is_Volatile (Flag16)
-- Defined in all type entities, and also in constants, components and
-- variables. Set if a pragma Volatile applies to the entity. Also set
@ -5193,7 +5173,6 @@ package Einfo is
-- Is_Trivial_Subprogram (Flag235)
-- Is_Unchecked_Union (Flag117)
-- Is_Visible_Formal (Flag206)
-- Is_VMS_Exception (Flag133)
-- Kill_Elaboration_Checks (Flag32)
-- Kill_Range_Checks (Flag33)
-- Low_Bound_Tested (Flag205)
@ -5552,7 +5531,6 @@ package Einfo is
-- Contract (Node34)
-- Default_Expressions_Processed (Flag108)
-- Entry_Accepted (Flag152)
-- Is_AST_Entry (Flag132) (for entry only)
-- Needs_No_Actuals (Flag22)
-- Sec_Stack_Needed_For_Return (Flag167)
-- Uses_Sec_Stack (Flag95)
@ -5598,9 +5576,7 @@ package Einfo is
-- Renamed_Entity (Node18)
-- Register_Exception_Call (Node20)
-- Interface_Name (Node21)
-- Exception_Code (Uint22)
-- Discard_Names (Flag88)
-- Is_VMS_Exception (Flag133)
-- Is_Raised (Flag224)
-- E_Exception_Type
@ -6532,7 +6508,6 @@ package Einfo is
function Enumeration_Rep_Expr (Id : E) return N;
function Equivalent_Type (Id : E) return E;
function Esize (Id : E) return U;
function Exception_Code (Id : E) return U;
function Extra_Accessibility (Id : E) return E;
function Extra_Accessibility_Of_Result (Id : E) return E;
function Extra_Constrained (Id : E) return E;
@ -6654,7 +6629,6 @@ package Einfo is
function Interface_Alias (Id : E) return E;
function Interface_Name (Id : E) return N;
function Interfaces (Id : E) return L;
function Is_AST_Entry (Id : E) return B;
function Is_Abstract_Subprogram (Id : E) return B;
function Is_Abstract_Type (Id : E) return B;
function Is_Access_Constant (Id : E) return B;
@ -6749,7 +6723,6 @@ package Einfo is
function Is_Unchecked_Union (Id : E) return B;
function Is_Underlying_Record_View (Id : E) return B;
function Is_Unsigned_Type (Id : E) return B;
function Is_VMS_Exception (Id : E) return B;
function Is_Valued_Procedure (Id : E) return B;
function Is_Visible_Formal (Id : E) return B;
function Is_Visible_Lib_Unit (Id : E) return B;
@ -7168,7 +7141,6 @@ package Einfo is
procedure Set_Enumeration_Rep_Expr (Id : E; V : N);
procedure Set_Equivalent_Type (Id : E; V : E);
procedure Set_Esize (Id : E; V : U);
procedure Set_Exception_Code (Id : E; V : U);
procedure Set_Extra_Accessibility (Id : E; V : E);
procedure Set_Extra_Accessibility_Of_Result (Id : E; V : E);
procedure Set_Extra_Constrained (Id : E; V : E);
@ -7289,7 +7261,6 @@ package Einfo is
procedure Set_Interface_Alias (Id : E; V : E);
procedure Set_Interface_Name (Id : E; V : N);
procedure Set_Interfaces (Id : E; V : L);
procedure Set_Is_AST_Entry (Id : E; V : B := True);
procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True);
procedure Set_Is_Abstract_Type (Id : E; V : B := True);
procedure Set_Is_Access_Constant (Id : E; V : B := True);
@ -7390,7 +7361,6 @@ package Einfo is
procedure Set_Is_Unchecked_Union (Id : E; V : B := True);
procedure Set_Is_Underlying_Record_View (Id : E; V : B := True);
procedure Set_Is_Unsigned_Type (Id : E; V : B := True);
procedure Set_Is_VMS_Exception (Id : E; V : B := True);
procedure Set_Is_Valued_Procedure (Id : E; V : B := True);
procedure Set_Is_Visible_Formal (Id : E; V : B := True);
procedure Set_Is_Visible_Lib_Unit (Id : E; V : B := True);
@ -7918,7 +7888,6 @@ package Einfo is
pragma Inline (Enumeration_Rep_Expr);
pragma Inline (Equivalent_Type);
pragma Inline (Esize);
pragma Inline (Exception_Code);
pragma Inline (Extra_Accessibility);
pragma Inline (Extra_Accessibility_Of_Result);
pragma Inline (Extra_Constrained);
@ -8036,7 +8005,6 @@ package Einfo is
pragma Inline (Interface_Alias);
pragma Inline (Interface_Name);
pragma Inline (Interfaces);
pragma Inline (Is_AST_Entry);
pragma Inline (Is_Abstract_Subprogram);
pragma Inline (Is_Abstract_Type);
pragma Inline (Is_Access_Constant);
@ -8178,7 +8146,6 @@ package Einfo is
pragma Inline (Is_Unchecked_Union);
pragma Inline (Is_Underlying_Record_View);
pragma Inline (Is_Unsigned_Type);
pragma Inline (Is_VMS_Exception);
pragma Inline (Is_Valued_Procedure);
pragma Inline (Is_Visible_Formal);
pragma Inline (Is_Visible_Lib_Unit);
@ -8400,7 +8367,6 @@ package Einfo is
pragma Inline (Set_Enumeration_Rep_Expr);
pragma Inline (Set_Equivalent_Type);
pragma Inline (Set_Esize);
pragma Inline (Set_Exception_Code);
pragma Inline (Set_Extra_Accessibility);
pragma Inline (Set_Extra_Accessibility_Of_Result);
pragma Inline (Set_Extra_Constrained);
@ -8518,7 +8484,6 @@ package Einfo is
pragma Inline (Set_Interface_Alias);
pragma Inline (Set_Interface_Name);
pragma Inline (Set_Interfaces);
pragma Inline (Set_Is_AST_Entry);
pragma Inline (Set_Is_Abstract_Subprogram);
pragma Inline (Set_Is_Abstract_Type);
pragma Inline (Set_Is_Access_Constant);
@ -8619,7 +8584,6 @@ package Einfo is
pragma Inline (Set_Is_Unchecked_Union);
pragma Inline (Set_Is_Underlying_Record_View);
pragma Inline (Set_Is_Unsigned_Type);
pragma Inline (Set_Is_VMS_Exception);
pragma Inline (Set_Is_Valued_Procedure);
pragma Inline (Set_Is_Visible_Formal);
pragma Inline (Set_Is_Visible_Lib_Unit);

63
gcc/ada/exp_ch11.adb
View File

@ -24,7 +24,6 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Casing; use Casing;
with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
@ -1685,59 +1684,17 @@ package body Exp_Ch11 is
Str := String_From_Name_Buffer;
-- For VMS exceptions, convert the raise into a call to
-- lib$stop so it will be handled by __gnat_error_handler.
-- Convert raise to call to the Raise_Exception routine
if Is_VMS_Exception (Id) then
declare
Excep_Image : String_Id;
Cond : Node_Id;
begin
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;
if Exception_Code (Id) /= No_Uint then
Cond :=
Make_Integer_Literal (Loc, Exception_Code (Id));
else
Cond :=
Unchecked_Convert_To (Standard_Integer,
Make_Function_Call (Loc,
Name => New_Occurrence_Of
(RTE (RE_Import_Value), Loc),
Parameter_Associations => New_List
(Make_String_Literal (Loc,
Strval => Excep_Image))));
end if;
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Lib_Stop), Loc),
Parameter_Associations => New_List (Cond)));
Analyze_And_Resolve (Cond, Standard_Integer);
end;
-- Not VMS exception case, convert raise to call to the
-- Raise_Exception routine.
else
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Name (N),
Attribute_Name => Name_Identity),
Make_String_Literal (Loc,
Strval => Str))));
end if;
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Name (N),
Attribute_Name => Name_Identity),
Make_String_Literal (Loc, Strval => Str))));
end;
-- Case of no name present (reraise). We rewrite the raise to:

86
gcc/ada/exp_ch4.adb
View File

@ -42,7 +42,6 @@ with Exp_Intr; use Exp_Intr;
with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Exp_VFpt; use Exp_VFpt;
with Freeze; use Freeze;
with Inline; use Inline;
with Lib; use Lib;
@ -6446,12 +6445,6 @@ package body Exp_Ch4 is
Attribute_Name => Name_First)),
Reason => CE_Overflow_Check_Failed));
end if;
-- Vax floating-point types case
if Vax_Float (Etype (N)) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Abs;
---------------------
@ -6493,11 +6486,6 @@ package body Exp_Ch4 is
if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
Apply_Arithmetic_Overflow_Check (N);
return;
-- Vax floating-point types case
elsif Vax_Float (Typ) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Add;
@ -6706,12 +6694,6 @@ package body Exp_Ch4 is
elsif Is_Integer_Type (Typ) then
Apply_Divide_Checks (N);
-- Deal with Vax_Float
elsif Vax_Float (Typ) then
Expand_Vax_Arith (N);
return;
end if;
end Expand_N_Op_Divide;
@ -7432,13 +7414,6 @@ package body Exp_Ch4 is
Rewrite_Comparison (N);
-- If we still have comparison for Vax_Float, process it
if Vax_Float (Typl) and then Nkind (N) in N_Op_Compare then
Expand_Vax_Comparison (N);
return;
end if;
Optimize_Length_Comparison (N);
end Expand_N_Op_Eq;
@ -7843,13 +7818,6 @@ package body Exp_Ch4 is
Rewrite_Comparison (N);
-- If we still have comparison, and Vax_Float type, process it
if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
Expand_Vax_Comparison (N);
return;
end if;
Optimize_Length_Comparison (N);
end Expand_N_Op_Ge;
@ -7893,13 +7861,6 @@ package body Exp_Ch4 is
Rewrite_Comparison (N);
-- If we still have comparison, and Vax_Float type, process it
if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
Expand_Vax_Comparison (N);
return;
end if;
Optimize_Length_Comparison (N);
end Expand_N_Op_Gt;
@ -7943,13 +7904,6 @@ package body Exp_Ch4 is
Rewrite_Comparison (N);
-- If we still have comparison, and Vax_Float type, process it
if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
Expand_Vax_Comparison (N);
return;
end if;
Optimize_Length_Comparison (N);
end Expand_N_Op_Le;
@ -7993,13 +7947,6 @@ package body Exp_Ch4 is
Rewrite_Comparison (N);
-- If we still have comparison, and Vax_Float type, process it
if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
Expand_Vax_Comparison (N);
return;
end if;
Optimize_Length_Comparison (N);
end Expand_N_Op_Lt;
@ -8033,11 +7980,6 @@ package body Exp_Ch4 is
Right_Opnd => Right_Opnd (N)));
Analyze_And_Resolve (N, Typ);
-- Vax floating-point types case
elsif Vax_Float (Etype (N)) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Minus;
@ -8510,12 +8452,6 @@ package body Exp_Ch4 is
elsif Is_Signed_Integer_Type (Etype (N)) then
Apply_Arithmetic_Overflow_Check (N);
-- Deal with VAX float case
elsif Vax_Float (Typ) then
Expand_Vax_Arith (N);
return;
end if;
end Expand_N_Op_Multiply;
@ -8554,13 +8490,6 @@ package body Exp_Ch4 is
Rewrite_Comparison (N);
-- If we still have comparison for Vax_Float, process it
if Vax_Float (Typ) and then Nkind (N) in N_Op_Compare then
Expand_Vax_Comparison (N);
return;
end if;
-- For all cases other than elementary types, we rewrite node as the
-- negation of an equality operation, and reanalyze. The equality to be
-- used is defined in the same scope and has the same signature. This
@ -9290,11 +9219,6 @@ package body Exp_Ch4 is
if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
Apply_Arithmetic_Overflow_Check (N);
-- VAX floating-point types case
elsif Vax_Float (Typ) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Subtract;
@ -11009,16 +10933,6 @@ package body Exp_Ch4 is
end;
end if;
-- Final step, if the result is a type conversion involving Vax_Float
-- types, then it is subject for further special processing.
if Nkind (N) = N_Type_Conversion
and then (Vax_Float (Operand_Type) or else Vax_Float (Target_Type))
then
Expand_Vax_Conversion (N);
goto Done;
end if;
-- Here at end of processing
<<Done>>

32
gcc/ada/exp_ch6.adb
View File

@ -43,7 +43,6 @@ with Exp_Pakd; use Exp_Pakd;
with Exp_Prag; use Exp_Prag;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Exp_VFpt; use Exp_VFpt;
with Fname; use Fname;
with Freeze; use Freeze;
with Inline; use Inline;
@ -3926,19 +3925,19 @@ package body Exp_Ch6 is
-- Back end inlining: let the back end handle it
elsif No (Unit_Declaration_Node (Subp))
or else
Nkind (Unit_Declaration_Node (Subp)) /= N_Subprogram_Declaration
or else
No (Body_To_Inline (Unit_Declaration_Node (Subp)))
or else Nkind (Unit_Declaration_Node (Subp)) /=
N_Subprogram_Declaration
or else No (Body_To_Inline (Unit_Declaration_Node (Subp)))
then
Add_Inlined_Body (Subp);
Register_Backend_Call (Call_Node);
-- Frontend expansion of supported functions returning unconstrained
-- types
-- Frontend expands supported functions returning unconstrained types
else
pragma Assert (Ekind (Subp) = E_Function
and then Returns_Unconstrained_Type (Subp));
else pragma Assert (Ekind (Subp) = E_Function
and then Returns_Unconstrained_Type (Subp));
declare
Spec : constant Node_Id := Unit_Declaration_Node (Subp);
@ -5201,21 +5200,6 @@ package body Exp_Ch6 is
procedure Expand_N_Function_Call (N : Node_Id) is
begin
Expand_Call (N);
-- If the return value of a foreign compiled function is VAX Float, then
-- expand the return (adjusts the location of the return value on
-- Alpha/VMS, no-op everywhere else).
-- Comes_From_Source intercepts recursive expansion.
if Nkind (N) = N_Function_Call
and then Vax_Float (Etype (N))
and then Present (Name (N))
and then Present (Entity (Name (N)))
and then Has_Foreign_Convention (Entity (Name (N)))
and then Comes_From_Source (Parent (N))
then
Expand_Vax_Foreign_Return (N);
end if;
end Expand_N_Function_Call;
---------------------------------------

5
gcc/ada/fe.h
View File

@ -154,11 +154,6 @@ extern void Get_External_Name (Entity_Id, Boolean, String_Pointer);
extern Boolean Is_Fully_Repped_Tagged_Type (Entity_Id);
/* exp_vfpt: */
#define Get_Vax_Real_Literal_As_Signed exp_vfpt__get_vax_real_literal_as_signed
extern Ureal Get_Vax_Real_Literal_As_Signed (Node_Id);
/* lib: */
#define Cunit lib__cunit

25
gcc/ada/gnatchop.adb
View File

@ -255,23 +255,22 @@ procedure Gnatchop is
procedure Parse_Offset_Info
(Chop_File : File_Num;
Source : not null access String);
-- Parses the output of the compiler indicating the offsets
-- and names of the compilation units in Chop_File.
-- Parses the output of the compiler indicating the offsets and names of
-- the compilation units in Chop_File.
procedure Parse_Token
(Source : not null access String;
Ptr : in out Positive;
Token_Ptr : out Positive);
-- Skips any separators and stores the start of the token in Token_Ptr.
-- Then stores the position of the next separator in Ptr.
-- On return Source (Token_Ptr .. Ptr - 1) is the token.
-- Then stores the position of the next separator in Ptr. On return
-- Source (Token_Ptr .. Ptr - 1) is the token.
procedure Read_File
(FD : File_Descriptor;
Contents : out String_Access;
Success : out Boolean);
-- Reads file associated with FS into the newly allocated
-- string Contents.
-- Reads file associated with FS into the newly allocated string Contents.
-- Success is true iff the number of bytes read is equal to the file size.
function Report_Duplicate_Units return Boolean;
@ -293,17 +292,17 @@ procedure Gnatchop is
-- Write all units that result from chopping the Input file
procedure Write_Config_File (Input : File_Num; U : Unit_Num);
-- Call to write configuration pragmas (append them to gnat.adc)
-- Input is the file number for the chop file and U identifies the
-- unit entry for the configuration pragmas.
-- Call to write configuration pragmas (append them to gnat.adc). Input is
-- the file number for the chop file and U identifies the unit entry for
-- the configuration pragmas.
function Get_Config_Pragmas
(Input : File_Num;
U : Unit_Num) return String_Access;
-- Call to read configuration pragmas from given unit entry, and
-- return a buffer containing the pragmas to be appended to
-- following units. Input is the file number for the chop file and
-- U identifies the unit entry for the configuration pragmas.
-- Call to read configuration pragmas from given unit entry, and return a
-- buffer containing the pragmas to be appended to following units. Input
-- is the file number for the chop file and U identifies the unit entry for
-- the configuration pragmas.
procedure Write_Source_Reference_Pragma
(Info : Unit_Info;

3
gcc/ada/gnatcmd.adb
View File

@ -191,7 +191,7 @@ procedure GNATCmd is
-- The index of the command in the arguments of the GNAT driver
My_Exit_Status : Exit_Status := Success;
-- The exit status of the spawned tool.
-- The exit status of the spawned tool
Current_Work_Dir : constant String := Get_Current_Dir;
-- The path of the working directory
@ -1429,6 +1429,7 @@ begin
declare
Command : constant String := Command_Name;
begin
for Index in reverse Command'Range loop
if Command (Index) = Directory_Separator then

16
gcc/ada/gnatls.adb
View File

@ -150,9 +150,9 @@ procedure Gnatls is
Stamp : Time_Stamp_Type;
Checksum : Word;
Status : out File_Status);
-- Determine the file status (Status) of the file represented by FS
-- with the expected Stamp and checksum given as argument. FS will be
-- updated to the full file name if available.
-- Determine the file status (Status) of the file represented by FS with
-- the expected Stamp and checksum given as argument. FS will be updated
-- to the full file name if available.
function Corresponding_Sdep_Entry (A : ALI_Id; U : Unit_Id) return Sdep_Id;
-- Give the Sdep entry corresponding to the unit U in ali record A
@ -175,7 +175,7 @@ procedure Gnatls is
-- Reset Print flags properly when selective output is chosen
procedure Scan_Ls_Arg (Argv : String);
-- Scan and process lser specific arguments. Argv is a single argument
-- Scan and process user specific arguments (Argv is a single argument)
procedure Search_RTS (Name : String);
-- Find include and objects path for the RTS name.
@ -184,16 +184,14 @@ procedure Gnatls is
-- Print usage message
procedure Output_License_Information;
-- Output license statement, and if not found, output reference to
-- COPYING.
-- Output license statement, and if not found, output reference to COPYING
function Image (Restriction : Restriction_Id) return String;
-- Returns the capitalized image of Restriction
function Normalize (Path : String) return String;
-- Returns a normalized path name.
-- On Windows, the directory separators are set to '\' in
-- Normalize_Pathname.
-- Returns a normalized path name. On Windows, the directory separators are
-- set to '\' in Normalize_Pathname.
------------------------------------------
-- GNATDIST specific output subprograms --

7
gcc/ada/gnatname.adb
View File

@ -551,6 +551,7 @@ begin
declare
Command : constant String := Command_Name;
begin
for Index in reverse Command'Range loop
if Command (Index) = Directory_Separator then
@ -579,12 +580,12 @@ begin
declare
New_Arguments : Argument_Data;
pragma Warnings (Off, New_Arguments);
-- Declaring this defaulted initialized object ensures
-- that the new allocated component of table Arguments
-- is correctly initialized.
-- Declaring this defaulted initialized object ensures that the new
-- allocated component of table Arguments is correctly initialized.
begin
Arguments.Append (New_Arguments);
end;
Patterns.Init (Arguments.Table (1).Directories);
Patterns.Set_Last (Arguments.Table (1).Directories, 0);
Patterns.Init (Arguments.Table (1).Name_Patterns);

24
gcc/ada/inline.adb
View File

@ -165,10 +165,10 @@ package body Inline is
function Has_Single_Return (N : Node_Id) return Boolean;
-- In general we cannot inline functions that return unconstrained type.
-- However, we can handle such functions if all return statements return
-- a local variable that is the only declaration in the body of the
-- function. In that case the call can be replaced by that local
-- variable as is done for other inlined calls.
-- However, we can handle such functions if all return statements return a
-- local variable that is the only declaration in the body of the function.
-- In that case the call can be replaced by that local variable as is done
-- for other inlined calls.
function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean;
-- Return True if E is in the main unit or its spec or in a subunit
@ -429,7 +429,7 @@ package body Inline is
procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id);
-- Append Subp to the list of subprograms that cannot be inlined by
-- the backend
-- the backend.
----------------------------
-- Back_End_Cannot_Inline --
@ -3332,7 +3332,7 @@ package body Inline is
-- expanded into a procedure call which must be added after the
-- object declaration.
if Is_Unc_Decl and then Back_End_Inlining then
if Is_Unc_Decl and Back_End_Inlining then
Insert_Action_After (Parent (N), Blk);
else
Set_Expression (Parent (N), Empty);
@ -4329,9 +4329,9 @@ package body Inline is
return False;
end Has_Initialized_Type;
------------------------
-- Has_Single_Return --
------------------------
-----------------------
-- Has_Single_Return --
-----------------------
function Has_Single_Return (N : Node_Id) return Boolean is
Return_Statement : Node_Id := Empty;
@ -4376,8 +4376,8 @@ package body Inline is
return Abandon;
end if;
-- We can only inline a build-in-place function if
-- it has a single extended return.
-- We can only inline a build-in-place function if it has a single
-- extended return.
elsif Nkind (N) = N_Extended_Return_Statement then
if No (Return_Statement) then
@ -4572,6 +4572,8 @@ package body Inline is
-- Number_Of_Statements --
--------------------------
-- Why not List_Length???
function Number_Of_Statements (Stats : List_Id) return Natural is
Stat_Count : Integer := 0;
Stmt : Node_Id;

10
gcc/ada/inline.ads
View File

@ -131,6 +131,9 @@ package Inline is
Table_Increment => Alloc.Pending_Instantiations_Increment,
Table_Name => "Pending_Descriptor");
-- The following should be initialized in an init call in Frontend, we
-- have thoughts of making the frontend reusable in future ???
Inlined_Calls : Elist_Id := No_Elist;
-- List of frontend inlined calls
@ -242,13 +245,14 @@ package Inline is
function Has_Excluded_Declaration
(Subp : Entity_Id;
Decls : List_Id) return Boolean;
-- Check for declarations that make inlining not worthwhile inlining Subp
-- Check a list of declarations, Decls, that make the inlining of Subp not
-- worthwhile
function Has_Excluded_Statement
(Subp : Entity_Id;
Stats : List_Id) return Boolean;
-- Check for statements that make inlining not worthwhile: any tasking
-- statement, nested at any level.
-- Check a list of statements, Stats, that make inlining of Subp not
-- worthwhile, including any tasking statement, nested at any level.
procedure Register_Backend_Call (N : Node_Id);
-- Append N to the list Backend_Calls

1
gcc/ada/krunch.adb
View File

@ -257,5 +257,4 @@ begin
end loop;
return;
end Krunch;

5
gcc/ada/make.adb
View File

@ -2257,6 +2257,7 @@ package body Make is
Args : Argument_List)
is
pragma Unreferenced (Is_Main_Source);
begin
Arguments_Project := No_Project;
Last_Argument := 0;
@ -6413,8 +6414,8 @@ package body Make is
if Prefix'Length > 0 then
declare
PATH : constant String :=
Prefix & Directory_Separator & "bin" & Path_Separator &
Getenv ("PATH").all;
Prefix & Directory_Separator & "bin" & Path_Separator
& Getenv ("PATH").all;
begin
Setenv ("PATH", PATH);
end;

1
gcc/ada/mlib-prj.adb
View File

@ -498,6 +498,7 @@ package body MLib.Prj is
begin
if Libgnarl_Needed /= Yes then
-- Scan the ALI file
Name_Len := ALI_File'Length;

3
gcc/ada/mlib.ads
View File

@ -89,8 +89,7 @@ package MLib is
-- for each directory in the rpath.
private
Preserve : Attribute := Time_Stamps;
-- Used by Copy_ALI_Files.
-- Used by Copy_ALI_Files
end MLib;

2
gcc/ada/osint.adb
View File

@ -1078,10 +1078,12 @@ package body Osint is
N : C_File_Name;
A : System.Address) return size_t;
pragma Import (C, Internal, "__gnat_file_length_attr");
begin
-- The conversion from size_t to Long_Integer is ok here as this
-- routine is only to be used by the compiler and we do not expect
-- a unit to be larger than a 32bit integer.
return Long_Integer (Internal (-1, Name, Attr.all'Address));
end File_Length;

2
gcc/ada/sem_ch11.adb
View File

@ -46,7 +46,6 @@ with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Uintp; use Uintp;
package body Sem_Ch11 is
@ -61,7 +60,6 @@ package body Sem_Ch11 is
Generate_Definition (Id);
Enter_Name (Id);
Set_Ekind (Id, E_Exception);
Set_Exception_Code (Id, Uint_0);
Set_Etype (Id, Standard_Exception_Type);
Set_Is_Statically_Allocated (Id);
Set_Is_Pure (Id, PF);

2
gcc/ada/sem_ch6.adb
View File

@ -3571,7 +3571,7 @@ package body Sem_Ch6 is
if not Back_End_Inlining then
if Has_Pragma_Inline_Always (Spec_Id)
or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining)
or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining)
then
Build_Body_To_Inline (N, Spec_Id);
end if;

1
gcc/ada/sem_ch8.adb
View File

@ -558,7 +558,6 @@ package body Sem_Ch8 is
Analyze (Nam);
Set_Ekind (Id, E_Exception);
Set_Exception_Code (Id, Uint_0);
Set_Etype (Id, Standard_Exception_Type);
Set_Is_Pure (Id, Is_Pure (Current_Scope));

158
gcc/ada/sem_mech.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1996-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- --
@ -27,10 +27,8 @@ with Atree; use Atree;
with Einfo; use Einfo;
with Errout; use Errout;
with Namet; use Namet;
with Nlists; use Nlists;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
@ -43,19 +41,13 @@ package body Sem_Mech is
-------------------------
procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
Class : Node_Id;
Param : Node_Id;
procedure Bad_Class;
-- Signal bad descriptor class name
procedure Bad_Mechanism;
-- Signal bad mechanism name
procedure Bad_Class is
begin
Error_Msg_N ("unrecognized descriptor class name", Class);
end Bad_Class;
-------------------
-- Bad_Mechanism --
-------------------
procedure Bad_Mechanism is
begin
@ -70,26 +62,14 @@ package body Sem_Mech 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
Set_Mechanism_With_Checks (Ent, By_Copy, Mech_Name);
return;
elsif Chars (Mech_Name) = Name_Reference then
Set_Mechanism_With_Checks (Ent, By_Reference, Mech_Name);
return;
elsif Chars (Mech_Name) = Name_Descriptor then
Check_VMS (Mech_Name);
Set_Mechanism_With_Checks (Ent, By_Descriptor, Mech_Name);
return;
elsif Chars (Mech_Name) = Name_Short_Descriptor then
Check_VMS (Mech_Name);
Set_Mechanism_With_Checks (Ent, By_Short_Descriptor, Mech_Name);
return;
elsif Chars (Mech_Name) = Name_Copy then
Error_Msg_N ("bad mechanism name, Value assumed", Mech_Name);
@ -97,138 +77,10 @@ package body Sem_Mech is
else
Bad_Mechanism;
return;
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;
return;
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;
return;
else
Class := Explicit_Actual_Parameter (Param);
end if;
else
Bad_Mechanism;
return;
end if;
-- Fall through here with Class set to descriptor class name
Check_VMS (Mech_Name);
if Nkind (Class) /= N_Identifier then
Bad_Class;
return;
elsif Chars (Name (Mech_Name)) = Name_Descriptor
and then Chars (Class) = Name_UBS
then
Set_Mechanism_With_Checks (Ent, By_Descriptor_UBS, Mech_Name);
elsif Chars (Name (Mech_Name)) = Name_Descriptor
and then Chars (Class) = Name_UBSB
then
Set_Mechanism_With_Checks (Ent, By_Descriptor_UBSB, Mech_Name);
elsif Chars (Name (Mech_Name)) = Name_Descriptor
and then Chars (Class) = Name_UBA
then
Set_Mechanism_With_Checks (Ent, By_Descriptor_UBA, Mech_Name);
elsif Chars (Name (Mech_Name)) = Name_Descriptor
and then Chars (Class) = Name_S
then
Set_Mechanism_With_Checks (Ent, By_Descriptor_S, Mech_Name);
elsif Chars (Name (Mech_Name)) = Name_Descriptor
and then Chars (Class) = Name_SB
then
Set_Mechanism_With_Checks (Ent, By_Descriptor_SB, Mech_Name);
elsif Chars (Name (Mech_Name)) = Name_Descriptor
and then Chars (Class) = Name_A
then
Set_Mechanism_With_Checks (Ent, By_Descriptor_A, Mech_Name);
elsif Chars (Name (Mech_Name)) = Name_Descriptor
and then Chars (Class) = Name_NCA
then
Set_Mechanism_With_Checks (Ent, By_Descriptor_NCA, Mech_Name);
elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
and then Chars (Class) = Name_UBS
then
Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBS, Mech_Name);
elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
and then Chars (Class) = Name_UBSB
then
Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBSB, Mech_Name);
elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
and then Chars (Class) = Name_UBA
then
Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBA, Mech_Name);
elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
and then Chars (Class) = Name_S
then
Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_S, Mech_Name);
elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
and then Chars (Class) = Name_SB
then
Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_SB, Mech_Name);
elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
and then Chars (Class) = Name_A
then
Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_A, Mech_Name);
elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
and then Chars (Class) = Name_NCA
then
Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_NCA, Mech_Name);
else
Bad_Class;
return;
end if;
end Set_Mechanism_Value;

12
gcc/ada/sem_util.adb
View File

@ -2986,18 +2986,6 @@ package body Sem_Util is
end if;
end Check_Unprotected_Access;
---------------
-- Check_VMS --
---------------
procedure Check_VMS (Construct : Node_Id) is
begin
if not OpenVMS_On_Target then
Error_Msg_N
("this construct is allowed only in Open'V'M'S", Construct);
end if;
end Check_VMS;
------------------------
-- Collect_Interfaces --
------------------------

6
gcc/ada/sem_util.ads
View File

@ -319,12 +319,6 @@ package Sem_Util is
-- and the context is external to the protected operation, to warn against
-- a possible unlocked access to data.
procedure Check_VMS (Construct : Node_Id);
-- Check that this the target is OpenVMS, and if so, return with no effect,
-- otherwise post an error noting this can only be used with OpenVMS ports.
-- The argument is the construct in question and is used to post the error
-- message.
procedure Collect_Interfaces
(T : Entity_Id;
Ifaces_List : out Elist_Id;

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

@ -697,7 +697,6 @@ package Snames is
Name_Copy : constant Name_Id := N + $;
Name_D_Float : constant Name_Id := N + $;
Name_Decreases : constant Name_Id := N + $;
Name_Descriptor : constant Name_Id := N + $;
Name_Disable : constant Name_Id := N + $;
Name_Dot_Replacement : constant Name_Id := N + $;
Name_Dynamic : constant Name_Id := N + $;
@ -775,7 +774,6 @@ package Snames is
Name_Secondary_Stack_Size : constant Name_Id := N + $;
Name_Section : constant Name_Id := N + $;
Name_Semaphore : constant Name_Id := N + $;
Name_Short_Descriptor : constant Name_Id := N + $;
Name_Simple_Barriers : constant Name_Id := N + $;
Name_SPARK : constant Name_Id := N + $;
Name_SPARK_05 : constant Name_Id := N + $;