+2014-08-01 Robert Dewar <dewar@adacore.com>
+
+ * a-numaux-vxworks.ads, a-numaux-x86.adb, a-numaux-x86.ads,
+ a-numaux-darwin.adb, a-numaux-darwin.ads, a-numaux.ads,
+ a-numaux-libc-x86.ads: Fix bad package header comments.
+ * elists.ads, elists.adb (Append_New_Elmt): New procedure.
+ * gnat_rm.texi, a-calend.adb, gnatcmd.adb, einfo.adb, einfo.ads,
+ checks.adb, sem_prag.adb, sem_prag.ads, rtsfind.ads, freeze.adb,
+ sem_util.adb, sem_attr.adb, exp_dbug.adb, exp_dbug.ads, gnat1drv.adb,
+ targparm.adb, targparm.ads, exp_ch6.adb, switch-b.adb, s-shasto.ads,
+ stand.ads, s-auxdec.ads, opt.adb, opt.ads, mlib-tgt.ads, s-fatgen.adb,
+ s-fatgen.ads, system.ads, snames.ads-tmpl, s-stalib.ads,
+ s-os_lib.adb: Remove VMS-specific code.
+
2014-08-01 Arnaud Charlet <charlet@adacore.com>
* exp_attr.adb (Is_Inline_Floating_Point_Attribute): Revert to
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, 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- --
-- by Integer in various routines. One ramification of this model is that
-- the caller site must perform validity checks on returned results.
-- The end result of this model is the lack of target specific files per
- -- child of Ada.Calendar (a-calfor, a-calfor-vms, a-calfor-vxwors, etc).
+ -- child of Ada.Calendar (e.g. a-calfor).
-----------------------
-- Local Subprograms --
-- B o d y --
-- (Apple OS X Version) --
-- --
--- Copyright (C) 1998-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-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- --
-- --
------------------------------------------------------------------------------
--- File a-numaux.adb <- a-numaux-darwin.adb
-
package body Ada.Numerics.Aux is
-----------------------
-- --
------------------------------------------------------------------------------
--- This version is for use with normal Unix math functions, except for
--- sine/cosine which have been implemented directly in Ada to get the required
--- accuracy in OS X. Alternative packages are used on VxWorks (no need for the
--- -lm Linker_Options), and on the x86 (where we have two versions one using
--- inline ASM, and one importing from the C long routines that take 80-bit
--- arguments).
+-- This version is for use on OS X. It uses the normal Unix math functions,
+-- except for sine/cosine which have been implemented directly in Ada to get
+-- the required accuracy.
package Ada.Numerics.Aux is
pragma Pure;
-- S p e c --
-- (C Library Version for x86) --
-- --
--- Copyright (C) 1992-2013, 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 provides the basic computational interface for the generic
--- elementary functions. The C library version interfaces with the routines
--- in the C mathematical library, and is thus quite portable, although it may
--- not necessarily meet the requirements for accuracy in the numerics annex.
--- One advantage of using this package is that it will interface directly to
--- hardware instructions, such as the those provided on the Intel x86.
-
--- Note: there are two versions of this package. One using the 80-bit x86
--- long double format (which is this version), and one using 64-bit IEEE
--- double (see file a-numaux.ads).
+-- This version is for the x86 using the 80-bit x86 long double format
package Ada.Numerics.Aux is
pragma Pure;
-- S p e c --
-- (C Library Version, VxWorks) --
-- --
--- Copyright (C) 1992-2013, 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 provides the basic computational interface for the generic
--- elementary functions. The C library version interfaces with the routines
--- in the C mathematical library, and is thus quite portable, although it may
--- not necessarily meet the requirements for accuracy in the numerics annex.
--- One advantage of using this package is that it will interface directly to
--- hardware instructions, such as the those provided on the Intel x86.
-
--- Note: there are two versions of this package. One using the normal IEEE
--- 64-bit double format (which is this version), and one using 80-bit x86
--- long double (see file 4onumaux.ads).
+-- Version for use on VxWorks (where we have no libm.a library), so the pragma
+-- Linker_Options ("-lm") is omitted in this version.
package Ada.Numerics.Aux is
pragma Pure;
- -- This version omits the pragma linker_options ("-lm") since there is
- -- no libm.a library for VxWorks.
-
type Double is digits 15;
-- Type Double is the type used to call the C routines
-- B o d y --
-- (Machine Version for x86) --
-- --
--- Copyright (C) 1998-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-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- --
-- --
------------------------------------------------------------------------------
--- File a-numaux.adb <- 86numaux.adb
-
--- This version of Numerics.Aux is for the IEEE Double Extended floating
--- point format on x86.
-
with System.Machine_Code; use System.Machine_Code;
package body Ada.Numerics.Aux is
-- S p e c --
-- (Machine Version for x86) --
-- --
--- Copyright (C) 1992-2013, 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 provides the basic computational interface for the generic
--- elementary functions. This implementation is based on the glibc assembly
--- sources for the x86 glibc math library.
-
--- Note: there are two versions of this package. One using the 80-bit x86
--- long double format (which is this version), and one using 64-bit IEEE
--- double (see file a-numaux.ads). The latter version imports the C
--- routines directly.
+-- Version for the x86, using 64-bit IEEE format with inline asm statements
package Ada.Numerics.Aux is
pragma Pure;
-- hardware instructions, such as the those provided on the Intel x86.
-- This version here is for use with normal Unix math functions. Alternative
--- packages are used VxWorks (no need for the -lm Linker_Options), and on the
--- x86 (where we have two versions one using inline ASM, and one importing
--- from the C long routines that take 80-bit arguments).
+-- versions are provided for special situations:
+
+-- a-numaux-darwin For OS/X (special handling of sin/cos for accuracy)
+-- a-numaux-libc-x86 For the x86, using 80-bit long double format
+-- a-numaux-x86 For the x86, using 64-bit IEEE (inline asm statements)
+-- a-numaux-vxworks For use on VxWorks (where we have no libm.a library)
package Ada.Numerics.Aux is
pragma Pure;
function Range_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
if Present (E) then
-
- -- Note: for now we always suppress range checks on Vax float types,
- -- since Gigi does not know how to generate these checks.
-
- if Vax_Float (E) then
- return True;
-
- elsif Kill_Range_Checks (E) then
+ if Kill_Range_Checks (E) then
return True;
elsif Checks_May_Be_Suppressed (E) then
declare
Typ : constant Entity_Id := Etype (Expr);
begin
- if Vax_Float (Typ) then
- return True;
- elsif Checks_May_Be_Suppressed (Typ)
+ if Checks_May_Be_Suppressed (Typ)
and then (Is_Check_Suppressed (Typ, Range_Check)
or else
Is_Check_Suppressed (Typ, Validity_Check))
-- RM_Size Uint13
-- Alignment Uint14
- -- First_Optional_Parameter Node14
-- Normalized_Position Uint14
-- Shadow_Entities List14
return Node17 (Id);
end First_Literal;
- function First_Optional_Parameter (Id : E) return E is
- begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
- return Node14 (Id);
- end First_Optional_Parameter;
-
function First_Private_Entity (Id : E) return E is
begin
pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)
Set_Node17 (Id, V);
end Set_First_Literal;
- procedure Set_First_Optional_Parameter (Id : E; V : E) is
- begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
- Set_Node14 (Id, V);
- end Set_First_Optional_Parameter;
-
procedure Set_First_Private_Entity (Id : E; V : E) is
begin
pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)
end if;
end Underlying_Type;
- ---------------
- -- Vax_Float --
- ---------------
-
- -- To be removed ???
-
- function Vax_Float (Id : E) return B is
- pragma Unreferenced (Id);
- begin
- return False;
- end Vax_Float;
-
------------------------
-- Write_Entity_Flags --
------------------------
E_Loop_Parameter =>
Write_Str ("Alignment");
- when E_Function |
- E_Procedure =>
- Write_Str ("First_Optional_Parameter");
-
when E_Component |
E_Discriminant =>
Write_Str ("Normalized_Position");
-- Note that this field is set in enumeration subtypes, but it still
-- points to the first literal of the base type in this case.
--- First_Optional_Parameter (Node14)
--- Defined in (non-generic) function and procedure entities. Set to a
--- non-null value only if a pragma Import_Function, Import_Procedure
--- or Import_Valued_Procedure specifies a First_Optional_Parameter
--- argument, in which case this field points to the parameter entity
--- corresponding to the specified parameter.
-
-- First_Private_Entity (Node16)
-- Defined in all entities containing private parts (packages, protected
-- types and subtypes, task types and subtypes). The entities on the
-- Safe_Last_Value (synth)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
- -- Vax_Float (synth)
-- (plus type attributes)
-- E_Function
-- Protected_Body_Subprogram (Node11)
-- Next_Inlined_Subprogram (Node12)
-- Elaboration_Entity (Node13) (not implicit /=)
- -- First_Optional_Parameter (Node14) (non-generic case only)
-- DT_Position (Uint15)
-- DTC_Entity (Node16)
-- First_Entity (Node17)
-- Protected_Body_Subprogram (Node11)
-- Next_Inlined_Subprogram (Node12)
-- Elaboration_Entity (Node13)
- -- First_Optional_Parameter (Node14) (non-generic case only)
-- DT_Position (Uint15)
-- DTC_Entity (Node16)
-- First_Entity (Node17)
function First_Exit_Statement (Id : E) return N;
function First_Index (Id : E) return N;
function First_Literal (Id : E) return E;
- function First_Optional_Parameter (Id : E) return E;
function First_Private_Entity (Id : E) return E;
function First_Rep_Item (Id : E) return N;
function Float_Rep (Id : E) return F;
function Used_As_Generic_Actual (Id : E) return B;
function Uses_Lock_Free (Id : E) return B;
function Uses_Sec_Stack (Id : E) return B;
- function Vax_Float (Id : E) return B;
function Warnings_Off (Id : E) return B;
function Warnings_Off_Used (Id : E) return B;
function Warnings_Off_Used_Unmodified (Id : E) return B;
procedure Set_First_Exit_Statement (Id : E; V : N);
procedure Set_First_Index (Id : E; V : N);
procedure Set_First_Literal (Id : E; V : E);
- procedure Set_First_Optional_Parameter (Id : E; V : E);
procedure Set_First_Private_Entity (Id : E; V : E);
procedure Set_First_Rep_Item (Id : E; V : N);
procedure Set_Float_Rep (Id : E; V : F);
pragma Inline (First_Exit_Statement);
pragma Inline (First_Index);
pragma Inline (First_Literal);
- pragma Inline (First_Optional_Parameter);
pragma Inline (First_Private_Entity);
pragma Inline (First_Rep_Item);
pragma Inline (Freeze_Node);
pragma Inline (Set_First_Exit_Statement);
pragma Inline (Set_First_Index);
pragma Inline (Set_First_Literal);
- pragma Inline (Set_First_Optional_Parameter);
pragma Inline (Set_First_Private_Entity);
pragma Inline (Set_First_Rep_Item);
pragma Inline (Set_Freeze_Node);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, 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- --
end if;
end Append_Elmt;
+ ---------------------
+ -- Append_New_Elmt --
+ ---------------------
+
+ procedure Append_New_Elmt (N : Node_Or_Entity_Id; To : in out Elist_Id) is
+ begin
+ if To = No_Elist then
+ To := New_Elmt_List;
+ end if;
+
+ Append_Elmt (N, To);
+ end Append_New_Elmt;
+
------------------------
-- Append_Unique_Elmt --
------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, 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- --
-- Appends N at the end of To, allocating a new element. N must be a
-- non-empty node or entity Id, and To must be an Elist (not No_Elist).
+ procedure Append_New_Elmt (N : Node_Or_Entity_Id; To : in out Elist_Id);
+ pragma Inline (Append_New_Elmt);
+ -- Like Append_Elmt if Elist_Id is not No_List, but if Elist_Id is No_List,
+ -- then first assigns it an empty element list and then does the append.
+
procedure Append_Unique_Elmt (N : Node_Or_Entity_Id; To : Elist_Id);
-- Like Append_Elmt, except that a check is made to see if To already
-- contains N and if so the call has no effect.
-- Rewrite call to predefined operator as operator
-- Replace actuals to in-out parameters that are numeric conversions,
-- with explicit assignment to temporaries before and after the call.
- -- Remove optional actuals if First_Optional_Parameter specified.
-- Note that the list of actuals has been filled with default expressions
-- during semantic analysis of the call. Only the extra actuals required
Establish_Transient_Scope (Call_Node, Sec_Stack => True);
end if;
end if;
-
- -- Test for First_Optional_Parameter, and if so, truncate parameter list
- -- if there are optional parameters at the trailing end.
- -- Note: we never delete procedures for call via a pointer.
-
- if (Ekind (Subp) = E_Procedure or else Ekind (Subp) = E_Function)
- and then Present (First_Optional_Parameter (Subp))
- then
- declare
- Last_Keep_Arg : Node_Id;
-
- begin
- -- Last_Keep_Arg will hold the last actual that should be kept.
- -- If it remains empty at the end, it means that all parameters
- -- are optional.
-
- Last_Keep_Arg := Empty;
-
- -- Find first optional parameter, must be present since we checked
- -- the validity of the parameter before setting it.
-
- Formal := First_Formal (Subp);
- Actual := First_Actual (Call_Node);
- while Formal /= First_Optional_Parameter (Subp) loop
- Last_Keep_Arg := Actual;
- Next_Formal (Formal);
- Next_Actual (Actual);
- end loop;
-
- -- We have Formal and Actual pointing to the first potentially
- -- droppable argument. We can drop all the trailing arguments
- -- whose actual matches the default. Note that we know that all
- -- remaining formals have defaults, because we checked that this
- -- requirement was met before setting First_Optional_Parameter.
-
- -- We use Fully_Conformant_Expressions to check for identity
- -- between formals and actuals, which may miss some cases, but
- -- on the other hand, this is only an optimization (if we fail
- -- to truncate a parameter it does not affect functionality).
- -- So if the default is 3 and the actual is 1+2, we consider
- -- them unequal, which hardly seems worrisome.
-
- while Present (Formal) loop
- if not Fully_Conformant_Expressions
- (Actual, Default_Value (Formal))
- then
- Last_Keep_Arg := Actual;
- end if;
-
- Next_Formal (Formal);
- Next_Actual (Actual);
- end loop;
-
- -- If no arguments, delete entire list, this is the easy case
-
- if No (Last_Keep_Arg) then
- Set_Parameter_Associations (Call_Node, No_List);
- Set_First_Named_Actual (Call_Node, Empty);
-
- -- Case where at the last retained argument is positional. This
- -- is also an easy case, since the retained arguments are already
- -- in the right form, and we don't need to worry about the order
- -- of arguments that get eliminated.
-
- elsif Is_List_Member (Last_Keep_Arg) then
- while Present (Next (Last_Keep_Arg)) loop
- Discard_Node (Remove_Next (Last_Keep_Arg));
- end loop;
-
- Set_First_Named_Actual (Call_Node, Empty);
-
- -- This is the annoying case where the last retained argument
- -- is a named parameter. Since the original arguments are not
- -- in declaration order, we may have to delete some fairly
- -- random collection of arguments.
-
- else
- declare
- Temp : Node_Id;
- Passoc : Node_Id;
-
- begin
- -- First step, remove all the named parameters from the
- -- list (they are still chained using First_Named_Actual
- -- and Next_Named_Actual, so we have not lost them).
-
- Temp := First (Parameter_Associations (Call_Node));
-
- -- Case of all parameters named, remove them all
-
- if Nkind (Temp) = N_Parameter_Association then
- -- Suppress warnings to avoid warning on possible
- -- infinite loop (because Call_Node is not modified).
-
- pragma Warnings (Off);
- while Is_Non_Empty_List
- (Parameter_Associations (Call_Node))
- loop
- Temp :=
- Remove_Head (Parameter_Associations (Call_Node));
- end loop;
- pragma Warnings (On);
-
- -- Case of mixed positional/named, remove named parameters
-
- else
- while Nkind (Next (Temp)) /= N_Parameter_Association loop
- Next (Temp);
- end loop;
-
- while Present (Next (Temp)) loop
- Remove (Next (Temp));
- end loop;
- end if;
-
- -- Now we loop through the named parameters, till we get
- -- to the last one to be retained, adding them to the list.
- -- Note that the Next_Named_Actual list does not need to be
- -- touched since we are only reordering them on the actual
- -- parameter association list.
-
- Passoc := Parent (First_Named_Actual (Call_Node));
- loop
- Temp := Relocate_Node (Passoc);
- Append_To
- (Parameter_Associations (Call_Node), Temp);
- exit when
- Last_Keep_Arg = Explicit_Actual_Parameter (Passoc);
- Passoc := Parent (Next_Named_Actual (Passoc));
- end loop;
-
- Set_Next_Named_Actual (Temp, Empty);
-
- loop
- Temp := Next_Named_Actual (Passoc);
- exit when No (Temp);
- Set_Next_Named_Actual
- (Passoc, Next_Named_Actual (Parent (Temp)));
- end loop;
- end;
-
- end if;
- end;
- end if;
end Expand_Call;
-------------------------------
Add_Real_To_Buffer (Small_Value (E));
end if;
- -- Vax floating-point case
-
- elsif Vax_Float (E) then
- if Digits_Value (Base_Type (E)) = 6 then
- Get_External_Name (E, True, "XFF");
-
- elsif Digits_Value (Base_Type (E)) = 9 then
- Get_External_Name (E, True, "XFF");
-
- else
- pragma Assert (Digits_Value (Base_Type (E)) = 15);
- Get_External_Name (E, True, "XFG");
- end if;
-
-- Discrete case where bounds do not match size
elsif Is_Discrete_Type (E)
-- delta. In this case, the first nn/dd rational value is for delta,
-- and the second value is for small.
- ------------------------------
- -- VAX Floating-Point Types --
- ------------------------------
-
- -- Vax floating-point types are represented at run time as integer
- -- types, which are treated specially by the code generator. Their
- -- type names are encoded with the following suffix:
-
- -- typ___XFF
- -- typ___XFD
- -- typ___XFG
-
- -- representing the Vax F Float, D Float, and G Float types. The
- -- debugger must treat these specially. In particular, printing these
- -- values can be achieved using the debug procedures that are provided
- -- in package System.Vax_Float_Operations:
-
- -- procedure Debug_Output_D (Arg : D);
- -- procedure Debug_Output_F (Arg : F);
- -- procedure Debug_Output_G (Arg : G);
-
- -- These three procedures take a Vax floating-point argument, and
- -- output a corresponding decimal representation to standard output
- -- with no terminating line return.
-
--------------------
-- Discrete Types --
--------------------
-- Mark object as locked in the current (transient) scope
- declare
- Locked_Shared_Objects : Elist_Id renames
- Scope_Stack.Table (Scope_Stack.Last).Locked_Shared_Objects;
-
- begin
- if Locked_Shared_Objects = No_Elist then
- Locked_Shared_Objects := New_Elmt_List;
- end if;
-
- Append_Elmt (Obj, To => Locked_Shared_Objects);
- end;
+ Append_New_Elmt
+ (Obj,
+ To => Scope_Stack.Table (Scope_Stack.Last).Locked_Shared_Objects);
-- First insert the Lock call before
or else Nkind_In (Dcopy, N_Expanded_Name,
N_Integer_Literal,
N_Character_Literal,
- N_String_Literal)
- or else (Nkind (Dcopy) = N_Real_Literal
- and then not Vax_Float (Etype (Dcopy)))
+ N_String_Literal,
+ N_Real_Literal)
or else (Nkind (Dcopy) = N_Attribute_Reference
and then Attribute_Name (Dcopy) = Name_Null_Parameter)
or else Known_Null (Dcopy)
Ttypes.Bytes_Big_Endian := not Ttypes.Bytes_Big_Endian;
end if;
- -- Temporarily set True_VMS_Target to OpenVMS_On_Target. This is just
- -- temporary, we no longer deal with the debug flag -gnatdm here.
-
- Opt.True_VMS_Target := Targparm.OpenVMS_On_Target;
-
-- Activate front end layout if debug flag -gnatdF is set
if Debug_Flag_FF then
MECHANISM_ASSOCIATION ::=
[formal_parameter_NAME =>] MECHANISM_NAME
-MECHANISM_NAME ::=
- Value
-| Reference
-| Descriptor [([Class =>] CLASS_NAME)]
-| Short_Descriptor [([Class =>] CLASS_NAME)]
-
-CLASS_NAME ::= ubs | ubsb | uba | s | sb | a
+MECHANISM_NAME ::= Value | Reference
@end smallexample
@noindent
The form with an @code{'Access} attribute can be used to match an
anonymous access parameter.
-@cindex OpenVMS
-@cindex Passing by descriptor
-Passing by descriptor is supported only on the OpenVMS ports of GNAT@.
-The default behavior for Export_Function is to accept either 64bit or
-32bit descriptors unless short_descriptor is specified, then only 32bit
-descriptors are accepted.
-
@cindex Suppressing external name
Special treatment is given if the EXTERNAL is an explicit null
string or a static string expressions that evaluates to the null
MECHANISM_ASSOCIATION ::=
[formal_parameter_NAME =>] MECHANISM_NAME
-MECHANISM_NAME ::=
- Value
-| Reference
-| Descriptor [([Class =>] CLASS_NAME)]
-| Short_Descriptor [([Class =>] CLASS_NAME)]
-
-CLASS_NAME ::= ubs | ubsb | uba | s | sb | a
+MECHANISM_NAME ::= Value | Reference
@end smallexample
@noindent
pragma in conjunction with a @code{Export} or @code{Convention}
pragma that specifies the desired foreign convention.
-@cindex OpenVMS
-@cindex Passing by descriptor
-Passing by descriptor is supported only on the OpenVMS ports of GNAT@.
-The default behavior for Export_Procedure is to accept either 64bit or
-32bit descriptors unless short_descriptor is specified, then only 32bit
-descriptors are accepted.
-
@cindex Suppressing external name
Special treatment is given if the EXTERNAL is an explicit null
string or a static string expressions that evaluates to the null
MECHANISM_ASSOCIATION ::=
[formal_parameter_NAME =>] MECHANISM_NAME
-MECHANISM_NAME ::=
- Value
-| Reference
-| Descriptor [([Class =>] CLASS_NAME)]
-| Short_Descriptor [([Class =>] CLASS_NAME)]
-
-CLASS_NAME ::= ubs | ubsb | uba | s | sb | a
+MECHANISM_NAME ::= Value | Reference
@end smallexample
@noindent
pragma in conjunction with a @code{Export} or @code{Convention}
pragma that specifies the desired foreign convention.
-@cindex OpenVMS
-@cindex Passing by descriptor
-Passing by descriptor is supported only on the OpenVMS ports of GNAT@.
-The default behavior for Export_Valued_Procedure is to accept either 64bit or
-32bit descriptors unless short_descriptor is specified, then only 32bit
-descriptors are accepted.
-
@cindex Suppressing external name
Special treatment is given if the EXTERNAL is an explicit null
string or a static string expressions that evaluates to the null
[, [Parameter_Types =>] PARAMETER_TYPES]
[, [Result_Type =>] SUBTYPE_MARK]
[, [Mechanism =>] MECHANISM]
- [, [Result_Mechanism =>] MECHANISM_NAME]
- [, [First_Optional_Parameter =>] IDENTIFIER]);
+ [, [Result_Mechanism =>] MECHANISM_NAME]);
EXTERNAL_SYMBOL ::=
IDENTIFIER
[Internal =>] LOCAL_NAME
[, [External =>] EXTERNAL_SYMBOL]
[, [Parameter_Types =>] PARAMETER_TYPES]
- [, [Mechanism =>] MECHANISM]
- [, [First_Optional_Parameter =>] IDENTIFIER]);
+ [, [Mechanism =>] MECHANISM]);
EXTERNAL_SYMBOL ::=
IDENTIFIER
[Internal =>] LOCAL_NAME
[, [External =>] EXTERNAL_SYMBOL]
[, [Parameter_Types =>] PARAMETER_TYPES]
- [, [Mechanism =>] MECHANISM]
- [, [First_Optional_Parameter =>] IDENTIFIER]);
+ [, [Mechanism =>] MECHANISM]);
EXTERNAL_SYMBOL ::=
IDENTIFIER
@end smallexample
@noindent
-In VMS versions of the compiler, this configuration pragma causes all
-occurrences of the mechanism types Descriptor[_xxx] to be treated as
-Short_Descriptor[_xxx]. This is helpful in porting legacy applications from a
-32-bit environment to a 64-bit environment. This pragma is ignored for non-VMS
-versions.
+This pragma is provided for compatibility with other Ada implementations. It
+is recognized but ignored by all current versions of GNAT.
@node Pragma Simple_Storage_Pool_Type
@unnumberedsec Pragma Simple_Storage_Pool_Type
for C in Command_List'Range loop
- -- No usage for VMS only command or for Sync
+ -- No usage for Sync
if C /= Sync then
if Targparm.AAMP_On_Target then
procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id) is
begin
- if Backend_Inlined_Subps = No_Elist then
- Backend_Inlined_Subps := New_Elmt_List;
- end if;
-
- Append_Elmt (Subp, To => Backend_Inlined_Subps);
+ Append_New_Elmt (Subp, To => Backend_Inlined_Subps);
end Register_Backend_Inlined_Subprogram;
---------------------------------------------
procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id) is
begin
- if Backend_Not_Inlined_Subps = No_Elist then
- Backend_Not_Inlined_Subps := New_Elmt_List;
- end if;
-
- Append_Elmt (Subp, To => Backend_Not_Inlined_Subps);
+ Append_New_Elmt (Subp, To => Backend_Not_Inlined_Subps);
end Register_Backend_Not_Inlined_Subprogram;
-- Start of processing for Add_Inlined_Subprogram
-- Register the call in the list of inlined calls
- if Inlined_Calls = No_Elist then
- Inlined_Calls := New_Elmt_List;
- end if;
-
- Append_Elmt (N, To => Inlined_Calls);
+ Append_New_Elmt (N, To => Inlined_Calls);
-- Use generic machinery to copy body of inlined subprogram, as if it
-- were an instantiation, resetting source locations appropriately, so
procedure Register_Backend_Call (N : Node_Id) is
begin
- if Backend_Calls = No_Elist then
- Backend_Calls := New_Elmt_List;
- end if;
-
- Append_Elmt (N, To => Backend_Calls);
+ Append_New_Elmt (N, To => Backend_Calls);
end Register_Backend_Call;
--------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2009, AdaCore --
+-- Copyright (C) 2001-2014, AdaCore --
-- --
-- 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- --
-- "libtoto.so" will be a symbolic link to "libtoto.so.2.1" which
-- will be the actual library file.
--
- -- Symbol_Data is used for some platforms, including VMS, to generate
- -- the symbols to be exported by the library.
+ -- Symbol_Data is used for some platforms, to generate the symbols to be
+ -- exported by the library (not certain if it is currently in use or not).
--
-- Note: Depending on the OS, some of the parameters may not be taken into
-- account. For example, on Linux, Interfaces, Symbol_Data and Auto_Init
Optimize_Alignment_Config := Optimize_Alignment;
Persistent_BSS_Mode_Config := Persistent_BSS_Mode;
Polling_Required_Config := Polling_Required;
- Short_Descriptors_Config := Short_Descriptors;
SPARK_Mode_Config := SPARK_Mode;
SPARK_Mode_Pragma_Config := SPARK_Mode_Pragma;
Uneval_Old_Config := Uneval_Old;
Optimize_Alignment_Local := Save.Optimize_Alignment_Local;
Persistent_BSS_Mode := Save.Persistent_BSS_Mode;
Polling_Required := Save.Polling_Required;
- Short_Descriptors := Save.Short_Descriptors;
SPARK_Mode := Save.SPARK_Mode;
SPARK_Mode_Pragma := Save.SPARK_Mode_Pragma;
Uneval_Old := Save.Uneval_Old;
Save.Optimize_Alignment_Local := Optimize_Alignment_Local;
Save.Persistent_BSS_Mode := Persistent_BSS_Mode;
Save.Polling_Required := Polling_Required;
- Save.Short_Descriptors := Short_Descriptors;
Save.SPARK_Mode := SPARK_Mode;
Save.SPARK_Mode_Pragma := SPARK_Mode_Pragma;
Save.Uneval_Old := Uneval_Old;
Fast_Math := Fast_Math_Config;
Optimize_Alignment := Optimize_Alignment_Config;
Polling_Required := Polling_Required_Config;
- Short_Descriptors := Short_Descriptors_Config;
end Set_Opt_Config_Switches;
---------------
subtype Debug_Level_Value is Nat range 0 .. 3;
Debugger_Level : Debug_Level_Value := 0;
- -- GNATBIND
-- The value given to the -g parameter. The default value for -g with
- -- no value is 2. This is usually ignored by GNATBIND, except in the
- -- VMS version where it is passed as an argument to __gnat_initialize
- -- to trigger the activation of the remote debugging interface.
- -- Is this still true ???
+ -- no value is 2. This is not currently used but is retained for possible
+ -- future use.
Default_Exit_Status : Int := 0;
-- GNATBIND
-- GNAT
-- True if compiling in GNAT system mode (-gnatg switch)
- Heap_Size : Nat := 0;
- -- GNATBIND
- -- Heap size for memory allocations. Valid values are 32 and 64. Only
- -- available on VMS.
-
Identifier_Character_Set : Character;
-- GNAT
-- This variable indicates the character set to be used for identifiers.
-- GNAT
-- Set True if a pragma Short_Circuit_And_Or applies to the current unit.
- Short_Descriptors : Boolean := False;
- -- GNAT
- -- Set True if a pragma Short_Descriptors applies to the current unit.
-
type SPARK_Mode_Type is (None, Off, On);
-- Possible legal modes that can be set by aspect/pragma SPARK_Mode, as
-- well as the value None, which indicates no such pragma/aspect applies.
-- GNAT
-- Set to True (-gnatt) to generate output tree file
- True_VMS_Target : Boolean := False;
- -- Set True if we are on a VMS target. The setting of this flag reflects
- -- the true state of the compile, unlike Targparm.OpenVMS_On_Target which
- -- can also be true when debug flag m is set (-gnatdm). This is used in the
- -- few cases where we do NOT want -gnatdm to trigger the VMS behavior.
-
Try_Semantics : Boolean := False;
-- GNAT
-- Flag set to force attempt at semantic analysis, even if parser errors
-- flag is used to set the initial value for Polling_Required at the start
-- of analyzing each unit.
- Short_Descriptors_Config : Boolean;
- -- GNAT
- -- This is the value of the configuration switch that controls the use of
- -- Short_Descriptors for setting descriptor default sizes. It can be set
- -- True by the use of the pragma Short_Descriptors in the gnat.adc file.
- -- This flag is used to set the initial value for Short_Descriptors at the
- -- start of analyzing each unit.
-
SPARK_Mode_Config : SPARK_Mode_Type := None;
-- GNAT
-- The setting of SPARK_Mode from configuration pragmas
Optimize_Alignment_Local : Boolean;
Persistent_BSS_Mode : Boolean;
Polling_Required : Boolean;
- Short_Descriptors : Boolean;
SPARK_Mode : SPARK_Mode_Type;
SPARK_Mode_Pragma : Node_Id;
Uneval_Old : Character;
System_Val_Real,
System_Val_Uns,
System_Val_WChar,
- System_Vax_Float_Operations,
System_Version_Control,
System_WCh_StW,
System_WCh_WtS,
RE_Value_Wide_Character, -- System.Val_WChar
RE_Value_Wide_Wide_Character, -- System.Val_WChar
- RE_D, -- System.Vax_Float_Operations
- RE_F, -- System.Vax_Float_Operations
- RE_G, -- System.Vax_Float_Operations
- RE_Q, -- System.Vax_Float_Operations
- RE_S, -- System.Vax_Float_Operations
- RE_T, -- System.Vax_Float_Operations
-
- RE_D_To_G, -- System.Vax_Float_Operations
- RE_F_To_G, -- System.Vax_Float_Operations
- RE_F_To_Q, -- System.Vax_Float_Operations
- RE_F_To_S, -- System.Vax_Float_Operations
- RE_G_To_D, -- System.Vax_Float_Operations
- RE_G_To_F, -- System.Vax_Float_Operations
- RE_G_To_Q, -- System.Vax_Float_Operations
- RE_G_To_T, -- System.Vax_Float_Operations
- RE_Q_To_F, -- System.Vax_Float_Operations
- RE_Q_To_G, -- System.Vax_Float_Operations
- RE_S_To_F, -- System.Vax_Float_Operations
- RE_T_To_D, -- System.Vax_Float_Operations
- RE_T_To_G, -- System.Vax_Float_Operations
-
- RE_Abs_F, -- System.Vax_Float_Operations
- RE_Abs_G, -- System.Vax_Float_Operations
- RE_Add_F, -- System.Vax_Float_Operations
- RE_Add_G, -- System.Vax_Float_Operations
- RE_Div_F, -- System.Vax_Float_Operations
- RE_Div_G, -- System.Vax_Float_Operations
- RE_Mul_F, -- System.Vax_Float_Operations
- RE_Mul_G, -- System.Vax_Float_Operations
- RE_Neg_F, -- System.Vax_Float_Operations
- RE_Neg_G, -- System.Vax_Float_Operations
- RE_Return_D, -- System.Vax_Float_Operations
- RE_Return_F, -- System.Vax_Float_Operations
- RE_Return_G, -- System.Vax_Float_Operations
- RE_Sub_F, -- System.Vax_Float_Operations
- RE_Sub_G, -- System.Vax_Float_Operations
-
- RE_Eq_F, -- System.Vax_Float_Operations
- RE_Eq_G, -- System.Vax_Float_Operations
- RE_Le_F, -- System.Vax_Float_Operations
- RE_Le_G, -- System.Vax_Float_Operations
- RE_Lt_F, -- System.Vax_Float_Operations
- RE_Lt_G, -- System.Vax_Float_Operations
- RE_Ne_F, -- System.Vax_Float_Operations
- RE_Ne_G, -- System.Vax_Float_Operations
-
- RE_Valid_D, -- System.Vax_Float_Operations
- RE_Valid_F, -- System.Vax_Float_Operations
- RE_Valid_G, -- System.Vax_Float_Operations
-
RE_Version_String, -- System.Version_Control
RE_Get_Version_String, -- System.Version_Control
RE_Value_Wide_Character => System_Val_WChar,
RE_Value_Wide_Wide_Character => System_Val_WChar,
- RE_D => System_Vax_Float_Operations,
- RE_F => System_Vax_Float_Operations,
- RE_G => System_Vax_Float_Operations,
- RE_Q => System_Vax_Float_Operations,
- RE_S => System_Vax_Float_Operations,
- RE_T => System_Vax_Float_Operations,
-
- RE_D_To_G => System_Vax_Float_Operations,
- RE_F_To_G => System_Vax_Float_Operations,
- RE_F_To_Q => System_Vax_Float_Operations,
- RE_F_To_S => System_Vax_Float_Operations,
- RE_G_To_D => System_Vax_Float_Operations,
- RE_G_To_F => System_Vax_Float_Operations,
- RE_G_To_Q => System_Vax_Float_Operations,
- RE_G_To_T => System_Vax_Float_Operations,
- RE_Q_To_F => System_Vax_Float_Operations,
- RE_Q_To_G => System_Vax_Float_Operations,
- RE_S_To_F => System_Vax_Float_Operations,
- RE_T_To_D => System_Vax_Float_Operations,
- RE_T_To_G => System_Vax_Float_Operations,
-
- RE_Abs_F => System_Vax_Float_Operations,
- RE_Abs_G => System_Vax_Float_Operations,
- RE_Add_F => System_Vax_Float_Operations,
- RE_Add_G => System_Vax_Float_Operations,
- RE_Div_F => System_Vax_Float_Operations,
- RE_Div_G => System_Vax_Float_Operations,
- RE_Mul_F => System_Vax_Float_Operations,
- RE_Mul_G => System_Vax_Float_Operations,
- RE_Neg_F => System_Vax_Float_Operations,
- RE_Neg_G => System_Vax_Float_Operations,
- RE_Return_D => System_Vax_Float_Operations,
- RE_Return_F => System_Vax_Float_Operations,
- RE_Return_G => System_Vax_Float_Operations,
- RE_Sub_F => System_Vax_Float_Operations,
- RE_Sub_G => System_Vax_Float_Operations,
-
- RE_Eq_F => System_Vax_Float_Operations,
- RE_Eq_G => System_Vax_Float_Operations,
- RE_Le_F => System_Vax_Float_Operations,
- RE_Le_G => System_Vax_Float_Operations,
- RE_Lt_F => System_Vax_Float_Operations,
- RE_Lt_G => System_Vax_Float_Operations,
- RE_Ne_F => System_Vax_Float_Operations,
- RE_Ne_G => System_Vax_Float_Operations,
-
- RE_Valid_D => System_Vax_Float_Operations,
- RE_Valid_F => System_Vax_Float_Operations,
- RE_Valid_G => System_Vax_Float_Operations,
-
RE_Version_String => System_Version_Control,
RE_Get_Version_String => System_Version_Control,
pragma Preelaborate;
subtype Short_Address is Address;
- -- In some versions of System.Aux_DEC, notably that for VMS on IA64, there
- -- are two address types (64-bit and 32-bit), and the name Short_Address
- -- is used for the short address form. To avoid difficulties (in regression
- -- tests and elsewhere) with units that reference Short_Address, it is
- -- provided for other targets as a synonym for the normal Address type,
- -- and, as in the case where the lengths are different, Address and
- -- Short_Address can be freely inter-converted.
+ -- For compatibility with systems having short and long addresses
type Integer_8 is range -2 ** (8 - 1) .. +2 ** (8 - 1) - 1;
for Integer_8'Size use 8;
type F_Float is digits 6;
type D_Float is digits 9;
type G_Float is digits 15;
- -- We provide the type names, but these will be IEEE, not VMS format
+ -- We provide the type names, but these will be IEEE format, not VAX format
-- Floating point type declarations for IEEE floating point data types
-- Valid --
-----------
- -- Note: this routine does not work for VAX float. We compensate for this
- -- in Exp_Attr by using the Valid functions in Vax_Float_Operations rather
- -- than the corresponding instantiation of this function.
-
function Valid (X : not null access T) return Boolean is
-
IEEE_Emin : constant Integer := T'Machine_Emin - 1;
IEEE_Emax : constant Integer := T'Machine_Emax - 1;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, 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- --
-- register, and the whole point of 'Valid is to prevent exceptions.
-- Note that the object of type T must have the natural alignment
-- for type T. See Unaligned_Valid for further discussion.
- --
- -- Note: this routine does not work for Vax_Float ???
function Unaligned_Valid (A : System.Address) return Boolean;
-- This version of Valid is used if the floating-point value to
-- not require strict alignment (e.g. the ia32/x86), since on a
-- target not requiring strict alignment, it is fine to pass a
-- non-aligned value to the standard Valid routine.
- --
- -- Note: this routine does not work for Vax_Float ???
private
pragma Inline (Machine);
(Host_File : System.Address) return System.Address;
pragma Import
(C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
+ -- Convert possible foreign file syntax to canonical form
The_Name : String (1 .. Name'Length + 1);
Canonical_File_Addr : System.Address;
return "";
end if;
- -- First, convert VMS file spec to Unix file spec.
- -- If Name is not in VMS syntax, then this is equivalent
- -- to put Name at the beginning of Path_Buffer.
+ -- First, convert possible foreign file spec to Unix file spec. If no
+ -- conversion is required, all this does is put Name at the beginning
+ -- of Path_Buffer unchanged.
- VMS_Conversion : begin
+ File_Name_Conversion : begin
The_Name (1 .. Name'Length) := Name;
The_Name (The_Name'Last) := ASCII.NUL;
Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
Canonical_File_Len := Integer (CRTL.strlen (Canonical_File_Addr));
- -- If VMS syntax conversion has failed, return an empty string
- -- to indicate the failure.
+ -- If syntax conversion has failed, return an empty string to
+ -- indicate the failure.
if Canonical_File_Len = 0 then
return "";
End_Path := Canonical_File_Len;
Last := 1;
end;
- end VMS_Conversion;
+ end File_Name_Conversion;
-- Replace all '/' by Directory Separators (this is for Windows)
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-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- --
-- provides a more general implementation not dedicated to file
-- storage.
--- This unit (and shared passive partitions) are supported on all
--- GNAT implementations except on OpenVMS (where problems arise from
--- trying to share files, and with version numbers of files)
-
-- --------------------------
-- -- Shared Storage Model --
-- --------------------------
Lang : Character;
-- A character indicating the language raising the exception.
-- Set to "A" for exceptions defined by an Ada program.
- -- Set to "V" for imported VMS exceptions.
-- Set to "C" for imported C++ exceptions.
Name_Length : Natural;
-- identities and names.
Foreign_Data : Address;
- -- Data for imported exceptions. This represents the exception code
- -- for the handling of Import/Export_Exception for the VMS case.
- -- This represents the address of the RTTI for the C++ case.
+ -- Data for imported exceptions. Not used in the Ada case. This
+ -- represents the address of the RTTI for the C++ case.
Raise_Hook : Raise_Action;
-- This field can be used to place a "hook" on an exception. If the
null;
else
- -- Initialize if first time
-
- if No (Comp_Unit_List) then
- Comp_Unit_List := New_Elmt_List;
- end if;
-
- Append_Elmt (Comp_Unit, Comp_Unit_List);
+ Append_New_Elmt (Comp_Unit, To => Comp_Unit_List);
if Debug_Unit_Walk then
Write_Str ("Appending ");
-- Mark this component as processed
else
- if No (Comps) then
- Comps := New_Elmt_List;
- end if;
-
- Append_Elmt (Comp_Or_Discr, Comps);
+ Append_New_Elmt (Comp_Or_Discr, Comps);
end if;
end if;
-- Computes the Fore value for the current attribute prefix, which is
-- known to be a static fixed-point type. Used by Fore and Width.
- function Is_VAX_Float (Typ : Entity_Id) return Boolean;
- -- Determine whether Typ denotes a VAX floating point type
-
function Mantissa return Uint;
-- Returns the Mantissa value for the prefix type
return R;
end Fore_Value;
- ------------------
- -- Is_VAX_Float --
- ------------------
-
- function Is_VAX_Float (Typ : Entity_Id) return Boolean is
- pragma Unreferenced (Typ);
- begin
- return False;
- end Is_VAX_Float;
-
--------------
-- Mantissa --
--------------
Fold_Uint (N, Expr_Value (Lo_Bound), Static);
end if;
- -- Replace VAX Float_Type'First with a reference to the temporary
- -- which represents the low bound of the type. This transformation
- -- is needed since the back end cannot evaluate 'First on VAX.
-
- elsif Is_VAX_Float (P_Type)
- and then Nkind (Lo_Bound) = N_Identifier
- then
- Rewrite (N, New_Occurrence_Of (Entity (Lo_Bound), Sloc (N)));
- Analyze (N);
-
else
Check_Concurrent_Discriminant (Lo_Bound);
end if;
Fold_Uint (N, Expr_Value (Hi_Bound), Static);
end if;
- -- Replace VAX Float_Type'Last with a reference to the temporary
- -- which represents the high bound of the type. This transformation
- -- is needed since the back end cannot evaluate 'Last on VAX.
-
- elsif Is_VAX_Float (P_Type)
- and then Nkind (Hi_Bound) = N_Identifier
- then
- Rewrite (N, New_Occurrence_Of (Entity (Hi_Bound), Sloc (N)));
- Analyze (N);
-
else
Check_Concurrent_Discriminant (Hi_Bound);
end if;
-- If this is a nested generic, preserve default for later
-- instantiations.
- if No (Match)
- and then Box_Present (Formal)
- then
+ if No (Match) and then Box_Present (Formal) then
Append_Elmt
(Defining_Unit_Name (Specification (Last (Assoc))),
Default_Actuals);
and then Remove_Suffix (Prim_A, 'P') = Chars (Prim_G)
then
Set_Chars (Prim_A, Chars (Prim_G));
-
- if List = No_Elist then
- List := New_Elmt_List;
- end if;
-
- Append_Elmt (Prim_A, List);
+ Append_New_Elmt (Prim_A, To => List);
end if;
Next_Elmt (Prim_A_Elmt);
procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is
begin
- if No (To_List) then
- To_List := New_Elmt_List;
- end if;
-
- Append_Elmt (Item, To_List);
+ Append_New_Elmt (Item, To => To_List);
end Add_Item;
-------------------------------
Arg_Parameter_Types : Node_Id;
Arg_Result_Type : Node_Id := Empty;
Arg_Mechanism : Node_Id;
- Arg_Result_Mechanism : Node_Id := Empty;
- Arg_First_Optional_Parameter : Node_Id := Empty);
+ Arg_Result_Mechanism : Node_Id := Empty);
-- Common processing for all extended Import and Export pragmas applying
-- to subprograms. The caller omits any arguments that do not apply to
-- the pragma in question (for example, Arg_Result_Type can be non-Empty
Arg_Parameter_Types : Node_Id;
Arg_Result_Type : Node_Id := Empty;
Arg_Mechanism : Node_Id;
- Arg_Result_Mechanism : Node_Id := Empty;
- Arg_First_Optional_Parameter : Node_Id := Empty)
+ Arg_Result_Mechanism : Node_Id := Empty)
is
- pragma Unreferenced (Arg_First_Optional_Parameter);
- -- We ignore the First_Optional_Parameter argument. It was only
- -- relevant for VMS anyway, and otherwise ignored.
-
Ent : Entity_Id;
Def_Id : Entity_Id;
Hom_Id : Entity_Id;
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.
+ -- clear if this can be False now (there used for sure to be
+ -- cases on some systems where it was False), but anyway the
+ -- test is harmless if not needed, so it is retained.
and then Comes_From_Source (Arg)
then
-- MECHANISM_NAME ::=
-- Value
-- | Reference
- -- | Descriptor [([Class =>] CLASS_NAME)]
-
- -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
when Pragma_Export_Function => Export_Function : declare
Args : Args_List (1 .. 6);
-- MECHANISM_NAME ::=
-- Value
-- | Reference
- -- | Descriptor [([Class =>] CLASS_NAME)]
-
- -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
when Pragma_Export_Object => Export_Object : declare
Args : Args_List (1 .. 3);
-- MECHANISM_NAME ::=
-- Value
-- | Reference
- -- | Descriptor [([Class =>] CLASS_NAME)]
-
- -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
when Pragma_Export_Procedure => Export_Procedure : declare
Args : Args_List (1 .. 4);
-- MECHANISM_NAME ::=
-- Value
-- | Reference
- -- | Descriptor [([Class =>] CLASS_NAME)]
-
- -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
when Pragma_Export_Valued_Procedure =>
Export_Valued_Procedure : declare
-- pragma Ident (static_string_EXPRESSION)
- -- Note: pragma Comment shares this processing. Pragma Comment is
- -- identical to Ident, except that the restriction of the argument to
- -- 31 characters and the placement restrictions are not enforced for
- -- pragma Comment.
+ -- Note: pragma Comment shares this processing. Pragma Ident is
+ -- identical in effect to pragma Commment.
when Pragma_Ident | Pragma_Comment => Ident : declare
Str : Node_Id;
Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
Store_Note (N);
- -- For pragma Ident, preserve DEC compatibility by requiring the
- -- pragma to appear in a declarative part or package spec.
-
- if Prag_Id = Pragma_Ident then
- Check_Is_In_Decl_Part_Or_Package_Spec;
- end if;
-
Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
declare
if Present (CS) then
- -- For Ident, we do not permit multiple instances
-
- if Prag_Id = Pragma_Ident then
- Error_Pragma ("duplicate% pragma not permitted");
-
- -- For Comment, we concatenate the string, unless we want
- -- to preserve the tree structure for ASIS.
+ -- If we have multiple instances, concatenate them, but
+ -- not in ASIS, where we want the original tree.
- elsif not ASIS_Mode then
+ if not ASIS_Mode then
Start_String (Strval (CS));
Store_String_Char (' ');
Store_String_Chars (Strval (Str));
elsif Nkind (GP) = N_Subunit then
null;
-
- -- Otherwise we have a misplaced pragma Ident, but we ignore
- -- this if we are in an instantiation, since it comes from
- -- a generic, and has no relevance to the instantiation.
-
- elsif Prag_Id = Pragma_Ident then
- if Instantiation_Location (Loc) = No_Location then
- Error_Pragma ("pragma% only allowed at outer level");
- end if;
end if;
end;
end Ident;
-- [, [Parameter_Types =>] (PARAMETER_TYPES)]
-- [, [Result_Type =>] SUBTYPE_MARK]
-- [, [Mechanism =>] MECHANISM]
- -- [, [Result_Mechanism =>] MECHANISM_NAME]
- -- [, [First_Optional_Parameter =>] IDENTIFIER]);
+ -- [, [Result_Mechanism =>] MECHANISM_NAME]);
-- EXTERNAL_SYMBOL ::=
-- IDENTIFIER
-- MECHANISM_NAME ::=
-- Value
-- | Reference
- -- | Descriptor [([Class =>] CLASS_NAME)]
-
- -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
when Pragma_Import_Function => Import_Function : declare
- Args : Args_List (1 .. 7);
- Names : constant Name_List (1 .. 7) := (
+ Args : Args_List (1 .. 6);
+ Names : constant Name_List (1 .. 6) := (
Name_Internal,
Name_External,
Name_Parameter_Types,
Name_Result_Type,
Name_Mechanism,
- Name_Result_Mechanism,
- Name_First_Optional_Parameter);
+ Name_Result_Mechanism);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Result_Type : Node_Id renames Args (4);
Mechanism : Node_Id renames Args (5);
Result_Mechanism : Node_Id renames Args (6);
- First_Optional_Parameter : Node_Id renames Args (7);
begin
GNAT_Pragma;
Arg_Parameter_Types => Parameter_Types,
Arg_Result_Type => Result_Type,
Arg_Mechanism => Mechanism,
- Arg_Result_Mechanism => Result_Mechanism,
- Arg_First_Optional_Parameter => First_Optional_Parameter);
+ Arg_Result_Mechanism => Result_Mechanism);
end Import_Function;
-------------------
-- [Internal =>] LOCAL_NAME
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Parameter_Types =>] (PARAMETER_TYPES)]
- -- [, [Mechanism =>] MECHANISM]
- -- [, [First_Optional_Parameter =>] IDENTIFIER]);
+ -- [, [Mechanism =>] MECHANISM]);
-- EXTERNAL_SYMBOL ::=
-- IDENTIFIER
-- MECHANISM_NAME ::=
-- Value
-- | Reference
- -- | Descriptor [([Class =>] CLASS_NAME)]
-
- -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
when Pragma_Import_Procedure => Import_Procedure : declare
- Args : Args_List (1 .. 5);
- Names : constant Name_List (1 .. 5) := (
+ Args : Args_List (1 .. 4);
+ Names : constant Name_List (1 .. 4) := (
Name_Internal,
Name_External,
Name_Parameter_Types,
- Name_Mechanism,
- Name_First_Optional_Parameter);
+ Name_Mechanism);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Parameter_Types : Node_Id renames Args (3);
Mechanism : Node_Id renames Args (4);
- First_Optional_Parameter : Node_Id renames Args (5);
begin
GNAT_Pragma;
Arg_Internal => Internal,
Arg_External => External,
Arg_Parameter_Types => Parameter_Types,
- Arg_Mechanism => Mechanism,
- Arg_First_Optional_Parameter => First_Optional_Parameter);
+ Arg_Mechanism => Mechanism);
end Import_Procedure;
-----------------------------
-- [Internal =>] LOCAL_NAME
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Parameter_Types =>] (PARAMETER_TYPES)]
- -- [, [Mechanism =>] MECHANISM]
- -- [, [First_Optional_Parameter =>] IDENTIFIER]);
+ -- [, [Mechanism =>] MECHANISM]);
-- EXTERNAL_SYMBOL ::=
-- IDENTIFIER
-- MECHANISM_NAME ::=
-- Value
-- | Reference
- -- | Descriptor [([Class =>] CLASS_NAME)]
-
- -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
when Pragma_Import_Valued_Procedure =>
Import_Valued_Procedure : declare
- Args : Args_List (1 .. 5);
- Names : constant Name_List (1 .. 5) := (
+ Args : Args_List (1 .. 4);
+ Names : constant Name_List (1 .. 4) := (
Name_Internal,
Name_External,
Name_Parameter_Types,
- Name_Mechanism,
- Name_First_Optional_Parameter);
+ Name_Mechanism);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Parameter_Types : Node_Id renames Args (3);
Mechanism : Node_Id renames Args (4);
- First_Optional_Parameter : Node_Id renames Args (5);
begin
GNAT_Pragma;
Arg_Internal => Internal,
Arg_External => External,
Arg_Parameter_Types => Parameter_Types,
- Arg_Mechanism => Mechanism,
- Arg_First_Optional_Parameter => First_Optional_Parameter);
+ Arg_Mechanism => Mechanism);
end Import_Valued_Procedure;
-----------------
-- pragma Short_Descriptors;
+ -- Recognize and validate, but otherwise ignore
+
when Pragma_Short_Descriptors =>
GNAT_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
- Short_Descriptors := True;
------------------------------
-- Simple_Storage_Pool_Type --
Set_Body_References (State_Id, New_Elmt_List);
end if;
- Append_Elmt (Ref, Body_References (State_Id));
+ Append_Elmt (Ref, To => Body_References (State_Id));
exit;
end if;
end if;
-- dealing with subprogram body stubs or expression functions.
procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id);
- -- This routine is used to set an encoded interface name. The node S is an
- -- N_String_Literal node for the external name to be set, and E is an
+ -- This routine is used to set an encoded interface name. The node S is
+ -- an N_String_Literal node for the external name to be set, and E is an
-- entity whose Interface_Name field is to be set. In the normal case where
-- S contains a name that is a valid C identifier, then S is simply set as
- -- the value of the Interface_Name. Otherwise it is encoded. See the body
- -- for details of the encoding. This encoding is only done on VMS systems,
- -- since it seems pretty silly, but is needed to pass some dubious tests in
- -- the test suite.
+ -- the value of the Interface_Name. Otherwise it is encoded as needed by
+ -- particular operating systems. See the body for details of the encoding.
end Sem_Prag;
return Abandon;
end if;
- if Writable_Actuals_List = No_Elist then
- Writable_Actuals_List := New_Elmt_List;
- end if;
-
- Append_Elmt (N, Writable_Actuals_List);
+ Append_New_Elmt (N, To => Writable_Actuals_List);
else
if Identifiers_List = No_Elist then
declare
Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
begin
- if not Is_Tag (Comp)
- and then Chars (Comp) /= Name_uParent
- then
+ if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then
Append_Elmt (Comp, Into);
end if;
end;
function Has_Denormals (E : Entity_Id) return Boolean is
begin
- return Is_Floating_Point_Type (E)
- and then Denorm_On_Target
- and then not Vax_Float (E);
+ return Is_Floating_Point_Type (E) and then Denorm_On_Target;
end Has_Denormals;
-------------------------------------------
function Has_Signed_Zeros (E : Entity_Id) return Boolean is
begin
- return Is_Floating_Point_Type (E)
- and then Signed_Zeros_On_Target
- and then not Vax_Float (E);
+ return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target;
end Has_Signed_Zeros;
-----------------------------
-- Ada 83, Ada 95, and Ada 2005 mode as well, where they are technically
-- considered to be implementation dependent pragmas.
- -- The entries marked VMS are VMS specific pragmas that are recognized only
- -- in OpenVMS versions of GNAT. They are ignored in other versions with an
- -- appropriate warning.
-
-- The entries marked AAMP are AAMP specific pragmas that are recognized
-- only in GNAT for the AAMP. They are ignored in other versions with
-- appropriate warnings.
-- pragma.
Name_Provide_Shift_Operators : constant Name_Id := N + $; -- GNAT
- Name_Psect_Object : constant Name_Id := N + $; -- VMS
+ Name_Psect_Object : constant Name_Id := N + $; -- GNAT
Name_Pure : constant Name_Id := N + $;
Name_Pure_Function : constant Name_Id := N + $; -- GNAT
Name_Refined_Depends : constant Name_Id := N + $; -- GNAT
Name_Test_Case : constant Name_Id := N + $; -- GNAT
Name_Task_Info : constant Name_Id := N + $; -- GNAT
Name_Task_Name : constant Name_Id := N + $; -- GNAT
- Name_Task_Storage : constant Name_Id := N + $; -- VMS
+ Name_Task_Storage : constant Name_Id := N + $; -- GNAT
Name_Thread_Local_Storage : constant Name_Id := N + $; -- GNAT
Name_Time_Slice : constant Name_Id := N + $; -- GNAT
Name_Title : constant Name_Id := N + $; -- GNAT
-- Entity for universal real type. The bounds of this type correspond to
-- to the largest supported real type (i.e. Long_Long_Float). It is the
-- type used for runtime calculations in type universal real. Note that
- -- this type is always IEEE format, even if Long_Long_Float is Vax_Float
- -- (and in that case the bounds don't correspond exactly).
+ -- this type is always IEEE format.
Universal_Fixed : Entity_Id;
-- Entity for universal fixed type. This is a type with arbitrary
Ptr := Ptr + 1;
Usage_Requested := True;
- -- Processing for H switch
-
- when 'H' =>
- if Ptr = Max then
- Bad_Switch (Switch_Chars);
- end if;
-
- Ptr := Ptr + 1;
- Scan_Nat (Switch_Chars, Max, Ptr, Heap_Size, C);
-
- if Heap_Size /= 32 and then Heap_Size /= 64 then
- Bad_Switch (Switch_Chars);
- end if;
-
-- Processing for i switch
when 'i' =>
-- S p e c --
-- (Compiler Version) --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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 --
Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
- OpenVMS : constant Boolean := False;
Preallocated_Stacks : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
SNZ, -- Signed_Zeros
SSL, -- Suppress_Standard_Library
UAM, -- Use_Ada_Main_Program_Name
- VMS, -- OpenVMS
- VXF, -- VAX Float
ZCD); -- ZCX_By_Default
Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False);
SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros";
SSL_Str : aliased constant Source_Buffer := "Suppress_Standard_Library";
UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name";
- VMS_Str : aliased constant Source_Buffer := "OpenVMS";
- VXF_Str : aliased constant Source_Buffer := "VAX_Float";
ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default";
-- The following defines a set of pointers to the above strings,
SNZ_Str'Access,
SSL_Str'Access,
UAM_Str'Access,
- VMS_Str'Access,
- VXF_Str'Access,
ZCD_Str'Access);
-----------------------
when SSL => Suppress_Standard_Library_On_Target := Result;
when SNZ => Signed_Zeros_On_Target := Result;
when UAM => Use_Ada_Main_Program_Name_On_Target := Result;
- when VMS => OpenVMS_On_Target := Result;
- when VXF => VAX_Float_On_Target := Result;
when ZCD => ZCX_By_Default_On_Target := Result;
goto Line_Loop_Continue;
-- The default values here are used if no value is found in system.ads.
-- This should normally happen if the special version of system.ads used
- -- by the compiler itself is in use or if the value is only relevant to
- -- a particular target (e.g. OpenVMS, AAMP). The default values are
- -- suitable for use in normal environments. This approach allows the
- -- possibility of new versions of the compiler (possibly with new system
- -- parameters added) being used to compile older versions of the compiler
- -- sources, as well as avoiding duplicating values in all system-*.ads
- -- files for flags that are used on a few platforms only.
+ -- by the compiler itself is in use or if the value is only relevant to a
+ -- particular target (e.g. AAMP). The default values are suitable for use
+ -- in normal environments. This approach allows the possibility of new
+ -- versions of the compiler (possibly with new system parameters added)
+ -- being used to compile older versions of the compiler sources, as well as
+ -- avoiding duplicating values in all system-*.ads files for flags that are
+ -- used on a few platforms only.
-- All these parameters should be regarded as read only by all clients
-- of the package. The only way they get modified is by calling the
projects / thirdparty / gcc.git / commitdiff
