+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M --
--- --
--- S p e c --
--- (OpenVMS 64bit GCC_ZCX DEC Threads Version) --
--- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package System is
-pragma Pure (System);
--- Note that we take advantage of the implementation permission to
--- make this unit Pure instead of Preelaborable, see RM 13.7(36)
-
- type Name is (SYSTEM_NAME_GNAT);
- System_Name : constant Name := SYSTEM_NAME_GNAT;
-
- -- System-Dependent Named Numbers
-
- Min_Int : constant := Long_Long_Integer'First;
- Max_Int : constant := Long_Long_Integer'Last;
-
- Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
- Max_Nonbinary_Modulus : constant := Integer'Last;
-
- Max_Base_Digits : constant := Long_Long_Float'Digits;
- Max_Digits : constant := Long_Long_Float'Digits;
-
- Max_Mantissa : constant := 63;
- Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
-
- Tick : constant := 0.01;
-
- -- Storage-related Declarations
-
- type Address is new Long_Integer;
- Null_Address : constant Address;
- -- Although this is declared as an integer type, no arithmetic operations
- -- are available (see abstract declarations below), and furthermore there
- -- is special processing in the compiler that prevents the use of integer
- -- literals with this type (use To_Address to convert integer literals).
- --
- -- Conversion to and from Short_Address is however freely permitted, and
- -- is indeed the reason that Address is declared as an integer type. See
- --
-
- Storage_Unit : constant := 8;
- Word_Size : constant := 64;
- Memory_Size : constant := 2 ** 64;
-
- -- Address comparison
-
- function "<" (Left, Right : Address) return Boolean;
- function "<=" (Left, Right : Address) return Boolean;
- function ">" (Left, Right : Address) return Boolean;
- function ">=" (Left, Right : Address) return Boolean;
- function "=" (Left, Right : Address) return Boolean;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
- pragma Import (Intrinsic, "=");
-
- -- Abstract declarations for arithmetic operations on type address.
- -- These declarations are needed when Address is non-private. They
- -- avoid excessive visibility of arithmetic operations on address
- -- which are typically available elsewhere (e.g. Storage_Elements)
- -- and which would cause excessive ambiguities in application code.
-
- function "+" (Left, Right : Address) return Address is abstract;
- function "-" (Left, Right : Address) return Address is abstract;
- function "/" (Left, Right : Address) return Address is abstract;
- function "*" (Left, Right : Address) return Address is abstract;
- function "mod" (Left, Right : Address) return Address is abstract;
-
- -- Other System-Dependent Declarations
-
- type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := Low_Order_First;
-
- -- Priority-related Declarations (RM D.1)
-
- Max_Priority : constant Positive := 30;
- Max_Interrupt_Priority : constant Positive := 31;
-
- subtype Any_Priority is Integer range 0 .. 31;
- subtype Priority is Any_Priority range 0 .. 30;
- subtype Interrupt_Priority is Any_Priority range 31 .. 31;
-
- Default_Priority : constant Priority := 15;
-
-private
-
- Null_Address : constant Address := 0;
-
- --------------------------------------
- -- System Implementation Parameters --
- --------------------------------------
-
- -- These parameters provide information about the target that is used
- -- by the compiler. They are in the private part of System, where they
- -- can be accessed using the special circuitry in the Targparm unit
- -- whose source should be consulted for more detailed descriptions
- -- of the individual switch values.
-
- AAMP : constant Boolean := False;
- Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := False;
- Command_Line_Args : constant Boolean := True;
- Configurable_Run_Time : constant Boolean := False;
- Denorm : constant Boolean := False;
- Duration_32_Bits : constant Boolean := False;
- Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
- Functions_Return_By_DSP : constant Boolean := False;
- Machine_Overflows : constant Boolean := False;
- Machine_Rounds : constant Boolean := True;
- OpenVMS : constant Boolean := True;
- Signed_Zeros : constant Boolean := True;
- Stack_Check_Default : constant Boolean := True;
- Stack_Check_Probes : constant Boolean := True;
- Support_64_Bit_Divides : constant Boolean := True;
- Support_Aggregates : constant Boolean := True;
- Support_Composite_Assign : constant Boolean := True;
- Support_Composite_Compare : constant Boolean := True;
- Support_Long_Shifts : constant Boolean := True;
- Suppress_Standard_Library : constant Boolean := False;
- Use_Ada_Main_Program_Name : constant Boolean := False;
- ZCX_By_Default : constant Boolean := True;
- GCC_ZCX_Support : constant Boolean := True;
- Front_End_ZCX_Support : constant Boolean := False;
-
- -- Obsolete entries, to be removed eventually (bootstrap issues!)
-
- High_Integrity_Mode : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := False;
-
- --------------------------
- -- Underlying Priorities --
- ---------------------------
-
- -- Important note: this section of the file must come AFTER the
- -- definition of the system implementation parameters to ensure
- -- that the value of these parameters is available for analysis
- -- of the declarations here (using Rtsfind at compile time).
-
- -- The underlying priorities table provides a generalized mechanism
- -- for mapping from Ada priorities to system priorities. In some
- -- cases a 1-1 mapping is not the convenient or optimal choice.
-
- -- For DEC Threads OpenVMS, we use the full range of 31 priorities
- -- in the Ada model, but map them by compression onto the more limited
- -- range of priorities available in OpenVMS.
-
- -- To replace the default values of the Underlying_Priorities mapping,
- -- copy this source file into your build directory, edit the file to
- -- reflect your desired behavior, and recompile with the command:
-
- -- $ gcc -c -O3 -gnatpgn system.ads
-
- -- then recompile the run-time parts that depend on this package:
-
- -- $ gnatmake -a -gnatn -O3 <your application>
-
- -- then force rebuilding your application if you need different options:
-
- -- $ gnatmake -f <your options> <your application>
-
- type Priorities_Mapping is array (Any_Priority) of Integer;
- pragma Suppress_Initialization (Priorities_Mapping);
- -- Suppress initialization in case gnat.adc specifies Normalize_Scalars
-
- Underlying_Priorities : constant Priorities_Mapping :=
-
- (Priority'First => 16,
-
- 1 => 17,
- 2 => 18,
- 3 => 18,
- 4 => 18,
- 5 => 18,
- 6 => 19,
- 7 => 19,
- 8 => 19,
- 9 => 20,
- 10 => 20,
- 11 => 21,
- 12 => 21,
- 13 => 22,
- 14 => 23,
-
- Default_Priority => 24,
-
- 16 => 25,
- 17 => 25,
- 18 => 25,
- 19 => 26,
- 20 => 26,
- 21 => 26,
- 22 => 27,
- 23 => 27,
- 24 => 27,
- 25 => 28,
- 26 => 28,
- 27 => 29,
- 28 => 29,
- 29 => 30,
-
- Priority'Last => 30,
-
- Interrupt_Priority => 31);
-
- ----------------------------
- -- Special VMS Interfaces --
- ----------------------------
-
- procedure Lib_Stop (I : in Integer);
- pragma Interface (C, Lib_Stop);
- pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value));
- -- Interface to VMS condition handling. Used by RTSfind and pragma
- -- {Import,Export}_Exception. Put here because this is the only
- -- VMS specific package that doesn't drag in tasking.
-
-end System;
+2004-06-07 Robert Dewar <dewar@gnat.com>
+
+ * a-direct.ads, einfo.ads: Minor comment updates
+
+ * s-taprop-lynxos.adb, s-taprop-tru64.adb, s-taprop-irix.adb,
+ s-taprop-irix-athread.adb, s-taprop-hpux-dce.adb, s-taprop-linux.adb,
+ s-taprop-dummy.adb, s-taprop-os2.adb, s-taprop-solaris.adb,
+ s-taprop-vms.adb, s-taprop-mingw.adb, s-taprop-vxworks.adb,
+ s-taprop-posix.adb, s-taprop.ads, exp_dbug.adb: Minor reformatting.
+
+ * s-interr-sigaction.adb: Remove unreferenced variable
+ (Attached_Interrupts). Minor reformatting.
+ Avoid use of variable I (replace by J).
+
+ * par-ch10.adb: Fix text of one error message
+
+ * checks.adb, checks.ads, cstand.adb, vms_data.ads, errout.ads,
+ exp_aggr.adb, exp_ch3.adb, exp_ch3.ads, exp_ch5.adb, exp_ch6.adb,
+ exp_ch9.adb, exp_code.adb, gnat1drv.adb, lib-load.adb, lib-writ.adb,
+ opt.adb, par.adb, opt.ads, par-ch11.adb, par-ch3.adb, par-ch4.adb,
+ par-ch5.adb, par-ch6.adb, par-ch8.adb, par-ch9.adb, par-prag.adb,
+ par-util.adb, scng.adb, sem_aggr.adb, sem_attr.adb, sem_cat.adb,
+ sem_ch10.adb, sem_ch10.adb, sem_ch11.adb, sem_ch12.adb, sem_ch2.adb,
+ sem_ch3.adb, sem_ch3.ads, sem_ch4.adb, sem_ch5.adb, sem_ch6.adb,
+ sem_ch7.adb, sem_ch8.adb, sem_ch9.adb, sem_eval.adb, sem_prag.adb,
+ sem_res.adb, sem_type.adb, sem_util.adb, sinfo.ads, snames.adb,
+ snames.ads, snames.h, sprint.adb, switch-c.adb: Modifications for Ada
+ 2005 support.
+
+2004-06-07 Doug Rupp <rupp@gnat.com>
+
+ * mlib-tgt-vms.adb: Rename mlib-tgt-vms.adb mlib-tgt-vms-alpha.adb
+
+ * s-vaflop-vms.adb: Rename s-vaflop-vms.adb to s-vaflop-vms-alpha.adb
+
+ * mlib-tgt-vms-ia64.adb: New file.
+
+ * Makefile.in: Rename mlib-tgt-vms.adb to mlib-tgt-vms-alpha.adb
+ Add mlib-tgt-vms-ia64.adb
+ Rename s-vaflop-vms.adb to s-vaflop-vms-alpha.adb.
+ Move to alpha specific ifeq section.
+ Add VMS specific versions of symbols.adb
+ Renaming of 5q vms files.
+
+ * 5qsystem.ads renamed to system-vms_64.ads.
+
+2004-06-07 Vincent Celier <celier@gnat.com>
+
+ * a-calend.ads: Add a GNAT Note comment after function Time_Of to
+ explain that when a time of day corresponding to the non existing hour
+ on the day switching to DST is specified, Split may return a different
+ value for Seconds.
+
+ * gnatcmd.adb: Add processing of GNAT METRIC (for gnatmetric), similar
+ to GNAT PRETTY.
+
+ * g-os_lib.adb (OpenVMS): New Boolean value imported from System.
+ (Normalize_Pathname): Only resolve VMS logical names when on VMS.
+
+ * mlib-prj.adb (Build_Library): New flag Gtrasymobj_Needed, initialize
+ to False.
+ If Gtrasymobj_Needed is True, add the full path of g-trasym.obj to
+ the linking options.
+ (Build_Library.Check_Libs): On VMS, if there is a dependency on
+ g-trasym.ads, set Gtrasymobj_Needed to True.
+
+ * prj-attr.adb: Add new package Metrics for gnatmetric
+
+ * prj-nmsc.adb (Record_Other_Sources): Put source file names in
+ canonical case to take into account files with upper case characters on
+ Windows.
+ (Ada_Check): Load the reference symbol file name in the name buffer to
+ check it, not the symbol file name.
+
+ * snames.ads, snames.adb: Add standard name Metrics (name of project
+ file package for gnatmetric).
+
+ * vms_conv.ads: Add Metric to Comment_Type
+
+ * vms_conv.adb (Initialize): Add component dor Metric in Command_List
+
+ * vms_data.ads: Add qualifiers for GNAT METRIC
+
+ * makegpr.adb (Link_Executables): Take into account the switches
+ specified in package Linker of the main project.
+
+2004-06-07 Thomas Quinot <quinot@act-europe.fr>
+
+ * bindgen.adb (Set_Unit_Number): Units is an instance of Table, and so
+ the index of the last element is Units.Last, not Units.Table'Last
+ (which is usually not a valid index within the actually allocated
+ storage for the table).
+
+ * exp_ch4.adb (Insert_Dereference_Action): Change predicate that
+ determines whether to generate a call to a checked storage pool
+ Dereference action.
+ Generate such a call only for a dereference that either comes from
+ source, or is the result of rewriting a dereference that comes from
+ source.
+
+2004-06-07 Romain Berrendonner <berrendo@act-europe.fr>
+
+ * bindgen.adb (Gen_Output_File): Add support for GAP builds.
+
+2004-06-07 Eric Botcazou <ebotcazou@act-europe.fr>
+
+ (gnat_to_gnu_entity) <E_Array_Subtype>: For multi-dimensional arrays at
+ file level, elaborate the stride for inner dimensions in alignment
+ units, not bytes.
+
+ * exp_ch5.adb: Correct wrong reference to Component_May_Be_Bit_Aligned
+ in a comment.
+
+2004-06-07 Javier Miranda <miranda@gnat.com>
+
+ * exp_ch6.adb: Correct wrong modification in previous patch
+
+2004-06-07 Vasiliy Fofanov <fofanov@act-europe.fr>
+
+ * g-trasym.ads: Corrected comment to properly reflect level of support
+ on VMS.
+
+2004-06-07 Hristian Kirtchev <kirtchev@gnat.com>
+
+ * lib-xref.adb (Generate_Reference): Add nested function Is_On_LHS. It
+ includes case of a variable referenced on the left hand side of an
+ assignment, therefore remove redundant code. Variables and prefixes of
+ indexed or selected components are now marked as referenced on left
+ hand side. Warnings are now properly emitted when variables or prefixes
+ are assigned but not read.
+
+ * sem_warn.adb (Output_Unreferenced_Messages): Add additional checks to
+ left hand side referenced variables. Private access types do not
+ produce the warning "variable ... is assigned but never read".
+ Add also additional checks to left hand side referenced variables.
+ Aliased, renamed objects and access types do not produce the warning
+ "variable ... is assigned but never read" since other entities may read
+ the memory location.
+
+2004-06-07 Jerome Guitton <guitton@act-europe.fr>
+
+ * Makefile.in: In the powerpc/vxworks-specific section, restore
+ EXTRA_GNATRTL_NONTASKING_OBJS and EXTRA_GNATRTL_TASKING_OBJS (removed
+ by mistake).
+
+2004-06-07 Ed Schonberg <schonberg@gnat.com>
+
+ * sem_ch4.adb (Remove_Abstract_Operations): Refine the removal of
+ predefined operators.
+ Removes spurious type errors from g-trasym-vms.adb.
+
+ * sem_res.adb (Rewrite_Renamed_Operator): If intrinsic operator is
+ distinct from the operator appearing in the source, call appropriate
+ routine to insert conversions when needed, and complete resolution of
+ node.
+ (Resolve_Intrinsic_Operator): Fix cut-and-paste bug on transfer of
+ interpretations for rewritten right operand.
+ (Set_Mixed_Mode_Operand): Handle properly a universal real operand when
+ the other operand is overloaded and the context is a type conversion.
+
+2004-06-07 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
+
+ * ada-tree.def (BLOCK_STMT): Now has two operands.
+ (BREAK_STMT): New.
+
+ * ada-tree.h: (BLOCK_STMT_BLOCK): New macro.
+
+ * gigi.h: (gnat_poplevel): Now returns a tree.
+
+ * trans.c (end_block_stmt): Add arg; all callers changed.
+ (tree_transform, case N_Case_Statement): Make a BLOCK_STMT for a WHEN.
+ (start_block_stmt): Clear BLOCK_STMT_BLOCK.
+ (add_stmt): Set TREE_TYPE.
+ (gnat_expand_stmt, case BLOCK_STMT): Handle BLOCK_STMT_BLOCK.
+ (gnat_expand_stmt, case BREAK_STMT): New case.
+
+ * utils.c (gnat_poplevel): Return a BLOCK, if we made one.
+
+2004-06-07 Jose Ruiz <ruiz@act-europe.fr>
+
+ * s-stchop.adsm s-stchop.adb, s-stchop-vxworks.adb: Remove the
+ procedure Set_Stack_Size that is not needed.
+
+2004-06-07 Sergey Rybin <rybin@act-europe.fr>
+
+ * gnat_ugn.texi: Clarify the case when non-standard naming scheme is
+ used for gnatpp input file and for the files upon which it depends
+
+2004-06-07 Ben Brosgol <brosgol@gnat.com>
+
+ * gnat_ugn.texi: Wordsmithing of "GNAT and Libraries" chapter
+
+2004-06-07 Arnaud Charlet <charlet@act-europe.fr>
+
+ * gnatvsn.ads: Bump version numbers appropriately.
+ Add new build type.
+
+2004-06-07 Pascal Obry <obry@gnat.com>
+
+ * gnat_ugn.texi: Improve comments about imported names and link names
+ on Windows. Add a note about the requirement to use -k gnatdll's option
+ when working with a DLL which has stripped stdcall symbols (no @nn
+ suffix).
+
2004-05-27 Vincent Celier <celier@gnat.com>
* vms_data.ads: Add new GNAT PRETTY qualifiers /NO_BACKUP and
s-tratas.adb<s-tratas-default.adb \
s-tfsetr.adb<s-tfsetr-vxworks.adb
endif
+
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
+ EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
endif
ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),)
ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(targ))),)
ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),)
LIBGNAT_TARGET_PAIRS_AUX1 = \
- s-auxdec.ads<5qauxdec.ads \
+ s-auxdec.ads<s-auxdec-vms_64.ads \
s-crtl.ads<s-crtl-vms.ads \
s-osinte.adb<s-osinte-vms-ia64.adb \
s-osinte.ads<s-osinte-vms-ia64.ads \
- system.ads<5qsystem.ads
+ system.ads<system-vms_64.ads
else
ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),)
LIBGNAT_TARGET_PAIRS_AUX1 = \
s-crtl.ads<s-crtl-vms.ads \
s-osinte.adb<s-osinte-vms.adb \
s-osinte.ads<s-osinte-vms.ads \
+ s-vaflop.adb<s-vaflop-vms-alpha.adb \
system.ads<system-vms-zcx.ads
endif
endif
s-tpopde.ads<s-tpopde-vms.ads \
s-traent.adb<s-traent-vms.adb \
s-traent.ads<s-traent-vms.ads \
- s-vaflop.adb<s-vaflop-vms.adb \
$(LIBGNAT_TARGET_PAIRS_AUX1) \
$(LIBGNAT_TARGET_PAIRS_AUX2)
- TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vms.adb
+ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),)
+ TOOLS_TARGET_PAIRS= \
+ mlib-tgt.adb<mlib-tgt-vms-ia64.adb \
+ symbols.adb<symbols-vms-ia64.adb
+else
+ TOOLS_TARGET_PAIRS= \
+ mlib-tgt.adb<mlib-tgt-vms-alpha.adb \
+ symbols.adb<symbols-vms-alpha.adb
+endif
GNATLIB_SHARED=gnatlib-shared-vms
ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),)
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1997 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
(Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
- Seconds : Day_Duration := 0.0)
- return Time;
+ Seconds : Day_Duration := 0.0) return Time;
+ -- GNAT Note: Normally when procedure Split is called on a Time value
+ -- result of a call to function Time_Of, the out parameters of procedure
+ -- Split are identical to the in parameters of function Time_Of. However,
+ -- when a non-existent time of day is specified, the values for Seconds
+ -- may or may not be different. This may happen when Daylight Saving Time
+ -- (DST) is in effect, on the day when switching to DST, if Seconds
+ -- specifies a time of day in the hour that does not exist. For example,
+ -- in New York:
+ --
+ -- Time_Of (Year => 1998, Month => 4, Day => 5, Seconds => 10740.0)
+ --
+ -- will return a Time value T. If Split is called on T, the resulting
+ -- Seconds may be 14340.0 (3:59:00) instead of 10740.0 (2:59:00 being
+ -- a time that not exist).
function "+" (Left : Time; Right : Duration) return Time;
function "+" (Left : Duration; Right : Time) return Time;
------------------------------------------------------------------------------
--- --
+-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . D I R E C T O R I E S --
-- --
------------------------------------------------------------------------------
--- Ada0Y: Implementation of Ada.Directories (AI95-00248). Note that this
--- unit is available without -gnatX. That seems reasonable, since you only
+-- Ada 2005: Implementation of Ada.Directories (AI95-00248). Note that this
+-- unit is available without -gnat05. That seems reasonable, since you only
-- get it if you explicitly ask for it.
-- External files may be classified as directories, special files, or ordinary
-- all of its contents (possibly including other directories) are deleted.
-- The exception Name_Error is propagated if the string given as Directory
-- does not identify an existing directory. The exception Use_Error is
- -- propagatedi f the external environment does not support the deletion of
+ -- propagated if the external environment does not support the deletion of
-- the directory or some portion of its contents with the given name (in
-- the absence of Name_Error). If Use_Error is propagated, it is
-- unspecified if a portion of the contents of the directory are deleted.
DEFTREECODE (DECL_STMT, "decl_stmt", 's', 1)
/* This represents a list of statements. BLOCK_STMT_LIST is a list
- statement tree, chained via TREE_CHAIN. */
-DEFTREECODE (BLOCK_STMT, "block_stmt", 's', 1)
+ statement tree, chained via TREE_CHAIN. BLOCK_STMT_BLOCK, if nonzero,
+ is the BLOCK node for these statements. */
+DEFTREECODE (BLOCK_STMT, "block_stmt", 's', 2)
/* This is an IF statement. IF_STMT_COND is the condition being tested,
IF_STMT_TRUE is the statement to be executed if the condition is
/* An "asm" statement. The operands are ASM_STMT_TEMPLATE, ASM_STMT_OUTPUT,
ASM_STMT_ORIG_OUT, ASM_STMT_INPUT, and ASM_STMT_CLOBBER. */
DEFTREECODE (ASM_STMT, "asm_stmt", 's', 5)
+
+/* An analog to the C "break" statement. */
+DEFTREECODE (BREAK_STMT, "break_stmt", 's', 0)
#define EXPR_STMT_EXPR(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXPR_STMT, 0)
#define DECL_STMT_VAR(NODE) TREE_OPERAND_CHECK_CODE (NODE, DECL_STMT, 0)
#define BLOCK_STMT_LIST(NODE) TREE_OPERAND_CHECK_CODE (NODE, BLOCK_STMT, 0)
+#define BLOCK_STMT_BLOCK(NODE) TREE_OPERAND_CHECK_CODE (NODE, BLOCK_STMT, 1)
#define IF_STMT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 0)
#define IF_STMT_TRUE(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 1)
#define IF_STMT_ELSEIF(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 2)
procedure Gen_Output_File (Filename : String) is
Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
+ Is_GAP_Version : constant Boolean := Get_Gnat_Build_Type = GAP;
begin
-- Acquire settings for Interrupt_State pragmas
-- Get the time stamp of the former bind for public version warning
- if Is_Public_Version then
+ if Is_Public_Version or Is_GAP_Version then
Record_Time_From_Last_Bind;
end if;
---------------------
procedure Set_Unit_Number (U : Unit_Id) is
- Num_Units : constant Nat := Nat (Units.Table'Last) - Nat (Unit_Id'First);
+ Num_Units : constant Nat := Nat (Units.Last) - Nat (Unit_Id'First);
Unum : constant Nat := Nat (U) - Nat (Unit_Id'First);
begin
if Has_Null_Exclusion
and then not Is_Access_Type (Typ)
then
- Error_Msg_N ("(Ada 0Y) must be an access type", Related_Nod);
+ Error_Msg_N ("(Ada 2005) must be an access type", Related_Nod);
end if;
end Check_Must_Be_Access;
and then Can_Never_Be_Null (Typ)
then
Error_Msg_N
- ("(Ada 0Y) already a null-excluding type", Related_Nod);
+ ("(Ada 2005) already a null-excluding type", Related_Nod);
end if;
end Check_Already_Null_Excluding_Type;
case Msg_K is
when Components =>
Error_Msg_N
- ("(Ada 0Y) null-excluding components must be initialized",
- Related_Nod);
+ ("(Ada 2005) null-excluding components must be " &
+ "initialized", Related_Nod);
when Formals =>
Error_Msg_N
- ("(Ada 0Y) null-excluding formals must be initialized",
+ ("(Ada 2005) null-excluding formals must be initialized",
Related_Nod);
when Objects =>
Error_Msg_N
- ("(Ada 0Y) null-excluding objects must be initialized",
+ ("(Ada 2005) null-excluding objects must be initialized",
Related_Nod);
end case;
end if;
case Msg_K is
when Components =>
Error_Msg_N
- ("(Ada 0Y) NULL not allowed in null-excluding components",
- Expr);
+ ("(Ada 2005) NULL not allowed in null-excluding " &
+ "components", Expr);
when Formals =>
Error_Msg_N
- ("(Ada 0Y) NULL not allowed in null-excluding formals",
+ ("(Ada 2005) NULL not allowed in null-excluding formals",
Expr);
when Objects =>
Error_Msg_N
- ("(Ada 0Y) NULL not allowed in null-excluding objects",
+ ("(Ada 2005) NULL not allowed in null-excluding objects",
Expr);
end case;
end if;
-- will be raised if the value is not valid.
procedure Null_Exclusion_Static_Checks (N : Node_Id);
- -- Ada 0Y (AI-231): Check bad usages of the null-exclusion issue
+ -- Ada 2005 (AI-231): Check bad usages of the null-exclusion issue
procedure Remove_Checks (Expr : Node_Id);
-- Remove all checks from Expr except those that are only executed
Build_Exception (S_Tasking_Error);
-- Numeric_Error is a normal exception in Ada 83, but in Ada 95
- -- it is a renaming of Constraint_Error
+ -- it is a renaming of Constraint_Error. Is this test too early???
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Build_Exception (S_Numeric_Error);
else
gnu_arr_type = TREE_TYPE (gnu_arr_type),
gnu_str_name = concat_id_with_name (gnu_str_name, "ST"))
{
+ tree eltype = TREE_TYPE (gnu_arr_type);
+
TYPE_SIZE (gnu_arr_type)
= elaborate_expression_1 (gnat_entity, gnat_entity,
TYPE_SIZE (gnu_arr_type),
gnu_str_name, definition, 0);
+
+ /* ??? For now, store the size as a multiple of the
+ alignment of the element type in bytes so that we
+ can see the alignment from the tree. */
TYPE_SIZE_UNIT (gnu_arr_type)
- = elaborate_expression_1
- (gnat_entity, gnat_entity, TYPE_SIZE_UNIT (gnu_arr_type),
- concat_id_with_name (gnu_str_name, "U"), definition, 0);
+ = build_binary_op
+ (MULT_EXPR, sizetype,
+ elaborate_expression_1
+ (gnat_entity, gnat_entity,
+ build_binary_op (EXACT_DIV_EXPR, sizetype,
+ TYPE_SIZE_UNIT (gnu_arr_type),
+ size_int (TYPE_ALIGN (eltype)
+ / BITS_PER_UNIT)),
+ concat_id_with_name (gnu_str_name, "A_U"),
+ definition, 0),
+ size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT));
}
}
-- types, i.e. record types (Java classes) that hold pointers to each
-- other. If such a type is an access type, it has no explicit freeze
-- node, so that the back-end does not attempt to elaborate it.
--- Currently this flag is also used to implement Ada0Y (AI-50217).
+-- Currently this flag is also used to implement Ada 2005 (AI-50217).
-- It will be renamed to From_Limited_With after removal of the current
-- GNAT with_type clause???
-- fide package with the limited-view list through the first_entity and
-- first_private attributes. The elements of this list are the shadow
-- entities created for the types and local packages that are declared
--- in a package that appears in a limited_with clause (Ada0Y: AI-50217)
+-- in a package appearing in a limited_with clause (Ada 2005: AI-50217)
-- Lit_Indexes (Node15)
-- Present in enumeration types and subtypes. Non-empty only for the
-- Non_Limited_View (Node17)
-- Present in incomplete types that are the shadow entities created
--- when analyzing a limited_with_clause (Ada0Y: AI-50217). Points to
+-- when analyzing a limited_with_clause (Ada 2005: AI-50217). Points to
-- the defining entity in the original declaration.
-- Nonzero_Is_True (Flag162) [base type only]
Gname4 : aliased constant String := "gnatf";
Vname4 : aliased constant String := "REPORT_ERRORS=FULL";
+ Gname5 : aliased constant String := "gnat05";
+ Vname5 : aliased constant String := "05";
+
type Cstring_Ptr is access constant String;
Gnames : array (Nat range <>) of Cstring_Ptr :=
(Gname1'Access,
Gname2'Access,
Gname3'Access,
- Gname4'Access);
+ Gname4'Access,
+ Gname5'Access);
Vnames : array (Nat range <>) of Cstring_Ptr :=
(Vname1'Access,
Vname2'Access,
Vname3'Access,
- Vname4'Access);
+ Vname4'Access,
+ Vname5'Access);
-----------------------------------------------------
-- Global Values Used for Error Message Insertions --
function Has_Default_Init_Comps (N : Node_Id) return Boolean;
-- N is an aggregate (record or array). Checks the presence of default
- -- initialization (<>) in any component (Ada 0Y: AI-287)
+ -- initialization (<>) in any component (Ada 2005: AI-287)
------------------------------------------------------
-- Local subprograms for Record Aggregate Expansion --
--
-- Otherwise we call Build_Code recursively.
--
- -- Ada 0Y (AI-287): In case of default initialized component, Expr is
- -- empty and we generate a call to the corresponding IP subprogram.
+ -- Ada 2005 (AI-287): In case of default initialized component, Expr
+ -- is empty and we generate a call to the corresponding IP subprogram.
function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id;
-- Nodes L and H must be side-effect free expressions.
Res : List_Id;
begin
- -- Ada 0Y (AI-287): Do nothing else in case of default
+ -- Ada 2005 (AI-287): Do nothing else in case of default
-- initialized component.
if not Present (Expr) then
Set_Assignment_OK (Indexed_Comp);
- -- Ada 0Y (AI-287): In case of default initialized component, Expr
+ -- Ada 2005 (AI-287): In case of default initialized component, Expr
-- is not present (and therefore we also initialize Expr_Q to empty).
if not Present (Expr) then
elsif Present (Next (First (New_Indices))) then
- -- Ada 0Y (AI-287): Do nothing in case of default initialized
+ -- Ada 2005 (AI-287): Do nothing in case of default initialized
-- component because we have received the component type in
-- the formal parameter Ctype.
end if;
end if;
- -- Ada 0Y (AI-287): We only analyze the expression in case of non
+ -- Ada 2005 (AI-287): We only analyze the expression in case of non-
-- default initialized components (otherwise Expr_Q is not present).
if Present (Expr_Q)
end if;
end if;
- -- Ada 0Y (AI-287): In case of default initialized component, call
+ -- Ada 2005 (AI-287): In case of default initialized component, call
-- the initialization subprogram associated with the component type.
if not Present (Expr) then
if Empty_Range (L, H) then
Append_To (S, Make_Null_Statement (Loc));
- -- Ada 0Y (AI-287): Nothing else need to be done in case of
+ -- Ada 2005 (AI-287): Nothing else need to be done in case of
-- default initialized component.
if not Present (Expr) then
if Present (Component_Associations (N)) then
Assoc := Last (Component_Associations (N));
- -- Ada 0Y (AI-287)
+ -- Ada 2005 (AI-287)
if Box_Present (Assoc) then
Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
Selector_Name => Make_Identifier (Loc, Name_uController));
Set_Assignment_OK (Ref);
- -- Ada 0Y (AI-287): Give support to default initialization of limited
- -- types and components.
+ -- Ada 2005 (AI-287): Give support to default initialization of
+ -- limited types and components.
if (Nkind (Target) = N_Identifier
and then Present (Etype (Target))
Check_Ancestor_Discriminants (Entity (A));
end if;
- -- Ada 0Y (AI-287): If the ancestor part is a limited type,
+ -- Ada 2005 (AI-287): If the ancestor part is a limited type,
-- a recursive call expands the ancestor.
elsif Is_Limited_Type (Etype (A)) then
while Present (Comp) loop
Selector := Entity (First (Choices (Comp)));
- -- Ada 0Y (AI-287): Default initialization of a limited component
+ -- Ada 2005 (AI-287): Default initialization of a limited component
if Box_Present (Comp)
and then Is_Limited_Type (Etype (Selector))
then
- -- Ada 0Y (AI-287): If the component type has tasks then generate
- -- the activation chain and master entities (except in case of an
- -- allocator because in that case these entities are generated
- -- by Build_Task_Allocate_Block_With_Init_Stmts).
+ -- Ada 2005 (AI-287): If the component type has tasks then
+ -- generate the activation chain and master entities (except
+ -- in case of an allocator because in that case these entities
+ -- are generated by Build_Task_Allocate_Block_With_Init_Stmts).
declare
Ctype : constant Entity_Id := Etype (Selector);
-- Start of processing for Convert_To_Positional
begin
- -- Ada 0Y (AI-287): Do not convert in case of default initialized
+ -- Ada 2005 (AI-287): Do not convert in case of default initialized
-- components because in this case will need to call the corresponding
-- IP procedure.
if Has_Default_Init_Comps (N) then
- -- Ada 0Y (AI-287): This case has not been analyzed???
+ -- Ada 2005 (AI-287): This case has not been analyzed???
raise Program_Error;
end if;
then
Convert_To_Assignments (N, Typ);
- -- Ada 0Y (AI-287): In case of default initialized components we convert
- -- the aggregate into assignments.
+ -- Ada 2005 (AI-287): In case of default initialized components we
+ -- convert the aggregate into assignments.
elsif Has_Default_Init_Comps (N) then
Convert_To_Assignments (N, Typ);
Append_To (Args, Make_Identifier (Loc, Name_uChain));
- -- Ada 0Y (AI-287): In case of default initialized components
+ -- Ada 2005 (AI-287): In case of default initialized components
-- with tasks, we generate a null string actual parameter.
-- This is just a workaround that must be improved later???
end if;
end if;
- -- Ada 0Y (AI-287) In case of default initialized components, we
- -- need to generate the corresponding selected component node
+ -- Ada 2005 (AI-287) In case of default initialized components,
+ -- we need to generate the corresponding selected component node
-- to access the discriminant value. In other cases this is not
-- required because we are inside the init proc and we use the
-- corresponding formal.
Exp := New_Copy_Tree (Original_Node (Exp));
end if;
- -- Ada 0Y (AI-231): Generate conversion to the null-excluding
+ -- Ada 2005 (AI-231): Generate conversion to the null-excluding
-- type to force the corresponding run-time check
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then Can_Never_Be_Null (Etype (Id)) -- Lhs
- and then (Present (Etype (Exp))
- and then not Can_Never_Be_Null (Etype (Exp)))
+ and then Present (Etype (Exp))
+ and then not Can_Never_Be_Null (Etype (Exp))
then
- Rewrite (Exp, Convert_To (Etype (Id),
- Relocate_Node (Exp)));
+ Rewrite (Exp, Convert_To (Etype (Id), Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Etype (Id));
end if;
elsif Is_Access_Type (Typ) then
- -- Ada 0Y (AI-231): Generate conversion to the null-excluding
+ -- Ada 2005 (AI-231): Generate conversion to the null-excluding
-- type to force the corresponding run-time check
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then (Can_Never_Be_Null (Def_Id)
- or else Can_Never_Be_Null (Typ))
+ or else Can_Never_Be_Null (Typ))
then
- Rewrite (Expr_Q, Convert_To (Etype (Def_Id),
- Relocate_Node (Expr_Q)));
+ Rewrite
+ (Expr_Q,
+ Convert_To (Etype (Def_Id), Relocate_Node (Expr_Q)));
Analyze_And_Resolve (Expr_Q, Etype (Def_Id));
end if;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
In_Init_Proc : Boolean := False;
Enclos_Type : Entity_Id := Empty;
Discr_Map : Elist_Id := New_Elmt_List;
- With_Default_Init : Boolean := False)
- return List_Id;
+ With_Default_Init : Boolean := False) return List_Id;
-- Builds a call to the initialization procedure of the Id entity. Id_Ref
-- is either a new reference to Id (for record fields), or an indexed
-- component (for array elements). Loc is the source location for the
-- can appear within expressions in array bounds (not as stand-alone
-- identifiers) and a general replacement is necessary.
--
- -- Ada0Y (AI-287): With_Default_Init is used to indicate that the initia-
- -- lization call corresponds to a default initialized component of an
- -- aggregate.
+ -- Ada 2005 (AI-287): With_Default_Init is used to indicate that the
+ -- initialization call corresponds to a default initialized component
+ -- of an aggregate.
procedure Freeze_Type (N : Node_Id);
-- This procedure executes the freezing actions associated with the given
function Get_Simple_Init_Val
(T : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id;
+ Loc : Source_Ptr) return Node_Id;
-- For a type which Needs_Simple_Initialization (see above), prepares
-- the tree for an expression representing the required initial value.
-- Loc is the source location used in constructing this tree which is
is
Loc : constant Source_Ptr := Sloc (Nod);
+ Result : Node_Id;
+ C : Entity_Id;
+
+ First_Time : Boolean := True;
+
function Suitable_Element (C : Entity_Id) return Entity_Id;
-- Return the first field to compare beginning with C, skipping the
- -- inherited components
+ -- inherited components.
+
+ ----------------------
+ -- Suitable_Element --
+ ----------------------
function Suitable_Element (C : Entity_Id) return Entity_Id is
begin
end if;
end Suitable_Element;
- Result : Node_Id;
- C : Entity_Id;
-
- First_Time : Boolean := True;
-
-- Start of processing for Expand_Record_Equality
begin
C := Suitable_Element (First_Entity (Typ));
while Present (C) loop
-
declare
New_Lhs : Node_Id;
New_Rhs : Node_Id;
First_Time := False;
New_Lhs := Lhs;
New_Rhs := Rhs;
-
else
New_Lhs := New_Copy_Tree (Lhs);
New_Rhs := New_Copy_Tree (Rhs);
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Pool : constant Entity_Id := Associated_Storage_Pool (Typ);
- Pnod : Node_Id := Parent (N);
+ Pnod : constant Node_Id := Parent (N);
function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
-- Return true if type of P is derived from Checked_Pool;
begin
pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
- -- Do not recursively add a dereference check for the
- -- attribute references contained within the generated check.
-
- if not Comes_From_Source (Pnod)
- and then Nkind (Pnod) = N_Explicit_Dereference
- and then Nkind (Parent (Pnod)) = N_Attribute_Reference
- and then (Attribute_Name (Parent (Pnod)) = Name_Size
- or else Attribute_Name (Parent (Pnod)) = Name_Alignment)
+ if not (Is_Checked_Storage_Pool (Pool)
+ and then Comes_From_Source (Original_Node (Pnod)))
then
return;
-
- elsif not Is_Checked_Storage_Pool (Pool) then
- return;
end if;
- -- Do not generate a dereference check for the object passed
- -- to an init proc: such a check is not desired (we know for
- -- sure that a valid dereference is passed to init procs,
- -- and the calls to 'Size and 'Alignment containent in the
- -- dereference check would be erroneous anyway if the init proc
- -- has not been executed yet.)
-
- while Present (Pnod) loop
- if Nkind (Pnod) = N_Procedure_Call_Statement
- and then Is_Entity_Name (Name (Pnod))
- and then Is_Init_Proc (Name (Pnod))
- then
- return;
- end if;
-
- Pnod := Parent (Pnod);
- exit when Nkind (Pnod) not in N_Subexpr;
- end loop;
-
Insert_Action (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
-- hand side of an assignment, and this function determines if there
-- is a record component reference where the record may be bit aligned
-- in a manner that causes trouble for the back end (see description
- -- of Sem_Util.Component_May_Be_Bit_Aligned for further details).
+ -- of Exp_Util.Component_May_Be_Bit_Aligned for further details).
------------------------------
-- Change_Of_Representation --
(Expression (Rhs), Designated_Type (Etype (Lhs)));
end if;
- -- Ada 0Y (AI-231): Generate conversion to the null-excluding
+ -- Ada 2005 (AI-231): Generate conversion to the null-excluding
-- type to force the corresponding run-time check
if Is_Access_Type (Typ)
- and then ((Is_Entity_Name (Lhs)
- and then Can_Never_Be_Null (Entity (Lhs)))
- or else Can_Never_Be_Null (Etype (Lhs)))
+ and then
+ ((Is_Entity_Name (Lhs) and then Can_Never_Be_Null (Entity (Lhs)))
+ or else Can_Never_Be_Null (Etype (Lhs)))
then
Rewrite (Rhs, Convert_To (Etype (Lhs),
Relocate_Node (Rhs)));
elsif Convention (Subp) = Convention_Java then
null;
- -- Ada 0Y (AI-231): do not force the check in case of Ada 0Y unless
- -- it is a null-excluding type
+ -- Ada 2005 (AI-231): do not force the check in case of Ada 2005
+ -- unless it is a null-excluding type
- elsif not Extensions_Allowed
+ elsif Ada_Version < Ada_05
or else Can_Never_Be_Null (Etype (Prev))
then
Cond :=
begin
S := Scope (E);
- -- Ada 0Y (AI-287): Do not set/get the has_master_entity reminder in
- -- internal scopes. Required for nested limited aggregates.
+ -- Ada 2005 (AI-287): Do not set/get the has_master_entity reminder
+ -- in internal scopes. Required for nested limited aggregates.
- if Extensions_Allowed then
+ if Ada_Version >= Ada_05 then
while Is_Internal (S) loop
S := Scope (S);
end loop;
Insert_Before (P, Decl);
Analyze (Decl);
- -- Ada 0Y (AI-287): Set the has_master_entity reminder in the
+ -- Ada 2005 (AI-287): Set the has_master_entity reminder in the
-- non-internal scope selected above.
- if not Extensions_Allowed then
- Set_Has_Master_Entity (Scope (E));
- else
+ if Ada_Version >= Ada_05 then
Set_Has_Master_Entity (S);
+ else
+ Set_Has_Master_Entity (Scope (E));
end if;
-- Now mark the containing scope as a task master
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
(Actions : List_Id;
N : Node_Id;
Init_Stmts : List_Id);
- -- Ada0Y (AI-287): Similar to previous routine, but used to expand alloca-
- -- ted aggregates with default initialized components. Init_Stmts contains
- -- the list of statements required to initialize the allocated aggregate.
- -- It replaces the call to Init (Args) done by Build_Task_Allocate_Block.
+ -- Ada 2005 (AI-287): Similar to previous routine, but used to expand
+ -- allocated aggregates with default initialized components. Init_Stmts
+ -- contains the list of statements required to initialize the allocated
+ -- aggregate. It replaces the call to Init (Args) done by
+ -- Build_Task_Allocate_Block.
function Concurrent_Ref (N : Node_Id) return Node_Id;
-- Given the name of a concurrent object (task or protected object), or
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- are never static).
if Is_OK_Static_Expression (Temp)
- or else (Ada_83 and then Nkind (Temp) = N_String_Literal)
+ or else (Ada_Version = Ada_83
+ and then Nkind (Temp) = N_String_Literal)
then
return Get_String_Node (Temp);
-- Get_External_Name --
-----------------------
- procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean)
- is
+ procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean) is
E : Entity_Id := Entity;
Kind : Entity_Kind;
package body GNAT.OS_Lib is
+ OpenVMS : Boolean;
+ -- Note: OpenVMS should be a constant, but it cannot be, because it
+ -- prevents bootstrapping on some platforms.
+
+ pragma Import (Ada, OpenVMS, "system__openvms");
+ -- Needed to avoid doing useless checks when non on a VMS platform (see
+ -- Normalize_Pathname).
+
package SSL renames System.Soft_Links;
-- The following are used by Create_Temp_File
-- Resolving logical names from VMS.
-- If we have a Unix path on VMS such as /temp/..., and TEMP is a
-- logical name, we need to resolve this logical name.
- -- As we have no means to know if we are on VMS, we need to do that
- -- for absolute paths starting with '/'.
-- We find the directory, change to it, get the current directory,
-- and change the directory to this value.
- if Path_Buffer (1) = '/' then
+ if OpenVMS and then Path_Buffer (1) = '/' then
declare
Cur_Dir : String := Get_Directory ("");
-- Save the current directory, so that we can change dir back to
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2004 Ada Core Technologies, 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- --
-- Run-time symbolic traceback support
-- Note: this is only available on selected targets. Currently it is
--- supported on Sparc/Solaris, GNU/Linux, Windows NT, HP-UX and Tru64.
+-- supported on Sparc/Solaris, GNU/Linux, Windows NT, HP-UX, VMS and Tru64.
-- The routines provided in this package assume that your application has
-- been compiled with debugging information turned on, since this information
-- need to be provided when launching the executable), and load then in
-- memory, causing a significant cpu and memory overhead.
--- This package is not intended to be used within a shared library,
--- symbolic tracebacks are only supported for the main executable
--- and not for shared libraries.
+-- On all platforms except VMS, this package is not intended to be used
+-- within a shared library, symbolic tracebacks are only supported for the
+-- main executable and not for shared libraries.
+-- You should consider using gdb to obtain symbolic traceback in such cases.
--- You should consider using off-line symbolic traceback instead, using
--- addr2line or gdb.
+-- On VMS, there is no restriction on using this facility with shared
+-- libraries. However, the OS should be at least v7.3-1 and OS patch
+-- VMS731_TRACE-V0100 must be applied in order to use this package.
with Ada.Exceptions; use Ada.Exceptions;
is in reverse order (it has to be so for back-end compatibility). */
extern tree getdecls (void);
-/* Enter and exit a new binding level. */
+/* Enter and exit a new binding level. We return the BLOCK node, if any
+ when we exit a binding level. */
extern void gnat_pushlevel (void);
-extern void gnat_poplevel (void);
+extern tree gnat_poplevel (void);
/* Insert BLOCK at the end of the list of subblocks of the
current binding level. This is used when a BIND_EXPR is expanded,
-- a junk spec as not needing a body when it really does).
if Main_Kind = N_Package_Declaration
- and then Ada_83
+ and then Ada_Version = Ada_83
and then Operating_Mode = Generate_Code
and then Distribution_Stub_Mode /= Generate_Caller_Stub_Body
and then not Compilation_Errors
If the compilation unit
contained in the input source depends semantically upon units located
outside the current directory, you have to provide the source search path
-when invoking @command{gnatpp}; see the description of the @command{gnatpp}
-switches below.
+when invoking @command{gnatpp}, if these units are contained in files with
+names that do not follow the GNAT file naming rules, you have to provide
+the configuration file describing the corresponding naming scheme;
+see the description of the @command{gnatpp}
+switches below. Another possibility is to use a project file and to
+call @command{gnatpp} through the @command{gnat} driver
The @command{gnatpp} command has the form
@cindex Library, building, installing, using
@noindent
-This chapter addresses the issues related to building and using
-libraries with GNAT. It also shows how the GNAT run-time library can be
-recompiled. It is recommended that the user understands how to use the
-@ref{GNAT Project Manager} facility before reading this chapter.
+This chapter describes how to build and use
+libraries with GNAT, and also shows how to recompile the GNAT run-time library.
+You should be familiar with the
+Project Manager facility (see @ref{GNAT Project Manager}) before reading this
+chapter.
@menu
* Introduction to Libraries in GNAT::
applications that use it. A library can be either statically linked with the
application, in which case its code is directly included in the application,
or, on platforms that support it, be dynamically linked, in which case
-its code is shared by all applications making use of this library. GNAT
-supports both types of libraries. In the static case, the compiled code can
-be provided in different ways. The simplest way is to provide directly the
-set of objects produced by the compiler during the compilation of the library.
-It is also possible to group the objects into an archive using whatever
-commands are provided by the operating system. For the later case, the objects
-are grouped into a shared library.
+its code is shared by all applications making use of this library.
+
+GNAT supports both types of libraries.
+In the static case, the compiled code can be provided in different ways.
+The simplest approach is to provide directly the
+set of objects resulting from compilation of the library source files.
+Alternatively, you can group the objects into an archive using whatever
+commands are provided by the operating system. For the latter case,
+the objects are grouped into a shared library.
In the GNAT environment, a library has two types of components:
@itemize @bullet
@item
Source files.
@item
-Compiled code and Ali files. See @ref{The Ada Library Information Files}.
+Compiled code and @file{ALI} files.
+See @ref{The Ada Library Information Files}.
@end itemize
@noindent
-GNAT libraries can either completely expose their source files to the
-compilation context of the user's application, or alternatively only expose
-a limited set of source files, called interface units, in which case they are
-called @ref{Stand-alone Ada Libraries}. In addition, GNAT provides full support
-for foreign libraries which are only available in the object format.
+A GNAT library may either completely expose its source files to the
+compilation context of the user's application.
+Alternatively, it may expose
+a limited subset of its source files, called @emph{interface units},
+in which case the library is referred to as a @emph{stand-alone library}
+(see @ref{Stand-alone Ada Libraries}). In addition, GNAT fully supports
+foreign libraries, which are only available in the object format.
-Ada semantics requires that all compilation units comprising the application
-are elaborated in the timely fashion. Where possible, GNAT provides facilities
+All compilation units comprising
+an application are elaborated, in an order partially defined by Ada language
+semantics.
+Where possible, GNAT provides facilities
to ensure that compilation units of a library are automatically elaborated;
however, there are cases where this must be responsibility of a user. This will
-be addressed in greater detail further on.
+be addressed in greater detail below.
@node General Ada Libraries
@section General Ada Libraries
@subsection Building the library
@noindent
-The easiest way to build a library is to use the @ref{GNAT Project Manager},
-which supports a special type of projects called @ref{Library Projects}.
+The easiest way to build a library is to use the Project Manager,
+which supports a special type of projects called Library Projects
+(see @ref{Library Projects}).
A project is considered a library project, when two project-level attributes
are defined in it: @code{Library_Name} and @code{Library_Dir}. In order to
control different aspects of library configuration, additional optional
project-level attributes can be specified:
-@itemize
-@item @code{Library_Kind}
+@table @code
+@item Library_Kind
This attribute controls whether the library is to be static or shared
-@item @code{Library_Version}
+
+@item Library_Version
This attribute specifies what is the library version; this value is used
during dynamic linking of shared libraries to determine if the currently
installed versions of the binaries are compatible.
-@item @code{Library_Options}, @code{Library_GCC}
+
+@item Library_Options
+@item Library_GCC
These attributes specify additional low-level options to be used during
library generation, and redefine the actual application used to generate
library.
-@end itemize
+@end table
@noindent
-GNAT Project Manager takes full care of the library maintenance task,
+The GNAT Project Manager takes full care of the library maintenance task,
including recompilation of the source files for which objects do not exist
or are not up to date, assembly of the library archive, and installation of
-the library, i.e. the copy of associated source, object and ALI files to the
-specific location.
+the library, i.e. copying associated source, object and @file{ALI} files
+to the specified location.
-It is not entirely trivial to correctly do all the steps required to
-produce a library. We recommend that you use @ref{GNAT Project Manager}
+It is not entirely trivial to correctly perform all the steps required to
+produce a library. We recommend that you use the GNAT Project Manager
for this task. In special cases where this is not desired, the necessary
steps are discussed below.
There are various possibilities for compiling the units that make up the
-library: for example with a Makefile @ref{Using the GNU make Utility},
+library: for example with a Makefile (see @ref{Using the GNU make Utility})
or with a conventional script.
For simple libraries, it is also possible to create a
dummy main program which depends upon all the packages that comprise the
interface of the library. This dummy main program can then be given to
-gnatmake, which will ensure that all necessary objects are built.
+@command{gnatmake}, which will ensure that all necessary objects are built.
-After this task is accomplished, the user should follow the standard procedure
+After this task is accomplished, you should follow the standard procedure
of the underlying operating system to produce the static or shared library.
-Below is an example of such a dummy program and the generic commands used to
-build an archive or a shared library.
-
+Here is an example of such a dummy program:
@smallexample @c ada
-@iftex
-@leftskip=.7cm
-@end iftex
+@group
with My_Lib.Service1;
with My_Lib.Service2;
with My_Lib.Service3;
begin
null;
end;
+@end group
@end smallexample
+@noindent
+Here are the generic commands that will build an archive or a shared library.
+
@smallexample
# compiling the library
$ gnatmake -c my_lib_dummy.adb
# Make the ALI files read-only so that gnatmake will not try to
# regenerate the objects that are in the library
$ chmod -w *.ali
-
@end smallexample
@noindent
-Please note that the library must have a name of the form libxxx.a or
-libxxx.so in order to be accessed by the directive -lxxx at link
-time.
+Please note that the library must have a name of the form @file{libxxx.a} or
+@file{libxxx.so} in order to be accessed by the directive @option{-lxxx}
+at link time.
@node Installing the library
@subsection Installing the library
In the GNAT model, installing a library consists in copying into a specific
location the files that make up this library. When the library is built using
projects, it is automatically installed in the location specified in the
-project by means of the attribute @code{Library_Dir}, otherwise it is
-responsibility of the user. GNAT also supports installing the sources in a
-different directory from the other files (ALI, objects, archives) since the
-source path and the object path can be specified separately.
-
-For general purpose libraries, it is possible for the system
-administrator to put those libraries in the default compiler paths. To
-achieve this, he must specify their location in the configuration files
-@file{ada_source_path} and @file{ada_object_path} that must be located in
-the GNAT
+project by means of the attribute @code{Library_Dir},
+otherwise the user must specify the destination.
+GNAT also supports installing the sources in a
+different directory from the other files (@file{ALI}, objects, archives)
+since the source path and the object path can be specified separately.
+
+The system administrator can place general purpose libraries in the default
+compiler paths, by specifying the libraries' location in the configuration
+files @file{ada_source_path} and @file{ada_object_path}.
+These configuration files must be located in the GNAT
installation tree at the same place as the gcc spec file. The location of
the gcc spec file can be determined as follows:
@smallexample
@end smallexample
@noindent
-The configuration files mentioned above have simple format: each line in them
-must contain one unique
-directory name. Those names are added to the corresponding path
+The configuration files mentioned above have a simple format: each line
+must contain one unique directory name.
+Those names are added to the corresponding path
in their order of appearance in the file. The names can be either absolute
-or relative, in the latter case, they are relative to where theses files
+or relative; in the latter case, they are relative to where theses files
are located.
-@file{ada_source_path} and @file{ada_object_path} might actually not be
+The files @file{ada_source_path} and @file{ada_object_path} might not be
present in a
GNAT installation, in which case, GNAT will look for its run-time library in
-he directories @file{adainclude} for the sources and @file{adalib} for the
-objects and @file{ALI} files. When the files exist, the compiler does not
-look in @file{adainclude} and @file{adalib} at all, and thus the
+the directories @file{adainclude} (for the sources) and @file{adalib} (for the
+objects and @file{ALI} files). When the files exist, the compiler does not
+look in @file{adainclude} and @file{adalib}, and thus the
@file{ada_source_path} file
must contain the location for the GNAT run-time sources (which can simply
be @file{adainclude}). In the same way, the @file{ada_object_path} file must
contain the location for the GNAT run-time objects (which can simply
be @file{adalib}).
-You can also specify a new default path to the runtime library at compilation
-time with the switch @option{--RTS=rts-path}. You can easily choose and change
-the runtime you want your program to be compiled with. This switch is
-recognized by gcc, gnatmake, gnatbind, gnatls, gnatfind and gnatxref.
+You can also specify a new default path to the run-time library at compilation
+time with the switch @option{--RTS=rts-path}. You can thus choose / change
+the run-time library you want your program to be compiled with. This switch is
+recognized by @command{gcc}, @command{gnatmake}, @command{gnatbind},
+@command{gnatls}, @command{gnatfind} and @command{gnatxref}.
It is possible to install a library before or after the standard GNAT
library, by reordering the lines in the configuration files. In general, a
@noindent
Once again, the project facility greatly simplifies the addition of libraries
to the compilation. If the project file for an application lists a library
-project in its @code{with} clause, the project manager will ensure that the
-library files are consistent, and are considered during compilation and
-linking of the main application.
+project in its @code{with} clause, the Project Manager will ensure that the
+library files are consistent, and that they are considered during the
+compilation and linking of the application.
-Even if you have a third-party, non-Ada library, you can still use GNAT
-Project facility to provide a wrapper for it. The following project for
-example, when "withed" in your main project, will link with the third-party
-library liba.a:
+Even if you have a third-party, non-Ada library, you can still use GNAT's
+Project Manager facility to provide a wrapper for it. The following project for
+example, when @code{with}ed in your main project, will link with the
+third-party library @file{liba.a}:
@smallexample @c projectfile
@group
@noindent
In order to use an Ada library manually, you need to make sure that this
library is on both your source and object path
-@ref{Search Paths and the Run-Time Library (RTL)}
-and @ref{Search Paths for gnatbind}. Furthermore, when the objects are grouped
-in an archive or a shared library, the user needs to specify the desired
+(see @ref{Search Paths and the Run-Time Library (RTL)},
+and @ref{Search Paths for gnatbind}). Furthermore, when the objects are grouped
+in an archive or a shared library, you need to specify the desired
library at link time.
-By means of example, you can use the library @file{mylib} installed in
+For example, you can use the library @file{mylib} installed in
@file{/dir/my_lib_src} and @file{/dir/my_lib_obj} with the following commands:
@smallexample
@end smallexample
@noindent
-This can be simplified down to the following:
+This can be expressed more simply:
@smallexample
$ gnatmake my_appl
@end smallexample
+@noindent
when the following conditions are met:
@itemize @bullet
@item
variable @code{ADA_OBJECTS_PATH}, or by the administrator to the file
@file{ada_object_path}
@item
-a pragma @code{Linker_Options}, has been added to one of the sources.
+a pragma @code{Linker_Options} has been added to one of the sources.
For example:
@smallexample @c ada
@cindex Stand-alone library, building, using
@menu
-* Introduction to Stand-Alone Libraries::
-* Building SAL::
-* Creating SAL to be used in a non-Ada context::
-* Restrictions in SALs::
+* Introduction to Stand-alone Libraries::
+* Building a Stand-alone Library::
+* Creating a Stand-alone Library to be used in a non-Ada context::
+* Restrictions in Stand-alone Libraries::
@end menu
-@node Introduction to Stand-Alone Libraries
-@subsection Introduction to Stand-Alone Libraries
+@node Introduction to Stand-alone Libraries
+@subsection Introduction to Stand-alone Libraries
@noindent
A Stand-alone Library (SAL) is a library that contains the necessary code to
-elaborate the Ada units that are included in the library. Different from
-ordinary libraries, which consist of all sources, objects and ALI files of the
-library, the SAL creator can specify a restricted subset of compilation units
-comprising SAL to serve as a library interface. In this case, the fully
-self-sufficient set of files of such library will normally consist of objects
-archive, sources of interface units specs, and ALI files of interface units.
-Note that if interface specs contain generics or inlined subprograms, body
+elaborate the Ada units that are included in the library. In contrast with
+an ordinary library, which consists of all sources, objects and @file{ALI}
+files of the
+library, a SAL may specify a restricted subset of compilation units
+to serve as a library interface. In this case, the fully
+self-sufficient set of files will normally consist of an objects
+archive, the sources of interface units' specs, and the @file{ALI}
+files of interface units.
+If an interface spec contains a generic unit or an inlined subprogram,
+the body's
source must also be provided; if the units that must be provided in the source
-form depend on other units, the source and ALIs of those must also be provided.
+form depend on other units, the source and @file{ALI} files of those must
+also be provided.
-The main purpose of SAL is to minimize the recompilation overhead of client
-applications when the new version of the library is installed. Specifically,
+The main purpose of a SAL is to minimize the recompilation overhead of client
+applications when a new version of the library is installed. Specifically,
if the interface sources have not changed, client applications do not need to
-be recompiled. If, furthermore, SAL is provided in the shared form and its
-version, controlled by @code{Library_Version} attribute, is not changed, the
-clients don't need to be relinked, either.
+be recompiled. If, furthermore, a SAL is provided in the shared form and its
+version, controlled by @code{Library_Version} attribute, is not changed,
+then the clients do not need to be relinked.
-SALs also allow the library providers to minimize amount of library source
-text exposed to the clients, which might be necessary for different reasons.
+SALs also allow the library providers to minimize the amount of library source
+text exposed to the clients. Such ``information hiding'' might be useful or
+necessary for various reasons.
-Stand-alone libraries are also well suited to be used in an executable which
-main is not written in Ada.
+Stand-alone libraries are also well suited to be used in an executable whose
+main routine is not written in Ada.
-@node Building SAL
-@subsection Building SAL
+@node Building a Stand-alone Library
+@subsection Building a Stand-alone Library
@noindent
-GNAT Project facility provides a simple way of building and installing
-stand-alone libraries, see @ref{Stand-alone Library Projects}.
+GNAT's Project facility provides a simple way of building and installing
+stand-alone libraries; see @ref{Stand-alone Library Projects}.
To be a Stand-alone Library Project, in addition to the two attributes
that make a project a Library Project (@code{Library_Name} and
-@code{Library_Dir}, see @ref{Library Projects}), the attribute
-@code{Library_Interface} must be defined.
+@code{Library_Dir}; see @ref{Library Projects}), the attribute
+@code{Library_Interface} must be defined. For example:
@smallexample @c projectfile
@group
@end group
@end smallexample
+@noindent
Attribute @code{Library_Interface} has a non empty string list value,
each string in the list designating a unit contained in an immediate source
of the project file.
When a Stand-alone Library is built, first the binder is invoked to build
a package whose name depends on the library name
-(^b~dummy.ads/b^B$DUMMY.ADS/B^ in the example above).
+(@file{^b~dummy.ads/b^B$DUMMY.ADS/B^} in the example above).
This binder-generated package includes initialization and
finalization procedures whose
-names depend on the library name (dummyinit and dummyfinal in the example
+names depend on the library name (@code{dummyinit} and @code{dummyfinal}
+in the example
above). The object corresponding to this package is included in the library.
-The user must ensure timely (e.g. prior to any use of interfaces in the SAL)
-calling of these procedures if static SAL is built, or shared SAL is built
-with project-level attribute @code{Library_Auto_Init} set to "false".
+You must ensure timely (e.g., prior to any use of interfaces in the SAL)
+calling of these procedures if a static SAL is built, or if a shared SAL
+is built
+with the project-level attribute @code{Library_Auto_Init} set to
+@code{"false"}.
For a Stand-Alone Library, only the @file{ALI} files of the Interface Units
(those that are listed in attribute @code{Library_Interface}) are copied to
imported from Ada units outside of the library. If other units are imported,
the binding phase will fail.
-The attribute @code{Library_Src_Dir}, may be specified for a
+The attribute @code{Library_Src_Dir} may be specified for a
Stand-Alone Library. @code{Library_Src_Dir} is a simple attribute that has a
single string value. Its value must be the path (absolute or relative to the
project directory) of an existing directory. This directory cannot be the
object directory or one of the source directories, but it can be the same as
the library directory. The sources of the Interface
-Units of the library, necessary to an Ada client of the library, will be
-copied to the designated directory, called Interface Copy directory.
+Units of the library that are needed by an Ada client of the library will be
+copied to the designated directory, called the Interface Copy directory.
These sources includes the specs of the Interface Units, but they may also
include bodies and subunits, when pragmas @code{Inline} or @code{Inline_Always}
-are used, or when there is a generic units in the spec. Before the sources
+are used, or when there is a generic unit in the spec. Before the sources
are copied to the Interface Copy directory, an attempt is made to delete all
files in the Interface Copy directory.
-Building stand-alone libraries by hand is difficult. Below are listed the steps
-necessary to be done by the user:
+Building stand-alone libraries by hand is somewhat tedious, but for those
+occasions when it is necessary here are the steps that you need to perform:
@itemize @bullet
@item
-compile all library sources
+Compile all library sources.
+
@item
-invoke the binder with the switch -n (No Ada main program),
-with all the ALI files of the interfaces, and
-with the switch -L to give specific names to the init and final
-procedure.
+Invoke the binder with the switch @option{-n} (No Ada main program),
+with all the @file{ALI} files of the interfaces, and
+with the switch @option{-L} to give specific names to the @code{init}
+and @code{final} procedures. For example:
@smallexample
gnatbind -n int1.ali int2.ali -Lsal1
@end smallexample
+
@item
-compile the binder generated file
+Compile the binder generated file:
@smallexample
gcc -c b~int2.adb
@end smallexample
+
@item
-link the dynamic library with all the necessary object files,
-indicating to the linker the names of the init (and possibly
-final) procedures for automatic initialization (and finalization).
-The built library should be put in a directory different from
+Link the dynamic library with all the necessary object files,
+indicating to the linker the names of the @code{init} (and possibly
+@code{final}) procedures for automatic initialization (and finalization).
+The built library should be placed in a directory different from
the object directory.
+
@item
-copy the ALI files of the interface to the library directory,
-add in the copy the indication that it is an interface to a SAL
-(i.e. add a word @option{SL} on the line in ALI file that starts
-with letter P) and make the modified copy of the ALI file read-only.
+Copy the @code{ALI} files of the interface to the library directory,
+add in this copy an indication that it is an interface to a SAL
+(i.e. add a word @option{SL} on the line in the @file{ALI} file that starts
+with letter ``P'') and make the modified copy of the @file{ALI} file
+read-only.
@end itemize
@noindent
Using SALs is not different from using other libraries
(see @ref{Using the library}).
-@node Creating SAL to be used in a non-Ada context
-@subsection Creating SAL to be used in a non-Ada context
+@node Creating a Stand-alone Library to be used in a non-Ada context
+@subsection Creating a Stand-alone Library to be used in a non-Ada context
@noindent
-It is easy to adapt SAL build procedure discussed above for use of SAL in
+It is easy to adapt the SAL build procedure discussed above for use of a SAL in
a non-Ada context.
The only extra step required is to ensure that library interface subprograms
@noindent
On the foreign language side, you must provide a ``foreign'' view of the
-library interface; remeber that it should contain elaboration routines in
-addition to interface subrporams.
+library interface; remember that it should contain elaboration routines in
+addition to interface subprograms.
The example below shows the content of @code{mylib_interface.h} (note
that there is no rule for the naming of this file, any name can be used)
libraries can be used simultaneously, as long as the elaboration
procedure of each library is called.
-Below is an example of C program that uses our @code{mylib} library.
+Below is an example of C program that uses the @code{mylib} library.
@smallexample
#include "mylib_interface.h"
@noindent
Note that invoking any library finalization procedure generated by
-@code{gnatbind} shuts down the Ada run time permanently. Consequently, the
+@code{gnatbind} shuts down the Ada run-time environment.
+Consequently, the
finalization of all Ada libraries must be performed at the end of the program.
-No call to these libraries nor the Ada run time should be made past the
-finalization phase.
+No call to these libraries nor to the Ada run-time library should be made
+after the finalization phase.
-@node Restrictions in SALs
-@subsection Restrictions in SALs
+@node Restrictions in Stand-alone Libraries
+@subsection Restrictions in Stand-alone Libraries
@noindent
The pragmas listed below should be used with caution inside libraries,
@item pragma @code{Task_Dispatching_Policy}
@item pragma @code{Unreserve_All_Interrupts}
@end itemize
+
+@noindent
When using a library that contains such pragmas, the user must make sure
that all libraries use the same pragmas with the same values. Otherwise,
-a @code{Program_Error} will
+@code{Program_Error} will
be raised during the elaboration of the conflicting
libraries. The usage of these pragmas and its consequences for the user
should therefore be well documented.
-Similarly, the traceback in exception occurrences mechanism should be
+Similarly, the traceback in the exception occurrence mechanism should be
enabled or disabled in a consistent manner across all libraries.
-Otherwise, a Program_Error will be raised during the elaboration of the
+Otherwise, Program_Error will be raised during the elaboration of the
conflicting libraries.
-If the @code{'Version} and @code{'Body_Version}
-attributes are used inside a library, then it is necessary to
-perform a @code{gnatbind} step that mentions all @file{ALI} files in all
+If the @code{Version} or @code{Body_Version}
+attributes are used inside a library, then you need to
+perform a @code{gnatbind} step that specifies all @file{ALI} files in all
libraries, so that version identifiers can be properly computed.
In practice these attributes are rarely used, so this is unlikely
to be a consideration.
@noindent
On AIX, the resolver library initializes some internal structure on
the first call to @code{get*by*} functions, which are used to implement
-@code{GNAT.Sockets.Get_Host_By_Name} and @code{GNAT.Sockets.Get_Host_By_Addrss}.
+@code{GNAT.Sockets.Get_Host_By_Name} and
+@code{GNAT.Sockets.Get_Host_By_Addrss}.
If such initialization occurs within an Ada task, and the stack size for
the task is the default size, a stack overflow may occur.
To avoid this overflow, the user should either ensure that the first call
-to @code{GNAT.Sockets.Get_Host_By_Name} or @code{GNAT.Sockets.Get_Host_By_Addrss}
+to @code{GNAT.Sockets.Get_Host_By_Name} or
+@code{GNAT.Sockets.Get_Host_By_Addrss}
occurs in the environment task, or use @code{pragma Storage_Size} to
specify a sufficiently large size for the stack of the task that contains
this call.
to standard output the list of entry points in the DLL. Note that if
some routines in the DLL have the @code{Stdcall} convention
(@pxref{Windows Calling Conventions}) with stripped @code{@@}@i{nn}
-suffix then you'll have to edit @file{api.def} to add it.
+suffix then you'll have to edit @file{api.def} to add it, and specify
+@code{-k} to @code{gnatdll} when creating the import library.
@noindent
Here are some hints to find the right @code{@@}@i{nn} suffix.
@item -k
@cindex @option{-k} (@code{gnatdll})
Removes the @code{@@}@i{nn} suffix from the import library's exported
-names. You must specified this option if you want to use a
-@code{Stdcall} function in a DLL for which the @code{@@}@i{nn} suffix
-has been removed. This is the case for most of the Windows NT DLL for
-example. This option has no effect when @option{-n} option is specified.
+names, but keeps them for the link names. You must specify this
+option if you want to use a @code{Stdcall} function in a DLL for which
+the @code{@@}@i{nn} suffix has been removed. This is the case for most
+of the Windows NT DLL for example. This option has no effect when
+@option{-n} option is specified.
@item -l @var{file}
@cindex @option{-l} (@code{gnatdll})
Gnatls_String : constant String_Access := new String'("gnatls");
Pretty_String : constant String_Access := new String'("pretty_printer");
Gnatstub_String : constant String_Access := new String'("gnatstub");
+ Metric_String : constant String_Access := new String'("metrics");
Xref_String : constant String_Access := new String'("cross_reference");
Packages_To_Check_By_Binder : constant String_List_Access :=
Packages_To_Check_By_Gnatstub : constant String_List_Access :=
new String_List'((Naming_String, Gnatstub_String));
+ Packages_To_Check_By_Metric : constant String_List_Access :=
+ new String_List'((Naming_String, Metric_String));
+
Packages_To_Check_By_Xref : constant String_List_Access :=
new String_List'((Naming_String, Xref_String));
function Configuration_Pragmas_File return Name_Id;
-- Return an argument, if there is a configuration pragmas file to be
-- specified for Project, otherwise return No_Name.
- -- Used for gnatstub (GNAT STUB), gnatpp (GNAT PRETTY) and gnatelim
- -- (GNAT ELIM).
+ -- Used for gnatstub (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim
+ -- (GNAT ELIM), and gnatmetric (GNAT METRIC).
procedure Delete_Temp_Config_Files;
-- Delete all temporary config files
end loop;
New_Line;
- Put_Line ("Commands FIND, LIST, PRETTY, STUB and XREF accept " &
+ Put_Line ("Commands FIND, LIST, PRETTY, STUB, NETRIC and XREF accept " &
"project file switches -vPx, -Pprj and -Xnam=val");
New_Line;
end Non_VMS_Usage;
or else The_Command = Xref
or else The_Command = Pretty
or else The_Command = Stub
+ or else The_Command = Metric
then
case The_Command is
when Bind =>
when List =>
Tool_Package_Name := Name_Gnatls;
Packages_To_Check := Packages_To_Check_By_Gnatls;
+ when Metric =>
+ Tool_Package_Name := Name_Metrics;
+ Packages_To_Check := Packages_To_Check_By_Metric;
when Pretty =>
Tool_Package_Name := Name_Pretty_Printer;
Packages_To_Check := Packages_To_Check_By_Pretty;
-- Packages Binder (for gnatbind), Cross_Reference (for
-- gnatxref), Linker (for gnatlink) Finder (for gnatfind),
- -- Pretty_Printer (for gnatpp) and Eliminate (for gnatelim)
- -- have an attributed Switches, an associative array, indexed
- -- by the name of the file.
+ -- Pretty_Printer (for gnatpp) Eliminate (for gnatelim) and
+ -- Metric (for gnatmetric) have an attributed Switches,
+ -- an associative array, indexed by the name of the file.
-- They also have an attribute Default_Switches, indexed
-- by the name of the programming language.
Prj.Env.Set_Ada_Paths (Project, Including_Libraries => False);
- -- For gnatstub, gnatpp and gnatelim, create a configuration pragmas
- -- file, if necessary.
+ -- For gnatstub, gnatmetric, gnatpp and gnatelim, create
+ -- a configuration pragmas file, if necessary.
if The_Command = Pretty
+ or else The_Command = Metric
or else The_Command = Stub
or else The_Command = Elim
then
end;
end if;
- -- For gnat pretty, if no file has been put on the command line,
- -- call gnatpp with all the sources of the main project.
+ -- For gnat pretty and gnat metric, if no file has been put on the
+ -- command line, call the tool with all the sources of the main
+ -- project.
- if The_Command = Pretty then
+ if The_Command = Pretty or else The_Command = Metric then
declare
Add_Sources : Boolean := True;
Unit_Data : Prj.Com.Unit_Data;
-- Static string identifying this version, that can be used as an argument
-- to e.g. pragma Ident.
- type Gnat_Build_Type is (FSF, Public);
+ type Gnat_Build_Type is (FSF, Public, GAP);
-- See Get_Gnat_Build_Type below for the meaning of these values.
function Get_Gnat_Build_Type return Gnat_Build_Type;
-- The binder will output informational messages, and the bug box
-- generated by the package Comperr will give appropriate bug
-- submission instructions.
+ --
+ -- GAP
+ -- GNAT Academic Program, similar to Public.
Ver_Len_Max : constant := 32;
-- Longest possible length for Gnat_Version_String in this or any
-- value should never be decreased in the future, but it would be
-- OK to increase it if absolutely necessary.
- Library_Version : constant String := "3.4";
+ Library_Version : constant String := "3.5";
-- Library version. This value must be updated whenever any change to the
-- compiler affects the library formats in such a way as to obsolete
-- previously compiled library modules.
Verbose_Library_Version : constant String := "GNAT Lib v" & Library_Version;
-- Version string stored in e.g. ALI files.
- ASIS_Version_Number : constant := 2;
+ ASIS_Version_Number : constant := 4;
-- ASIS Version. This is used to check for consistency between the compiler
-- used to generate trees, and an ASIS application that is reading the
-- trees. It must be updated (incremented) whenever a change is made to
-- legitimately occurs (e.g. two package bodies that contain
-- inlined subprogram referenced by the other).
- -- Ada0Y (AI-50217): We also ignore limited_with clauses, because
+ -- Ada 2005 (AI-50217): We also ignore limited_with clauses, because
-- their purpose is precisely to create legal circular structures.
if Loading (Unum)
Item := First (Context_Items (Cunit));
while Present (Item) loop
- -- Ada0Y (AI-50217): limited with_clauses do not create
+ -- Ada 2005 (AI-50217): limited with_clauses do not create
-- dependencies
if Nkind (Item) = N_With_Clause
-- a body or if a body is present in Ada 83 mode.
if Body_Required (Cunit)
- or else (Ada_83
+ or else (Ada_Version = Ada_83
and then Full_Source_Name (Body_Fname) /= No_File)
then
Write_Info_Name (Body_Fname);
Def : Source_Ptr;
Ent : Entity_Id;
+ function Is_On_LHS (Node : Node_Id) return Boolean;
+ -- Used to check if a node is on the left hand side of an
+ -- assignment. The following cases are handled:
+ --
+ -- Variable Node is a direct descendant of an assignment
+ -- statement.
+ --
+ -- Prefix Of an indexed or selected component that is
+ -- present in a subtree rooted by an assignment
+ -- statement. There is no restriction of nesting
+ -- of components, thus cases such as A.B(C).D are
+ -- handled properly.
+
+ ---------------
+ -- Is_On_LHS --
+ ---------------
+
+ -- Couldn't we use Is_Lvalue or whatever it is called ???
+
+ function Is_On_LHS (Node : Node_Id) return Boolean is
+ N : Node_Id := Node;
+
+ begin
+ -- Only identifiers are considered, is this necessary???
+
+ if Nkind (N) /= N_Identifier then
+ return False;
+ end if;
+
+ -- Reach the assignment statement subtree root. In the
+ -- case of a variable being a direct descendant of an
+ -- assignment statement, the loop is skiped.
+
+ while Nkind (Parent (N)) /= N_Assignment_Statement loop
+
+ -- Check whether the parent is a component and the
+ -- current node is its prefix.
+
+ if (Nkind (Parent (N)) = N_Selected_Component
+ or else
+ Nkind (Parent (N)) = N_Indexed_Component)
+ and then Prefix (Parent (N)) = N
+ then
+ N := Parent (N);
+ else
+ return False;
+ end if;
+ end loop;
+
+ -- Parent (N) is an assignment statement, check whether
+ -- N is its name.
+
+ return Name (Parent (N)) = N;
+ end Is_On_LHS;
+
+ -- Start of processing for Generate_Reference
+
begin
pragma Assert (Nkind (E) in N_Entity);
-- For a variable that appears on the left side of an
-- assignment statement, we set the Referenced_As_LHS
-- flag since this is indeed a left hand side.
+ -- We also set the Referenced_As_LHS flag of a prefix
+ -- of selected or indexed component.
if Ekind (E) = E_Variable
- and then Nkind (Parent (N)) = N_Assignment_Statement
- and then Name (Parent (N)) = N
- and then No (Renamed_Object (E))
+ and then Is_On_LHS (N)
then
Set_Referenced_As_LHS (E);
Get_Name_String (Source.Object_Name),
True);
+ -- Add the switches specified in package Linker of
+ -- the main project.
+
+ Add_Switches
+ (Data => Data,
+ Proc => Linker,
+ Language => Source.Language,
+ File_Name => Main_Id);
+
-- Add the switches specified in attribute
-- Linker_Options of packages Linker.
S_Dec_Ads : Name_Id := No_Name;
-- Name_Id for "dec.ads"
+ G_Trasym_Ads : Name_Id := No_Name;
+ -- Name_Id for "g-trasym.ads"
+
No_Argument_List : aliased String_List := (1 .. 0 => null);
No_Argument : constant String_List_Access := No_Argument_List'Access;
Libdecgnat_Needed : Boolean := False;
-- On OpenVMS, set to True if library needs to be linked with libdecgnat
+ Gtrasymobj_Needed : Boolean := False;
+ -- On OpenVMS, set to True if library needs to be linked with
+ -- g-trasym.obj.
+
Data : Project_Data := Projects.Table (For_Project);
Object_Directory_Path : constant String :=
-- to link with -lgnarl (this is the case when there is a dependency
-- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file
-- indicates that there is a need to link with -ldecgnat (this is the
- -- case when there is a dependency on dec.ads).
+ -- case when there is a dependency on dec.ads), and set
+ -- Gtrasymobj_Needed if there is a dependency on g-trasym.ads.
procedure Process (The_ALI : File_Name_Type);
-- Check if the closure of a library unit which is or should be in the
begin
if not Libgnarl_Needed or
- (Hostparm.OpenVMS and then (not Libdecgnat_Needed))
+ (Hostparm.OpenVMS and then
+ ((not Libdecgnat_Needed) or
+ (not Gtrasymobj_Needed)))
then
-- Scan the ALI file
if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then
Libgnarl_Needed := True;
- elsif Hostparm.OpenVMS and then
- ALI.Sdep.Table (Index).Sfile = S_Dec_Ads
- then
- Libdecgnat_Needed := True;
+ elsif Hostparm.OpenVMS then
+ if ALI.Sdep.Table (Index).Sfile = S_Dec_Ads then
+ Libdecgnat_Needed := True;
+
+ elsif ALI.Sdep.Table (Index).Sfile = G_Trasym_Ads then
+ Gtrasymobj_Needed := True;
+ end if;
end if;
end loop;
end if;
-- of "s-osinte.ads".
if S_Osinte_Ads = No_Name then
- Name_Len := 12;
- Name_Buffer (1 .. Name_Len) := "s-osinte.ads";
+ Name_Len := 0;
+ Add_Str_To_Name_Buffer ("s-osinte.ads");
S_Osinte_Ads := Name_Find;
end if;
if S_Dec_Ads = No_Name then
- Name_Len := 7;
- Name_Buffer (1 .. Name_Len) := "dec.ads";
+ Name_Len := 0;
+ Add_Str_To_Name_Buffer ("dec.ads");
S_Dec_Ads := Name_Find;
end if;
+ if G_Trasym_Ads = No_Name then
+ Name_Len := 0;
+ Add_Str_To_Name_Buffer ("g-trasym.ads");
+ G_Trasym_Ads := Name_Find;
+ end if;
+
-- We work in the object directory
Change_Dir (Object_Directory_Path);
new String'(ALI_File);
-- Find out if for this ALI file,
- -- libgnarl or libdecgnat (on OpenVMS)
- -- is necessary.
+ -- libgnarl or libdecgnat or g-trasym.obj
+ -- (on OpenVMS) is necessary.
Check_Libs (ALI_File);
end if;
end if;
+ if Gtrasymobj_Needed then
+ Opts.Increment_Last;
+ Opts.Table (Opts.Last) :=
+ new String'(Lib_Directory & "/g-trasym.obj");
+ end if;
+
if Libdecgnat_Needed then
Opts.Increment_Last;
Opts.Table (Opts.Last) :=
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . T G T --
+-- (Alpha VMS Version) --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003-2004, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Alpha VMS version of the body
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+with MLib.Fil;
+with MLib.Utl;
+with Namet; use Namet;
+with Opt; use Opt;
+with Output; use Output;
+with Prj.Com;
+with System; use System;
+with System.Case_Util; use System.Case_Util;
+
+package body MLib.Tgt is
+
+ use GNAT;
+
+ Empty_Argument_List : aliased Argument_List := (1 .. 0 => null);
+ Additional_Objects : Argument_List_Access := Empty_Argument_List'Access;
+ -- Used to add the generated auto-init object files for auto-initializing
+ -- stand-alone libraries.
+
+ Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler";
+ -- The name of the command to invoke the macro-assembler
+
+ VMS_Options : Argument_List := (1 .. 1 => null);
+
+ Gnatsym_Name : constant String := "gnatsym";
+
+ Gnatsym_Path : String_Access;
+
+ Arguments : Argument_List_Access := null;
+ Last_Argument : Natural := 0;
+
+ Success : Boolean := False;
+
+ Shared_Libgcc : aliased String := "-shared-libgcc";
+
+ No_Shared_Libgcc_Switch : aliased Argument_List := (1 .. 0 => null);
+ Shared_Libgcc_Switch : aliased Argument_List :=
+ (1 => Shared_Libgcc'Access);
+ Link_With_Shared_Libgcc : Argument_List_Access :=
+ No_Shared_Libgcc_Switch'Access;
+
+ ------------------------------
+ -- Target dependent section --
+ ------------------------------
+
+ function Popen (Command, Mode : System.Address) return System.Address;
+ pragma Import (C, Popen);
+
+ function Pclose (File : System.Address) return Integer;
+ pragma Import (C, Pclose);
+
+ ---------------------
+ -- Archive_Builder --
+ ---------------------
+
+ function Archive_Builder return String is
+ begin
+ return "ar";
+ end Archive_Builder;
+
+ -----------------------------
+ -- Archive_Builder_Options --
+ -----------------------------
+
+ function Archive_Builder_Options return String_List_Access is
+ begin
+ return new String_List'(1 => new String'("cr"));
+ end Archive_Builder_Options;
+
+ -----------------
+ -- Archive_Ext --
+ -----------------
+
+ function Archive_Ext return String is
+ begin
+ return "olb";
+ end Archive_Ext;
+
+ ---------------------
+ -- Archive_Indexer --
+ ---------------------
+
+ function Archive_Indexer return String is
+ begin
+ return "ranlib";
+ end Archive_Indexer;
+
+ ---------------------------
+ -- Build_Dynamic_Library --
+ ---------------------------
+
+ procedure Build_Dynamic_Library
+ (Ofiles : Argument_List;
+ Foreign : Argument_List;
+ Afiles : Argument_List;
+ Options : Argument_List;
+ Interfaces : Argument_List;
+ Lib_Filename : String;
+ Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
+ Driver_Name : Name_Id := No_Name;
+ Lib_Address : String := "";
+ Lib_Version : String := "";
+ Relocatable : Boolean := False;
+ Auto_Init : Boolean := False)
+ is
+ pragma Unreferenced (Foreign);
+ pragma Unreferenced (Afiles);
+ pragma Unreferenced (Lib_Address);
+ pragma Unreferenced (Relocatable);
+
+ Lib_File : constant String :=
+ Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Filename, DLL_Ext);
+
+ Opts : Argument_List := Options;
+ Last_Opt : Natural := Opts'Last;
+ Opts2 : Argument_List (Options'Range);
+ Last_Opt2 : Natural := Opts2'First - 1;
+
+ Inter : constant Argument_List := Interfaces;
+
+ function Is_Interface (Obj_File : String) return Boolean;
+ -- For a Stand-Alone Library, returns True if Obj_File is the object
+ -- file name of an interface of the SAL.
+ -- For other libraries, always return True.
+
+ function Option_File_Name return String;
+ -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"
+
+ function Version_String return String;
+ -- Returns Lib_Version if not empty, otherwise returns "1".
+ -- Fails gnatmake if Lib_Version is not the image of a positive number.
+
+ ------------------
+ -- Is_Interface --
+ ------------------
+
+ function Is_Interface (Obj_File : String) return Boolean is
+ ALI : constant String :=
+ Fil.Ext_To
+ (Filename => To_Lower (Base_Name (Obj_File)),
+ New_Ext => "ali");
+
+ begin
+ if Inter'Length = 0 then
+ return True;
+
+ elsif ALI'Length > 2 and then
+ ALI (ALI'First .. ALI'First + 1) = "b$"
+ then
+ return True;
+
+ else
+ for J in Inter'Range loop
+ if Inter (J).all = ALI then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end if;
+ end Is_Interface;
+
+ ----------------------
+ -- Option_File_Name --
+ ----------------------
+
+ function Option_File_Name return String is
+ begin
+ if Symbol_Data.Symbol_File = No_Name then
+ return "symvec.opt";
+ else
+ Get_Name_String (Symbol_Data.Symbol_File);
+ To_Lower (Name_Buffer (1 .. Name_Len));
+ return Name_Buffer (1 .. Name_Len);
+ end if;
+ end Option_File_Name;
+
+ --------------------
+ -- Version_String --
+ --------------------
+
+ function Version_String return String is
+ Version : Integer := 0;
+ begin
+ if Lib_Version = "" then
+ return "1";
+
+ else
+ begin
+ Version := Integer'Value (Lib_Version);
+
+ if Version <= 0 then
+ raise Constraint_Error;
+ end if;
+
+ return Lib_Version;
+
+ exception
+ when Constraint_Error =>
+ Fail ("illegal version """, Lib_Version,
+ """ (on VMS version must be a positive number)");
+ return "";
+ end;
+ end if;
+ end Version_String;
+
+ Opt_File_Name : constant String := Option_File_Name;
+ Version : constant String := Version_String;
+ For_Linker_Opt : String_Access;
+
+ -- Start of processing for Build_Dynamic_Library
+
+ begin
+ -- Invoke gcc with -shared-libgcc, but only for GCC 3 or higher
+
+ if GCC_Version >= 3 then
+ Link_With_Shared_Libgcc := Shared_Libgcc_Switch'Access;
+ else
+ Link_With_Shared_Libgcc := No_Shared_Libgcc_Switch'Access;
+ end if;
+
+ -- If option file name does not ends with ".opt", append "/OPTIONS"
+ -- to its specification for the VMS linker.
+
+ if Opt_File_Name'Length > 4
+ and then
+ Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt"
+ then
+ For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name);
+ else
+ For_Linker_Opt :=
+ new String'("--for-linker=" & Opt_File_Name & "/OPTIONS");
+ end if;
+
+ VMS_Options (VMS_Options'First) := For_Linker_Opt;
+
+ for J in Inter'Range loop
+ To_Lower (Inter (J).all);
+ end loop;
+
+ -- "gnatsym" is necessary for building the option file
+
+ if Gnatsym_Path = null then
+ Gnatsym_Path := OS_Lib.Locate_Exec_On_Path (Gnatsym_Name);
+
+ if Gnatsym_Path = null then
+ Fail (Gnatsym_Name, " not found in path");
+ end if;
+ end if;
+
+ -- For auto-initialization of a stand-alone library, we create
+ -- a macro-assembly file and we invoke the macro-assembler.
+
+ if Auto_Init then
+ declare
+ Macro_File_Name : constant String := Lib_Filename & "$init.asm";
+ Macro_File : File_Descriptor;
+ Init_Proc : String := Lib_Filename & "INIT";
+ Popen_Result : System.Address;
+ Pclose_Result : Integer;
+ Len : Natural;
+ OK : Boolean := True;
+
+ Command : constant String :=
+ Macro_Name & " " & Macro_File_Name & ASCII.NUL;
+ -- The command to invoke the assembler on the generated auto-init
+ -- assembly file.
+
+ Mode : constant String := "r" & ASCII.NUL;
+ -- The mode for the invocation of Popen
+
+ begin
+ To_Upper (Init_Proc);
+
+ if Verbose_Mode then
+ Write_Str ("Creating auto-init assembly file """);
+ Write_Str (Macro_File_Name);
+ Write_Line ("""");
+ end if;
+
+ -- Create and write the auto-init assembly file
+
+ declare
+ First_Line : constant String :=
+ ASCII.HT & ".section LIB$INITIALIZE,GBL,NOWRT" &
+ ASCII.LF;
+ Second_Line : constant String :=
+ ASCII.HT & ".long " & Init_Proc & ASCII.LF;
+ -- First and second lines of the auto-init assembly file
+
+ begin
+ Macro_File := Create_File (Macro_File_Name, Text);
+ OK := Macro_File /= Invalid_FD;
+
+ if OK then
+ Len := Write
+ (Macro_File, First_Line (First_Line'First)'Address,
+ First_Line'Length);
+ OK := Len = First_Line'Length;
+ end if;
+
+ if OK then
+ Len := Write
+ (Macro_File, Second_Line (Second_Line'First)'Address,
+ Second_Line'Length);
+ OK := Len = Second_Line'Length;
+ end if;
+
+ if OK then
+ Close (Macro_File, OK);
+ end if;
+
+ if not OK then
+ Fail ("creation of auto-init assembly file """,
+ Macro_File_Name, """ failed");
+ end if;
+ end;
+
+ -- Invoke the macro-assembler
+
+ if Verbose_Mode then
+ Write_Str ("Assembling auto-init assembly file """);
+ Write_Str (Macro_File_Name);
+ Write_Line ("""");
+ end if;
+
+ Popen_Result := Popen (Command (Command'First)'Address,
+ Mode (Mode'First)'Address);
+
+ if Popen_Result = Null_Address then
+ Fail ("assembly of auto-init assembly file """,
+ Macro_File_Name, """ failed");
+ end if;
+
+ -- Wait for the end of execution of the macro-assembler
+
+ Pclose_Result := Pclose (Popen_Result);
+
+ if Pclose_Result < 0 then
+ Fail ("assembly of auto init assembly file """,
+ Macro_File_Name, """ failed");
+ end if;
+
+ -- Add the generated object file to the list of objects to be
+ -- included in the library.
+
+ Additional_Objects :=
+ new Argument_List'
+ (1 => new String'(Lib_Filename & "$init.obj"));
+ end;
+ end if;
+
+ -- Allocate the argument list and put the symbol file name, the
+ -- reference (if any) and the policy (if not autonomous).
+
+ Arguments := new Argument_List (1 .. Ofiles'Length + 8);
+
+ Last_Argument := 0;
+
+ -- Verbosity
+
+ if Verbose_Mode then
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-v");
+ end if;
+
+ -- Version number (major ID)
+
+ if Lib_Version /= "" then
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-V");
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'(Version);
+ end if;
+
+ -- Symbol file
+
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-s");
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'(Opt_File_Name);
+
+ -- Reference Symbol File
+
+ if Symbol_Data.Reference /= No_Name then
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-r");
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) :=
+ new String'(Get_Name_String (Symbol_Data.Reference));
+ end if;
+
+ -- Policy
+
+ case Symbol_Data.Symbol_Policy is
+ when Autonomous =>
+ null;
+
+ when Compliant =>
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-c");
+
+ when Controlled =>
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-C");
+ end case;
+
+ -- Add each relevant object file
+
+ for Index in Ofiles'Range loop
+ if Is_Interface (Ofiles (Index).all) then
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'(Ofiles (Index).all);
+ end if;
+ end loop;
+
+ -- Spawn gnatsym
+
+ Spawn (Program_Name => Gnatsym_Path.all,
+ Args => Arguments (1 .. Last_Argument),
+ Success => Success);
+
+ if not Success then
+ Fail ("unable to create symbol file for library """,
+ Lib_Filename, """");
+ end if;
+
+ Free (Arguments);
+
+ -- Move all the -l switches from Opts to Opts2
+
+ declare
+ Index : Natural := Opts'First;
+ Opt : String_Access;
+
+ begin
+ while Index <= Last_Opt loop
+ Opt := Opts (Index);
+
+ if Opt'Length > 2 and then
+ Opt (Opt'First .. Opt'First + 1) = "-l"
+ then
+ if Index < Last_Opt then
+ Opts (Index .. Last_Opt - 1) :=
+ Opts (Index + 1 .. Last_Opt);
+ end if;
+
+ Last_Opt := Last_Opt - 1;
+
+ Last_Opt2 := Last_Opt2 + 1;
+ Opts2 (Last_Opt2) := Opt;
+
+ else
+ Index := Index + 1;
+ end if;
+ end loop;
+ end;
+
+ -- Invoke gcc to build the library
+
+ Utl.Gcc
+ (Output_File => Lib_File,
+ Objects => Ofiles & Additional_Objects.all,
+ Options => VMS_Options,
+ Options_2 => Link_With_Shared_Libgcc.all &
+ Opts (Opts'First .. Last_Opt) &
+ Opts2 (Opts2'First .. Last_Opt2),
+ Driver_Name => Driver_Name);
+
+ -- The auto-init object file need to be deleted, so that it will not
+ -- be included in the library as a regular object file, otherwise
+ -- it will be included twice when the library will be built next
+ -- time, which may lead to errors.
+
+ if Auto_Init then
+ declare
+ Auto_Init_Object_File_Name : constant String :=
+ Lib_Filename & "$init.obj";
+ Disregard : Boolean;
+
+ begin
+ if Verbose_Mode then
+ Write_Str ("deleting auto-init object file """);
+ Write_Str (Auto_Init_Object_File_Name);
+ Write_Line ("""");
+ end if;
+
+ Delete_File (Auto_Init_Object_File_Name, Success => Disregard);
+ end;
+ end if;
+ end Build_Dynamic_Library;
+
+ -------------------------
+ -- Default_DLL_Address --
+ -------------------------
+
+ function Default_DLL_Address return String is
+ begin
+ return "";
+ end Default_DLL_Address;
+
+ -------------
+ -- DLL_Ext --
+ -------------
+
+ function DLL_Ext return String is
+ begin
+ return "exe";
+ end DLL_Ext;
+
+ --------------------
+ -- Dynamic_Option --
+ --------------------
+
+ function Dynamic_Option return String is
+ begin
+ return "-shared";
+ end Dynamic_Option;
+
+ -------------------
+ -- Is_Object_Ext --
+ -------------------
+
+ function Is_Object_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".obj";
+ end Is_Object_Ext;
+
+ --------------
+ -- Is_C_Ext --
+ --------------
+
+ function Is_C_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".c";
+ end Is_C_Ext;
+
+ --------------------
+ -- Is_Archive_Ext --
+ --------------------
+
+ function Is_Archive_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".olb" or else Ext = ".exe";
+ end Is_Archive_Ext;
+
+ -------------
+ -- Libgnat --
+ -------------
+
+ function Libgnat return String is
+ Libgnat_A : constant String := "libgnat.a";
+ Libgnat_Olb : constant String := "libgnat.olb";
+
+ begin
+ Name_Len := Libgnat_A'Length;
+ Name_Buffer (1 .. Name_Len) := Libgnat_A;
+
+ if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then
+ return Libgnat_A;
+
+ else
+ return Libgnat_Olb;
+ end if;
+ end Libgnat;
+
+ ------------------------
+ -- Library_Exists_For --
+ ------------------------
+
+ function Library_Exists_For (Project : Project_Id) return Boolean is
+ begin
+ if not Projects.Table (Project).Library then
+ Fail ("INTERNAL ERROR: Library_Exists_For called " &
+ "for non library project");
+ return False;
+
+ else
+ declare
+ Lib_Dir : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Dir);
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ if Projects.Table (Project).Library_Kind = Static then
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+ end;
+ end if;
+ end Library_Exists_For;
+
+ ---------------------------
+ -- Library_File_Name_For --
+ ---------------------------
+
+ function Library_File_Name_For (Project : Project_Id) return Name_Id is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
+ "for non library project");
+ return No_Name;
+
+ else
+ declare
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ Name_Len := 3;
+ Name_Buffer (1 .. Name_Len) := "lib";
+
+ if Projects.Table (Project).Library_Kind = Static then
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+
+ return Name_Find;
+ end;
+ end if;
+ end Library_File_Name_For;
+
+ ----------------
+ -- Object_Ext --
+ ----------------
+
+ function Object_Ext return String is
+ begin
+ return "obj";
+ end Object_Ext;
+
+ ----------------
+ -- PIC_Option --
+ ----------------
+
+ function PIC_Option return String is
+ begin
+ return "";
+ end PIC_Option;
+
+ -----------------------------------------------
+ -- Standalone_Library_Auto_Init_Is_Supported --
+ -----------------------------------------------
+
+ function Standalone_Library_Auto_Init_Is_Supported return Boolean is
+ begin
+ return True;
+ end Standalone_Library_Auto_Init_Is_Supported;
+
+ ---------------------------
+ -- Support_For_Libraries --
+ ---------------------------
+
+ function Support_For_Libraries return Library_Support is
+ begin
+ return Full;
+ end Support_For_Libraries;
+
+end MLib.Tgt;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . T G T --
+-- (Integrity VMS Version) --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Integrity VMS version of the body
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+with MLib.Fil;
+with MLib.Utl;
+with Namet; use Namet;
+with Opt; use Opt;
+with Output; use Output;
+with Prj.Com;
+with System; use System;
+with System.Case_Util; use System.Case_Util;
+
+package body MLib.Tgt is
+
+ use GNAT;
+
+ Empty_Argument_List : aliased Argument_List := (1 .. 0 => null);
+ Additional_Objects : Argument_List_Access := Empty_Argument_List'Access;
+ -- Used to add the generated auto-init object files for auto-initializing
+ -- stand-alone libraries.
+
+ Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler";
+ -- The name of the command to invoke the macro-assembler
+
+ VMS_Options : Argument_List := (1 .. 1 => null);
+
+ Gnatsym_Name : constant String := "gnatsym";
+
+ Gnatsym_Path : String_Access;
+
+ Arguments : Argument_List_Access := null;
+ Last_Argument : Natural := 0;
+
+ Success : Boolean := False;
+
+ Shared_Libgcc : aliased String := "-shared-libgcc";
+
+ No_Shared_Libgcc_Switch : aliased Argument_List := (1 .. 0 => null);
+ Shared_Libgcc_Switch : aliased Argument_List :=
+ (1 => Shared_Libgcc'Access);
+ Link_With_Shared_Libgcc : Argument_List_Access :=
+ No_Shared_Libgcc_Switch'Access;
+
+ ------------------------------
+ -- Target dependent section --
+ ------------------------------
+
+ function Popen (Command, Mode : System.Address) return System.Address;
+ pragma Import (C, Popen);
+
+ function Pclose (File : System.Address) return Integer;
+ pragma Import (C, Pclose);
+
+ ---------------------
+ -- Archive_Builder --
+ ---------------------
+
+ function Archive_Builder return String is
+ begin
+ return "ar";
+ end Archive_Builder;
+
+ -----------------------------
+ -- Archive_Builder_Options --
+ -----------------------------
+
+ function Archive_Builder_Options return String_List_Access is
+ begin
+ return new String_List'(1 => new String'("cr"));
+ end Archive_Builder_Options;
+
+ -----------------
+ -- Archive_Ext --
+ -----------------
+
+ function Archive_Ext return String is
+ begin
+ return "olb";
+ end Archive_Ext;
+
+ ---------------------
+ -- Archive_Indexer --
+ ---------------------
+
+ function Archive_Indexer return String is
+ begin
+ return "ranlib";
+ end Archive_Indexer;
+
+ ---------------------------
+ -- Build_Dynamic_Library --
+ ---------------------------
+
+ procedure Build_Dynamic_Library
+ (Ofiles : Argument_List;
+ Foreign : Argument_List;
+ Afiles : Argument_List;
+ Options : Argument_List;
+ Interfaces : Argument_List;
+ Lib_Filename : String;
+ Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
+ Driver_Name : Name_Id := No_Name;
+ Lib_Address : String := "";
+ Lib_Version : String := "";
+ Relocatable : Boolean := False;
+ Auto_Init : Boolean := False)
+ is
+ pragma Unreferenced (Foreign);
+ pragma Unreferenced (Afiles);
+ pragma Unreferenced (Lib_Address);
+ pragma Unreferenced (Relocatable);
+
+ Lib_File : constant String :=
+ Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Filename, DLL_Ext);
+
+ Opts : Argument_List := Options;
+ Last_Opt : Natural := Opts'Last;
+ Opts2 : Argument_List (Options'Range);
+ Last_Opt2 : Natural := Opts2'First - 1;
+
+ Inter : constant Argument_List := Interfaces;
+
+ function Is_Interface (Obj_File : String) return Boolean;
+ -- For a Stand-Alone Library, returns True if Obj_File is the object
+ -- file name of an interface of the SAL.
+ -- For other libraries, always return True.
+
+ function Option_File_Name return String;
+ -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"
+
+ function Version_String return String;
+ -- Returns Lib_Version if not empty, otherwise returns "1".
+ -- Fails gnatmake if Lib_Version is not the image of a positive number.
+
+ ------------------
+ -- Is_Interface --
+ ------------------
+
+ function Is_Interface (Obj_File : String) return Boolean is
+ ALI : constant String :=
+ Fil.Ext_To
+ (Filename => To_Lower (Base_Name (Obj_File)),
+ New_Ext => "ali");
+
+ begin
+ if Inter'Length = 0 then
+ return True;
+
+ elsif ALI'Length > 2 and then
+ ALI (ALI'First .. ALI'First + 1) = "b$"
+ then
+ return True;
+
+ else
+ for J in Inter'Range loop
+ if Inter (J).all = ALI then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end if;
+ end Is_Interface;
+
+ ----------------------
+ -- Option_File_Name --
+ ----------------------
+
+ function Option_File_Name return String is
+ begin
+ if Symbol_Data.Symbol_File = No_Name then
+ return "symvec.opt";
+ else
+ Get_Name_String (Symbol_Data.Symbol_File);
+ To_Lower (Name_Buffer (1 .. Name_Len));
+ return Name_Buffer (1 .. Name_Len);
+ end if;
+ end Option_File_Name;
+
+ --------------------
+ -- Version_String --
+ --------------------
+
+ function Version_String return String is
+ Version : Integer := 0;
+ begin
+ if Lib_Version = "" then
+ return "1";
+
+ else
+ begin
+ Version := Integer'Value (Lib_Version);
+
+ if Version <= 0 then
+ raise Constraint_Error;
+ end if;
+
+ return Lib_Version;
+
+ exception
+ when Constraint_Error =>
+ Fail ("illegal version """, Lib_Version,
+ """ (on VMS version must be a positive number)");
+ return "";
+ end;
+ end if;
+ end Version_String;
+
+ Opt_File_Name : constant String := Option_File_Name;
+ Version : constant String := Version_String;
+ For_Linker_Opt : String_Access;
+
+ -- Start of processing for Build_Dynamic_Library
+
+ begin
+ -- Invoke gcc with -shared-libgcc, but only for GCC 3 or higher
+
+ if GCC_Version >= 3 then
+ Link_With_Shared_Libgcc := Shared_Libgcc_Switch'Access;
+ else
+ Link_With_Shared_Libgcc := No_Shared_Libgcc_Switch'Access;
+ end if;
+
+ -- Option file must end with ".opt"
+
+ if Opt_File_Name'Length > 4
+ and then
+ Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt"
+ then
+ For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name);
+ else
+ Fail ("Options File """, Opt_File_Name, """ must end with .opt");
+ end if;
+
+ VMS_Options (VMS_Options'First) := For_Linker_Opt;
+
+ for J in Inter'Range loop
+ To_Lower (Inter (J).all);
+ end loop;
+
+ -- "gnatsym" is necessary for building the option file
+
+ if Gnatsym_Path = null then
+ Gnatsym_Path := OS_Lib.Locate_Exec_On_Path (Gnatsym_Name);
+
+ if Gnatsym_Path = null then
+ Fail (Gnatsym_Name, " not found in path");
+ end if;
+ end if;
+
+ -- For auto-initialization of a stand-alone library, we create
+ -- a macro-assembly file and we invoke the macro-assembler.
+
+ if Auto_Init then
+ declare
+ Macro_File_Name : constant String := Lib_Filename & "$init.asm";
+ Macro_File : File_Descriptor;
+ Init_Proc : String := Lib_Filename & "INIT";
+ Popen_Result : System.Address;
+ Pclose_Result : Integer;
+ Len : Natural;
+ OK : Boolean := True;
+
+ Command : constant String :=
+ Macro_Name & " " & Macro_File_Name & ASCII.NUL;
+ -- The command to invoke the assembler on the generated auto-init
+ -- assembly file.
+
+ Mode : constant String := "r" & ASCII.NUL;
+ -- The mode for the invocation of Popen
+
+ begin
+ To_Upper (Init_Proc);
+
+ if Verbose_Mode then
+ Write_Str ("Creating auto-init assembly file """);
+ Write_Str (Macro_File_Name);
+ Write_Line ("""");
+ end if;
+
+ -- Create and write the auto-init assembly file
+
+ declare
+ First_Line : constant String :=
+ ASCII.HT &
+ ".type " & Init_Proc & "#, @function" &
+ ASCII.LF;
+ Second_Line : constant String :=
+ ASCII.HT &
+ ".global " & Init_Proc & "#" &
+ ASCII.LF;
+ Third_Line : constant String :=
+ ASCII.HT &
+ ".global LIB$INITIALIZE#" &
+ ASCII.LF;
+ Fourth_Line : constant String :=
+ ASCII.HT &
+ ".section LIB$INITIALIZE#,""a"",@progbits" &
+ ASCII.LF;
+ Fifth_Line : constant String :=
+ ASCII.HT &
+ "data4 @fptr(" & Init_Proc & "#)" &
+ ASCII.LF;
+
+ begin
+ Macro_File := Create_File (Macro_File_Name, Text);
+ OK := Macro_File /= Invalid_FD;
+
+ if OK then
+ Len := Write
+ (Macro_File, First_Line (First_Line'First)'Address,
+ First_Line'Length);
+ OK := Len = First_Line'Length;
+ end if;
+
+ if OK then
+ Len := Write
+ (Macro_File, Second_Line (Second_Line'First)'Address,
+ Second_Line'Length);
+ OK := Len = Second_Line'Length;
+ end if;
+
+ if OK then
+ Len := Write
+ (Macro_File, Third_Line (Third_Line'First)'Address,
+ Third_Line'Length);
+ OK := Len = Third_Line'Length;
+ end if;
+
+ if OK then
+ Len := Write
+ (Macro_File, Fourth_Line (Fourth_Line'First)'Address,
+ Fourth_Line'Length);
+ OK := Len = Fourth_Line'Length;
+ end if;
+
+ if OK then
+ Len := Write
+ (Macro_File, Fifth_Line (Fifth_Line'First)'Address,
+ Fifth_Line'Length);
+ OK := Len = Fifth_Line'Length;
+ end if;
+
+ if OK then
+ Close (Macro_File, OK);
+ end if;
+
+ if not OK then
+ Fail ("creation of auto-init assembly file """,
+ Macro_File_Name, """ failed");
+ end if;
+ end;
+
+ -- Invoke the macro-assembler
+
+ if Verbose_Mode then
+ Write_Str ("Assembling auto-init assembly file """);
+ Write_Str (Macro_File_Name);
+ Write_Line ("""");
+ end if;
+
+ Popen_Result := Popen (Command (Command'First)'Address,
+ Mode (Mode'First)'Address);
+
+ if Popen_Result = Null_Address then
+ Fail ("assembly of auto-init assembly file """,
+ Macro_File_Name, """ failed");
+ end if;
+
+ -- Wait for the end of execution of the macro-assembler
+
+ Pclose_Result := Pclose (Popen_Result);
+
+ if Pclose_Result < 0 then
+ Fail ("assembly of auto init assembly file """,
+ Macro_File_Name, """ failed");
+ end if;
+
+ -- Add the generated object file to the list of objects to be
+ -- included in the library.
+
+ Additional_Objects :=
+ new Argument_List'
+ (1 => new String'(Lib_Filename & "$init.obj"));
+ end;
+ end if;
+
+ -- Allocate the argument list and put the symbol file name, the
+ -- reference (if any) and the policy (if not autonomous).
+
+ Arguments := new Argument_List (1 .. Ofiles'Length + 8);
+
+ Last_Argument := 0;
+
+ -- Verbosity
+
+ if Verbose_Mode then
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-v");
+ end if;
+
+ -- Version number (major ID)
+
+ if Lib_Version /= "" then
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-V");
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'(Version);
+ end if;
+
+ -- Symbol file
+
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-s");
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'(Opt_File_Name);
+
+ -- Reference Symbol File
+
+ if Symbol_Data.Reference /= No_Name then
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-r");
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) :=
+ new String'(Get_Name_String (Symbol_Data.Reference));
+ end if;
+
+ -- Policy
+
+ case Symbol_Data.Symbol_Policy is
+ when Autonomous =>
+ null;
+
+ when Compliant =>
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-c");
+
+ when Controlled =>
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-C");
+ end case;
+
+ -- Add each relevant object file
+
+ for Index in Ofiles'Range loop
+ if Is_Interface (Ofiles (Index).all) then
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'(Ofiles (Index).all);
+ end if;
+ end loop;
+
+ -- Spawn gnatsym
+
+ Spawn (Program_Name => Gnatsym_Path.all,
+ Args => Arguments (1 .. Last_Argument),
+ Success => Success);
+
+ if not Success then
+ Fail ("unable to create symbol file for library """,
+ Lib_Filename, """");
+ end if;
+
+ Free (Arguments);
+
+ -- Move all the -l switches from Opts to Opts2
+
+ declare
+ Index : Natural := Opts'First;
+ Opt : String_Access;
+
+ begin
+ while Index <= Last_Opt loop
+ Opt := Opts (Index);
+
+ if Opt'Length > 2 and then
+ Opt (Opt'First .. Opt'First + 1) = "-l"
+ then
+ if Index < Last_Opt then
+ Opts (Index .. Last_Opt - 1) :=
+ Opts (Index + 1 .. Last_Opt);
+ end if;
+
+ Last_Opt := Last_Opt - 1;
+
+ Last_Opt2 := Last_Opt2 + 1;
+ Opts2 (Last_Opt2) := Opt;
+
+ else
+ Index := Index + 1;
+ end if;
+ end loop;
+ end;
+
+ -- Invoke gcc to build the library
+
+ Utl.Gcc
+ (Output_File => Lib_File,
+ Objects => Ofiles & Additional_Objects.all,
+ Options => VMS_Options,
+ Options_2 => Link_With_Shared_Libgcc.all &
+ Opts (Opts'First .. Last_Opt) &
+ Opts2 (Opts2'First .. Last_Opt2),
+ Driver_Name => Driver_Name);
+
+ -- The auto-init object file need to be deleted, so that it will not
+ -- be included in the library as a regular object file, otherwise
+ -- it will be included twice when the library will be built next
+ -- time, which may lead to errors.
+
+ if Auto_Init then
+ declare
+ Auto_Init_Object_File_Name : constant String :=
+ Lib_Filename & "$init.obj";
+ Disregard : Boolean;
+
+ begin
+ if Verbose_Mode then
+ Write_Str ("deleting auto-init object file """);
+ Write_Str (Auto_Init_Object_File_Name);
+ Write_Line ("""");
+ end if;
+
+ Delete_File (Auto_Init_Object_File_Name, Success => Disregard);
+ end;
+ end if;
+ end Build_Dynamic_Library;
+
+ -------------------------
+ -- Default_DLL_Address --
+ -------------------------
+
+ function Default_DLL_Address return String is
+ begin
+ return "";
+ end Default_DLL_Address;
+
+ -------------
+ -- DLL_Ext --
+ -------------
+
+ function DLL_Ext return String is
+ begin
+ return "exe";
+ end DLL_Ext;
+
+ --------------------
+ -- Dynamic_Option --
+ --------------------
+
+ function Dynamic_Option return String is
+ begin
+ return "-shared";
+ end Dynamic_Option;
+
+ -------------------
+ -- Is_Object_Ext --
+ -------------------
+
+ function Is_Object_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".obj";
+ end Is_Object_Ext;
+
+ --------------
+ -- Is_C_Ext --
+ --------------
+
+ function Is_C_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".c";
+ end Is_C_Ext;
+
+ --------------------
+ -- Is_Archive_Ext --
+ --------------------
+
+ function Is_Archive_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".olb" or else Ext = ".exe";
+ end Is_Archive_Ext;
+
+ -------------
+ -- Libgnat --
+ -------------
+
+ function Libgnat return String is
+ Libgnat_A : constant String := "libgnat.a";
+ Libgnat_Olb : constant String := "libgnat.olb";
+
+ begin
+ Name_Len := Libgnat_A'Length;
+ Name_Buffer (1 .. Name_Len) := Libgnat_A;
+
+ if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then
+ return Libgnat_A;
+
+ else
+ return Libgnat_Olb;
+ end if;
+ end Libgnat;
+
+ ------------------------
+ -- Library_Exists_For --
+ ------------------------
+
+ function Library_Exists_For (Project : Project_Id) return Boolean is
+ begin
+ if not Projects.Table (Project).Library then
+ Fail ("INTERNAL ERROR: Library_Exists_For called " &
+ "for non library project");
+ return False;
+
+ else
+ declare
+ Lib_Dir : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Dir);
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ if Projects.Table (Project).Library_Kind = Static then
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+ end;
+ end if;
+ end Library_Exists_For;
+
+ ---------------------------
+ -- Library_File_Name_For --
+ ---------------------------
+
+ function Library_File_Name_For (Project : Project_Id) return Name_Id is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
+ "for non library project");
+ return No_Name;
+
+ else
+ declare
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ Name_Len := 3;
+ Name_Buffer (1 .. Name_Len) := "lib";
+
+ if Projects.Table (Project).Library_Kind = Static then
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+
+ return Name_Find;
+ end;
+ end if;
+ end Library_File_Name_For;
+
+ ----------------
+ -- Object_Ext --
+ ----------------
+
+ function Object_Ext return String is
+ begin
+ return "obj";
+ end Object_Ext;
+
+ ----------------
+ -- PIC_Option --
+ ----------------
+
+ function PIC_Option return String is
+ begin
+ return "";
+ end PIC_Option;
+
+ -----------------------------------------------
+ -- Standalone_Library_Auto_Init_Is_Supported --
+ -----------------------------------------------
+
+ function Standalone_Library_Auto_Init_Is_Supported return Boolean is
+ begin
+ return True;
+ end Standalone_Library_Auto_Init_Is_Supported;
+
+ ---------------------------
+ -- Support_For_Libraries --
+ ---------------------------
+
+ function Support_For_Libraries return Library_Support is
+ begin
+ return Full;
+ end Support_For_Libraries;
+
+end MLib.Tgt;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . T G T --
--- (VMS Version) --
--- --
--- B o d y --
--- --
--- Copyright (C) 2003-2004, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the VMS version of the body
-
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-
-with MLib.Fil;
-with MLib.Utl;
-with Namet; use Namet;
-with Opt; use Opt;
-with Output; use Output;
-with Prj.Com;
-with System; use System;
-with System.Case_Util; use System.Case_Util;
-
-package body MLib.Tgt is
-
- use GNAT;
-
- Empty_Argument_List : aliased Argument_List := (1 .. 0 => null);
- Additional_Objects : Argument_List_Access := Empty_Argument_List'Access;
- -- Used to add the generated auto-init object files for auto-initializing
- -- stand-alone libraries.
-
- Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler";
- -- The name of the command to invoke the macro-assembler
-
- VMS_Options : Argument_List := (1 .. 1 => null);
-
- Gnatsym_Name : constant String := "gnatsym";
-
- Gnatsym_Path : String_Access;
-
- Arguments : Argument_List_Access := null;
- Last_Argument : Natural := 0;
-
- Success : Boolean := False;
-
- Shared_Libgcc : aliased String := "-shared-libgcc";
-
- No_Shared_Libgcc_Switch : aliased Argument_List := (1 .. 0 => null);
- Shared_Libgcc_Switch : aliased Argument_List :=
- (1 => Shared_Libgcc'Access);
- Link_With_Shared_Libgcc : Argument_List_Access :=
- No_Shared_Libgcc_Switch'Access;
-
- ------------------------------
- -- Target dependent section --
- ------------------------------
-
- function Popen (Command, Mode : System.Address) return System.Address;
- pragma Import (C, Popen);
-
- function Pclose (File : System.Address) return Integer;
- pragma Import (C, Pclose);
-
- ---------------------
- -- Archive_Builder --
- ---------------------
-
- function Archive_Builder return String is
- begin
- return "ar";
- end Archive_Builder;
-
- -----------------------------
- -- Archive_Builder_Options --
- -----------------------------
-
- function Archive_Builder_Options return String_List_Access is
- begin
- return new String_List'(1 => new String'("cr"));
- end Archive_Builder_Options;
-
- -----------------
- -- Archive_Ext --
- -----------------
-
- function Archive_Ext return String is
- begin
- return "olb";
- end Archive_Ext;
-
- ---------------------
- -- Archive_Indexer --
- ---------------------
-
- function Archive_Indexer return String is
- begin
- return "ranlib";
- end Archive_Indexer;
-
- ---------------------------
- -- Build_Dynamic_Library --
- ---------------------------
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Foreign : Argument_List;
- Afiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Address : String := "";
- Lib_Version : String := "";
- Relocatable : Boolean := False;
- Auto_Init : Boolean := False)
- is
- pragma Unreferenced (Foreign);
- pragma Unreferenced (Afiles);
- pragma Unreferenced (Lib_Address);
- pragma Unreferenced (Relocatable);
-
- Lib_File : constant String :=
- Lib_Dir & Directory_Separator & "lib" &
- Fil.Ext_To (Lib_Filename, DLL_Ext);
-
- Opts : Argument_List := Options;
- Last_Opt : Natural := Opts'Last;
- Opts2 : Argument_List (Options'Range);
- Last_Opt2 : Natural := Opts2'First - 1;
-
- Inter : constant Argument_List := Interfaces;
-
- function Is_Interface (Obj_File : String) return Boolean;
- -- For a Stand-Alone Library, returns True if Obj_File is the object
- -- file name of an interface of the SAL.
- -- For other libraries, always return True.
-
- function Option_File_Name return String;
- -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"
-
- function Version_String return String;
- -- Returns Lib_Version if not empty, otherwise returns "1".
- -- Fails gnatmake if Lib_Version is not the image of a positive number.
-
- ------------------
- -- Is_Interface --
- ------------------
-
- function Is_Interface (Obj_File : String) return Boolean is
- ALI : constant String :=
- Fil.Ext_To
- (Filename => To_Lower (Base_Name (Obj_File)),
- New_Ext => "ali");
-
- begin
- if Inter'Length = 0 then
- return True;
-
- elsif ALI'Length > 2 and then
- ALI (ALI'First .. ALI'First + 1) = "b$"
- then
- return True;
-
- else
- for J in Inter'Range loop
- if Inter (J).all = ALI then
- return True;
- end if;
- end loop;
-
- return False;
- end if;
- end Is_Interface;
-
- ----------------------
- -- Option_File_Name --
- ----------------------
-
- function Option_File_Name return String is
- begin
- if Symbol_Data.Symbol_File = No_Name then
- return "symvec.opt";
- else
- Get_Name_String (Symbol_Data.Symbol_File);
- To_Lower (Name_Buffer (1 .. Name_Len));
- return Name_Buffer (1 .. Name_Len);
- end if;
- end Option_File_Name;
-
- --------------------
- -- Version_String --
- --------------------
-
- function Version_String return String is
- Version : Integer := 0;
- begin
- if Lib_Version = "" then
- return "1";
-
- else
- begin
- Version := Integer'Value (Lib_Version);
-
- if Version <= 0 then
- raise Constraint_Error;
- end if;
-
- return Lib_Version;
-
- exception
- when Constraint_Error =>
- Fail ("illegal version """, Lib_Version,
- """ (on VMS version must be a positive number)");
- return "";
- end;
- end if;
- end Version_String;
-
- Opt_File_Name : constant String := Option_File_Name;
- Version : constant String := Version_String;
- For_Linker_Opt : String_Access;
-
- -- Start of processing for Build_Dynamic_Library
-
- begin
- -- Invoke gcc with -shared-libgcc, but only for GCC 3 or higher
-
- if GCC_Version >= 3 then
- Link_With_Shared_Libgcc := Shared_Libgcc_Switch'Access;
- else
- Link_With_Shared_Libgcc := No_Shared_Libgcc_Switch'Access;
- end if;
-
- -- If option file name does not ends with ".opt", append "/OPTIONS"
- -- to its specification for the VMS linker.
-
- if Opt_File_Name'Length > 4
- and then
- Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt"
- then
- For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name);
- else
- For_Linker_Opt :=
- new String'("--for-linker=" & Opt_File_Name & "/OPTIONS");
- end if;
-
- VMS_Options (VMS_Options'First) := For_Linker_Opt;
-
- for J in Inter'Range loop
- To_Lower (Inter (J).all);
- end loop;
-
- -- "gnatsym" is necessary for building the option file
-
- if Gnatsym_Path = null then
- Gnatsym_Path := OS_Lib.Locate_Exec_On_Path (Gnatsym_Name);
-
- if Gnatsym_Path = null then
- Fail (Gnatsym_Name, " not found in path");
- end if;
- end if;
-
- -- For auto-initialization of a stand-alone library, we create
- -- a macro-assembly file and we invoke the macro-assembler.
-
- if Auto_Init then
- declare
- Macro_File_Name : constant String := Lib_Filename & "$init.asm";
- Macro_File : File_Descriptor;
- Init_Proc : String := Lib_Filename & "INIT";
- Popen_Result : System.Address;
- Pclose_Result : Integer;
- Len : Natural;
- OK : Boolean := True;
-
- Command : constant String :=
- Macro_Name & " " & Macro_File_Name & ASCII.NUL;
- -- The command to invoke the assembler on the generated auto-init
- -- assembly file.
-
- Mode : constant String := "r" & ASCII.NUL;
- -- The mode for the invocation of Popen
-
- begin
- To_Upper (Init_Proc);
-
- if Verbose_Mode then
- Write_Str ("Creating auto-init assembly file """);
- Write_Str (Macro_File_Name);
- Write_Line ("""");
- end if;
-
- -- Create and write the auto-init assembly file
-
- declare
- First_Line : constant String :=
- ASCII.HT & ".section LIB$INITIALIZE,GBL,NOWRT" &
- ASCII.LF;
- Second_Line : constant String :=
- ASCII.HT & ".long " & Init_Proc & ASCII.LF;
- -- First and second lines of the auto-init assembly file
-
- begin
- Macro_File := Create_File (Macro_File_Name, Text);
- OK := Macro_File /= Invalid_FD;
-
- if OK then
- Len := Write
- (Macro_File, First_Line (First_Line'First)'Address,
- First_Line'Length);
- OK := Len = First_Line'Length;
- end if;
-
- if OK then
- Len := Write
- (Macro_File, Second_Line (Second_Line'First)'Address,
- Second_Line'Length);
- OK := Len = Second_Line'Length;
- end if;
-
- if OK then
- Close (Macro_File, OK);
- end if;
-
- if not OK then
- Fail ("creation of auto-init assembly file """,
- Macro_File_Name, """ failed");
- end if;
- end;
-
- -- Invoke the macro-assembler
-
- if Verbose_Mode then
- Write_Str ("Assembling auto-init assembly file """);
- Write_Str (Macro_File_Name);
- Write_Line ("""");
- end if;
-
- Popen_Result := Popen (Command (Command'First)'Address,
- Mode (Mode'First)'Address);
-
- if Popen_Result = Null_Address then
- Fail ("assembly of auto-init assembly file """,
- Macro_File_Name, """ failed");
- end if;
-
- -- Wait for the end of execution of the macro-assembler
-
- Pclose_Result := Pclose (Popen_Result);
-
- if Pclose_Result < 0 then
- Fail ("assembly of auto init assembly file """,
- Macro_File_Name, """ failed");
- end if;
-
- -- Add the generated object file to the list of objects to be
- -- included in the library.
-
- Additional_Objects :=
- new Argument_List'
- (1 => new String'(Lib_Filename & "$init.obj"));
- end;
- end if;
-
- -- Allocate the argument list and put the symbol file name, the
- -- reference (if any) and the policy (if not autonomous).
-
- Arguments := new Argument_List (1 .. Ofiles'Length + 8);
-
- Last_Argument := 0;
-
- -- Verbosity
-
- if Verbose_Mode then
- Last_Argument := Last_Argument + 1;
- Arguments (Last_Argument) := new String'("-v");
- end if;
-
- -- Version number (major ID)
-
- if Lib_Version /= "" then
- Last_Argument := Last_Argument + 1;
- Arguments (Last_Argument) := new String'("-V");
- Last_Argument := Last_Argument + 1;
- Arguments (Last_Argument) := new String'(Version);
- end if;
-
- -- Symbol file
-
- Last_Argument := Last_Argument + 1;
- Arguments (Last_Argument) := new String'("-s");
- Last_Argument := Last_Argument + 1;
- Arguments (Last_Argument) := new String'(Opt_File_Name);
-
- -- Reference Symbol File
-
- if Symbol_Data.Reference /= No_Name then
- Last_Argument := Last_Argument + 1;
- Arguments (Last_Argument) := new String'("-r");
- Last_Argument := Last_Argument + 1;
- Arguments (Last_Argument) :=
- new String'(Get_Name_String (Symbol_Data.Reference));
- end if;
-
- -- Policy
-
- case Symbol_Data.Symbol_Policy is
- when Autonomous =>
- null;
-
- when Compliant =>
- Last_Argument := Last_Argument + 1;
- Arguments (Last_Argument) := new String'("-c");
-
- when Controlled =>
- Last_Argument := Last_Argument + 1;
- Arguments (Last_Argument) := new String'("-C");
- end case;
-
- -- Add each relevant object file
-
- for Index in Ofiles'Range loop
- if Is_Interface (Ofiles (Index).all) then
- Last_Argument := Last_Argument + 1;
- Arguments (Last_Argument) := new String'(Ofiles (Index).all);
- end if;
- end loop;
-
- -- Spawn gnatsym
-
- Spawn (Program_Name => Gnatsym_Path.all,
- Args => Arguments (1 .. Last_Argument),
- Success => Success);
-
- if not Success then
- Fail ("unable to create symbol file for library """,
- Lib_Filename, """");
- end if;
-
- Free (Arguments);
-
- -- Move all the -l switches from Opts to Opts2
-
- declare
- Index : Natural := Opts'First;
- Opt : String_Access;
-
- begin
- while Index <= Last_Opt loop
- Opt := Opts (Index);
-
- if Opt'Length > 2 and then
- Opt (Opt'First .. Opt'First + 1) = "-l"
- then
- if Index < Last_Opt then
- Opts (Index .. Last_Opt - 1) :=
- Opts (Index + 1 .. Last_Opt);
- end if;
-
- Last_Opt := Last_Opt - 1;
-
- Last_Opt2 := Last_Opt2 + 1;
- Opts2 (Last_Opt2) := Opt;
-
- else
- Index := Index + 1;
- end if;
- end loop;
- end;
-
- -- Invoke gcc to build the library
-
- Utl.Gcc
- (Output_File => Lib_File,
- Objects => Ofiles & Additional_Objects.all,
- Options => VMS_Options,
- Options_2 => Link_With_Shared_Libgcc.all &
- Opts (Opts'First .. Last_Opt) &
- Opts2 (Opts2'First .. Last_Opt2),
- Driver_Name => Driver_Name);
-
- -- The auto-init object file need to be deleted, so that it will not
- -- be included in the library as a regular object file, otherwise
- -- it will be included twice when the library will be built next
- -- time, which may lead to errors.
-
- if Auto_Init then
- declare
- Auto_Init_Object_File_Name : constant String :=
- Lib_Filename & "$init.obj";
- Disregard : Boolean;
-
- begin
- if Verbose_Mode then
- Write_Str ("deleting auto-init object file """);
- Write_Str (Auto_Init_Object_File_Name);
- Write_Line ("""");
- end if;
-
- Delete_File (Auto_Init_Object_File_Name, Success => Disregard);
- end;
- end if;
- end Build_Dynamic_Library;
-
- -------------------------
- -- Default_DLL_Address --
- -------------------------
-
- function Default_DLL_Address return String is
- begin
- return "";
- end Default_DLL_Address;
-
- -------------
- -- DLL_Ext --
- -------------
-
- function DLL_Ext return String is
- begin
- return "exe";
- end DLL_Ext;
-
- --------------------
- -- Dynamic_Option --
- --------------------
-
- function Dynamic_Option return String is
- begin
- return "-shared";
- end Dynamic_Option;
-
- -------------------
- -- Is_Object_Ext --
- -------------------
-
- function Is_Object_Ext (Ext : String) return Boolean is
- begin
- return Ext = ".obj";
- end Is_Object_Ext;
-
- --------------
- -- Is_C_Ext --
- --------------
-
- function Is_C_Ext (Ext : String) return Boolean is
- begin
- return Ext = ".c";
- end Is_C_Ext;
-
- --------------------
- -- Is_Archive_Ext --
- --------------------
-
- function Is_Archive_Ext (Ext : String) return Boolean is
- begin
- return Ext = ".olb" or else Ext = ".exe";
- end Is_Archive_Ext;
-
- -------------
- -- Libgnat --
- -------------
-
- function Libgnat return String is
- Libgnat_A : constant String := "libgnat.a";
- Libgnat_Olb : constant String := "libgnat.olb";
-
- begin
- Name_Len := Libgnat_A'Length;
- Name_Buffer (1 .. Name_Len) := Libgnat_A;
-
- if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then
- return Libgnat_A;
-
- else
- return Libgnat_Olb;
- end if;
- end Libgnat;
-
- ------------------------
- -- Library_Exists_For --
- ------------------------
-
- function Library_Exists_For (Project : Project_Id) return Boolean is
- begin
- if not Projects.Table (Project).Library then
- Fail ("INTERNAL ERROR: Library_Exists_For called " &
- "for non library project");
- return False;
-
- else
- declare
- Lib_Dir : constant String :=
- Get_Name_String (Projects.Table (Project).Library_Dir);
- Lib_Name : constant String :=
- Get_Name_String (Projects.Table (Project).Library_Name);
-
- begin
- if Projects.Table (Project).Library_Kind = Static then
- return Is_Regular_File
- (Lib_Dir & Directory_Separator & "lib" &
- Fil.Ext_To (Lib_Name, Archive_Ext));
-
- else
- return Is_Regular_File
- (Lib_Dir & Directory_Separator & "lib" &
- Fil.Ext_To (Lib_Name, DLL_Ext));
- end if;
- end;
- end if;
- end Library_Exists_For;
-
- ---------------------------
- -- Library_File_Name_For --
- ---------------------------
-
- function Library_File_Name_For (Project : Project_Id) return Name_Id is
- begin
- if not Projects.Table (Project).Library then
- Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
- "for non library project");
- return No_Name;
-
- else
- declare
- Lib_Name : constant String :=
- Get_Name_String (Projects.Table (Project).Library_Name);
-
- begin
- Name_Len := 3;
- Name_Buffer (1 .. Name_Len) := "lib";
-
- if Projects.Table (Project).Library_Kind = Static then
- Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
-
- else
- Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
- end if;
-
- return Name_Find;
- end;
- end if;
- end Library_File_Name_For;
-
- ----------------
- -- Object_Ext --
- ----------------
-
- function Object_Ext return String is
- begin
- return "obj";
- end Object_Ext;
-
- ----------------
- -- PIC_Option --
- ----------------
-
- function PIC_Option return String is
- begin
- return "";
- end PIC_Option;
-
- -----------------------------------------------
- -- Standalone_Library_Auto_Init_Is_Supported --
- -----------------------------------------------
-
- function Standalone_Library_Auto_Init_Is_Supported return Boolean is
- begin
- return True;
- end Standalone_Library_Auto_Init_Is_Supported;
-
- ---------------------------
- -- Support_For_Libraries --
- ---------------------------
-
- function Support_For_Libraries return Library_Support is
- begin
- return Full;
- end Support_For_Libraries;
-
-end MLib.Tgt;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Register_Opt_Config_Switches is
begin
- Ada_83_Config := Ada_83;
+ Ada_Version_Config := Ada_Version;
Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks;
Exception_Locations_Suppressed_Config := Exception_Locations_Suppressed;
Extensions_Allowed_Config := Extensions_Allowed;
procedure Restore_Opt_Config_Switches (Save : Config_Switches_Type) is
begin
- Ada_83 := Save.Ada_83;
- Ada_95 := not Ada_83;
+ Ada_Version := Save.Ada_Version;
Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks;
Exception_Locations_Suppressed := Save.Exception_Locations_Suppressed;
Extensions_Allowed := Save.Extensions_Allowed;
procedure Save_Opt_Config_Switches (Save : out Config_Switches_Type) is
begin
- Save.Ada_83 := Ada_83;
+ Save.Ada_Version := Ada_Version;
Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks;
Save.Exception_Locations_Suppressed := Exception_Locations_Suppressed;
Save.Extensions_Allowed := Extensions_Allowed;
procedure Set_Opt_Config_Switches (Internal_Unit : Boolean) is
begin
if Internal_Unit then
- Ada_83 := False;
- Ada_95 := True;
+ Ada_Version := Ada_Version_Default;
Dynamic_Elaboration_Checks := False;
Extensions_Allowed := True;
External_Name_Exp_Casing := As_Is;
Use_VADS_Size := False;
else
- Ada_83 := Ada_83_Config;
- Ada_95 := not Ada_83_Config;
+ Ada_Version := Ada_Version_Config;
Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config;
Extensions_Allowed := Extensions_Allowed_Config;
External_Name_Exp_Casing := External_Name_Exp_Casing_Config;
procedure Tree_Read is
Tree_Version_String_Len : Nat;
+ Ada_Version_Config_Val : Nat;
begin
Tree_Read_Int (Tree_ASIS_Version_Number);
Tree_Read_Bool (Verbose_Mode);
Tree_Read_Data (Warning_Mode'Address,
Warning_Mode_Type'Object_Size / Storage_Unit);
- Tree_Read_Bool (Ada_83_Config);
+ Tree_Read_Int (Ada_Version_Config_Val);
Tree_Read_Bool (All_Errors_Mode);
Tree_Read_Bool (Assertions_Enabled);
Tree_Read_Bool (Enable_Overflow_Checks);
Tree_Read_Bool (Full_List);
+ Ada_Version_Config := Ada_Version_Type'Val (Ada_Version_Config_Val);
+
-- Read version string: we have to check the length first
Tree_Read_Int (Tree_Version_String_Len);
Tree_Write_Bool (Verbose_Mode);
Tree_Write_Data (Warning_Mode'Address,
Warning_Mode_Type'Object_Size / Storage_Unit);
- Tree_Write_Bool (Ada_83_Config);
+ Tree_Write_Int (Ada_Version_Type'Pos (Ada_Version_Config));
Tree_Write_Bool (All_Errors_Mode);
Tree_Write_Bool (Assertions_Enabled);
Tree_Write_Bool (Enable_Overflow_Checks);
-- GNATBIND, GNATLINK
-- Set True if binder file to be generated in Ada rather than C
- Ada_95 : Boolean := True;
+ type Ada_Version_Type is (Ada_83, Ada_95, Ada_05);
+ -- Versions of Ada for Ada_Version below. Note that these are ordered,
+ -- so that tests like Ada_Version >= Ada_95 are legitimate and useful.
+
+ Ada_Version_Default : Ada_Version_Type := Ada_95;
-- GNAT
- -- Set True if operating in Ada 95 mode
- -- Set False if operating in Ada 83 mode
+ -- Default Ada version if no switch given
- Ada_83 : Boolean := False;
+ Ada_Version : Ada_Version_Type := Ada_Version_Default;
-- GNAT
- -- Set True if operating in Ada 83 mode
- -- Set False if operating in Ada 95 mode
+ -- Current Ada version for compiler
Ada_Final_Suffix : constant String := "final";
Ada_Final_Name : String_Ptr := new String'("ada" & Ada_Final_Suffix);
Extensions_Allowed : Boolean := False;
-- GNAT
-- Set to True by switch -gnatX if GNAT specific language extensions
- -- are allowed. For example, "with type" is a GNAT extension.
+ -- are allowed. For example, "limited with" is a GNAT extension.
type External_Casing_Type is (
As_Is, -- External names cased as they appear in the Ada source
-- 'p' PC (US, IBM page 437)
-- '8' PC (European, IBM page 850)
-- 'f' Full upper set (all distinct)
- -- 'n' No upper characters (Ada/83 rules)
+ -- 'n' No upper characters (Ada 83 rules)
-- 'w' Latin-1 plus wide characters allowed in identifiers
--
-- The setting affects the set of letters allowed in identifiers and the
-- command line switches, or by the use of appropriate configuration
-- pragmas in the gnat.adc file.
- Ada_83_Config : Boolean;
+ Ada_Version_Config : Ada_Version_Type;
-- GNAT
- -- This is the value of the configuration switch for Ada 83 mode, as set
- -- by the command line switch -gnat83, and possibly modified by the use
- -- of configuration pragmas Ada_95 and Ada_83 in the gnat.adc file. This
- -- switch is used to set the initial value for Ada_83 mode at the start
+ -- This is the value of the configuration switch for the Ada 83 mode, as
+ -- set by the command line switches -gnat83/95/05, and possibly modified
+ -- by the use of configuration pragmas Ada_83/Ada95/Ada05. This switch
+ -- is used to set the initial value for Ada_Version mode at the start
-- of analysis of a unit. Note however, that the setting of this flag
-- is ignored for internal and predefined units (which are always compiled
- -- in Ada 95 mode).
+ -- in the most up to date version of Ada).
Dynamic_Elaboration_Checks_Config : Boolean := False;
-- GNAT
private
type Config_Switches_Type is record
- Ada_83 : Boolean;
+ Ada_Version : Ada_Version_Type;
Dynamic_Elaboration_Checks : Boolean;
Exception_Locations_Suppressed : Boolean;
Extensions_Allowed : Boolean;
Unit_Node := Specification (Unit_Node);
elsif Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_N
("(Ada 83) library unit renaming not allowed", Unit_Node);
end if;
-- Ada 83 error checks
- if Ada_83 then
+ if Ada_Version = Ada_83 then
-- Check we did not with any child units
-- WITH_CLAUSE ::=
-- [LIMITED] [PRIVATE] with library_unit_NAME {,library_unit_NAME};
- -- Note: the two qualifiers are ADA0Y extensions.
+ -- Note: the two qualifiers are Ada 2005 extensions.
-- WITH_TYPE_CLAUSE ::=
-- with type type_NAME is access; | with type type_NAME is tagged;
-- Processing for WITH clause
- -- Ada0Y (AI-50217, AI-262): First check for LIMITED WITH,
+ -- Ada 2005 (AI-50217, AI-262): First check for LIMITED WITH,
-- PRIVATE WITH, or both.
if Token = Tok_Limited then
Error_Msg_SC ("unexpected LIMITED ignored");
end if;
- if not Extensions_Allowed then
- Error_Msg_SP ("`LIMITED WITH` is an Ada0X extension");
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP ("LIMITED WITH is an Ada 2005 extension");
Error_Msg_SP
- ("\unit must be compiled with -gnatX switch");
-
+ ("\unit must be compiled with -gnat05 switch");
end if;
elsif Token = Tok_Private then
Restore_Scan_State (Scan_State); -- to PRIVATE
return Item_List;
- elsif not Extensions_Allowed then
- Error_Msg_SP ("`PRIVATE WITH` is an Ada0X extension");
+ elsif Ada_Version < Ada_05 then
+ Error_Msg_SP ("PRIVATE WITH is an Ada 2005 extension");
Error_Msg_SP
- ("\unit must be compiled with -gnatX switch");
+ ("\unit must be compiled with -gnat05 switch");
end if;
else
if Token = Tok_Type then
- -- WITH TYPE is an extension
+ -- WITH TYPE is an GNAT specific extension
if not Extensions_Allowed then
- Error_Msg_SP ("`WITH TYPE` is a non-standard extension");
+ Error_Msg_SP ("`WITH TYPE` is a 'G'N'A'T extension");
Error_Msg_SP ("\unit must be compiled with -gnatX switch");
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Scan; -- past identifier
if Token = Tok_Colon then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SP ("(Ada 83) choice parameter not allowed!");
end if;
case Token is
when Tok_Access |
- Tok_Not => -- Ada 0Y (AI-231)
+ Tok_Not => -- Ada 2005 (AI-231)
Typedef_Node := P_Access_Type_Definition;
TF_Semicolon;
exit;
-- LIMITED RECORD or LIMITED NULL RECORD
if Token = Tok_Record or else Token = Tok_Null then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SP
("(Ada 83) limited record declaration not allowed!");
end if;
Scan; -- past NEW
end if;
- Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Subtype_Indication
return False;
else
- if not Extensions_Allowed then
+ if Ada_Version < Ada_05 then
Error_Msg_SP
- ("null-excluding access is an Ada 0Y extension");
- Error_Msg_SP ("\unit must be compiled with -gnatX switch");
+ ("null-excluding access is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
Scan; -- past NOT
if Token = Tok_Null then
Scan; -- past NULL
else
- Error_Msg_SP ("(Ada 0Y) missing NULL");
+ Error_Msg_SP ("NULL expected");
end if;
return True;
return Subtype_Mark;
else
if Not_Null_Present then
- Error_Msg_SP ("(Ada 0Y) constrained null-exclusion not allowed");
+ Error_Msg_SP ("constrained null-exclusion not allowed");
end if;
Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
if Present (Init_Expr) then
if Not_Null_Present then
- Error_Msg_SP ("(Ada 0Y) null-exclusion not allowed in "
+ Error_Msg_SP ("null-exclusion not allowed in "
& "numeric expression");
end if;
(Decl_Node, P_Array_Type_Definition);
else
- Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Object_Definition (Decl_Node,
(Decl_Node, P_Array_Type_Definition);
else
- Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Object_Definition (Decl_Node,
P_Subtype_Indication (Not_Null_Present));
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
- -- Ada 0Y (AI-254)
+ -- Ada 2005 (AI-254)
elsif Token = Tok_Not then
-- ...
-- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
- Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
if Token = Tok_Access then
- if not Extensions_Allowed then
+ if Ada_Version < Ada_05 then
Error_Msg_SP
("generalized use of anonymous access types " &
- "is an Ada 0Y extension");
- Error_Msg_SP ("\unit must be compiled with -gnatX switch");
+ "is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
Acc_Node := P_Access_Definition (Not_Null_Present);
-- Object renaming declaration
if Token_Is_Renames then
- Error_Msg_SP ("(Ada 0Y) null-exclusion not allowed in "
- & "object renamings");
+ Error_Msg_SP
+ ("null-exclusion not allowed in object renamings");
raise Error_Resync;
-- Object declaration
end if;
end if;
- -- Ada 0Y (AI-230): Access Definition case
+ -- Ada 2005 (AI-230): Access Definition case
elsif Token = Tok_Access then
- if not Extensions_Allowed then
+ if Ada_Version < Ada_05 then
Error_Msg_SP
("generalized use of anonymous access types " &
- "is an Ada 0Y extension");
- Error_Msg_SP ("\unit must be compiled with -gnatX switch");
+ "is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
Scan;
end if;
- Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present);
Set_Subtype_Indication (Typedef_Node,
P_Subtype_Indication (Not_Null_Present));
Typedef_Node : Node_Id;
begin
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83): modular types not allowed");
end if;
Check_Simple_Expression_In_Ada_83 (Delta_Node);
if Token = Tok_Digits then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!");
end if;
Scan; -- past ALIASED
end if;
- Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231/AI-254)
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
- -- Ada 0Y (AI-230): Access Definition case
+ -- Ada 2005 (AI-230): Access Definition case
if Token = Tok_Access then
- if not Extensions_Allowed then
+ if Ada_Version < Ada_05 then
Error_Msg_SP
("generalized use of anonymous access types " &
- "is an Ada 0Y extension");
- Error_Msg_SP ("\unit must be compiled with -gnatX switch");
+ "is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
if Aliased_Present then
Scan; -- past the left paren
if Token = Tok_Box then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
end if;
Specification_Node :=
New_Node (N_Discriminant_Specification, Ident_Sloc);
Set_Defining_Identifier (Specification_Node, Idents (Ident));
- Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
if Token = Tok_Access then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC
("(Ada 83) access discriminant not allowed!");
end if;
Set_Discriminant_Type
(Specification_Node, P_Subtype_Mark);
No_Constraint;
- Set_Null_Exclusion_Present -- Ada 0Y (AI-231)
+ Set_Null_Exclusion_Present -- Ada 2005 (AI-231)
(Specification_Node, Not_Null_Present);
end if;
Scan; -- past ALIASED
end if;
- Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231/AI-254)
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
- -- Ada 0Y (AI-230): Access Definition case
+ -- Ada 2005 (AI-230): Access Definition case
if Token = Tok_Access then
- if not Extensions_Allowed then
+ if Ada_Version < Ada_05 then
Error_Msg_SP
- ("Generalized use of anonymous access types " &
- "is an Ada 0Y extension");
- Error_Msg_SP ("\unit must be compiled with -gnatX switch");
+ ("generalized use of anonymous access types " &
+ "is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
if Aliased_Present then
-- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
- -- Ada 0Y (AI-254): If Header_Already_Parsed then the caller has already
+ -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
-- parsed the null_exclusion part and has also removed the ACCESS token;
-- otherwise the caller has just checked that the initial token is ACCESS
begin
if not Header_Already_Parsed then
- Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
Scan; -- past ACCESS
end if;
end if;
if Token = Tok_Procedure then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) access to procedure not allowed!");
end if;
Set_Protected_Present (Type_Def_Node, Prot_Flag);
elsif Token = Tok_Function then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) access to function not allowed!");
end if;
Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
if Token = Tok_All or else Token = Tok_Constant then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) access modifier not allowed!");
end if;
Def_Node := New_Node (N_Access_Definition, Token_Ptr);
Scan; -- past ACCESS
- -- Ada 0Y (AI-254/AI-231)
+ -- Ada 2005 (AI-254/AI-231)
- if Extensions_Allowed then
+ if Ada_Version >= Ada_05 then
- -- Ada 0Y (AI-254): Access_To_Subprogram_Definition
+ -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
if Token = Tok_Protected
or else Token = Tok_Procedure
Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present);
Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node);
- -- Ada 0Y (AI-231)
+ -- Ada 2005 (AI-231)
-- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
else
-- Ada 95
else
- -- Ada 0Y (AI-254): The null-exclusion present is never present
+ -- Ada 2005 (AI-254): The null-exclusion present is never present
-- in Ada 83 and Ada 95
pragma Assert (Null_Exclusion_Present = False);
-- Error recovery: can raise Error_Resync
-- Note: POSITIONAL_ARRAY_AGGREGATE rule has been extended to give support
- -- to Ada0Y limited aggregates (AI-287)
+ -- to Ada 2005 limited aggregates (AI-287)
function P_Aggregate_Or_Paren_Expr return Node_Id is
Aggregate_Node : Node_Id;
end if;
end if;
- -- Ada0Y (AI-287): The box notation is allowed only with named
+ -- Ada 2005 (AI-287): The box notation is allowed only with named
-- notation because positional notation might be error prone. For
-- example, in "(X, <>, Y, <>)", there is no type associated with
-- the boxes, so you might not be leaving out the components you
-- thought you were leaving out.
- if Extensions_Allowed and then Token = Tok_Box then
- Error_Msg_SC ("(Ada 0Y) box notation only allowed with "
+ if Ada_Version >= Ada_05 and then Token = Tok_Box then
+ Error_Msg_SC ("(Ada 2005) box notation only allowed with "
& "named notation");
Scan; -- past BOX
Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
return Error;
end if;
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) extension aggregate not allowed");
end if;
-- Error recovery: can raise Error_Resync
-- Note: RECORD_COMPONENT_ASSOCIATION and ARRAY_COMPONENT_ASSOCIATION
- -- rules have been extended to give support to Ada0Y limited
+ -- rules have been extended to give support to Ada 2005 limited
-- aggregates (AI-287)
function P_Record_Or_Array_Component_Association return Node_Id is
if Token = Tok_Box then
- -- Ada0Y (AI-287): The box notation is used to indicate the default
- -- initialization of limited aggregate components
+ -- Ada 2005(AI-287): The box notation is used to indicate the
+ -- default initialization of limited aggregate components
- if not Extensions_Allowed then
+ if Ada_Version < Ada_05 then
Error_Msg_SP
- ("(Ada 0Y) limited aggregates are an Ada0X extension");
- Error_Msg_SP ("\unit must be compiled with -gnatX switch");
+ ("limited aggregate is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
Set_Box_Present (Assoc_Node);
Alloc_Node := New_Node (N_Allocator, Token_Ptr);
T_New;
- -- Scan Null_Exclusion if present (Ada 0Y (AI-231))
+ -- Scan Null_Exclusion if present (Ada 2005 (AI-231))
Null_Exclusion_Present := P_Null_Exclusion;
Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Check for misplacement of later vs basic declarations in Ada 83
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Decl := First (Decls);
-- Loop through sequence of basic declarative items
if Nkind (Decl) not in N_Later_Decl_Item
and then Nkind (Decl) /= N_Pragma
then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_Sloc := Body_Sloc;
Error_Msg_N
("(Ada 83) decl cannot appear after body#", Decl);
Error_Msg_SP ("child unit allowed only at library level");
raise Error_Resync;
- elsif Ada_83 then
+ elsif Ada_Version = Ada_83 then
Error_Msg_SP ("(Ada 83) child unit not allowed!");
end if;
Specification_Node :=
New_Node (N_Parameter_Specification, Ident_Sloc);
Set_Defining_Identifier (Specification_Node, Idents (Ident));
- Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
if Token = Tok_Access then
Set_Null_Exclusion_Present
(Specification_Node, Not_Null_Present);
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) access parameters not allowed");
end if;
end if;
P_Mode (Specification_Node);
- Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
end if;
Set_Null_Exclusion_Present
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Use_Node := New_Node (N_Use_Type_Clause, Prev_Token_Ptr);
Set_Subtype_Marks (Use_Node, New_List);
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) use type not allowed!");
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Exception handlers not allowed in Ada 95 node
if Present (Exception_Handlers (Hand_Seq)) then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_N
("(Ada 83) exception handlers in accept not allowed",
First_Non_Pragma (Exception_Handlers (Hand_Seq)));
-- Else error
else
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_BC ("OR or ELSE expected");
else
Error_Msg_BC ("OR or ELSE or THEN ABORT expected");
Abortable_Part_Node := New_Node (N_Abortable_Part, Token_Ptr);
T_Abort; -- scan past ABORT
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SP ("(Ada 83) asynchronous select not allowed!");
end if;
------------
-- This pragma must be processed at parse time, since we want to set
- -- the Ada 83 and Ada 95 switches properly at parse time to recognize
- -- Ada 83 syntax or Ada 95 syntax as appropriate.
+ -- the Ada version properly at parse time to recognize the appropriate
+ -- Ada version syntax.
when Pragma_Ada_83 =>
- Ada_83 := True;
- Ada_95 := False;
+ Ada_Version := Ada_83;
------------
-- Ada_95 --
------------
-- This pragma must be processed at parse time, since we want to set
- -- the Ada 83 and Ada_95 switches properly at parse time to recognize
- -- Ada 83 syntax or Ada 95 syntax as appropriate.
+ -- the Ada version properly at parse time to recognize the appropriate
+ -- Ada version syntax.
when Pragma_Ada_95 =>
- Ada_83 := False;
- Ada_95 := True;
+ Ada_Version := Ada_95;
+
+ ------------
+ -- Ada_05 --
+ ------------
+
+ -- This pragma must be processed at parse time, since we want to set
+ -- the Ada version properly at parse time to recognize the appropriate
+ -- Ada version syntax.
+
+ when Pragma_Ada_05 =>
+ Ada_Version := Ada_05;
-----------
-- Debug --
Check_Arg_Count (1);
Check_No_Identifier (Arg1);
Check_Arg_Is_On_Or_Off (Arg1);
- Opt.Extensions_Allowed := (Chars (Expression (Arg1)) = Name_On);
+
+ if Chars (Expression (Arg1)) = Name_On then
+ Extensions_Allowed := True;
+ Ada_Version := Ada_Version_Type'Last;
+ else
+ Extensions_Allowed := False;
+ Ada_Version := Ada_Version_Type'Min (Ada_Version, Ada_95);
+ end if;
----------------
-- List (2.8) --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id) is
begin
if Expr_Form = EF_Non_Simple then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_N ("(Ada 83) this expression must be parenthesized!", E);
end if;
end if;
function P_Access_Definition
(Null_Exclusion_Present : Boolean) return Node_Id;
- -- Ada 0Y (AI-231/AI-254): The caller parses the null-exclusion part
+ -- Ada 2005 (AI-231/AI-254): The caller parses the null-exclusion part
-- and indicates if it was present
function P_Access_Type_Definition
(Header_Already_Parsed : Boolean := False) return Node_Id;
- -- Ada 0Y (AI-254): The formal is used to indicate if the caller has
+ -- Ada 2005 (AI-254): The formal is used to indicate if the caller has
-- parsed the null_exclusion part. In this case the caller has also
-- removed the ACCESS token
-- declaration of this type for details.
function P_Null_Exclusion return Boolean;
- -- Ada 0Y (AI-231): Parse the null-excluding part. True indicates
+ -- Ada 2005 (AI-231): Parse the null-excluding part. True indicates
-- that the null-excluding part was present.
function P_Subtype_Indication
(Not_Null_Present : Boolean := False) return Node_Id;
- -- Ada 0Y (AI-231): The flag Not_Null_Present indicates that the
+ -- Ada 2005 (AI-231): The flag Not_Null_Present indicates that the
-- null-excluding part has been scanned out and it was present.
function Init_Expr_Opt (P : Boolean := False) return Node_Id;
Not_Null_Present : Boolean := False) return Node_Id;
-- This version of P_Subtype_Indication is called when the caller has
-- already scanned out the subtype mark which is passed as a parameter.
- -- Ada 0Y (AI-231): The flag Not_Null_Present indicates that the
+ -- Ada 2005 (AI-231): The flag Not_Null_Present indicates that the
-- null-excluding part has been scanned out and it was present.
function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id;
"Ladefault_switches#" &
"Lbswitches#" &
+ -- package Metrics
+
+ "Pmetrics#" &
+ "Ladefault_switches#" &
+ "Lbswitches#" &
+
-- package Ide
"Pide#" &
else
Data.Symbol_Data.Reference := Lib_Ref_Symbol_File.Value;
- Get_Name_String (Lib_Symbol_File.Value);
+ Get_Name_String (Lib_Ref_Symbol_File.Value);
if Name_Len = 0 then
Error_Msg
then
Name_Len := Last;
Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
Canonical_Name := Name_Find;
NL := Source_Names.Get (Canonical_Name);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . A U X _ D E C --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1996-2004 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS For A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains definitions that are designed to be compatible
+-- with the extra definitions in package System for DEC Ada implementations.
+
+-- These definitions can be used directly by withing this package, or merged
+-- with System using pragma Extend_System (Aux_DEC)
+
+-- This is the IPF VMS 64 bit version.
+
+with Unchecked_Conversion;
+
+package System.Aux_DEC is
+pragma Elaborate_Body (Aux_DEC);
+
+ subtype Short_Address is Address
+ range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1;
+ for Short_Address'Object_Size use 32;
+ -- This subtype allows addresses to be converted from 64 bits to 32 bits
+ -- with an appropriate range check. Note that since this is a subtype of
+ -- type System.Address, the same limitations apply to this subtype. Namely
+ -- there are no visible arithmetic operations, and integer literals are
+ -- not available.
+
+ Short_Memory_Size : constant := 2 ** 32;
+ -- Defined for convenience of porting.
+
+ type Integer_8 is range -2 ** (8 - 1) .. +2 ** (8 - 1) - 1;
+ for Integer_8'Size use 8;
+
+ type Integer_16 is range -2 ** (16 - 1) .. +2 ** (16 - 1) - 1;
+ for Integer_16'Size use 16;
+
+ type Integer_32 is range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1;
+ for Integer_32'Size use 32;
+
+ type Integer_64 is range -2 ** (64 - 1) .. +2 ** (64 - 1) - 1;
+ for Integer_64'Size use 64;
+
+ type Largest_Integer is range Min_Int .. Max_Int;
+
+ type AST_Handler is limited private;
+
+ No_AST_Handler : constant AST_Handler;
+
+ type Type_Class is
+ (Type_Class_Enumeration,
+ Type_Class_Integer,
+ Type_Class_Fixed_Point,
+ Type_Class_Floating_Point,
+ Type_Class_Array,
+ Type_Class_Record,
+ Type_Class_Access,
+ Type_Class_Task, -- also in Ada 95 protected
+ Type_Class_Address);
+
+ function "not" (Left : Largest_Integer) return Largest_Integer;
+ function "and" (Left, Right : Largest_Integer) return Largest_Integer;
+ function "or" (Left, Right : Largest_Integer) return Largest_Integer;
+ function "xor" (Left, Right : Largest_Integer) return Largest_Integer;
+
+ Address_Zero : constant Address;
+ No_Addr : constant Address;
+ Address_Size : constant := Standard'Address_Size;
+
+ function "+" (Left : Address; Right : Integer) return Address;
+ function "+" (Left : Integer; Right : Address) return Address;
+ function "-" (Left : Address; Right : Address) return Integer;
+ function "-" (Left : Address; Right : Integer) return Address;
+
+ generic
+ type Target is private;
+ function Fetch_From_Address (A : Address) return Target;
+
+ generic
+ type Target is private;
+ procedure Assign_To_Address (A : Address; T : Target);
+
+ -- Floating point type declarations for VAX floating point data types
+
+ pragma Warnings (Off);
+
+ type F_Float is digits 6;
+ pragma Float_Representation (VAX_Float, F_Float);
+
+ type D_Float is digits 9;
+ pragma Float_Representation (Vax_Float, D_Float);
+
+ type G_Float is digits 15;
+ pragma Float_Representation (Vax_Float, G_Float);
+
+ -- Floating point type declarations for IEEE floating point data types
+
+ type IEEE_Single_Float is digits 6;
+ pragma Float_Representation (IEEE_Float, IEEE_Single_Float);
+
+ type IEEE_Double_Float is digits 15;
+ pragma Float_Representation (IEEE_Float, IEEE_Double_Float);
+
+ pragma Warnings (On);
+
+ Non_Ada_Error : exception;
+
+ -- Hardware-oriented types and functions
+
+ type Bit_Array is array (Integer range <>) of Boolean;
+ pragma Pack (Bit_Array);
+
+ subtype Bit_Array_8 is Bit_Array (0 .. 7);
+ subtype Bit_Array_16 is Bit_Array (0 .. 15);
+ subtype Bit_Array_32 is Bit_Array (0 .. 31);
+ subtype Bit_Array_64 is Bit_Array (0 .. 63);
+
+ type Unsigned_Byte is range 0 .. 255;
+ for Unsigned_Byte'Size use 8;
+
+ function "not" (Left : Unsigned_Byte) return Unsigned_Byte;
+ function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte;
+ function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte;
+ function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte;
+
+ function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte;
+ function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8;
+
+ type Unsigned_Byte_Array is array (Integer range <>) of Unsigned_Byte;
+
+ type Unsigned_Word is range 0 .. 65535;
+ for Unsigned_Word'Size use 16;
+
+ function "not" (Left : Unsigned_Word) return Unsigned_Word;
+ function "and" (Left, Right : Unsigned_Word) return Unsigned_Word;
+ function "or" (Left, Right : Unsigned_Word) return Unsigned_Word;
+ function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word;
+
+ function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word;
+ function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16;
+
+ type Unsigned_Word_Array is array (Integer range <>) of Unsigned_Word;
+
+ type Unsigned_Longword is range -2_147_483_648 .. 2_147_483_647;
+ for Unsigned_Longword'Size use 32;
+
+ function "not" (Left : Unsigned_Longword) return Unsigned_Longword;
+ function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword;
+ function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword;
+ function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword;
+
+ function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword;
+ function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32;
+
+ type Unsigned_Longword_Array is
+ array (Integer range <>) of Unsigned_Longword;
+
+ type Unsigned_32 is range 0 .. 4_294_967_295;
+ for Unsigned_32'Size use 32;
+
+ function "not" (Left : Unsigned_32) return Unsigned_32;
+ function "and" (Left, Right : Unsigned_32) return Unsigned_32;
+ function "or" (Left, Right : Unsigned_32) return Unsigned_32;
+ function "xor" (Left, Right : Unsigned_32) return Unsigned_32;
+
+ function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32;
+ function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32;
+
+ type Unsigned_Quadword is record
+ L0 : Unsigned_Longword;
+ L1 : Unsigned_Longword;
+ end record;
+
+ for Unsigned_Quadword'Size use 64;
+ for Unsigned_Quadword'Alignment use
+ Integer'Min (8, Standard'Maximum_Alignment);
+
+ function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword;
+ function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword;
+ function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword;
+ function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword;
+
+ function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword;
+ function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64;
+
+ type Unsigned_Quadword_Array is
+ array (Integer range <>) of Unsigned_Quadword;
+
+ function To_Address (X : Integer) return Address;
+ pragma Pure_Function (To_Address);
+
+ function To_Address_Long (X : Unsigned_Longword) return Address;
+ pragma Pure_Function (To_Address_Long);
+
+ function To_Integer (X : Address) return Integer;
+
+ function To_Unsigned_Longword (X : Address) return Unsigned_Longword;
+ function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword;
+
+ -- Conventional names for static subtypes of type UNSIGNED_LONGWORD
+
+ subtype Unsigned_1 is Unsigned_Longword range 0 .. 2** 1-1;
+ subtype Unsigned_2 is Unsigned_Longword range 0 .. 2** 2-1;
+ subtype Unsigned_3 is Unsigned_Longword range 0 .. 2** 3-1;
+ subtype Unsigned_4 is Unsigned_Longword range 0 .. 2** 4-1;
+ subtype Unsigned_5 is Unsigned_Longword range 0 .. 2** 5-1;
+ subtype Unsigned_6 is Unsigned_Longword range 0 .. 2** 6-1;
+ subtype Unsigned_7 is Unsigned_Longword range 0 .. 2** 7-1;
+ subtype Unsigned_8 is Unsigned_Longword range 0 .. 2** 8-1;
+ subtype Unsigned_9 is Unsigned_Longword range 0 .. 2** 9-1;
+ subtype Unsigned_10 is Unsigned_Longword range 0 .. 2**10-1;
+ subtype Unsigned_11 is Unsigned_Longword range 0 .. 2**11-1;
+ subtype Unsigned_12 is Unsigned_Longword range 0 .. 2**12-1;
+ subtype Unsigned_13 is Unsigned_Longword range 0 .. 2**13-1;
+ subtype Unsigned_14 is Unsigned_Longword range 0 .. 2**14-1;
+ subtype Unsigned_15 is Unsigned_Longword range 0 .. 2**15-1;
+ subtype Unsigned_16 is Unsigned_Longword range 0 .. 2**16-1;
+ subtype Unsigned_17 is Unsigned_Longword range 0 .. 2**17-1;
+ subtype Unsigned_18 is Unsigned_Longword range 0 .. 2**18-1;
+ subtype Unsigned_19 is Unsigned_Longword range 0 .. 2**19-1;
+ subtype Unsigned_20 is Unsigned_Longword range 0 .. 2**20-1;
+ subtype Unsigned_21 is Unsigned_Longword range 0 .. 2**21-1;
+ subtype Unsigned_22 is Unsigned_Longword range 0 .. 2**22-1;
+ subtype Unsigned_23 is Unsigned_Longword range 0 .. 2**23-1;
+ subtype Unsigned_24 is Unsigned_Longword range 0 .. 2**24-1;
+ subtype Unsigned_25 is Unsigned_Longword range 0 .. 2**25-1;
+ subtype Unsigned_26 is Unsigned_Longword range 0 .. 2**26-1;
+ subtype Unsigned_27 is Unsigned_Longword range 0 .. 2**27-1;
+ subtype Unsigned_28 is Unsigned_Longword range 0 .. 2**28-1;
+ subtype Unsigned_29 is Unsigned_Longword range 0 .. 2**29-1;
+ subtype Unsigned_30 is Unsigned_Longword range 0 .. 2**30-1;
+ subtype Unsigned_31 is Unsigned_Longword range 0 .. 2**31-1;
+
+ -- Function for obtaining global symbol values
+
+ function Import_Value (Symbol : String) return Unsigned_Longword;
+ function Import_Address (Symbol : String) return Address;
+ function Import_Largest_Value (Symbol : String) return Largest_Integer;
+
+ pragma Import (Intrinsic, Import_Value);
+ pragma Import (Intrinsic, Import_Address);
+ pragma Import (Intrinsic, Import_Largest_Value);
+
+ -- For the following declarations, note that the declaration without
+ -- a Retry_Count parameter means to retry infinitely. A value of zero
+ -- for the Retry_Count parameter means do not retry.
+
+ -- Interlocked-instruction procedures
+
+ procedure Clear_Interlocked
+ (Bit : in out Boolean;
+ Old_Value : out Boolean);
+
+ procedure Set_Interlocked
+ (Bit : in out Boolean;
+ Old_Value : out Boolean);
+
+ type Aligned_Word is record
+ Value : Short_Integer;
+ end record;
+
+ for Aligned_Word'Alignment use
+ Integer'Min (2, Standard'Maximum_Alignment);
+
+ procedure Clear_Interlocked
+ (Bit : in out Boolean;
+ Old_Value : out Boolean;
+ Retry_Count : in Natural;
+ Success_Flag : out Boolean);
+
+ procedure Set_Interlocked
+ (Bit : in out Boolean;
+ Old_Value : out Boolean;
+ Retry_Count : in Natural;
+ Success_Flag : out Boolean);
+
+ procedure Add_Interlocked
+ (Addend : in Short_Integer;
+ Augend : in out Aligned_Word;
+ Sign : out Integer);
+
+ type Aligned_Integer is record
+ Value : Integer;
+ end record;
+
+ for Aligned_Integer'Alignment use
+ Integer'Min (4, Standard'Maximum_Alignment);
+
+ type Aligned_Long_Integer is record
+ Value : Long_Integer;
+ end record;
+
+ for Aligned_Long_Integer'Alignment use
+ Integer'Min (8, Standard'Maximum_Alignment);
+
+ -- For the following declarations, note that the declaration without
+ -- a Retry_Count parameter mean to retry infinitely. A value of zero
+ -- for the Retry_Count means do not retry.
+
+ procedure Add_Atomic
+ (To : in out Aligned_Integer;
+ Amount : in Integer);
+
+ procedure Add_Atomic
+ (To : in out Aligned_Integer;
+ Amount : in Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Integer;
+ Success_Flag : out Boolean);
+
+ procedure Add_Atomic
+ (To : in out Aligned_Long_Integer;
+ Amount : in Long_Integer);
+
+ procedure Add_Atomic
+ (To : in out Aligned_Long_Integer;
+ Amount : in Long_Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Long_Integer;
+ Success_Flag : out Boolean);
+
+ procedure And_Atomic
+ (To : in out Aligned_Integer;
+ From : in Integer);
+
+ procedure And_Atomic
+ (To : in out Aligned_Integer;
+ From : in Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Integer;
+ Success_Flag : out Boolean);
+
+ procedure And_Atomic
+ (To : in out Aligned_Long_Integer;
+ From : in Long_Integer);
+
+ procedure And_Atomic
+ (To : in out Aligned_Long_Integer;
+ From : in Long_Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Long_Integer;
+ Success_Flag : out Boolean);
+
+ procedure Or_Atomic
+ (To : in out Aligned_Integer;
+ From : in Integer);
+
+ procedure Or_Atomic
+ (To : in out Aligned_Integer;
+ From : in Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Integer;
+ Success_Flag : out Boolean);
+
+ procedure Or_Atomic
+ (To : in out Aligned_Long_Integer;
+ From : in Long_Integer);
+
+ procedure Or_Atomic
+ (To : in out Aligned_Long_Integer;
+ From : in Long_Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Long_Integer;
+ Success_Flag : out Boolean);
+
+ type Insq_Status is
+ (Fail_No_Lock, OK_Not_First, OK_First);
+
+ for Insq_Status use
+ (Fail_No_Lock => -1,
+ OK_Not_First => 0,
+ OK_First => +1);
+
+ type Remq_Status is (
+ Fail_No_Lock,
+ Fail_Was_Empty,
+ OK_Not_Empty,
+ OK_Empty);
+
+ for Remq_Status use
+ (Fail_No_Lock => -1,
+ Fail_Was_Empty => 0,
+ OK_Not_Empty => +1,
+ OK_Empty => +2);
+
+ procedure Insqhi
+ (Item : in Address;
+ Header : in Address;
+ Status : out Insq_Status);
+
+ procedure Remqhi
+ (Header : in Address;
+ Item : out Address;
+ Status : out Remq_Status);
+
+ procedure Insqti
+ (Item : in Address;
+ Header : in Address;
+ Status : out Insq_Status);
+
+ procedure Remqti
+ (Header : in Address;
+ Item : out Address;
+ Status : out Remq_Status);
+
+private
+
+ Address_Zero : constant Address := Null_Address;
+ No_Addr : constant Address := Null_Address;
+
+ -- An AST_Handler value is from a typing point of view simply a pointer
+ -- to a procedure taking a single 64bit parameter. However, this
+ -- is a bit misleading, because the data that this pointer references is
+ -- highly stylized. See body of System.AST_Handling for full details.
+
+ type AST_Handler is access procedure (Param : Long_Integer);
+ No_AST_Handler : constant AST_Handler := null;
+
+ -- Other operators have incorrect profiles. It would be nice to make
+ -- them intrinsic, since the backend can handle them, but the front
+ -- end is not prepared to deal with them, so at least inline them.
+
+ pragma Inline_Always ("+");
+ pragma Inline_Always ("-");
+ pragma Inline_Always ("not");
+ pragma Inline_Always ("and");
+ pragma Inline_Always ("or");
+ pragma Inline_Always ("xor");
+
+ -- Other inlined subprograms
+
+ pragma Inline_Always (Fetch_From_Address);
+ pragma Inline_Always (Assign_To_Address);
+
+ -- Synchronization related subprograms. These are declared to have
+ -- convention C so that the critical parameters are passed by reference.
+ -- Without this, the parameters are passed by copy, creating load/store
+ -- race conditions. We also inline them, since this seems more in the
+ -- spirit of the original (hardware instrinsic) routines.
+
+ pragma Convention (C, Clear_Interlocked);
+ pragma Inline_Always (Clear_Interlocked);
+
+ pragma Convention (C, Set_Interlocked);
+ pragma Inline_Always (Set_Interlocked);
+
+ pragma Convention (C, Add_Interlocked);
+ pragma Inline_Always (Add_Interlocked);
+
+ pragma Convention (C, Add_Atomic);
+ pragma Inline_Always (Add_Atomic);
+
+ pragma Convention (C, And_Atomic);
+ pragma Inline_Always (And_Atomic);
+
+ pragma Convention (C, Or_Atomic);
+ pragma Inline_Always (Or_Atomic);
+
+ -- Provide proper unchecked conversion definitions for transfer
+ -- functions. Note that we need this level of indirection because
+ -- the formal parameter name is X and not Source (and this is indeed
+ -- detectable by a program)
+
+ function To_Unsigned_Byte_A is new
+ Unchecked_Conversion (Bit_Array_8, Unsigned_Byte);
+
+ function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte
+ renames To_Unsigned_Byte_A;
+
+ function To_Bit_Array_8_A is new
+ Unchecked_Conversion (Unsigned_Byte, Bit_Array_8);
+
+ function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8
+ renames To_Bit_Array_8_A;
+
+ function To_Unsigned_Word_A is new
+ Unchecked_Conversion (Bit_Array_16, Unsigned_Word);
+
+ function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word
+ renames To_Unsigned_Word_A;
+
+ function To_Bit_Array_16_A is new
+ Unchecked_Conversion (Unsigned_Word, Bit_Array_16);
+
+ function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16
+ renames To_Bit_Array_16_A;
+
+ function To_Unsigned_Longword_A is new
+ Unchecked_Conversion (Bit_Array_32, Unsigned_Longword);
+
+ function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword
+ renames To_Unsigned_Longword_A;
+
+ function To_Bit_Array_32_A is new
+ Unchecked_Conversion (Unsigned_Longword, Bit_Array_32);
+
+ function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32
+ renames To_Bit_Array_32_A;
+
+ function To_Unsigned_32_A is new
+ Unchecked_Conversion (Bit_Array_32, Unsigned_32);
+
+ function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32
+ renames To_Unsigned_32_A;
+
+ function To_Bit_Array_32_A is new
+ Unchecked_Conversion (Unsigned_32, Bit_Array_32);
+
+ function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32
+ renames To_Bit_Array_32_A;
+
+ function To_Unsigned_Quadword_A is new
+ Unchecked_Conversion (Bit_Array_64, Unsigned_Quadword);
+
+ function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword
+ renames To_Unsigned_Quadword_A;
+
+ function To_Bit_Array_64_A is new
+ Unchecked_Conversion (Unsigned_Quadword, Bit_Array_64);
+
+ function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64
+ renames To_Bit_Array_64_A;
+
+ pragma Warnings (Off);
+ -- Turn warnings off. This is needed for systems with 64-bit integers,
+ -- where some of these operations are of dubious meaning, but we do not
+ -- want warnings when we compile on such systems.
+
+ function To_Address_A is new
+ Unchecked_Conversion (Integer, Address);
+ pragma Pure_Function (To_Address_A);
+
+ function To_Address (X : Integer) return Address
+ renames To_Address_A;
+ pragma Pure_Function (To_Address);
+
+ function To_Address_Long_A is new
+ Unchecked_Conversion (Unsigned_Longword, Address);
+ pragma Pure_Function (To_Address_Long_A);
+
+ function To_Address_Long (X : Unsigned_Longword) return Address
+ renames To_Address_Long_A;
+ pragma Pure_Function (To_Address_Long);
+
+ function To_Integer_A is new
+ Unchecked_Conversion (Address, Integer);
+
+ function To_Integer (X : Address) return Integer
+ renames To_Integer_A;
+
+ function To_Unsigned_Longword_A is new
+ Unchecked_Conversion (Address, Unsigned_Longword);
+
+ function To_Unsigned_Longword (X : Address) return Unsigned_Longword
+ renames To_Unsigned_Longword_A;
+
+ function To_Unsigned_Longword_A is new
+ Unchecked_Conversion (AST_Handler, Unsigned_Longword);
+
+ function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword
+ renames To_Unsigned_Longword_A;
+
+ pragma Warnings (On);
+
+end System.Aux_DEC;
type Server_Task_Access is access Server_Task;
- Attached_Interrupts : array (Interrupt_ID) of Boolean;
- Handlers : array (Interrupt_ID) of Task_Id;
- Descriptors : array (Interrupt_ID) of Handler_Desc;
- Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0);
+ Handlers : array (Interrupt_ID) of Task_Id;
+ Descriptors : array (Interrupt_ID) of Handler_Desc;
+ Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0);
pragma Volatile_Components (Interrupt_Count);
function TISR is new Unchecked_Conversion (Handler_Ptr, isr_address);
+ --------------------
+ -- Signal_Handler --
+ --------------------
+
procedure Signal_Handler (Sig : Interrupt_ID) is
Handler : Task_Id renames Handlers (Sig);
+
begin
if Intr_Attach_Reset and then
intr_attach (int (Sig), TISR (Signal_Handler'Access)) = FUNC_ERR
if New_Handler = null then
- -- The null handler means we are detaching the handler.
+ -- The null handler means we are detaching the handler
- Attached_Interrupts (Interrupt) := False;
Descriptors (Interrupt) :=
(Kind => Unknown, T => null, E => 0, H => null, Static => False);
Descriptors (Interrupt).Kind := Protected_Procedure;
Descriptors (Interrupt).H := New_Handler;
Descriptors (Interrupt).Static := Static;
- Attached_Interrupts (Interrupt) := True;
end if;
end Attach_Handler;
(Old_Handler : out Parameterless_Handler;
New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID;
- Static : Boolean := False) is
+ Static : Boolean := False)
+ is
begin
if Is_Reserved (Interrupt) then
raise Program_Error;
procedure Detach_Handler
(Interrupt : Interrupt_ID;
- Static : Boolean := False) is
+ Static : Boolean := False)
+ is
begin
if Is_Reserved (Interrupt) then
raise Program_Error;
"Trying to detach a static Interrupt Handler");
end if;
- Attached_Interrupts (Interrupt) := False;
Descriptors (Interrupt) :=
(Kind => Unknown, T => null, E => 0, H => null, Static => False);
Int_Ref : System.Address)
is
Interrupt : constant Interrupt_ID :=
- Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
+ Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
New_Task : Server_Task_Access;
-- make by the task before it terminates.
T.Interrupt_Entry := True;
-
- Attached_Interrupts (Interrupt) := True;
end Bind_Interrupt_To_Entry;
------------------------------
procedure Detach_Interrupt_Entries (T : Task_Id) is
begin
- for I in Interrupt_ID loop
- if not Is_Reserved (I) then
- if Descriptors (I).Kind = Task_Entry and then
- Descriptors (I).T = T then
- Attached_Interrupts (I) := False;
- Descriptors (I).Kind := Unknown;
-
- if intr_attach (int (I), null) = FUNC_ERR then
+ for J in Interrupt_ID loop
+ if not Is_Reserved (J) then
+ if Descriptors (J).Kind = Task_Entry
+ and then Descriptors (J).T = T
+ then
+ Descriptors (J).Kind := Unknown;
+
+ if intr_attach (int (J), null) = FUNC_ERR then
raise Program_Error;
end if;
end if;
return My_Stack; -- Never trust the cached value, but return local copy!
end Set_Stack_Info;
- --------------------
- -- Set_Stack_Size --
- --------------------
-
- -- Specify the stack size for the current frame.
-
- procedure Set_Stack_Size
- (Stack_Size : System.Storage_Elements.Storage_Offset)
- is
- My_Stack : Stack_Access;
- Frame_Address : constant System.Address := My_Stack'Address;
-
- begin
- My_Stack := Stack_Check (Frame_Address);
-
- if Stack_Grows_Down then
- My_Stack.Limit := My_Stack.Base - Stack_Size;
- else
- My_Stack.Limit := My_Stack.Base + Stack_Size;
- end if;
- end Set_Stack_Size;
-
-----------------
-- Stack_Check --
-----------------
return My_Stack; -- Never trust the cached value, but return local copy!
end Set_Stack_Info;
- --------------------
- -- Set_Stack_Size --
- --------------------
-
- -- Specify the stack size for the current frame.
-
- procedure Set_Stack_Size
- (Stack_Size : System.Storage_Elements.Storage_Offset)
- is
- My_Stack : Stack_Access;
- Frame_Address : constant System.Address := My_Stack'Address;
-
- begin
- My_Stack := Stack_Check (Frame_Address);
-
- if Stack_Grows_Down then
- My_Stack.Limit := My_Stack.Base - Stack_Size;
- else
- My_Stack.Limit := My_Stack.Base + Stack_Size;
- end if;
- end Set_Stack_Size;
-
-----------------
-- Stack_Check --
-----------------
-- We want to guarantee the absence of elaboration code because the
-- binder does not handle references to this package.
-with System.Storage_Elements;
-
pragma Polling (Off);
-- Turn off polling, we do not want polling to take place during stack
-- checking operations. It causes infinite loops and other problems.
package System.Stack_Checking.Operations is
- procedure Set_Stack_Size
- (Stack_Size : System.Storage_Elements.Storage_Offset);
- -- Specify the stack size for the current task.
-
procedure Update_Stack_Cache (Stack : Stack_Access);
-- Set the stack cache for the current task. Note that this is only
-- for optimization purposes, nothing can be assumed about the
function Suspend_Task
(T : ST.Task_Id;
- Thread_Self : OSI.Thread_Id)
- return Boolean
+ Thread_Self : OSI.Thread_Id) return Boolean
is
begin
return False;
function Resume_Task
(T : ST.Task_Id;
- Thread_Self : OSI.Thread_Id)
- return Boolean
+ Thread_Self : OSI.Thread_Id) return Boolean
is
begin
return False;
function Suspend_Task
(T : ST.Task_Id;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
function Resume_Task
(T : ST.Task_Id;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
Tmp_Set : aliased sigset_t;
Result : Interfaces.C.int;
- function State (Int : System.Interrupt_Management.Interrupt_ID)
- return Character;
+ function State
+ (Int : System.Interrupt_Management.Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
procedure Initialize_Athread_Library;
function To_Task_Id is new Unchecked_Conversion (System.Address, Task_Id);
-
function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
-------------------
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_Exit;
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
-
begin
Result := pthread_kill (T.Common.LL.Thread,
Signal (System.Interrupt_Management.Abort_Task_Interrupt));
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_Exit;
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_No_Locks;
function Suspend_Task
(T : ST.Task_Id;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
-
begin
return False;
end Suspend_Task;
function Resume_Task
(T : ST.Task_Id;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
-
begin
return False;
end Resume_Task;
Tmp_Set : aliased sigset_t;
Result : Interfaces.C.int;
- function State (Int : System.Interrupt_Management.Interrupt_ID)
- return Character;
+ function State
+ (Int : System.Interrupt_Management.Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c. The input argument is
-- the interrupt number, and the result is one of the following:
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
-
begin
null;
end Stack_Guard;
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_Exit;
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_No_Locks;
Tmp_Set : aliased sigset_t;
Result : Interfaces.C.int;
- function State (Int : System.Interrupt_Management.Interrupt_ID)
- return Character;
+ function State
+ (Int : System.Interrupt_Management.Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
function Suspend_Task
(T : ST.Task_Id;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
Result : Interfaces.C.int;
function State
- (Int : System.Interrupt_Management.Interrupt_ID)
- return Character;
+ (Int : System.Interrupt_Management.Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
pragma Unreferenced (Level);
-
begin
InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
end Initialize_Lock;
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
-
begin
Cond_Signal (T.Common.LL.CV'Access);
end Wakeup;
----------------
procedure Abort_Task (T : Task_Id) is
- pragma Unreferenced (T);
+ pragma Unreferenced (T);
begin
null;
end Abort_Task;
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_Exit;
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_No_Locks;
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
-
begin
null;
end Stack_Guard;
function Self return Task_Id is
Self_ID : Task_Id renames Thread_Local_Data_Ptr.Self_ID;
+
begin
-- Check that the thread local data has been initialized.
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
-
begin
Sem_Must_Not_Fail (DosPostEventSem (T.Common.LL.CV));
end Wakeup;
Loss_Of_Inheritance : Boolean := False)
is
pragma Unreferenced (Loss_Of_Inheritance);
-
begin
T.Common.Current_Priority := Prio;
Set_Temporary_Priority (T, Prio);
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
TLD : constant Access_Thread_Local_Data := Thread_Local_Data_Ptr;
-
begin
return Self_ID = TLD.Self_ID
and then TLD.Lock_Prio_Level = 0;
function Suspend_Task
(T : ST.Task_Id;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
begin
if Thread_Id (T.Common.LL.Thread) /= Thread_Self then
function Resume_Task
(T : ST.Task_Id;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
begin
if Thread_Id (T.Common.LL.Thread) /= Thread_Self then
function Monotonic_Clock return Duration is
TS : aliased timespec;
Result : Interfaces.C.int;
-
begin
Result := clock_gettime
(clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access);
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Warnings (Off, Reason);
-
Result : Interfaces.C.int;
-
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Warnings (Off, Self_ID);
-
begin
return True;
end Check_Exit;
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Warnings (Off, Self_ID);
-
begin
return True;
end Check_No_Locks;
function Suspend_Task
(T : ST.Task_Id;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
pragma Warnings (Off, T);
pragma Warnings (Off, Thread_Self);
-
begin
return False;
end Suspend_Task;
function Resume_Task
(T : ST.Task_Id;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
pragma Warnings (Off, T);
pragma Warnings (Off, Thread_Self);
-
begin
return False;
end Resume_Task;
Tmp_Set : aliased sigset_t;
Result : Interfaces.C.int;
- function State (Int : System.Interrupt_Management.Interrupt_ID)
- return Character;
+ function State
+ (Int : System.Interrupt_Management.Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
-
begin
null;
end Stack_Guard;
null;
end Configure_Processors;
- function State (Int : System.Interrupt_Management.Interrupt_ID)
- return Character;
+ function State
+ (Int : System.Interrupt_Management.Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
function Monotonic_Clock return Duration is
TS : aliased timespec;
Result : Interfaces.C.int;
-
begin
Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
pragma Assert (Result = 0);
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
-
begin
null;
end Stack_Guard;
function Monotonic_Clock return Duration is
TS : aliased timespec;
Result : Interfaces.C.int;
-
begin
Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
pragma Assert (Result = 0);
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_Exit;
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_No_Locks;
is
pragma Warnings (Off, T);
pragma Warnings (Off, Thread_Self);
-
begin
return False;
end Suspend_Task;
is
pragma Warnings (Off, T);
pragma Warnings (Off, Thread_Self);
-
begin
return False;
end Resume_Task;
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
-
Result : Interfaces.C.int;
-
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_Exit;
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_No_Locks;
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
-
begin
return False;
end Suspend_Task;
function Monotonic_Clock return Duration is
TS : aliased timespec;
Result : int;
-
begin
Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
pragma Assert (Result = 0);
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
-
Result : int;
-
begin
Result := semGive (T.Common.LL.CV);
pragma Assert (Result = 0);
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_Exit;
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_No_Locks;
function Suspend_Task
(T : ST.Task_Id;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
begin
if T.Common.LL.Thread /= 0
function Resume_Task
(T : ST.Task_Id;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
begin
if T.Common.LL.Thread /= 0
-- The effect should be consistent with the Ada Reference Manual.
-- In particular, when a task lowers its priority due to the loss of
-- inherited priority, it goes at the head of the queue for its new
- -- priority (RM D.2.2 par 9).
- -- Loss_Of_Inheritance helps the underlying implementation to do it
- -- right when the OS doesn't.
+ -- priority (RM D.2.2 par 9). Loss_Of_Inheritance helps the underlying
+ -- implementation to do it right when the OS doesn't.
function Get_Priority (T : ST.Task_Id) return System.Any_Priority;
pragma Inline (Get_Priority);
function Monotonic_Clock return Duration;
pragma Inline (Monotonic_Clock);
- -- Returns "absolute" time, represented as an offset
- -- relative to "the Epoch", which is Jan 1, 1970.
- -- This clock implementation is immune to the system's clock changes.
+ -- Returns "absolute" time, represented as an offset relative to "the
+ -- Epoch", which is Jan 1, 1970. This clock implementation is immune to
+ -- the system's clock changes.
function RT_Resolution return Duration;
pragma Inline (RT_Resolution);
- -- Returns the resolution of the underlying clock used to implement
- -- RT_Clock.
+ -- Returns resolution of the underlying clock used to implement RT_Clock
----------------
-- Extensions --
function Suspend_Task
(T : ST.Task_Id;
- Thread_Self : OSI.Thread_Id)
- return Boolean;
+ Thread_Self : OSI.Thread_Id) return Boolean;
-- Suspend a specific task when the underlying thread library provides
-- such functionality, unless the thread associated with T is Thread_Self.
-- Such functionality is needed by gdb on some targets (e.g VxWorks)
function Resume_Task
(T : ST.Task_Id;
- Thread_Self : OSI.Thread_Id)
- return Boolean;
+ Thread_Self : OSI.Thread_Id) return Boolean;
-- Resume a specific task when the underlying thread library provides
-- such functionality, unless the thread associated with T is Thread_Self.
-- Such functionality is needed by gdb on some targets (e.g VxWorks)
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1997-2000 Free Software Foundation, Inc. --
+-- (Version for Alpha OpenVMS) --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.IO; use System.IO;
+with System.Machine_Code; use System.Machine_Code;
+
+package body System.Vax_Float_Operations is
+
+ -- Ensure this gets compiled with -O to avoid extra (and possibly
+ -- improper) memory stores.
+
+ pragma Optimize (Time);
+
+ -- Declare the functions that do the conversions between floating-point
+ -- formats. Call the operands IEEE float so they get passed in
+ -- FP registers.
+
+ function Cvt_G_T (X : T) return T;
+ function Cvt_T_G (X : T) return T;
+ function Cvt_T_F (X : T) return S;
+
+ pragma Import (C, Cvt_G_T, "OTS$CVT_FLOAT_G_T");
+ pragma Import (C, Cvt_T_G, "OTS$CVT_FLOAT_T_G");
+ pragma Import (C, Cvt_T_F, "OTS$CVT_FLOAT_T_F");
+
+ -- In each of the conversion routines that are done with OTS calls,
+ -- we define variables of the corresponding IEEE type so that they are
+ -- passed and kept in the proper register class.
+
+ ------------
+ -- D_To_G --
+ ------------
+
+ function D_To_G (X : D) return G is
+ A, B : T;
+ C : G;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", A), D'Asm_Input ("m", X));
+ Asm ("cvtdg %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
+ return C;
+ end D_To_G;
+
+ ------------
+ -- F_To_G --
+ ------------
+
+ function F_To_G (X : F) return G is
+ A : T;
+ B : G;
+
+ begin
+ Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
+ return B;
+ end F_To_G;
+
+ ------------
+ -- F_To_S --
+ ------------
+
+ function F_To_S (X : F) return S is
+ A : T;
+ B : S;
+
+ begin
+ -- Because converting to a wider FP format is a no-op, we say
+ -- A is 64-bit even though we are loading 32 bits into it.
+ Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X));
+
+ B := S (Cvt_G_T (A));
+ return B;
+ end F_To_S;
+
+ ------------
+ -- G_To_D --
+ ------------
+
+ function G_To_D (X : G) return D is
+ A, B : T;
+ C : D;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
+ Asm ("cvtgd %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
+ Asm ("stg %1,%0", D'Asm_Output ("=m", C), T'Asm_Input ("f", B));
+ return C;
+ end G_To_D;
+
+ ------------
+ -- G_To_F --
+ ------------
+
+ function G_To_F (X : G) return F is
+ A : T;
+ B : S;
+ C : F;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
+ Asm ("cvtgf %1,%0", S'Asm_Output ("=f", B), T'Asm_Input ("f", A));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
+ return C;
+ end G_To_F;
+
+ ------------
+ -- G_To_Q --
+ ------------
+
+ function G_To_Q (X : G) return Q is
+ A : T;
+ B : Q;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
+ Asm ("cvtgq %1,%0", Q'Asm_Output ("=f", B), T'Asm_Input ("f", A));
+ return B;
+ end G_To_Q;
+
+ ------------
+ -- G_To_T --
+ ------------
+
+ function G_To_T (X : G) return T is
+ A, B : T;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
+ B := Cvt_G_T (A);
+ return B;
+ end G_To_T;
+
+ ------------
+ -- F_To_Q --
+ ------------
+
+ function F_To_Q (X : F) return Q is
+ begin
+ return G_To_Q (F_To_G (X));
+ end F_To_Q;
+
+ ------------
+ -- Q_To_F --
+ ------------
+
+ function Q_To_F (X : Q) return F is
+ A : S;
+ B : F;
+
+ begin
+ Asm ("cvtqf %1,%0", S'Asm_Output ("=f", A), Q'Asm_Input ("f", X));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A));
+ return B;
+ end Q_To_F;
+
+ ------------
+ -- Q_To_G --
+ ------------
+
+ function Q_To_G (X : Q) return G is
+ A : T;
+ B : G;
+
+ begin
+ Asm ("cvtqg %1,%0", T'Asm_Output ("=f", A), Q'Asm_Input ("f", X));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
+ return B;
+ end Q_To_G;
+
+ ------------
+ -- S_To_F --
+ ------------
+
+ function S_To_F (X : S) return F is
+ A : S;
+ B : F;
+
+ begin
+ A := Cvt_T_F (T (X));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A));
+ return B;
+ end S_To_F;
+
+ ------------
+ -- T_To_D --
+ ------------
+
+ function T_To_D (X : T) return D is
+ begin
+ return G_To_D (T_To_G (X));
+ end T_To_D;
+
+ ------------
+ -- T_To_G --
+ ------------
+
+ function T_To_G (X : T) return G is
+ A : T;
+ B : G;
+
+ begin
+ A := Cvt_T_G (X);
+ Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
+ return B;
+ end T_To_G;
+
+ -----------
+ -- Abs_F --
+ -----------
+
+ function Abs_F (X : F) return F is
+ A, B : S;
+ C : F;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X));
+ Asm ("cpys $f31,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
+ return C;
+ end Abs_F;
+
+ -----------
+ -- Abs_G --
+ -----------
+
+ function Abs_G (X : G) return G is
+ A, B : T;
+ C : G;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
+ Asm ("cpys $f31,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
+ return C;
+ end Abs_G;
+
+ -----------
+ -- Add_F --
+ -----------
+
+ function Add_F (X, Y : F) return F is
+ X1, Y1, R : S;
+ R1 : F;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
+ Asm ("addf %1,%2,%0", S'Asm_Output ("=f", R),
+ (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
+ return R1;
+ end Add_F;
+
+ -----------
+ -- Add_G --
+ -----------
+
+ function Add_G (X, Y : G) return G is
+ X1, Y1, R : T;
+ R1 : G;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
+ Asm ("addg %1,%2,%0", T'Asm_Output ("=f", R),
+ (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
+ return R1;
+ end Add_G;
+
+ --------------------
+ -- Debug_Output_D --
+ --------------------
+
+ procedure Debug_Output_D (Arg : D) is
+ begin
+ Put (D'Image (Arg));
+ end Debug_Output_D;
+
+ --------------------
+ -- Debug_Output_F --
+ --------------------
+
+ procedure Debug_Output_F (Arg : F) is
+ begin
+ Put (F'Image (Arg));
+ end Debug_Output_F;
+
+ --------------------
+ -- Debug_Output_G --
+ --------------------
+
+ procedure Debug_Output_G (Arg : G) is
+ begin
+ Put (G'Image (Arg));
+ end Debug_Output_G;
+
+ --------------------
+ -- Debug_String_D --
+ --------------------
+
+ Debug_String_Buffer : String (1 .. 32);
+ -- Buffer used by all Debug_String_x routines for returning result
+
+ function Debug_String_D (Arg : D) return System.Address is
+ Image_String : constant String := D'Image (Arg) & ASCII.NUL;
+ Image_Size : constant Integer := Image_String'Length;
+
+ begin
+ Debug_String_Buffer (1 .. Image_Size) := Image_String;
+ return Debug_String_Buffer (1)'Address;
+ end Debug_String_D;
+
+ --------------------
+ -- Debug_String_F --
+ --------------------
+
+ function Debug_String_F (Arg : F) return System.Address is
+ Image_String : constant String := F'Image (Arg) & ASCII.NUL;
+ Image_Size : constant Integer := Image_String'Length;
+
+ begin
+ Debug_String_Buffer (1 .. Image_Size) := Image_String;
+ return Debug_String_Buffer (1)'Address;
+ end Debug_String_F;
+
+ --------------------
+ -- Debug_String_G --
+ --------------------
+
+ function Debug_String_G (Arg : G) return System.Address is
+ Image_String : constant String := G'Image (Arg) & ASCII.NUL;
+ Image_Size : constant Integer := Image_String'Length;
+
+ begin
+ Debug_String_Buffer (1 .. Image_Size) := Image_String;
+ return Debug_String_Buffer (1)'Address;
+ end Debug_String_G;
+
+ -----------
+ -- Div_F --
+ -----------
+
+ function Div_F (X, Y : F) return F is
+ X1, Y1, R : S;
+
+ R1 : F;
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
+ Asm ("divf %1,%2,%0", S'Asm_Output ("=f", R),
+ (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
+ return R1;
+ end Div_F;
+
+ -----------
+ -- Div_G --
+ -----------
+
+ function Div_G (X, Y : G) return G is
+ X1, Y1, R : T;
+ R1 : G;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
+ Asm ("divg %1,%2,%0", T'Asm_Output ("=f", R),
+ (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
+ return R1;
+ end Div_G;
+
+ ----------
+ -- Eq_F --
+ ----------
+
+ function Eq_F (X, Y : F) return Boolean is
+ X1, Y1, R : S;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
+ Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R),
+ (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
+ return R /= 0.0;
+ end Eq_F;
+
+ ----------
+ -- Eq_G --
+ ----------
+
+ function Eq_G (X, Y : G) return Boolean is
+ X1, Y1, R : T;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
+ Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R),
+ (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
+ return R /= 0.0;
+ end Eq_G;
+
+ ----------
+ -- Le_F --
+ ----------
+
+ function Le_F (X, Y : F) return Boolean is
+ X1, Y1, R : S;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
+ Asm ("cmpgle %1,%2,%0", S'Asm_Output ("=f", R),
+ (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
+ return R /= 0.0;
+ end Le_F;
+
+ ----------
+ -- Le_G --
+ ----------
+
+ function Le_G (X, Y : G) return Boolean is
+ X1, Y1, R : T;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
+ Asm ("cmpgle %1,%2,%0", T'Asm_Output ("=f", R),
+ (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
+ return R /= 0.0;
+ end Le_G;
+
+ ----------
+ -- Lt_F --
+ ----------
+
+ function Lt_F (X, Y : F) return Boolean is
+ X1, Y1, R : S;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
+ Asm ("cmpglt %1,%2,%0", S'Asm_Output ("=f", R),
+ (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
+ return R /= 0.0;
+ end Lt_F;
+
+ ----------
+ -- Lt_G --
+ ----------
+
+ function Lt_G (X, Y : G) return Boolean is
+ X1, Y1, R : T;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
+ Asm ("cmpglt %1,%2,%0", T'Asm_Output ("=f", R),
+ (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
+ return R /= 0.0;
+ end Lt_G;
+
+ -----------
+ -- Mul_F --
+ -----------
+
+ function Mul_F (X, Y : F) return F is
+ X1, Y1, R : S;
+ R1 : F;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
+ Asm ("mulf %1,%2,%0", S'Asm_Output ("=f", R),
+ (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
+ return R1;
+ end Mul_F;
+
+ -----------
+ -- Mul_G --
+ -----------
+
+ function Mul_G (X, Y : G) return G is
+ X1, Y1, R : T;
+ R1 : G;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
+ Asm ("mulg %1,%2,%0", T'Asm_Output ("=f", R),
+ (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
+ return R1;
+ end Mul_G;
+
+ -----------
+ -- Neg_F --
+ -----------
+
+ function Neg_F (X : F) return F is
+ A, B : S;
+ C : F;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X));
+ Asm ("cpysn %1,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
+ return C;
+ end Neg_F;
+
+ -----------
+ -- Neg_G --
+ -----------
+
+ function Neg_G (X : G) return G is
+ A, B : T;
+ C : G;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
+ Asm ("cpysn %1,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
+ return C;
+ end Neg_G;
+
+ --------
+ -- pd --
+ --------
+
+ procedure pd (Arg : D) is
+ begin
+ Put_Line (D'Image (Arg));
+ end pd;
+
+ --------
+ -- pf --
+ --------
+
+ procedure pf (Arg : F) is
+ begin
+ Put_Line (F'Image (Arg));
+ end pf;
+
+ --------
+ -- pg --
+ --------
+
+ procedure pg (Arg : G) is
+ begin
+ Put_Line (G'Image (Arg));
+ end pg;
+
+ -----------
+ -- Sub_F --
+ -----------
+
+ function Sub_F (X, Y : F) return F is
+ X1, Y1, R : S;
+ R1 : F;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
+ Asm ("subf %1,%2,%0", S'Asm_Output ("=f", R),
+ (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
+ return R1;
+ end Sub_F;
+
+ -----------
+ -- Sub_G --
+ -----------
+
+ function Sub_G (X, Y : G) return G is
+ X1, Y1, R : T;
+ R1 : G;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
+ Asm ("subg %1,%2,%0", T'Asm_Output ("=f", R),
+ (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
+ return R1;
+ end Sub_G;
+
+end System.Vax_Float_Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1997-2000 Free Software Foundation, Inc. --
--- (Version for Alpha OpenVMS) --
--- --
--- 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with System.IO; use System.IO;
-with System.Machine_Code; use System.Machine_Code;
-
-package body System.Vax_Float_Operations is
-
- -- Ensure this gets compiled with -O to avoid extra (and possibly
- -- improper) memory stores.
-
- pragma Optimize (Time);
-
- -- Declare the functions that do the conversions between floating-point
- -- formats. Call the operands IEEE float so they get passed in
- -- FP registers.
-
- function Cvt_G_T (X : T) return T;
- function Cvt_T_G (X : T) return T;
- function Cvt_T_F (X : T) return S;
-
- pragma Import (C, Cvt_G_T, "OTS$CVT_FLOAT_G_T");
- pragma Import (C, Cvt_T_G, "OTS$CVT_FLOAT_T_G");
- pragma Import (C, Cvt_T_F, "OTS$CVT_FLOAT_T_F");
-
- -- In each of the conversion routines that are done with OTS calls,
- -- we define variables of the corresponding IEEE type so that they are
- -- passed and kept in the proper register class.
-
- ------------
- -- D_To_G --
- ------------
-
- function D_To_G (X : D) return G is
- A, B : T;
- C : G;
-
- begin
- Asm ("ldg %0,%1", T'Asm_Output ("=f", A), D'Asm_Input ("m", X));
- Asm ("cvtdg %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
- Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
- return C;
- end D_To_G;
-
- ------------
- -- F_To_G --
- ------------
-
- function F_To_G (X : F) return G is
- A : T;
- B : G;
-
- begin
- Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X));
- Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
- return B;
- end F_To_G;
-
- ------------
- -- F_To_S --
- ------------
-
- function F_To_S (X : F) return S is
- A : T;
- B : S;
-
- begin
- -- Because converting to a wider FP format is a no-op, we say
- -- A is 64-bit even though we are loading 32 bits into it.
- Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X));
-
- B := S (Cvt_G_T (A));
- return B;
- end F_To_S;
-
- ------------
- -- G_To_D --
- ------------
-
- function G_To_D (X : G) return D is
- A, B : T;
- C : D;
-
- begin
- Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
- Asm ("cvtgd %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
- Asm ("stg %1,%0", D'Asm_Output ("=m", C), T'Asm_Input ("f", B));
- return C;
- end G_To_D;
-
- ------------
- -- G_To_F --
- ------------
-
- function G_To_F (X : G) return F is
- A : T;
- B : S;
- C : F;
-
- begin
- Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
- Asm ("cvtgf %1,%0", S'Asm_Output ("=f", B), T'Asm_Input ("f", A));
- Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
- return C;
- end G_To_F;
-
- ------------
- -- G_To_Q --
- ------------
-
- function G_To_Q (X : G) return Q is
- A : T;
- B : Q;
-
- begin
- Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
- Asm ("cvtgq %1,%0", Q'Asm_Output ("=f", B), T'Asm_Input ("f", A));
- return B;
- end G_To_Q;
-
- ------------
- -- G_To_T --
- ------------
-
- function G_To_T (X : G) return T is
- A, B : T;
-
- begin
- Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
- B := Cvt_G_T (A);
- return B;
- end G_To_T;
-
- ------------
- -- F_To_Q --
- ------------
-
- function F_To_Q (X : F) return Q is
- begin
- return G_To_Q (F_To_G (X));
- end F_To_Q;
-
- ------------
- -- Q_To_F --
- ------------
-
- function Q_To_F (X : Q) return F is
- A : S;
- B : F;
-
- begin
- Asm ("cvtqf %1,%0", S'Asm_Output ("=f", A), Q'Asm_Input ("f", X));
- Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A));
- return B;
- end Q_To_F;
-
- ------------
- -- Q_To_G --
- ------------
-
- function Q_To_G (X : Q) return G is
- A : T;
- B : G;
-
- begin
- Asm ("cvtqg %1,%0", T'Asm_Output ("=f", A), Q'Asm_Input ("f", X));
- Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
- return B;
- end Q_To_G;
-
- ------------
- -- S_To_F --
- ------------
-
- function S_To_F (X : S) return F is
- A : S;
- B : F;
-
- begin
- A := Cvt_T_F (T (X));
- Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A));
- return B;
- end S_To_F;
-
- ------------
- -- T_To_D --
- ------------
-
- function T_To_D (X : T) return D is
- begin
- return G_To_D (T_To_G (X));
- end T_To_D;
-
- ------------
- -- T_To_G --
- ------------
-
- function T_To_G (X : T) return G is
- A : T;
- B : G;
-
- begin
- A := Cvt_T_G (X);
- Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
- return B;
- end T_To_G;
-
- -----------
- -- Abs_F --
- -----------
-
- function Abs_F (X : F) return F is
- A, B : S;
- C : F;
-
- begin
- Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X));
- Asm ("cpys $f31,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A));
- Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
- return C;
- end Abs_F;
-
- -----------
- -- Abs_G --
- -----------
-
- function Abs_G (X : G) return G is
- A, B : T;
- C : G;
-
- begin
- Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
- Asm ("cpys $f31,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
- Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
- return C;
- end Abs_G;
-
- -----------
- -- Add_F --
- -----------
-
- function Add_F (X, Y : F) return F is
- X1, Y1, R : S;
- R1 : F;
-
- begin
- Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
- Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
- Asm ("addf %1,%2,%0", S'Asm_Output ("=f", R),
- (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
- Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
- return R1;
- end Add_F;
-
- -----------
- -- Add_G --
- -----------
-
- function Add_G (X, Y : G) return G is
- X1, Y1, R : T;
- R1 : G;
-
- begin
- Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
- Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
- Asm ("addg %1,%2,%0", T'Asm_Output ("=f", R),
- (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
- Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
- return R1;
- end Add_G;
-
- --------------------
- -- Debug_Output_D --
- --------------------
-
- procedure Debug_Output_D (Arg : D) is
- begin
- Put (D'Image (Arg));
- end Debug_Output_D;
-
- --------------------
- -- Debug_Output_F --
- --------------------
-
- procedure Debug_Output_F (Arg : F) is
- begin
- Put (F'Image (Arg));
- end Debug_Output_F;
-
- --------------------
- -- Debug_Output_G --
- --------------------
-
- procedure Debug_Output_G (Arg : G) is
- begin
- Put (G'Image (Arg));
- end Debug_Output_G;
-
- --------------------
- -- Debug_String_D --
- --------------------
-
- Debug_String_Buffer : String (1 .. 32);
- -- Buffer used by all Debug_String_x routines for returning result
-
- function Debug_String_D (Arg : D) return System.Address is
- Image_String : constant String := D'Image (Arg) & ASCII.NUL;
- Image_Size : constant Integer := Image_String'Length;
-
- begin
- Debug_String_Buffer (1 .. Image_Size) := Image_String;
- return Debug_String_Buffer (1)'Address;
- end Debug_String_D;
-
- --------------------
- -- Debug_String_F --
- --------------------
-
- function Debug_String_F (Arg : F) return System.Address is
- Image_String : constant String := F'Image (Arg) & ASCII.NUL;
- Image_Size : constant Integer := Image_String'Length;
-
- begin
- Debug_String_Buffer (1 .. Image_Size) := Image_String;
- return Debug_String_Buffer (1)'Address;
- end Debug_String_F;
-
- --------------------
- -- Debug_String_G --
- --------------------
-
- function Debug_String_G (Arg : G) return System.Address is
- Image_String : constant String := G'Image (Arg) & ASCII.NUL;
- Image_Size : constant Integer := Image_String'Length;
-
- begin
- Debug_String_Buffer (1 .. Image_Size) := Image_String;
- return Debug_String_Buffer (1)'Address;
- end Debug_String_G;
-
- -----------
- -- Div_F --
- -----------
-
- function Div_F (X, Y : F) return F is
- X1, Y1, R : S;
-
- R1 : F;
- begin
- Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
- Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
- Asm ("divf %1,%2,%0", S'Asm_Output ("=f", R),
- (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
- Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
- return R1;
- end Div_F;
-
- -----------
- -- Div_G --
- -----------
-
- function Div_G (X, Y : G) return G is
- X1, Y1, R : T;
- R1 : G;
-
- begin
- Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
- Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
- Asm ("divg %1,%2,%0", T'Asm_Output ("=f", R),
- (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
- Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
- return R1;
- end Div_G;
-
- ----------
- -- Eq_F --
- ----------
-
- function Eq_F (X, Y : F) return Boolean is
- X1, Y1, R : S;
-
- begin
- Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
- Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
- Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R),
- (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
- return R /= 0.0;
- end Eq_F;
-
- ----------
- -- Eq_G --
- ----------
-
- function Eq_G (X, Y : G) return Boolean is
- X1, Y1, R : T;
-
- begin
- Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
- Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
- Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R),
- (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
- return R /= 0.0;
- end Eq_G;
-
- ----------
- -- Le_F --
- ----------
-
- function Le_F (X, Y : F) return Boolean is
- X1, Y1, R : S;
-
- begin
- Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
- Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
- Asm ("cmpgle %1,%2,%0", S'Asm_Output ("=f", R),
- (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
- return R /= 0.0;
- end Le_F;
-
- ----------
- -- Le_G --
- ----------
-
- function Le_G (X, Y : G) return Boolean is
- X1, Y1, R : T;
-
- begin
- Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
- Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
- Asm ("cmpgle %1,%2,%0", T'Asm_Output ("=f", R),
- (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
- return R /= 0.0;
- end Le_G;
-
- ----------
- -- Lt_F --
- ----------
-
- function Lt_F (X, Y : F) return Boolean is
- X1, Y1, R : S;
-
- begin
- Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
- Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
- Asm ("cmpglt %1,%2,%0", S'Asm_Output ("=f", R),
- (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
- return R /= 0.0;
- end Lt_F;
-
- ----------
- -- Lt_G --
- ----------
-
- function Lt_G (X, Y : G) return Boolean is
- X1, Y1, R : T;
-
- begin
- Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
- Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
- Asm ("cmpglt %1,%2,%0", T'Asm_Output ("=f", R),
- (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
- return R /= 0.0;
- end Lt_G;
-
- -----------
- -- Mul_F --
- -----------
-
- function Mul_F (X, Y : F) return F is
- X1, Y1, R : S;
- R1 : F;
-
- begin
- Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
- Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
- Asm ("mulf %1,%2,%0", S'Asm_Output ("=f", R),
- (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
- Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
- return R1;
- end Mul_F;
-
- -----------
- -- Mul_G --
- -----------
-
- function Mul_G (X, Y : G) return G is
- X1, Y1, R : T;
- R1 : G;
-
- begin
- Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
- Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
- Asm ("mulg %1,%2,%0", T'Asm_Output ("=f", R),
- (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
- Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
- return R1;
- end Mul_G;
-
- -----------
- -- Neg_F --
- -----------
-
- function Neg_F (X : F) return F is
- A, B : S;
- C : F;
-
- begin
- Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X));
- Asm ("cpysn %1,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A));
- Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
- return C;
- end Neg_F;
-
- -----------
- -- Neg_G --
- -----------
-
- function Neg_G (X : G) return G is
- A, B : T;
- C : G;
-
- begin
- Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
- Asm ("cpysn %1,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
- Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
- return C;
- end Neg_G;
-
- --------
- -- pd --
- --------
-
- procedure pd (Arg : D) is
- begin
- Put_Line (D'Image (Arg));
- end pd;
-
- --------
- -- pf --
- --------
-
- procedure pf (Arg : F) is
- begin
- Put_Line (F'Image (Arg));
- end pf;
-
- --------
- -- pg --
- --------
-
- procedure pg (Arg : G) is
- begin
- Put_Line (G'Image (Arg));
- end pg;
-
- -----------
- -- Sub_F --
- -----------
-
- function Sub_F (X, Y : F) return F is
- X1, Y1, R : S;
- R1 : F;
-
- begin
- Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
- Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
- Asm ("subf %1,%2,%0", S'Asm_Output ("=f", R),
- (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
- Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
- return R1;
- end Sub_F;
-
- -----------
- -- Sub_G --
- -----------
-
- function Sub_G (X, Y : G) return G is
- X1, Y1, R : T;
- R1 : G;
-
- begin
- Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
- Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
- Asm ("subg %1,%2,%0", T'Asm_Output ("=f", R),
- (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
- Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
- return R1;
- end Sub_G;
-
-end System.Vax_Float_Operations;
exit;
elsif C in Upper_Half_Character then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Bad_String_Char;
end if;
if Source (Scan_Ptr) not in Graphic_Character then
if Source (Scan_Ptr) in Upper_Half_Character then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Illegal_Character;
end if;
-- Here is where we check if it was a keyword
if Get_Name_Table_Byte (Token_Name) /= 0
- and then (Ada_95 or else Token_Name not in Ada_95_Reserved_Words)
+ and then (Ada_Version >= Ada_95
+ or else Token_Name not in Ada_95_Reserved_Words)
then
Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
-- sorted order.
procedure Check_Can_Never_Be_Null (N : Node_Id; Expr : Node_Id);
- -- Ada 0Y (AI-231): Check bad usage of the null-exclusion issue
+ -- Ada 2005 (AI-231): Check bad usage of the null-exclusion issue
------------------------------------------------------
-- Subprograms used for RECORD AGGREGATE Processing --
Check_Unset_Reference (Exp);
end if;
- -- Ada 0Y (AI-231): Generate conversion to the null-excluding
+ -- Ada 2005 (AI-231): Generate conversion to the null-excluding
-- type to force the corresponding run-time check
elsif Is_Access_Type (Check_Typ)
Error_Msg_N ("aggregate type cannot have limited component", N);
Explain_Limited_Type (Typ, N);
- -- Ada 0Y (AI-287): Limited aggregates allowed
+ -- Ada 2005 (AI-287): Limited aggregates allowed
elsif Is_Limited_Type (Typ)
- and not Extensions_Allowed
+ and Ada_Version < Ada_05
then
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
Set_Etype (N, Aggr_Typ); -- may be overridden later on
- -- Ada 0Y (AI-231): Propagate the null_exclusion attribute to the
- -- components of the array aggregate
+ -- Ada 2005 (AI-231): Propagate the null_exclusion attribute to
+ -- the components of the array aggregate
- if Extensions_Allowed then
+ if Ada_Version >= Ada_05 then
Set_Can_Never_Be_Null (Aggr_Typ, Can_Never_Be_Null (Typ));
end if;
end if;
end if;
- -- Ada 0Y (AI-231): Propagate the type to the nested aggregate.
+ -- Ada 2005 (AI-231): Propagate the type to the nested aggregate.
-- Required to check the null-exclusion attribute (if present).
-- This value may be overridden later on.
return Failure;
end if;
- if Ada_83
+ if Ada_Version = Ada_83
and then Assoc /= First (Component_Associations (N))
and then (Nkind (Parent (N)) = N_Assignment_Statement
or else
end if;
end loop;
- -- Ada 0Y (AI-231)
+ -- Ada 2005 (AI-231)
Check_Can_Never_Be_Null (N, Expression (Assoc));
- -- Ada 0Y (AI-287): In case of default initialized component
+ -- Ada 2005 (AI-287): In case of default initialized component
-- we delay the resolution to the expansion phase
if Box_Present (Assoc) then
- -- Ada 0Y (AI-287): In case of default initialization of a
- -- component the expander will generate calls to the
- -- corresponding initialization subprogram.
+ -- Ada 2005 (AI-287): In case of default initialization
+ -- of a component the expander will generate calls to
+ -- the corresponding initialization subprogram.
if Present (Base_Init_Proc (Etype (Component_Typ)))
or else Has_Task (Base_Type (Component_Typ))
null;
else
Error_Msg_N
- ("(Ada 0Y): no value supplied for this component",
+ ("(Ada 2005): no value supplied for this component",
Assoc);
end if;
while Present (Expr) loop
Nb_Elements := Nb_Elements + 1;
- Check_Can_Never_Be_Null (N, Expr); -- Ada 0Y (AI-231)
+ Check_Can_Never_Be_Null (N, Expr); -- Ada 2005 (AI-231)
if not Resolve_Aggr_Expr (Expr, Single_Elmt => True) then
return Failure;
if Others_Present then
Assoc := Last (Component_Associations (N));
- Check_Can_Never_Be_Null (N, Expression (Assoc)); -- Ada 0Y (AI-231)
+ Check_Can_Never_Be_Null
+ (N, Expression (Assoc)); -- Ada 2005 (AI-231)
- -- Ada 0Y (AI-287): In case of default initialized component
+ -- Ada 2005 (AI-287): In case of default initialized component
-- we delay the resolution to the expansion phase.
if Box_Present (Assoc) then
- -- Ada 0Y (AI-287): In case of default initialization of a
- -- component the expander will generate calls to the
- -- corresponding initialization subprogram.
+ -- Ada 2005 (AI-287): In case of default initialization
+ -- of a component the expander will generate calls to
+ -- the corresponding initialization subprogram.
if Present (Base_Init_Proc (Etype (Component_Typ))) then
null;
else
Error_Msg_N
- ("(Ada 0Y): no value supplied for these components",
+ ("(Ada 2005): no value supplied for these components",
Assoc);
end if;
elsif Is_Limited_Type (Typ) then
- -- Ada 0Y (AI-287): Limited aggregates are allowed
+ -- Ada 2005 (AI-287): Limited aggregates are allowed
- if Extensions_Allowed then
- null;
- else
+ if Ada_Version < Ada_05 then
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
return;
Mbox_Present : Boolean := False;
Others_Mbox : Boolean := False;
- -- Ada 0Y (AI-287): Variables used in case of default initialization to
- -- provide a functionality similar to Others_Etype. Mbox_Present
+ -- Ada 2005 (AI-287): Variables used in case of default initialization
+ -- to provide a functionality similar to Others_Etype. Mbox_Present
-- indicates that the component takes its default initialization;
-- Others_Mbox indicates that at least one component takes its default
-- initialization. Similar to Others_Etype, they are also updated as a
and then Comes_From_Source (Compon)
and then not In_Instance_Body
then
- -- Ada 0Y (AI-287): Limited aggregates are allowed
+ -- Ada 2005 (AI-287): Limited aggregates are allowed
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then Present (Expression (Assoc))
and then Nkind (Expression (Assoc)) = N_Aggregate
then
-- indispensable otherwise, because each one must be
-- expanded individually to preserve side-effects.
- -- Ada 0Y (AI-287): In case of default initialization of
- -- components, we duplicate the corresponding default
+ -- Ada 2005 (AI-287): In case of default initialization
+ -- of components, we duplicate the corresponding default
-- expression (from the record type declaration).
if Box_Present (Assoc) then
elsif Chars (Compon) = Chars (Selector_Name) then
if No (Expr) then
- -- Ada 0Y (AI-231)
+ -- Ada 2005 (AI-231)
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then Present (Expression (Assoc))
and then Nkind (Expression (Assoc)) = N_Null
and then Can_Never_Be_Null (Compon)
then
Error_Msg_N
- ("(Ada 0Y) NULL not allowed in null-excluding " &
+ ("(Ada 2005) NULL not allowed in null-excluding " &
"components", Expression (Assoc));
end if;
-- components are grouped together with a "|" choice.
-- For instance "filed1 | filed2 => Expr"
- -- Ada 0Y (AI-287)
+ -- Ada 2005 (AI-287)
if Box_Present (Assoc) then
Mbox_Present := True;
-- from the record type declaration
if Present (Next (Selector_Name)) then
- Expr := New_Copy_Tree
- (Expression (Parent (Compon)));
+ Expr :=
+ New_Copy_Tree (Expression (Parent (Compon)));
else
Expr := Expression (Parent (Compon));
end if;
if Discr_Present (Discrim) then
Resolve_Aggr_Expr (Positional_Expr, Discrim);
- -- Ada 0Y (AI-231)
+ -- Ada 2005 (AI-231)
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then Nkind (Positional_Expr) = N_Null
and then Can_Never_Be_Null (Discrim)
then
Error_Msg_N
- ("(Ada 0Y) NULL not allowed in null-excluding components",
- Positional_Expr);
+ ("(Ada 2005) NULL not allowed in null-excluding " &
+ "components", Positional_Expr);
end if;
Next (Positional_Expr);
Component := Node (Component_Elmt);
Resolve_Aggr_Expr (Positional_Expr, Component);
- -- Ada 0Y (AI-231)
- if Extensions_Allowed
+ -- Ada 2005 (AI-231)
+
+ if Ada_Version >= Ada_05
and then Nkind (Positional_Expr) = N_Null
and then Can_Never_Be_Null (Component)
then
Error_Msg_N
- ("(Ada 0Y) NULL not allowed in null-excluding components",
+ ("(Ada 2005) NULL not allowed in null-excluding components",
Positional_Expr);
end if;
if Mbox_Present and then Is_Limited_Type (Etype (Component)) then
- -- Ada 0Y (AI-287): In case of default initialization of a limited
- -- component we pass the limited component to the expander. The
- -- expander will generate calls to the corresponding initiali-
- -- zation subprograms.
+ -- Ada 2005 (AI-287): In case of default initialization of
+ -- a limited component we pass the limited component to
+ -- the expander. The expander will generate calls to the
+ -- corresponding initialization subprograms.
Add_Association
(Component => Component,
if Nkind (Selectr) = N_Others_Choice then
- -- Ada 0Y (AI-287): others choice may have expression or mbox
+ -- Ada 2005 (AI-287): others choice may have expression or mbox
if No (Others_Etype)
and then not Others_Mbox
procedure Check_Can_Never_Be_Null (N : Node_Id; Expr : Node_Id) is
begin
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then Nkind (Expr) = N_Null
and then Can_Never_Be_Null (Etype (N))
then
Error_Msg_N
- ("(Ada 0Y) NULL not allowed in null-excluding components", Expr);
+ ("(Ada 2005) NULL not allowed in null-excluding components", Expr);
end if;
end Check_Can_Never_Be_Null;
if Comes_From_Source (N) then
if not Attribute_83 (Attr_Id) then
- if Ada_83 and then Comes_From_Source (N) then
+ if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_Name_1 := Aname;
Error_Msg_N ("(Ada 83) attribute% is not standard?", N);
end if;
Find_Type (P);
Typ := Entity (P);
- if Ada_95
+ if Ada_Version >= Ada_95
and then not Is_Scalar_Type (Typ)
and then not Is_Generic_Type (Typ)
then
Check_Scalar_Type;
if Is_Real_Type (P_Type) then
- if Ada_83 and then Comes_From_Source (N) then
+ if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_Name_1 := Aname;
Error_Msg_N
("(Ada 83) % attribute not allowed for real types", N);
when Attribute_Range =>
Check_Array_Or_Scalar_Type;
- if Ada_83
+ if Ada_Version = Ada_83
and then Is_Scalar_Type (P_Type)
and then Comes_From_Source (N)
then
-- Again we compute the variable Static for easy reference later
-- (note that no array attributes are static in Ada 83).
- Static := Ada_95;
+ Static := Ada_Version >= Ada_95;
declare
N : Node_Id;
and then (Ekind (Btyp) = E_General_Access_Type
or else Ekind (Btyp) = E_Anonymous_Access_Type)
then
- -- Ada 0Y (AI-230): Check the accessibility of anonymous access
- -- types in record and array components. For a component defini
- -- tion the level is the same of the enclosing composite type.
+ -- Ada 2005 (AI-230): Check the accessibility of anonymous
+ -- access types in record and array components. For a
+ -- component definition the level is the same of the
+ -- enclosing composite type.
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then Ekind (Btyp) = E_Anonymous_Access_Type
and then (Is_Array_Type (Scope (Btyp))
or else Ekind (Scope (Btyp)) = E_Record_Type)
- and then Object_Access_Level (P)
- > Type_Access_Level (Btyp)
+ and then Object_Access_Level (P) > Type_Access_Level (Btyp)
then
-- In an instance, this is a runtime check, but one we
-- know will fail, so generate an appropriate warning.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
return;
end if;
- -- Ada0Y (AI-50217): Process explicit with_clauses that are not limited
+ -- Ada 2005 (AI-50217): Process explicit non-limited with_clauses
declare
Item : Node_Id;
-- in a limited_with clause. If the package was not previously analyzed
-- then it also performs a basic decoration of the real entities; this
-- is required to do not pass non-decorated entities to the back-end.
- -- Implements Ada 0Y (AI-50217).
+ -- Implements Ada 2005 (AI-50217).
procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
-- Check whether the source for the body of a compilation unit must
-- through a regular with clause. This procedure creates the implicit
-- limited with_clauses for the parents and loads the corresponding units.
-- The shadow entities are created when the inserted clause is analyzed.
- -- Implements Ada 0Y (AI-50217).
+ -- Implements Ada 2005 (AI-50217).
procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id);
-- When a child unit appears in a context clause, the implicit withs on
procedure Install_Limited_Context_Clauses (N : Node_Id);
-- Subsidiary to Install_Context. Process only limited with_clauses
- -- for current unit. Implements Ada 0Y (AI-50217).
+ -- for current unit. Implements Ada 2005 (AI-50217).
procedure Install_Limited_Withed_Unit (N : Node_Id);
-- Place shadow entities for a limited_with package in the visibility
- -- structures for the current compilation. Implements Ada 0Y (AI-50217).
+ -- structures for the current compilation. Implements Ada 2005 (AI-50217).
procedure Install_Withed_Unit
(With_Clause : Node_Id;
procedure Remove_Limited_With_Clause (N : Node_Id);
-- Remove from visibility the shadow entities introduced for a package
- -- mentioned in a limited_with clause. Implements Ada 0Y (AI-50217).
+ -- mentioned in a limited_with clause. Implements Ada 2005 (AI-50217).
procedure Remove_Parents (Lib_Unit : Node_Id);
-- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
Item := First (Context_Items (N));
while Present (Item) loop
- -- Ada 0Y (AI-50217): Do not consider limited-withed units
+ -- Ada 2005 (AI-50217): Do not consider limited-withed units
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
-- Loop through context items. This is done is three passes:
-- a) The first pass analyze non-limited with-clauses.
-- b) The second pass add implicit limited_with clauses for
- -- the parents of child units (Ada 0Y: AI-50217)
- -- c) The third pass analyzes limited_with clauses (Ada 0Y: AI-50217)
+ -- the parents of child units (Ada 2005: AI-50217)
+ -- c) The third pass analyzes limited_with clauses (Ada 2005: AI-50217)
Item := First (Context_Items (N));
while Present (Item) loop
begin
if Limited_Present (N) then
- -- Ada 0Y (AI-50217): Build visibility structures but do not
+ -- Ada 2005 (AI-50217): Build visibility structures but do not
-- analyze unit
Build_Limited_Views (N);
null;
end if;
- -- Ada 0Y (AI-262): Remove from visibility the entity corresponding to
- -- private_with units; they will be made visible later (just before the
- -- private part is analyzed)
+ -- Ada 2005 (AI-262): Remove from visibility the entity corresponding
+ -- to private_with units; they will be made visible later (just before
+ -- the private part is analyzed)
if Private_Present (N) then
Set_Is_Immediately_Visible (E_Name, False);
or else Nkind (Lib_Unit) = N_Subprogram_Body)
then
Check_Parent_Context (Library_Unit (N));
+
if Is_Child_Spec (Unit (Library_Unit (N))) then
Check_Parent_Context (Parent_Spec (Unit (Library_Unit (N))));
end if;
Item := First (Context_Items (N));
while Present (Item) loop
- -- Ada 0Y (AI-262): Allow private_with of a private child package in
- -- public siblings
+ -- Ada 2005 (AI-262): Allow private_with of a private child package
+ -- in public siblings
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
then
Set_Is_Immediately_Visible (Id);
- -- Ada 0Y (AI-262): Make visible the private entities of
+ -- Ada 2005 (AI-262): Make visible the private entities of
-- private-withed siblings
if Private_Present (Item) then
or else (Is_Child_Package
and then Is_Visible_Child_Unit (P)))
then
- -- Ada 0Y (AI-262): Install the private declarations of P
+ -- Ada 2005 (AI-262): Install the private declarations of P
if Private_Present (N)
and then not In_Private_Part (P)
P : constant Entity_Id := Scope (Uname);
begin
- -- Ada 0Y (AI-262): Do not install the private withed unit if we are
+ -- Ada 2005 (AI-262): Do not install the private withed unit if we are
-- compiling a package declaration and the Private_With_OK flag was not
-- set by the caller. These declarations will be installed later (before
-- analyzing the private part of the package).
Last_Pub_Lim_E := Last_Lim_E;
- -- Ada 0Y (AI-262): Add the limited view of the private declarations
+ -- Ada 2005 (AI-262): Add the limited view of the private declarations
-- Required to give support to limited-private-with clauses
Build_Chain (Scope => P,
Unit_Name : Entity_Id;
begin
- -- Ada 0Y (AI-50217): We remove the context clauses in two phases:
+ -- Ada 2005 (AI-50217): We remove the context clauses in two phases:
-- limited-views first and regular-views later (to maintain the
-- stack model).
Handler := First_Non_Pragma (L);
while Present (Handler) loop
Id1 := First (Exception_Choices (Handler));
-
while Present (Id1) loop
-- Only check against the exception choices which precede
("exception choice duplicates &#", Id, Id1);
else
- if Ada_83 and then Comes_From_Source (Id) then
+ if Ada_Version = Ada_83
+ and then Comes_From_Source (Id)
+ then
Error_Msg_N
("(Ada 83): duplicate exception choice&", Id);
end if;
-- generic is unit is validated, Set_Instance_Env completes Save_Env.
type Instance_Env is record
- Ada_83 : Boolean;
+ Ada_Version : Ada_Version_Type;
Instantiated_Parent : Assoc;
Exchanged_Views : Elist_Id;
Hidden_Entities : Elist_Id;
if K = E_Generic_In_Parameter then
- -- Ada 0Y (AI-287): Limited aggregates allowed in generic formals
+ -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
- if not Extensions_Allowed and then Is_Limited_Type (T) then
+ if Ada_Version < Ada_05 and then Is_Limited_Type (T) then
Error_Msg_N
("generic formal of mode IN must not be of limited type", N);
Explain_Limited_Type (T, N);
elsif Ekind (Gen_Unit) /= E_Generic_Package then
- -- Ada 0Y (AI-50217): Instance can not be used in limited with_clause
+ -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
if From_With_Type (Gen_Unit) then
Error_Msg_N
Saved : Instance_Env;
begin
- Saved.Ada_83 := Ada_83;
+ Saved.Ada_Version := Ada_Version;
Saved.Instantiated_Parent := Current_Instantiated_Parent;
Saved.Exchanged_Views := Exchanged_Views;
Saved.Hidden_Entities := Hidden_Entities;
elsif Is_Indefinite_Subtype (Act_T)
and then not Is_Indefinite_Subtype (A_Gen_T)
- and then Ada_95
+ and then Ada_Version >= Ada_95
then
Error_Msg_NE
("actual for & must be a definite subtype", Actual, Gen_T);
elsif not Subtypes_Statically_Match
(Formal_Subt, Etype (Actual_Discr))
- and then Ada_95
+ and then Ada_Version >= Ada_95
then
Error_Msg_NE
("subtypes of actual discriminants must match formal",
Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last);
begin
- Ada_83 := Saved.Ada_83;
+ Ada_Version := Saved.Ada_Version;
if No (Current_Instantiated_Parent.Act_Id) then
begin
-- Regardless of the current mode, predefined units are analyzed in
- -- Ada95 mode, and Ada83 checks don't apply.
+ -- the most current Ada mode, and earlier version Ada checks do not
+ -- apply to predefined units.
if Is_Internal_File_Name
(Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
Renamings_Included => True) then
- Ada_83 := False;
+ Ada_Version := Ada_Version_Type'Last;
end if;
Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);
procedure Analyze_String_Literal (N : Node_Id) is
begin
-
-- The type is eventually inherited from the context. If expansion
-- has already established the proper type, do not modify it.
-- turns out to be non-static, then the Is_Static_Expression flag
-- will be reset in Eval_String_Literal.
- if Ada_95 then
+ if Ada_Version >= Ada_95 then
Set_Is_Static_Expression (N);
end if;
Error_Msg_N ("task entries cannot have access parameters", N);
end if;
- -- Ada 0Y (AI-254): In case of anonymous access to subprograms
+ -- Ada 2005 (AI-254): In case of anonymous access to subprograms
-- call the corresponding semantic routine
if Present (Access_To_Subprogram_Definition (N)) then
Init_Size_Align (Anon_Type);
Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type));
- -- Ada 0Y (AI-231): Ada 0Y semantics for anonymous access differs from
- -- Ada 95 semantics. In Ada 0Y, anonymous access must specify if the
- -- null value is allowed; in Ada 95 the null value is not allowed
+ -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs
+ -- from Ada 95 semantics. In Ada 2005, anonymous access must specify
+ -- if the null value is allowed. In Ada 95 the null value is never
+ -- allowed.
- if Extensions_Allowed then
+ if Ada_Version >= Ada_05 then
Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N));
else
Set_Can_Never_Be_Null (Anon_Type, True);
Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
- -- Ada 0Y (AI-50217): Propagate the attribute that indicates that the
+ -- Ada 2005 (AI-50217): Propagate the attribute that indicates that the
-- designated type comes from the limited view (for back-end purposes).
Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type));
- -- Ada 0Y (AI-231): Propagate the access-constant attribute
+ -- Ada 2005 (AI-231): Propagate the access-constant attribute
Set_Is_Access_Constant (Anon_Type, Constant_Present (N));
Init_Size_Align (T_Name);
Set_Directly_Designated_Type (T_Name, Desig_Type);
- -- Ada 0Y (AI-231): Propagate the null-excluding attribute
+ -- Ada 2005 (AI-231): Propagate the null-excluding attribute
Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def));
-- access type is also imported, and therefore restricted in its use.
-- The access type may already be imported, so keep setting otherwise.
- -- Ada 0Y (AI-50217): If the non-limited view of the designated type is
- -- available, use it as the designated type of the access type, so that
- -- the back-end gets a usable entity.
+ -- Ada 2005 (AI-50217): If the non-limited view of the designated type
+ -- is available, use it as the designated type of the access type, so
+ -- that the back-end gets a usable entity.
declare
N_Desig : Entity_Id;
Set_Has_Task (T, False);
Set_Has_Controlled_Component (T, False);
- -- Ada 0Y (AI-231): Propagate the null-excluding and access-constant
+ -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant
-- attributes
Set_Can_Never_Be_Null (T, Null_Exclusion_Present (Def));
T := Find_Type_Of_Object
(Subtype_Indication (Component_Definition (N)), N);
- -- Ada 0Y (AI-230): Access Definition case
+ -- Ada 2005 (AI-230): Access Definition case
else
pragma Assert (Present
(Related_Nod => N,
N => Access_Definition (Component_Definition (N)));
- -- Ada 0Y (AI-230): In case of components that are anonymous access
- -- types the level of accessibility depends on the enclosing type
- -- declaration
+ -- Ada 2005 (AI-230): In case of components that are anonymous
+ -- access types the level of accessibility depends on the enclosing
+ -- type declaration
- Set_Scope (T, Current_Scope); -- Ada 0Y (AI-230)
+ Set_Scope (T, Current_Scope); -- Ada 2005 (AI-230)
- -- Ada 0Y (AI-254)
+ -- Ada 2005 (AI-254)
if Present (Access_To_Subprogram_Definition
(Access_Definition (Component_Definition (N))))
Set_Etype (Id, T);
Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N)));
- -- Ada 0Y (AI-231): Propagate the null-excluding attribute and carry
+ -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
-- out some static checks
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then (Null_Exclusion_Present (Component_Definition (N))
or else Can_Never_Be_Null (T))
then
end if;
end if;
- -- Ada 0Y (AI-231): Propagate the null-excluding attribute and carry
+ -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
-- out some static checks
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then (Null_Exclusion_Present (N)
or else Can_Never_Be_Null (T))
then
-- In Ada 83, deferred constant must be of private type
elsif not Is_Private_Type (T) then
- if Ada_83 and then Comes_From_Source (N) then
+ if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_N
("(Ada 83) deferred constant must be private type", N);
end if;
-- Not allowed in Ada 83
if not Constant_Present (N) then
- if Ada_83
+ if Ada_Version = Ada_83
and then Comes_From_Source (Object_Definition (N))
then
Error_Msg_N
Set_Directly_Designated_Type
(Id, Designated_Type (T));
- -- Ada 0Y (AI-231): Propagate the null-excluding attribute and
- -- carry out some static checks
+ -- Ada 2005 (AI-231): Propagate the null-excluding attribute
+ -- and carry out some static checks
if Null_Exclusion_Present (N)
or else Can_Never_Be_Null (T)
and then Can_Never_Be_Null (T)
then
Error_Msg_N
- ("(Ada 0Y) null exclusion not allowed if parent "
+ ("(Ada 2005) null exclusion not allowed if parent "
& "is already non-null", Subtype_Indication (N));
end if;
end if;
-- The full view, if present, now points to the current type
- -- Ada 0Y (AI-50217): If the type was previously decorated when imported
- -- through a LIMITED WITH clause, it appears as incomplete but has no
- -- full view.
+ -- Ada 2005 (AI-50217): If the type was previously decorated when
+ -- imported through a LIMITED WITH clause, it appears as incomplete
+ -- but has no full view.
if Ekind (Prev) = E_Incomplete_Type
and then Present (Full_View (Prev))
Element_Type := Process_Subtype (Subtype_Indication (Component_Def),
P, Related_Id, 'C');
- -- Ada 0Y (AI-230): Access Definition case
+ -- Ada 2005 (AI-230): Access Definition case
else pragma Assert (Present (Access_Definition (Component_Def)));
Element_Type := Access_Definition
(Related_Nod => Related_Id,
N => Access_Definition (Component_Def));
- -- Ada 0Y (AI-230): In case of components that are anonymous access
- -- types the level of accessibility depends on the enclosing type
- -- declaration
+ -- Ada 2005 (AI-230): In case of components that are anonymous
+ -- access types the level of accessibility depends on the enclosing
+ -- type declaration
- Set_Scope (Element_Type, Current_Scope); -- Ada 0Y (AI-230)
+ Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230)
- -- Ada 0Y (AI-254)
+ -- Ada 2005 (AI-254)
declare
CD : constant Node_Id :=
Set_Has_Aliased_Components (Etype (T));
end if;
- -- Ada 0Y (AI-231): Propagate the null-excluding attribute to the array
- -- to ensure that objects of this type are initialized
+ -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the
+ -- array to ensure that objects of this type are initialized.
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then (Null_Exclusion_Present (Component_Definition (Def))
or else Can_Never_Be_Null (Element_Type))
then
and then Can_Never_Be_Null (Element_Type)
then
Error_Msg_N
- ("(Ada 0Y) already a null-excluding type",
+ ("(Ada 2005) already a null-excluding type",
Subtype_Indication (Component_Definition (Def)));
end if;
end if;
Has_Private_Component (Derived_Type));
Conditional_Delay (Derived_Type, Subt);
- -- Ada 0Y (AI-231). Set the null-exclusion attribute
+ -- Ada 2005 (AI-231). Set the null-exclusion attribute
if Null_Exclusion_Present (Type_Definition (N))
or else Can_Never_Be_Null (Parent_Type)
and then not In_Instance
and then not In_Inlined_Body
then
- -- Ada 0Y (AI-287): Relax the strictness of the front-end in case of
- -- limited aggregates and extension aggregates.
+ -- Ada 2005 (AI-287): Relax the strictness of the front-end in
+ -- case of limited aggregates and extension aggregates.
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then (Nkind (Exp) = N_Aggregate
- or else Nkind (Exp) = N_Extension_Aggregate)
+ or else Nkind (Exp) = N_Extension_Aggregate)
then
null;
else
Set_Is_Immediately_Visible (D);
Set_Homonym (D, Prev);
- -- Ada 0Y (AI-230): Access discriminant allowed in non-limited
- -- record types
+ -- Ada 2005 (AI-230): Access discriminant allowed in
+ -- non-limited record types.
- if not Extensions_Allowed then
+ if Ada_Version < Ada_05 then
-- This restriction gets applied to the full type here; it
-- has already been applied earlier to the partial view
elsif Is_Unchecked_Union (Parent_Type) then
Error_Msg_N ("cannot derive from Unchecked_Union type", N);
- -- Ada 0Y (AI-231): Static check
+ -- Ada 2005 (AI-231): Static check
elsif Is_Access_Type (Parent_Type)
and then Null_Exclusion_Present (Type_Definition (N))
and then Can_Never_Be_Null (Parent_Type)
then
- Error_Msg_N ("(Ada 0Y) null exclusion not allowed if parent is "
+ Error_Msg_N ("(Ada 2005) null exclusion not allowed if parent is "
& "already non-null", Type_Definition (N));
end if;
-- be used for further derivation until the end of its visible part.
-- Note that derivation in the private part of the package is allowed.
- if Ada_83
+ if Ada_Version = Ada_83
and then Is_Derived_Type (Parent_Type)
and then In_Visible_Part (Scope (Parent_Type))
then
- if Ada_83 and then Comes_From_Source (Indic) then
+ if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then
Error_Msg_N
("(Ada 83): premature use of type for derivation", Indic);
end if;
elsif T = Any_Character then
- if not Ada_83 then
+ if Ada_Version >= Ada_95 then
Error_Msg_N
("ambiguous character literals (could be Wide_Character)",
I);
if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
Discr_Type := Access_Definition (N, Discriminant_Type (Discr));
- -- Ada 0Y (AI-254)
+ -- Ada 2005 (AI-254)
if Present (Access_To_Subprogram_Definition
(Discriminant_Type (Discr)))
if Is_Access_Type (Discr_Type) then
- -- Ada 0Y (AI-230): Access discriminant allowed in non-limited
+ -- Ada 2005 (AI-230): Access discriminant allowed in non-limited
-- record types
- if not Extensions_Allowed then
+ if Ada_Version < Ada_05 then
Check_Access_Discriminant_Requires_Limited
(Discr, Discriminant_Type (Discr));
end if;
- if Ada_83 and then Comes_From_Source (Discr) then
+ if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then
Error_Msg_N
("(Ada 83) access discriminant not allowed", Discr);
end if;
Default_Not_Present := True;
end if;
- -- Ada 0Y (AI-231): Set the null-excluding attribute and carry out
- -- some static checks
+ -- Ada 2005 (AI-231): Set the null-excluding attribute and carry
+ -- out some static checks.
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then (Null_Exclusion_Present (Discr)
or else Can_Never_Be_Null (Discr_Type))
then
Find_Type (S);
Check_Incomplete (S);
- -- Ada 0Y (AI-231): Static check
+ -- Ada 2005 (AI-231): Static check
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then Present (Parent (S))
and then Null_Exclusion_Present (Parent (S))
and then Nkind (Parent (S)) /= N_Access_To_Object_Definition
and then not Is_Access_Type (Entity (S))
then
Error_Msg_N
- ("(Ada 0Y) null-exclusion part requires an access type", S);
+ ("(Ada 2005) null-exclusion part requires an access type", S);
end if;
return Entity (S);
function Replace_Anonymous_Access_To_Protected_Subprogram
(N : Node_Id;
Prev_E : Entity_Id) return Entity_Id;
- -- Ada 0Y (AI-254): Create and decorate an internal full type declaration
- -- in the enclosing scope corresponding to an anonymous access to protected
- -- subprogram. In addition, replace the anonymous access by an occurrence
- -- of this internal type. Prev_Etype is used to link the new internal
- -- entity with the anonymous entity. Return the entity of this type
- -- declaration.
+ -- Ada 2005 (AI-254): Create and decorate an internal full type
+ -- declaration in the enclosing scope corresponding to an anonymous
+ -- access to protected subprogram. In addition, replace the anonymous
+ -- access by an occurrence of this internal type. Prev_Etype is used
+ -- to link the new internal entity with the anonymous entity. Return
+ -- the entity of this type declaration.
procedure Set_Completion_Referenced (E : Entity_Id);
-- If E is the completion of a private or incomplete type declaration,
and then Comes_From_Source (N)
and then not In_Instance_Body
then
- -- Ada 0Y (AI-287): Do not post an error if the expression
+ -- Ada 2005 (AI-287): Do not post an error if the expression
-- corresponds to a limited aggregate. Limited aggregates
-- are checked in sem_aggr in a per-component manner
-- (compare with handling of Get_Value subprogram).
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then Nkind (Expression (E)) = N_Aggregate
then
null;
Find_Type (Subtype_Mark (E));
if Is_Elementary_Type (Entity (Subtype_Mark (E))) then
- if not (Ada_83
+ if not (Ada_Version = Ada_83
and then Is_Access_Type (Entity (Subtype_Mark (E))))
then
Error_Msg_N ("constraint not allowed here", E);
Set_Directly_Designated_Type (Acc_Type, Type_Id);
Check_Fully_Declared (Type_Id, N);
- -- Ada 0Y (AI-231)
+ -- Ada 2005 (AI-231)
if Can_Never_Be_Null (Type_Id) then
- Error_Msg_N ("(Ada 0Y) qualified expression required",
+ Error_Msg_N ("(Ada 2005) qualified expression required",
Expression (N));
end if;
Check_Restriction (No_Local_Allocators, N);
end if;
- -- Ada 0Y (AI-231): Static checks
+ -- Ada 2005 (AI-231): Static checks
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then (Null_Exclusion_Present (N)
or else Can_Never_Be_Null (Etype (N)))
then
end if;
end if;
- if Ada_83
+ if Ada_Version = Ada_83
and then
(Nkind (Parent (N)) = N_Loop_Parameter_Specification
or else Nkind (Parent (N)) = N_Constrained_Array_Definition)
Error_Msg_N ("\use qualified expression instead", N);
elsif Nkind (Expr) = N_Character_Literal then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Resolve (Expr, T);
else
Error_Msg_N ("argument of conversion cannot be character literal",
Void_Interp_Seen : Boolean := False;
begin
- if Extensions_Allowed then
+ if Ada_Version >= Ada_05 then
Actual := First_Actual (N);
-
while Present (Actual) loop
- -- Ada 0Y (AI-50217): Post an error in case of premature usage of
- -- an entity from the limited view.
+
+ -- Ada 2005 (AI-50217): Post an error in case of premature
+ -- usage of an entity from the limited view.
if not Analyzed (Etype (Actual))
and then From_With_Type (Etype (Actual))
return;
end if;
- -- Ada 0Y (AI-230): Keep restriction imposed by Ada 83 and 95: Do not
- -- allow anonymous access types in equality operators.
+ -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
+ -- Do not allow anonymous access types in equality operators.
- if not Extensions_Allowed
+ if Ada_Version < Ada_05
and then Ekind (T1) = E_Anonymous_Access_Type
then
return;
and then Is_Abstract (It.Nam)
and then not Is_Dispatching_Operation (It.Nam)
and then
- (Extensions_Allowed
+ (Ada_Version >= Ada_05
or else Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (It.Nam))))
Get_First_Interp (N, I, It);
while Present (It.Nam) loop
- if Scope (It.Nam) = Standard_Standard then
+ if Scope (It.Nam) = Standard_Standard
+ and then Base_Type (It.Typ) =
+ Base_Type (Etype (Abstract_Op))
+ then
Remove_Interp (I);
end if;
Propagate_Tag (Lhs, Rhs);
end if;
- -- Ada 0Y (AI-231)
+ -- Ada 2005 (AI-231)
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then Nkind (Rhs) = N_Null
and then Is_Access_Type (T1)
and then not Assignment_OK (Lhs)
or else Can_Never_Be_Null (Etype (Lhs)))
then
Error_Msg_N
- ("(Ada 0Y) NULL not allowed in null-excluding objects", Lhs);
+ ("(Ada 2005) NULL not allowed in null-excluding objects", Lhs);
end if;
if Is_Scalar_Type (T1) then
("character literal as case expression is ambiguous", Exp);
return;
- elsif Ada_83
+ elsif Ada_Version = Ada_83
and then (Is_Generic_Type (Exp_Btype)
or else Is_Generic_Type (Root_Type (Exp_Btype)))
then
end if;
end if;
- -- Ada 0Y (AI-262): In library subprogram bodies, after the analysis
+ -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis
-- if its specification we have to install the private withed units.
if Is_Compilation_Unit (Body_Id)
-- skipped if either entity is an operator in package Standard.
-- or if either old or new instance is not from the source program.
- if Ada_83
+ if Ada_Version = Ada_83
and then Sloc (Old_Id) > Standard_Location
and then Sloc (New_Id) > Standard_Location
and then Comes_From_Source (Old_Id)
-- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
- if Ada_83 then
+ if Ada_Version = Ada_83 then
declare
Old_Disc : constant Node_Id := Declaration_Node (Old_Discr);
or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
end if;
- -- Ada 0Y (AI-254): Detect anonymous access to subprogram types.
+ -- Ada 2005 (AI-254): Detect anonymous access to subprogram types
Are_Anonymous_Access_To_Subprogram_Types :=
if (Ekind (Type_1) = E_Anonymous_Access_Type
and then Ekind (Type_2) = E_Anonymous_Access_Type)
- or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 0Y (AI-254)
+ or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 2005 (AI-254)
then
declare
Desig_1 : Entity_Id;
and then Ekind (Root_Type (Formal_Type)) =
E_Incomplete_Type)
then
- -- Ada 0Y (AI-50217): Incomplete tagged types that are made
- -- visible through a limited with_clause are valid formal
- -- types.
+ -- Ada 2005 (AI-50217): Incomplete tagged types that are made
+ -- visible by a limited with_clause are valid formal types.
if From_With_Type (Formal_Type)
and then Is_Tagged_Type (Formal_Type)
Parameter_Type (Param_Spec), Formal_Type);
end if;
- -- Ada 0Y (AI-231): Create and decorate an internal subtype
+ -- Ada 2005 (AI-231): Create and decorate an internal subtype
-- declaration corresponding to the null-excluding type of the
-- formal in the enclosing scope. In addition, replace the
-- parameter type of the formal to this internal subtype.
end;
end if;
- -- Ada 0Y (AI-231): Static checks
+ -- Ada 2005 (AI-231): Static checks
if Null_Exclusion_Present (Param_Spec)
or else Can_Never_Be_Null (Entity (Ptype))
Formal_Type :=
Access_Definition (Related_Nod, Parameter_Type (Param_Spec));
- -- Ada 0Y (AI-254)
+ -- Ada 2005 (AI-254)
declare
AD : constant Node_Id :=
if Nkind (Parameter_Type (Spec)) = N_Access_Definition then
- -- Ada 0Y (AI-231): This behaviour has been modified in Ada 0Y.
+ -- Ada 2005 (AI-231): This behaviour has been modified in Ada 2005.
-- It is only forced if the null_exclusion appears.
- if not Extensions_Allowed
+ if Ada_Version < Ada_05
or else Null_Exclusion_Present (Spec)
then
Set_Is_Known_Non_Null (Formal_Id);
or else Is_Child_Unit (Spec_Id))
and then not Unit_Requires_Body (Spec_Id)
then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_N
("optional package body (not allowed in Ada 95)?", N);
else
-- Used to resolved qualified names whose selector is a character literal.
function Has_Private_With (E : Entity_Id) return Boolean;
- -- Ada 0Y (AI-262): Determines if the current compilation unit has a
+ -- Ada 2005 (AI-262): Determines if the current compilation unit has a
-- private with on E
procedure Find_Expanded_Name (N : Node_Id);
T := Entity (Subtype_Mark (N));
Analyze_And_Resolve (Nam, T);
- -- Ada 0Y (AI-230/AI-254): Access renaming
+ -- Ada 2005 (AI-230/AI-254): Access renaming
else pragma Assert (Present (Access_Definition (N)));
T := Access_Definition
Analyze_And_Resolve (Nam, T);
- -- Ada 0Y (AI-231): "In the case where the type is defined by an
+ -- Ada 2005 (AI-231): "In the case where the type is defined by an
-- access_definition, the renamed entity shall be of an access-to-
-- constant type if and only if the access_definition defines an
-- access-to-constant type" ARM 8.5.1(4)
if Constant_Present (Access_Definition (N))
and then not Is_Access_Constant (Etype (Nam))
then
- Error_Msg_N ("(Ada 0Y): the renamed object is not "
+ Error_Msg_N ("(Ada 2005): the renamed object is not "
& "access-to-constant ('R'M 8.5.1(6))", N);
elsif Null_Exclusion_Present (Access_Definition (N)) then
- Error_Msg_N ("(Ada 0Y): null-excluding attribute ignored "
+ Error_Msg_N ("(Ada 2005): null-excluding attribute ignored "
& "('R'M 8.5.1(6))?", N);
end if;
end if;
Error_Msg_N
("expect package name in renaming", Name (N));
- -- Ada 0Y (AI-50217): Limited withed packages can not be renamed
+ -- Ada 2005 (AI-50217): Limited withed packages can not be renamed
elsif Ekind (Old_P) = E_Package
and then From_With_Type (Old_P)
---------------------------------
procedure Analyze_Subprogram_Renaming (N : Node_Id) is
- Spec : constant Node_Id := Specification (N);
- Save_83 : constant Boolean := Ada_83;
- Nam : constant Node_Id := Name (N);
+ Spec : constant Node_Id := Specification (N);
+ Save_AV : constant Ada_Version_Type := Ada_Version;
+ Nam : constant Node_Id := Name (N);
New_S : Entity_Id;
Old_S : Entity_Id := Empty;
Rename_Spec : Entity_Id;
Set_Has_Completion (Rename_Spec, Inside_A_Generic);
- if Ada_83 and then Comes_From_Source (N) then
+ if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_N ("(Ada 83) renaming cannot serve as a body", N);
end if;
-- between renamed entity and new entity, even though the same circuit
-- is used.
- Ada_83 := False;
+ Ada_Version := Ada_Version_Type'Max (Ada_Version, Ada_95);
if No (Old_S) then
Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
end if;
if Old_S /= Any_Id then
-
if Is_Actual
and then From_Default (N)
then
end if;
end if;
- Ada_83 := Save_83;
+ Ada_Version := Save_AV;
end Analyze_Subprogram_Renaming;
-------------------------
-- rather than undefined.
Nvis_Is_Private_Subprg : Boolean := False;
- -- Ada 0Y (AI-262): Set True to indicate that a form of Beaujolais
+ -- Ada 2005 (AI-262): Set True to indicate that a form of Beaujolais
-- effect concerning library subprograms has been detected. Used to
-- generate the precise error message.
Item : Node_Id;
begin
- -- Ada 0Y (AI-262): Generate a precise error concerning the
+ -- Ada 2005 (AI-262): Generate a precise error concerning the
-- Beaujolais effect that was previously detected
if Nvis_Is_Private_Subprg then
pragma Assert (Error_Msg_Sloc /= No_Location);
- Error_Msg_N ("(Ada 0Y): hidden by private with clause #", N);
+ Error_Msg_N ("(Ada 2005): hidden by private with clause #", N);
return;
end if;
Only_One_Visible := False;
All_Overloadable := All_Overloadable and Is_Overloadable (E2);
- -- Ada 0Y (AI-262): Protect against a form of Beujolais effect
+ -- Ada 2005 (AI-262): Protect against a form of Beujolais effect
-- that can occurr in private_with clauses. Example:
-- with A;
Set_Chars (Selector, Chars (Id));
end if;
- -- Ada 0Y (AI-50217): Check usage of entities in limited withed units
+ -- Ada 2005 (AI-50217): Check usage of entities in limited withed units
if Ekind (P_Name) = E_Package
and then From_With_Type (P_Name)
Set_Etype (N, C);
end if;
- -- Base attribute, allowed in Ada 95 mode only
+ -- Base attribute, not allowed in Ada 83
elsif Attribute_Name (N) = Name_Base then
- if Ada_83 and then Comes_From_Source (N) then
+ if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_N
("(Ada 83) Base attribute not allowed in subtype mark", N);
Find_Type (Prefix (N));
Typ := Entity (Prefix (N));
- if Ada_95
+ if Ada_Version >= Ada_95
and then not Is_Scalar_Type (Typ)
and then not Is_Generic_Type (Typ)
then
Set_In_Use (P);
- -- Ada 0Y (AI-50217): Check restriction.
+ -- Ada 2005 (AI-50217): Check restriction
if From_With_Type (P) then
Error_Msg_N ("limited withed package cannot appear in use clause", N);
Real_P := P;
end if;
- -- Ada 0Y (AI-262): Check the use_clause of a private withed package
+ -- Ada 2005 (AI-262): Check the use_clause of a private withed package
-- found in the private part of a package specification
if In_Private_Part (Current_Scope)
Id := First_Entity (P);
while Present (Id)
and then (Id /= First_Private_Entity (P)
- or else Private_With_OK) -- Ada 0Y (AI-262)
+ or else Private_With_OK) -- Ada 2005 (AI-262)
loop
Prev := Current_Entity (Id);
New_Scope (T);
if Present (Discriminant_Specifications (N)) then
- if Ada_83 and then Comes_From_Source (N) then
+ if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
end if;
-- Concatenation is never static in Ada 83, so if Ada 83
-- check operand non-static context
- if Ada_83
+ if Ada_Version = Ada_83
and then Comes_From_Source (N)
then
Check_Non_Static_Context (Left);
begin
-- Short circuit operations are never static in Ada 83
- if Ada_83
+ if Ada_Version = Ada_83
and then Comes_From_Source (N)
then
Check_Non_Static_Context (Left);
-- bound is type'First. In either case it is the upper bound that
-- is out of range of the index type.
- if Ada_95 then
+ if Ada_Version >= Ada_95 then
if Root_Type (Bas) = Standard_String
or else
Root_Type (Bas) = Standard_Wide_String
if Is_Static_Expression (N)
and then not In_Instance
and then not In_Inlined_Body
- and then Ada_95
+ and then Ada_Version >= Ada_95
then
if Nkind (Parent (N)) = N_Defining_Identifier
and then Is_Array_Type (Parent (N))
procedure Check_Ada_83_Warning is
begin
- if Ada_83 and then Comes_From_Source (N) then
+ if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
end if;
end Check_Ada_83_Warning;
-- pragmas like Import in Ada 83 mode. They will of course be
-- flagged with warnings as usual, but will not cause errors.
- elsif Ada_83 and then Nkind (Argx) = N_String_Literal then
+ elsif Ada_Version = Ada_83
+ and then Nkind (Argx) = N_String_Literal
+ then
return;
-- Static expression that raises Constraint_Error. This has
-- pragma Ada_83;
-- Note: this pragma also has some specific processing in Par.Prag
- -- because we want to set the Ada 83 mode switch during parsing.
+ -- because we want to set the Ada version mode during parsing.
when Pragma_Ada_83 =>
GNAT_Pragma;
- Ada_83 := True;
- Ada_95 := False;
+ Ada_Version := Ada_83;
Check_Arg_Count (0);
------------
-- pragma Ada_95;
-- Note: this pragma also has some specific processing in Par.Prag
- -- because we want to set the Ada 83 mode switch during parsing.
+ -- because we want to set the Ada 83 version mode during parsing.
when Pragma_Ada_95 =>
GNAT_Pragma;
- Ada_83 := False;
- Ada_95 := True;
+ Ada_Version := Ada_95;
+ Check_Arg_Count (0);
+
+ ------------
+ -- Ada_05 --
+ ------------
+
+ -- pragma Ada_05;
+
+ -- Note: this pragma also has some specific processing in Par.Prag
+ -- because we want to set the Ada 83 version mode during parsing.
+
+ when Pragma_Ada_05 =>
+ GNAT_Pragma;
+ Ada_Version := Ada_05;
Check_Arg_Count (0);
----------------------
-- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
-- placement rule does not apply.
- if Ada_83 and then Comes_From_Source (N) then
+ if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Citem := Next (N);
while Present (Citem) loop
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
- Extensions_Allowed := (Chars (Expression (Arg1)) = Name_On);
+
+ if Chars (Expression (Arg1)) = Name_On then
+ Extensions_Allowed := True;
+ Ada_Version := Ada_Version_Type'Last;
+ else
+ Extensions_Allowed := False;
+ Ada_Version := Ada_Version_Type'Min (Ada_Version, Ada_95);
+ end if;
--------------
-- External --
Pragma_Abort_Defer => -1,
Pragma_Ada_83 => -1,
Pragma_Ada_95 => -1,
+ Pragma_Ada_05 => -1,
Pragma_All_Calls_Remote => -1,
Pragma_Annotate => -1,
Pragma_Assert => -1,
function Operator_Kind
(Op_Name : Name_Id;
- Is_Binary : Boolean)
- return Node_Kind;
+ Is_Binary : Boolean) return Node_Kind;
-- Utility to map the name of an operator into the corresponding Node. Used
-- by other node rewriting procedures.
-- that operands are resolved properly. Recall that predefined operators
-- do not have a full signature and special resolution rules apply.
- procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id);
+ procedure Rewrite_Renamed_Operator
+ (N : Node_Id;
+ Op : Entity_Id;
+ Typ : Entity_Id);
-- An operator can rename another, e.g. in an instantiation. In that
- -- case, the proper operator node must be constructed.
+ -- case, the proper operator node must be constructed and resolved.
procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id);
-- The String_Literal_Subtype is built for all strings that are not
function Valid_Conversion
(N : Node_Id;
Target : Entity_Id;
- Operand : Node_Id)
- return Boolean;
+ Operand : Node_Id) return Boolean;
-- Verify legality rules given in 4.6 (8-23). Target is the target
-- type of the conversion, which may be an implicit conversion of
-- an actual parameter to an anonymous access type (in which case
function Operator_Kind
(Op_Name : Name_Id;
- Is_Binary : Boolean)
- return Node_Kind
+ Is_Binary : Boolean) return Node_Kind
is
Kind : Node_Kind;
-- Here we have an acceptable interpretation for the context
else
- -- A user-defined operator is tranformed into a function call at
- -- this point, so that further processing knows that operators are
- -- really operators (i.e. are predefined operators). User-defined
- -- operators that are intrinsic are just renamings of the predefined
- -- ones, and need not be turned into calls either, but if they rename
- -- a different operator, we must transform the node accordingly.
- -- Instantiations of Unchecked_Conversion are intrinsic but are
- -- treated as functions, even if given an operator designator.
-
- if Nkind (N) in N_Op
- and then Present (Entity (N))
- and then Ekind (Entity (N)) /= E_Operator
- then
-
- if not Is_Predefined_Op (Entity (N)) then
- Rewrite_Operator_As_Call (N, Entity (N));
-
- elsif Present (Alias (Entity (N))) then
- Rewrite_Renamed_Operator (N, Alias (Entity (N)));
- end if;
- end if;
-
-- Propagate type information and normalize tree for various
-- predefined operations. If the context only imposes a class of
-- types, rather than a specific type, propagate the actual type
end if;
end if;
+ -- A user-defined operator is tranformed into a function call at
+ -- this point, so that further processing knows that operators are
+ -- really operators (i.e. are predefined operators). User-defined
+ -- operators that are intrinsic are just renamings of the predefined
+ -- ones, and need not be turned into calls either, but if they rename
+ -- a different operator, we must transform the node accordingly.
+ -- Instantiations of Unchecked_Conversion are intrinsic but are
+ -- treated as functions, even if given an operator designator.
+
+ if Nkind (N) in N_Op
+ and then Present (Entity (N))
+ and then Ekind (Entity (N)) /= E_Operator
+ then
+
+ if not Is_Predefined_Op (Entity (N)) then
+ Rewrite_Operator_As_Call (N, Entity (N));
+
+ elsif Present (Alias (Entity (N))) then
+ Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ);
+
+ -- If the node is rewritten, it will be fully resolved in
+ -- Rewrite_Renamed_Operator.
+
+ if Analyzed (N) then
+ return;
+ end if;
+ end if;
+ end if;
+
case N_Subexpr'(Nkind (N)) is
when N_Aggregate => Resolve_Aggregate (N, Ctx_Type);
-- or IN OUT actual to a nested call, since this is a
-- case of reading an out parameter, which is not allowed.
- if Ada_83
+ if Ada_Version = Ada_83
and then Is_Entity_Name (A)
and then Ekind (Entity (A)) = E_Out_Parameter
then
Apply_Range_Check (A, F_Typ);
end if;
- -- Ada 0Y (AI-231)
+ -- Ada 2005 (AI-231)
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then Is_Access_Type (F_Typ)
and then (Can_Never_Be_Null (F)
or else Can_Never_Be_Null (F_Typ))
then
if Nkind (A) = N_Null then
- Error_Msg_NE ("(Ada 0Y) not allowed for null-exclusion " &
- "formal", A, F_Typ);
+ Error_Msg_NE
+ ("(Ada 2005) not allowed for " &
+ "null-exclusion formal", A, F_Typ);
end if;
end if;
end if;
end loop;
-- Reanalyze the literal with the fixed type of the context.
+ -- If context is Universal_Fixed, we are within a conversion,
+ -- leave the literal as a universal real because there is no
+ -- usable fixed type, and the target of the conversion plays
+ -- no role in the resolution.
- if N = L then
- Set_Analyzed (R, False);
- Resolve (R, B_Typ);
- else
- Set_Analyzed (L, False);
- Resolve (L, B_Typ);
- end if;
+ declare
+ Op2 : Node_Id;
+ T2 : Entity_Id;
+
+ begin
+ if N = L then
+ Op2 := R;
+ else
+ Op2 := L;
+ end if;
+
+ if B_Typ = Universal_Fixed
+ and then Nkind (Op2) = N_Real_Literal
+ then
+ T2 := Universal_Real;
+ else
+ T2 := B_Typ;
+ end if;
+
+ Set_Analyzed (Op2, False);
+ Resolve (Op2, T2);
+ end;
else
Resolve (N);
Set_Etype (R, Any_Type);
else
- if Ada_83
+ if Ada_Version = Ada_83
and then Etype (N) = Universal_Fixed
and then Nkind (Parent (N)) /= N_Type_Conversion
and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
Error_Msg_N ("illegal use of generic function", N);
elsif Ekind (E) = E_Out_Parameter
- and then Ada_83
+ and then Ada_Version = Ada_83
and then (Nkind (Parent (N)) in N_Op
or else (Nkind (Parent (N)) = N_Assignment_Statement
and then N = Expression (Parent (N)))
if Nkind (Arg2) = N_Type_Conversion then
Save_Interps (Right_Opnd (N), Expression (Arg2));
else
- Save_Interps (Right_Opnd (N), Arg1);
+ Save_Interps (Right_Opnd (N), Arg2);
end if;
Rewrite (Left_Opnd (N), Arg1);
procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
begin
- -- For now allow circumvention of the restriction against
- -- anonymous null access values via a debug switch to allow
- -- for easier transition.
+ -- Handle restriction against anonymous null access values
+ -- This restriction can be turned off using -gnatdh.
- -- Ada 0Y (AI-231): Remove restriction
+ -- Ada 2005 (AI-231): Remove restriction
- if not Extensions_Allowed
+ if Ada_Version < Ada_05
and then not Debug_Flag_J
and then Ekind (Typ) = E_Anonymous_Access_Type
and then Comes_From_Source (N)
-- Rewrite_Renamed_Operator --
------------------------------
- procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id) is
+ procedure Rewrite_Renamed_Operator
+ (N : Node_Id;
+ Op : Entity_Id;
+ Typ : Entity_Id)
+ is
Nam : constant Name_Id := Chars (Op);
Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op;
Op_Node : Node_Id;
begin
-- Rewrite the operator node using the real operator, not its
- -- renaming. Exclude user-defined intrinsic operations, which
- -- are treated separately.
+ -- renaming. Exclude user-defined intrinsic operations of the same
+ -- name, which are treated separately and rewritten as calls.
- if Ekind (Op) /= E_Function then
+ if Ekind (Op) /= E_Function
+ or else Chars (N) /= Nam
+ then
Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N));
Set_Chars (Op_Node, Nam);
Set_Etype (Op_Node, Etype (N));
end if;
Rewrite (N, Op_Node);
+
+ -- If the context type is private, add the appropriate conversions
+ -- so that the operator is applied to the full view. This is done
+ -- in the routines that resolve intrinsic operators,
+
+ if Is_Intrinsic_Subprogram (Op)
+ and then Is_Private_Type (Typ)
+ then
+ case Nkind (N) is
+ when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
+ N_Op_Expon | N_Op_Mod | N_Op_Rem =>
+ Resolve_Intrinsic_Operator (N, Typ);
+
+ when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
+ Resolve_Intrinsic_Unary_Operator (N, Typ);
+
+ when others =>
+ Resolve (N, Typ);
+ end case;
+ end if;
+
+ elsif Ekind (Op) = E_Function
+ and then Is_Intrinsic_Subprogram (Op)
+ then
+ -- Operator renames a user-defined operator of the same name. Use
+ -- the original operator in the node, which is the one that gigi
+ -- knows about.
+
+ Set_Entity (N, Op);
+ Set_Is_Overloaded (N, False);
end if;
end Rewrite_Renamed_Operator;
-- Look for visible fixed type declarations in the context.
Item := First (Context_Items (Cunit (Current_Sem_Unit)));
-
while Present (Item) loop
if Nkind (Item) = N_With_Clause then
Scop := Entity (Name (Item));
function Valid_Conversion
(N : Node_Id;
Target : Entity_Id;
- Operand : Node_Id)
- return Boolean
+ Operand : Node_Id) return Boolean
is
Target_Type : constant Entity_Id := Base_Type (Target);
Opnd_Type : Entity_Id := Etype (Operand);
function Conversion_Check
(Valid : Boolean;
- Msg : String)
- return Boolean;
+ Msg : String) return Boolean;
-- Little routine to post Msg if Valid is False, returns Valid value
function Valid_Tagged_Conversion
(Target_Type : Entity_Id;
- Opnd_Type : Entity_Id)
- return Boolean;
+ Opnd_Type : Entity_Id) return Boolean;
-- Specifically test for validity of tagged conversions
----------------------
function Conversion_Check
(Valid : Boolean;
- Msg : String)
- return Boolean
+ Msg : String) return Boolean
is
begin
if not Valid then
function Valid_Tagged_Conversion
(Target_Type : Entity_Id;
- Opnd_Type : Entity_Id)
- return Boolean
+ Opnd_Type : Entity_Id) return Boolean
is
begin
-- Upward conversions are allowed (RM 4.6(22)).
then
return True;
- -- Ada 0Y (AI-254): An Anonymous_Access_To_Subprogram is compatible with
- -- itself, or with an anonymous type created for an attribute
+ -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
+ -- with itself, or with an anonymous type created for an attribute
-- reference Access.
elsif (Ekind (Base_Type (T1)) = E_Anonymous_Access_Subprogram_Type
then
return True;
- -- Ada 0Y (AI-50217): Additional branches to make the shadow entity
+ -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
-- compatible with its real entity.
elsif From_With_Type (T1) then
if Is_Fixed_Point_Type (Typ)
and then (Chars (Nam1) = Name_Op_Multiply
or else Chars (Nam1) = Name_Op_Divide)
- and then Ada_83
+ and then Ada_Version = Ada_83
then
if It2.Nam = Predef_Subp then
return It1;
-
else
return It2;
end if;
elsif T = Universal_Fixed then
return Etype (R);
- -- Ada 0Y (AI-230): Support the following operators:
+ -- Ada 2005 (AI-230): Support the following operators:
-- function "=" (L, R : universal_access) return Boolean;
-- function "/=" (L, R : universal_access) return Boolean;
- elsif Extensions_Allowed
+ elsif Ada_Version >= Ada_05
and then Ekind (Etype (L)) = E_Anonymous_Access_Type
and then Is_Access_Type (Etype (R))
then
return Etype (L);
- elsif Extensions_Allowed
+ elsif Ada_Version >= Ada_05
and then Ekind (Etype (R)) = E_Anonymous_Access_Type
and then Is_Access_Type (Etype (L))
then
and then Base_Type (T1) = Base_Type (T)
and then Is_Numeric_Type (T)
and then (not Is_Fixed_Point_Type (T)
- or else Ada_83))
+ or else Ada_Version = Ada_83))
- -- Mixed_Mode operations on fixed-point types.
+ -- Mixed_Mode operations on fixed-point types
or else (Base_Type (T1) = Base_Type (T)
and then Base_Type (T2) = Base_Type (Standard_Integer)
and then Base_Type (T1) = Base_Type (T)
and then Is_Numeric_Type (T)
and then (not Is_Fixed_Point_Type (T)
- or else Ada_83))
+ or else Ada_Version = Ada_83))
- -- Mixed_Mode operations on fixed-point types.
+ -- Mixed_Mode operations on fixed-point types
or else (Base_Type (T1) = Base_Type (T)
and then Base_Type (T2) = Base_Type (Standard_Integer)
begin
if Ekind (T) = E_Incomplete_Type then
- -- Ada0Y (AI-50217): If the type is available through a limited
+ -- Ada 2005 (AI-50217): If the type is available through a limited
-- with_clause, verify that its full view has been analyzed.
if From_With_Type (T)
-- the body of an instance, constraint_checks are only warnings.
-- We also make this a warning if the Warn parameter is set.
- elsif Warn or else (Ada_83 and then Comes_From_Source (N)) then
+ elsif Warn
+ or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
+ then
Msgl := Msgl + 1;
Msgc (Msgl) := '?';
Wmsg := True;
-- declared at the library level to ensure that names such as
-- X.all'access don't fail static accessibility checks.
- -- Ada 0Y (AI-230): In case of anonymous access types that are
+ -- Ada 2005 (AI-230): In case of anonymous access types that are
-- component_definition or discriminants of a nonlimited type,
-- the level is the same as that of the enclosing component type.
Btyp := Base_Type (Typ);
if Ekind (Btyp) in Access_Kind then
if Ekind (Btyp) = E_Anonymous_Access_Type
- and then not Is_Array_Type (Scope (Btyp)) -- Ada 0Y (AI-230)
- and then Ekind (Scope (Btyp)) /= E_Record_Type -- Ada 0Y (AI-230)
+ and then not Is_Array_Type (Scope (Btyp)) -- Ada 2005 (AI-230)
+ and then Ekind (Scope (Btyp)) /= E_Record_Type -- Ada 2005 (AI-230)
then
return Scope_Depth (Standard_Standard);
end if;
then
if Warn_On_Modified_Unread
and then not Is_Imported (E)
+
+ -- Suppress the message for aliased, renamed
+ -- and access variables since there may be
+ -- other entities that read the memory location.
+
+ and then not Is_Aliased (E)
+ and then No (Renamed_Object (E))
+ and then not (Is_Access_Type (Etype (E))
+ or else
+
+ -- Case of private access type, must examine the
+ -- full view due to visibility issues.
+
+ (Is_Private_Type (Etype (E))
+ and then
+ Is_Access_Type
+ (Full_View (Etype (E)))))
then
Error_Msg_N
("variable & is assigned but never read?", E);
-- directly in the tree as a subtype mark. The N_Subtype_Indication
-- node is used only if a constraint is present.
- -- Note: [For Ada 0Y (AI-231)]: Because Ada 0Y extends this rule with
- -- the null-exclusion part (see AI-231), we had to introduce a new
+ -- Note: [For Ada 2005 (AI-231)]: Because Ada 2005 extends this rule
+ -- with the null-exclusion part (see AI-231), we had to introduce a new
-- attribute in all the parents of subtype_indication nodes to indicate
-- if the null-exclusion is present.
-- with an appropriate message), it is possible for anonymous arrays
-- to appear as component definitions. The semantics and back end handle
-- this case properly, and the expander in fact generates such cases.
- -- Access_Definition is an optional field that gives support to Ada 0Y
- -- (AI-230). The parser generates nodes that have either the
+ -- Access_Definition is an optional field that gives support to
+ -- Ada 2005 (AI-230). The parser generates nodes that have either the
-- Subtype_Indication field or else the Access_Definition field.
-- N_Component_Definition
-- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
-- | ACCESS_TO_SUBPROGRAM_DEFINITION
- -- Note: access to subprograms are an Ada 0Y (AI-254) extension
+ -- Note: access to subprograms are an Ada 2005 (AI-254) extension
-- N_Access_Definition
-- Sloc points to ACCESS
-- list of selector names in the record aggregate case, or a list of
-- discrete choices in the array aggregate case or an N_Others_Choice
-- node (which appears as a singleton list). Box_Present gives support
- -- to Ada 0Y (AI-287).
+ -- to Ada 2005 (AI-287).
------------------------------------
-- 4.3.1 Commponent Choice List --
-- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
-- Note: Access_Definition is an optional field that gives support to
- -- Ada 0Y (AI-230). The parser generates nodes that have either the
+ -- Ada 2005 (AI-230). The parser generates nodes that have either the
-- Subtype_Indication field or else the Access_Definition field.
-- N_Object_Renaming_Declaration
-- No_Entities_Ref_In_Spec (Flag8-Sem)
-- Note: Limited_Present and Limited_View_Installed give support to
- -- Ada 0Y (AI-50217).
+ -- Ada 2005 (AI-50217).
-- Similarly, Private_Present gives support to AI-50262.
----------------------
"Oexpon#" &
"ada_83#" &
"ada_95#" &
+ "ada_05#" &
"c_pass_by_copy#" &
"compile_time_warning#" &
"component_alignment#" &
"linker#" &
"local_configuration_pragmas#" &
"locally_removed_files#" &
+ "metrics#" &
"naming#" &
"object_dir#" &
"pretty_printer#" &
Name_Ada_83 : constant Name_Id := N + 107; -- GNAT
Name_Ada_95 : constant Name_Id := N + 108; -- GNAT
- Name_C_Pass_By_Copy : constant Name_Id := N + 109; -- GNAT
- Name_Compile_Time_Warning : constant Name_Id := N + 110; -- GNAT
- Name_Component_Alignment : constant Name_Id := N + 111; -- GNAT
- Name_Convention_Identifier : constant Name_Id := N + 112; -- GNAT
- Name_Discard_Names : constant Name_Id := N + 113;
- Name_Elaboration_Checks : constant Name_Id := N + 114; -- GNAT
- Name_Eliminate : constant Name_Id := N + 115; -- GNAT
- Name_Explicit_Overriding : constant Name_Id := N + 116;
- Name_Extend_System : constant Name_Id := N + 117; -- GNAT
- Name_Extensions_Allowed : constant Name_Id := N + 118; -- GNAT
- Name_External_Name_Casing : constant Name_Id := N + 119; -- GNAT
- Name_Float_Representation : constant Name_Id := N + 120; -- GNAT
- Name_Initialize_Scalars : constant Name_Id := N + 121; -- GNAT
- Name_Interrupt_State : constant Name_Id := N + 122; -- GNAT
- Name_License : constant Name_Id := N + 123; -- GNAT
- Name_Locking_Policy : constant Name_Id := N + 124;
- Name_Long_Float : constant Name_Id := N + 125; -- VMS
- Name_No_Run_Time : constant Name_Id := N + 126; -- GNAT
- Name_No_Strict_Aliasing : constant Name_Id := N + 127; -- GNAT
- Name_Normalize_Scalars : constant Name_Id := N + 128;
- Name_Polling : constant Name_Id := N + 129; -- GNAT
- Name_Persistent_Data : constant Name_Id := N + 130; -- GNAT
- Name_Persistent_Object : constant Name_Id := N + 131; -- GNAT
- Name_Profile : constant Name_Id := N + 132; -- Ada0Y
- Name_Propagate_Exceptions : constant Name_Id := N + 133; -- GNAT
- Name_Queuing_Policy : constant Name_Id := N + 134;
- Name_Ravenscar : constant Name_Id := N + 135;
- Name_Restricted_Run_Time : constant Name_Id := N + 136;
- Name_Restrictions : constant Name_Id := N + 137;
- Name_Restriction_Warnings : constant Name_Id := N + 138; -- GNAT
- Name_Reviewable : constant Name_Id := N + 139;
- Name_Source_File_Name : constant Name_Id := N + 140; -- GNAT
- Name_Source_File_Name_Project : constant Name_Id := N + 141; -- GNAT
- Name_Style_Checks : constant Name_Id := N + 142; -- GNAT
- Name_Suppress : constant Name_Id := N + 143;
- Name_Suppress_Exception_Locations : constant Name_Id := N + 144; -- GNAT
- Name_Task_Dispatching_Policy : constant Name_Id := N + 145;
- Name_Universal_Data : constant Name_Id := N + 146; -- AAMP
- Name_Unsuppress : constant Name_Id := N + 147; -- GNAT
- Name_Use_VADS_Size : constant Name_Id := N + 148; -- GNAT
- Name_Validity_Checks : constant Name_Id := N + 149; -- GNAT
- Name_Warnings : constant Name_Id := N + 150; -- GNAT
- Last_Configuration_Pragma_Name : constant Name_Id := N + 150;
+ Name_Ada_05 : constant Name_Id := N + 109; -- GNAT
+ Name_C_Pass_By_Copy : constant Name_Id := N + 110; -- GNAT
+ Name_Compile_Time_Warning : constant Name_Id := N + 111; -- GNAT
+ Name_Component_Alignment : constant Name_Id := N + 112; -- GNAT
+ Name_Convention_Identifier : constant Name_Id := N + 113; -- GNAT
+ Name_Discard_Names : constant Name_Id := N + 114;
+ Name_Elaboration_Checks : constant Name_Id := N + 115; -- GNAT
+ Name_Eliminate : constant Name_Id := N + 116; -- GNAT
+ Name_Explicit_Overriding : constant Name_Id := N + 117;
+ Name_Extend_System : constant Name_Id := N + 118; -- GNAT
+ Name_Extensions_Allowed : constant Name_Id := N + 119; -- GNAT
+ Name_External_Name_Casing : constant Name_Id := N + 120; -- GNAT
+ Name_Float_Representation : constant Name_Id := N + 121; -- GNAT
+ Name_Initialize_Scalars : constant Name_Id := N + 122; -- GNAT
+ Name_Interrupt_State : constant Name_Id := N + 123; -- GNAT
+ Name_License : constant Name_Id := N + 124; -- GNAT
+ Name_Locking_Policy : constant Name_Id := N + 125;
+ Name_Long_Float : constant Name_Id := N + 126; -- VMS
+ Name_No_Run_Time : constant Name_Id := N + 127; -- GNAT
+ Name_No_Strict_Aliasing : constant Name_Id := N + 128; -- GNAT
+ Name_Normalize_Scalars : constant Name_Id := N + 129;
+ Name_Polling : constant Name_Id := N + 130; -- GNAT
+ Name_Persistent_Data : constant Name_Id := N + 131; -- GNAT
+ Name_Persistent_Object : constant Name_Id := N + 132; -- GNAT
+ Name_Profile : constant Name_Id := N + 133; -- Ada0Y
+ Name_Propagate_Exceptions : constant Name_Id := N + 134; -- GNAT
+ Name_Queuing_Policy : constant Name_Id := N + 135;
+ Name_Ravenscar : constant Name_Id := N + 136;
+ Name_Restricted_Run_Time : constant Name_Id := N + 137;
+ Name_Restrictions : constant Name_Id := N + 138;
+ Name_Restriction_Warnings : constant Name_Id := N + 139; -- GNAT
+ Name_Reviewable : constant Name_Id := N + 140;
+ Name_Source_File_Name : constant Name_Id := N + 141; -- GNAT
+ Name_Source_File_Name_Project : constant Name_Id := N + 142; -- GNAT
+ Name_Style_Checks : constant Name_Id := N + 143; -- GNAT
+ Name_Suppress : constant Name_Id := N + 144;
+ Name_Suppress_Exception_Locations : constant Name_Id := N + 145; -- GNAT
+ Name_Task_Dispatching_Policy : constant Name_Id := N + 146;
+ Name_Universal_Data : constant Name_Id := N + 147; -- AAMP
+ Name_Unsuppress : constant Name_Id := N + 148; -- GNAT
+ Name_Use_VADS_Size : constant Name_Id := N + 149; -- GNAT
+ Name_Validity_Checks : constant Name_Id := N + 150; -- GNAT
+ Name_Warnings : constant Name_Id := N + 151; -- GNAT
+ Last_Configuration_Pragma_Name : constant Name_Id := N + 151;
-- Remaining pragma names
- Name_Abort_Defer : constant Name_Id := N + 151; -- GNAT
- Name_All_Calls_Remote : constant Name_Id := N + 152;
- Name_Annotate : constant Name_Id := N + 153; -- GNAT
+ Name_Abort_Defer : constant Name_Id := N + 152; -- GNAT
+ Name_All_Calls_Remote : constant Name_Id := N + 153;
+ Name_Annotate : constant Name_Id := N + 154; -- GNAT
-- Note: AST_Entry is not in this list because its name matches the
-- name of the corresponding attribute. However, it is included in the
-- and Check_Pragma_Id correctly recognize and process Name_AST_Entry.
-- AST_Entry is a VMS specific pragma.
- Name_Assert : constant Name_Id := N + 154; -- GNAT
- Name_Asynchronous : constant Name_Id := N + 155;
- Name_Atomic : constant Name_Id := N + 156;
- Name_Atomic_Components : constant Name_Id := N + 157;
- Name_Attach_Handler : constant Name_Id := N + 158;
- Name_Comment : constant Name_Id := N + 159; -- GNAT
- Name_Common_Object : constant Name_Id := N + 160; -- GNAT
- Name_Complex_Representation : constant Name_Id := N + 161; -- GNAT
- Name_Controlled : constant Name_Id := N + 162;
- Name_Convention : constant Name_Id := N + 163;
- Name_CPP_Class : constant Name_Id := N + 164; -- GNAT
- Name_CPP_Constructor : constant Name_Id := N + 165; -- GNAT
- Name_CPP_Virtual : constant Name_Id := N + 166; -- GNAT
- Name_CPP_Vtable : constant Name_Id := N + 167; -- GNAT
- Name_Debug : constant Name_Id := N + 168; -- GNAT
- Name_Elaborate : constant Name_Id := N + 169; -- Ada 83
- Name_Elaborate_All : constant Name_Id := N + 170;
- Name_Elaborate_Body : constant Name_Id := N + 171;
- Name_Export : constant Name_Id := N + 172;
- Name_Export_Exception : constant Name_Id := N + 173; -- VMS
- Name_Export_Function : constant Name_Id := N + 174; -- GNAT
- Name_Export_Object : constant Name_Id := N + 175; -- GNAT
- Name_Export_Procedure : constant Name_Id := N + 176; -- GNAT
- Name_Export_Value : constant Name_Id := N + 177; -- GNAT
- Name_Export_Valued_Procedure : constant Name_Id := N + 178; -- GNAT
- Name_External : constant Name_Id := N + 179; -- GNAT
- Name_Finalize_Storage_Only : constant Name_Id := N + 180; -- GNAT
- Name_Ident : constant Name_Id := N + 181; -- VMS
- Name_Import : constant Name_Id := N + 182;
- Name_Import_Exception : constant Name_Id := N + 183; -- VMS
- Name_Import_Function : constant Name_Id := N + 184; -- GNAT
- Name_Import_Object : constant Name_Id := N + 185; -- GNAT
- Name_Import_Procedure : constant Name_Id := N + 186; -- GNAT
- Name_Import_Valued_Procedure : constant Name_Id := N + 187; -- GNAT
- Name_Inline : constant Name_Id := N + 188;
- Name_Inline_Always : constant Name_Id := N + 189; -- GNAT
- Name_Inline_Generic : constant Name_Id := N + 190; -- GNAT
- Name_Inspection_Point : constant Name_Id := N + 191;
- Name_Interface : constant Name_Id := N + 192; -- Ada 83
- Name_Interface_Name : constant Name_Id := N + 193; -- GNAT
- Name_Interrupt_Handler : constant Name_Id := N + 194;
- Name_Interrupt_Priority : constant Name_Id := N + 195;
- Name_Java_Constructor : constant Name_Id := N + 196; -- GNAT
- Name_Java_Interface : constant Name_Id := N + 197; -- GNAT
- Name_Keep_Names : constant Name_Id := N + 198; -- GNAT
- Name_Link_With : constant Name_Id := N + 199; -- GNAT
- Name_Linker_Alias : constant Name_Id := N + 200; -- GNAT
- Name_Linker_Options : constant Name_Id := N + 201;
- Name_Linker_Section : constant Name_Id := N + 202; -- GNAT
- Name_List : constant Name_Id := N + 203;
- Name_Machine_Attribute : constant Name_Id := N + 204; -- GNAT
- Name_Main : constant Name_Id := N + 205; -- GNAT
- Name_Main_Storage : constant Name_Id := N + 206; -- GNAT
- Name_Memory_Size : constant Name_Id := N + 207; -- Ada 83
- Name_No_Return : constant Name_Id := N + 208; -- GNAT
- Name_Obsolescent : constant Name_Id := N + 209; -- GNAT
- Name_Optimize : constant Name_Id := N + 210;
- Name_Optional_Overriding : constant Name_Id := N + 211;
- Name_Overriding : constant Name_Id := N + 212;
- Name_Pack : constant Name_Id := N + 213;
- Name_Page : constant Name_Id := N + 214;
- Name_Passive : constant Name_Id := N + 215; -- GNAT
- Name_Preelaborate : constant Name_Id := N + 216;
- Name_Priority : constant Name_Id := N + 217;
- Name_Psect_Object : constant Name_Id := N + 218; -- VMS
- Name_Pure : constant Name_Id := N + 219;
- Name_Pure_Function : constant Name_Id := N + 220; -- GNAT
- Name_Remote_Call_Interface : constant Name_Id := N + 221;
- Name_Remote_Types : constant Name_Id := N + 222;
- Name_Share_Generic : constant Name_Id := N + 223; -- GNAT
- Name_Shared : constant Name_Id := N + 224; -- Ada 83
- Name_Shared_Passive : constant Name_Id := N + 225;
+ Name_Assert : constant Name_Id := N + 155; -- GNAT
+ Name_Asynchronous : constant Name_Id := N + 156;
+ Name_Atomic : constant Name_Id := N + 157;
+ Name_Atomic_Components : constant Name_Id := N + 158;
+ Name_Attach_Handler : constant Name_Id := N + 159;
+ Name_Comment : constant Name_Id := N + 160; -- GNAT
+ Name_Common_Object : constant Name_Id := N + 161; -- GNAT
+ Name_Complex_Representation : constant Name_Id := N + 162; -- GNAT
+ Name_Controlled : constant Name_Id := N + 163;
+ Name_Convention : constant Name_Id := N + 164;
+ Name_CPP_Class : constant Name_Id := N + 165; -- GNAT
+ Name_CPP_Constructor : constant Name_Id := N + 166; -- GNAT
+ Name_CPP_Virtual : constant Name_Id := N + 167; -- GNAT
+ Name_CPP_Vtable : constant Name_Id := N + 168; -- GNAT
+ Name_Debug : constant Name_Id := N + 169; -- GNAT
+ Name_Elaborate : constant Name_Id := N + 170; -- Ada 83
+ Name_Elaborate_All : constant Name_Id := N + 171;
+ Name_Elaborate_Body : constant Name_Id := N + 172;
+ Name_Export : constant Name_Id := N + 173;
+ Name_Export_Exception : constant Name_Id := N + 174; -- VMS
+ Name_Export_Function : constant Name_Id := N + 175; -- GNAT
+ Name_Export_Object : constant Name_Id := N + 176; -- GNAT
+ Name_Export_Procedure : constant Name_Id := N + 177; -- GNAT
+ Name_Export_Value : constant Name_Id := N + 178; -- GNAT
+ Name_Export_Valued_Procedure : constant Name_Id := N + 179; -- GNAT
+ Name_External : constant Name_Id := N + 180; -- GNAT
+ Name_Finalize_Storage_Only : constant Name_Id := N + 181; -- GNAT
+ Name_Ident : constant Name_Id := N + 182; -- VMS
+ Name_Import : constant Name_Id := N + 183;
+ Name_Import_Exception : constant Name_Id := N + 184; -- VMS
+ Name_Import_Function : constant Name_Id := N + 185; -- GNAT
+ Name_Import_Object : constant Name_Id := N + 186; -- GNAT
+ Name_Import_Procedure : constant Name_Id := N + 187; -- GNAT
+ Name_Import_Valued_Procedure : constant Name_Id := N + 188; -- GNAT
+ Name_Inline : constant Name_Id := N + 189;
+ Name_Inline_Always : constant Name_Id := N + 190; -- GNAT
+ Name_Inline_Generic : constant Name_Id := N + 191; -- GNAT
+ Name_Inspection_Point : constant Name_Id := N + 192;
+ Name_Interface : constant Name_Id := N + 193; -- Ada 83
+ Name_Interface_Name : constant Name_Id := N + 194; -- GNAT
+ Name_Interrupt_Handler : constant Name_Id := N + 195;
+ Name_Interrupt_Priority : constant Name_Id := N + 196;
+ Name_Java_Constructor : constant Name_Id := N + 197; -- GNAT
+ Name_Java_Interface : constant Name_Id := N + 198; -- GNAT
+ Name_Keep_Names : constant Name_Id := N + 199; -- GNAT
+ Name_Link_With : constant Name_Id := N + 200; -- GNAT
+ Name_Linker_Alias : constant Name_Id := N + 201; -- GNAT
+ Name_Linker_Options : constant Name_Id := N + 202;
+ Name_Linker_Section : constant Name_Id := N + 203; -- GNAT
+ Name_List : constant Name_Id := N + 204;
+ Name_Machine_Attribute : constant Name_Id := N + 205; -- GNAT
+ Name_Main : constant Name_Id := N + 206; -- GNAT
+ Name_Main_Storage : constant Name_Id := N + 207; -- GNAT
+ Name_Memory_Size : constant Name_Id := N + 208; -- Ada 83
+ Name_No_Return : constant Name_Id := N + 209; -- GNAT
+ Name_Obsolescent : constant Name_Id := N + 210; -- GNAT
+ Name_Optimize : constant Name_Id := N + 211;
+ Name_Optional_Overriding : constant Name_Id := N + 212;
+ Name_Overriding : constant Name_Id := N + 213;
+ Name_Pack : constant Name_Id := N + 214;
+ Name_Page : constant Name_Id := N + 215;
+ Name_Passive : constant Name_Id := N + 216; -- GNAT
+ Name_Preelaborate : constant Name_Id := N + 217;
+ Name_Priority : constant Name_Id := N + 218;
+ Name_Psect_Object : constant Name_Id := N + 219; -- VMS
+ Name_Pure : constant Name_Id := N + 220;
+ Name_Pure_Function : constant Name_Id := N + 221; -- GNAT
+ Name_Remote_Call_Interface : constant Name_Id := N + 222;
+ Name_Remote_Types : constant Name_Id := N + 223;
+ Name_Share_Generic : constant Name_Id := N + 224; -- GNAT
+ Name_Shared : constant Name_Id := N + 225; -- Ada 83
+ Name_Shared_Passive : constant Name_Id := N + 226;
-- Note: Storage_Size is not in this list because its name matches the
-- name of the corresponding attribute. However, it is included in the
-- Note: Storage_Unit is also omitted from the list because of a clash
-- with an attribute name, and is treated similarly.
- Name_Source_Reference : constant Name_Id := N + 226; -- GNAT
- Name_Stream_Convert : constant Name_Id := N + 227; -- GNAT
- Name_Subtitle : constant Name_Id := N + 228; -- GNAT
- Name_Suppress_All : constant Name_Id := N + 229; -- GNAT
- Name_Suppress_Debug_Info : constant Name_Id := N + 230; -- GNAT
- Name_Suppress_Initialization : constant Name_Id := N + 231; -- GNAT
- Name_System_Name : constant Name_Id := N + 232; -- Ada 83
- Name_Task_Info : constant Name_Id := N + 233; -- GNAT
- Name_Task_Name : constant Name_Id := N + 234; -- GNAT
- Name_Task_Storage : constant Name_Id := N + 235; -- VMS
- Name_Thread_Body : constant Name_Id := N + 236; -- GNAT
- Name_Time_Slice : constant Name_Id := N + 237; -- GNAT
- Name_Title : constant Name_Id := N + 238; -- GNAT
- Name_Unchecked_Union : constant Name_Id := N + 239; -- GNAT
- Name_Unimplemented_Unit : constant Name_Id := N + 240; -- GNAT
- Name_Unreferenced : constant Name_Id := N + 241; -- GNAT
- Name_Unreserve_All_Interrupts : constant Name_Id := N + 242; -- GNAT
- Name_Volatile : constant Name_Id := N + 243;
- Name_Volatile_Components : constant Name_Id := N + 244;
- Name_Weak_External : constant Name_Id := N + 245; -- GNAT
- Last_Pragma_Name : constant Name_Id := N + 245;
+ Name_Source_Reference : constant Name_Id := N + 227; -- GNAT
+ Name_Stream_Convert : constant Name_Id := N + 228; -- GNAT
+ Name_Subtitle : constant Name_Id := N + 229; -- GNAT
+ Name_Suppress_All : constant Name_Id := N + 230; -- GNAT
+ Name_Suppress_Debug_Info : constant Name_Id := N + 231; -- GNAT
+ Name_Suppress_Initialization : constant Name_Id := N + 232; -- GNAT
+ Name_System_Name : constant Name_Id := N + 233; -- Ada 83
+ Name_Task_Info : constant Name_Id := N + 234; -- GNAT
+ Name_Task_Name : constant Name_Id := N + 235; -- GNAT
+ Name_Task_Storage : constant Name_Id := N + 236; -- VMS
+ Name_Thread_Body : constant Name_Id := N + 237; -- GNAT
+ Name_Time_Slice : constant Name_Id := N + 238; -- GNAT
+ Name_Title : constant Name_Id := N + 239; -- GNAT
+ Name_Unchecked_Union : constant Name_Id := N + 240; -- GNAT
+ Name_Unimplemented_Unit : constant Name_Id := N + 241; -- GNAT
+ Name_Unreferenced : constant Name_Id := N + 242; -- GNAT
+ Name_Unreserve_All_Interrupts : constant Name_Id := N + 243; -- GNAT
+ Name_Volatile : constant Name_Id := N + 244;
+ Name_Volatile_Components : constant Name_Id := N + 245;
+ Name_Weak_External : constant Name_Id := N + 246; -- GNAT
+ Last_Pragma_Name : constant Name_Id := N + 246;
-- Language convention names for pragma Convention/Export/Import/Interface
-- Note that Name_C is not included in this list, since it was already
-- Entry and Protected, this is because these conventions cannot be
-- specified by a pragma.
- First_Convention_Name : constant Name_Id := N + 246;
- Name_Ada : constant Name_Id := N + 246;
- Name_Assembler : constant Name_Id := N + 247;
- Name_COBOL : constant Name_Id := N + 248;
- Name_CPP : constant Name_Id := N + 249;
- Name_Fortran : constant Name_Id := N + 250;
- Name_Intrinsic : constant Name_Id := N + 251;
- Name_Java : constant Name_Id := N + 252;
- Name_Stdcall : constant Name_Id := N + 253;
- Name_Stubbed : constant Name_Id := N + 254;
- Last_Convention_Name : constant Name_Id := N + 254;
+ First_Convention_Name : constant Name_Id := N + 247;
+ Name_Ada : constant Name_Id := N + 247;
+ Name_Assembler : constant Name_Id := N + 248;
+ Name_COBOL : constant Name_Id := N + 249;
+ Name_CPP : constant Name_Id := N + 250;
+ Name_Fortran : constant Name_Id := N + 251;
+ Name_Intrinsic : constant Name_Id := N + 252;
+ Name_Java : constant Name_Id := N + 253;
+ Name_Stdcall : constant Name_Id := N + 254;
+ Name_Stubbed : constant Name_Id := N + 255;
+ Last_Convention_Name : constant Name_Id := N + 255;
-- The following names are preset as synonyms for Assembler
- Name_Asm : constant Name_Id := N + 255;
- Name_Assembly : constant Name_Id := N + 256;
+ Name_Asm : constant Name_Id := N + 256;
+ Name_Assembly : constant Name_Id := N + 257;
-- The following names are preset as synonyms for C
- Name_Default : constant Name_Id := N + 257;
+ Name_Default : constant Name_Id := N + 258;
-- Name_Exernal (previously defined as pragma)
-- The following names are present as synonyms for Stdcall
- Name_DLL : constant Name_Id := N + 258;
- Name_Win32 : constant Name_Id := N + 259;
+ Name_DLL : constant Name_Id := N + 259;
+ Name_Win32 : constant Name_Id := N + 260;
-- Other special names used in processing pragmas
- Name_As_Is : constant Name_Id := N + 260;
- Name_Body_File_Name : constant Name_Id := N + 261;
- Name_Boolean_Entry_Barriers : constant Name_Id := N + 262;
- Name_Casing : constant Name_Id := N + 263;
- Name_Code : constant Name_Id := N + 264;
- Name_Component : constant Name_Id := N + 265;
- Name_Component_Size_4 : constant Name_Id := N + 266;
- Name_Copy : constant Name_Id := N + 267;
- Name_D_Float : constant Name_Id := N + 268;
- Name_Descriptor : constant Name_Id := N + 269;
- Name_Dot_Replacement : constant Name_Id := N + 270;
- Name_Dynamic : constant Name_Id := N + 271;
- Name_Entity : constant Name_Id := N + 272;
- Name_External_Name : constant Name_Id := N + 273;
- Name_First_Optional_Parameter : constant Name_Id := N + 274;
- Name_Form : constant Name_Id := N + 275;
- Name_G_Float : constant Name_Id := N + 276;
- Name_Gcc : constant Name_Id := N + 277;
- Name_Gnat : constant Name_Id := N + 278;
- Name_GPL : constant Name_Id := N + 279;
- Name_IEEE_Float : constant Name_Id := N + 280;
- Name_Internal : constant Name_Id := N + 281;
- Name_Link_Name : constant Name_Id := N + 282;
- Name_Lowercase : constant Name_Id := N + 283;
- Name_Max_Entry_Queue_Depth : constant Name_Id := N + 284;
- Name_Max_Entry_Queue_Length : constant Name_Id := N + 285;
- Name_Max_Size : constant Name_Id := N + 286;
- Name_Mechanism : constant Name_Id := N + 287;
- Name_Mixedcase : constant Name_Id := N + 288;
- Name_Modified_GPL : constant Name_Id := N + 289;
- Name_Name : constant Name_Id := N + 290;
- Name_NCA : constant Name_Id := N + 291;
- Name_No : constant Name_Id := N + 292;
- Name_On : constant Name_Id := N + 293;
- Name_Parameter_Types : constant Name_Id := N + 294;
- Name_Reference : constant Name_Id := N + 295;
- Name_No_Dynamic_Attachment : constant Name_Id := N + 296;
- Name_No_Dynamic_Interrupts : constant Name_Id := N + 297;
- Name_No_Requeue : constant Name_Id := N + 298;
- Name_No_Requeue_Statements : constant Name_Id := N + 299;
- Name_No_Task_Attributes : constant Name_Id := N + 300;
- Name_No_Task_Attributes_Package : constant Name_Id := N + 301;
- Name_Restricted : constant Name_Id := N + 302;
- Name_Result_Mechanism : constant Name_Id := N + 303;
- Name_Result_Type : constant Name_Id := N + 304;
- Name_Runtime : constant Name_Id := N + 305;
- Name_SB : constant Name_Id := N + 306;
- Name_Secondary_Stack_Size : constant Name_Id := N + 307;
- Name_Section : constant Name_Id := N + 308;
- Name_Semaphore : constant Name_Id := N + 309;
- Name_Simple_Barriers : constant Name_Id := N + 310;
- Name_Spec_File_Name : constant Name_Id := N + 311;
- Name_Static : constant Name_Id := N + 312;
- Name_Stack_Size : constant Name_Id := N + 313;
- Name_Subunit_File_Name : constant Name_Id := N + 314;
- Name_Task_Stack_Size_Default : constant Name_Id := N + 315;
- Name_Task_Type : constant Name_Id := N + 316;
- Name_Time_Slicing_Enabled : constant Name_Id := N + 317;
- Name_Top_Guard : constant Name_Id := N + 318;
- Name_UBA : constant Name_Id := N + 319;
- Name_UBS : constant Name_Id := N + 320;
- Name_UBSB : constant Name_Id := N + 321;
- Name_Unit_Name : constant Name_Id := N + 322;
- Name_Unknown : constant Name_Id := N + 323;
- Name_Unrestricted : constant Name_Id := N + 324;
- Name_Uppercase : constant Name_Id := N + 325;
- Name_User : constant Name_Id := N + 326;
- Name_VAX_Float : constant Name_Id := N + 327;
- Name_VMS : constant Name_Id := N + 328;
- Name_Working_Storage : constant Name_Id := N + 329;
+ Name_As_Is : constant Name_Id := N + 261;
+ Name_Body_File_Name : constant Name_Id := N + 262;
+ Name_Boolean_Entry_Barriers : constant Name_Id := N + 263;
+ Name_Casing : constant Name_Id := N + 264;
+ Name_Code : constant Name_Id := N + 265;
+ Name_Component : constant Name_Id := N + 266;
+ Name_Component_Size_4 : constant Name_Id := N + 267;
+ Name_Copy : constant Name_Id := N + 268;
+ Name_D_Float : constant Name_Id := N + 269;
+ Name_Descriptor : constant Name_Id := N + 270;
+ Name_Dot_Replacement : constant Name_Id := N + 271;
+ Name_Dynamic : constant Name_Id := N + 272;
+ Name_Entity : constant Name_Id := N + 273;
+ Name_External_Name : constant Name_Id := N + 274;
+ Name_First_Optional_Parameter : constant Name_Id := N + 275;
+ Name_Form : constant Name_Id := N + 276;
+ Name_G_Float : constant Name_Id := N + 277;
+ Name_Gcc : constant Name_Id := N + 278;
+ Name_Gnat : constant Name_Id := N + 279;
+ Name_GPL : constant Name_Id := N + 280;
+ Name_IEEE_Float : constant Name_Id := N + 281;
+ Name_Internal : constant Name_Id := N + 282;
+ Name_Link_Name : constant Name_Id := N + 283;
+ Name_Lowercase : constant Name_Id := N + 284;
+ Name_Max_Entry_Queue_Depth : constant Name_Id := N + 285;
+ Name_Max_Entry_Queue_Length : constant Name_Id := N + 286;
+ Name_Max_Size : constant Name_Id := N + 287;
+ Name_Mechanism : constant Name_Id := N + 288;
+ Name_Mixedcase : constant Name_Id := N + 289;
+ Name_Modified_GPL : constant Name_Id := N + 290;
+ Name_Name : constant Name_Id := N + 291;
+ Name_NCA : constant Name_Id := N + 292;
+ Name_No : constant Name_Id := N + 293;
+ Name_On : constant Name_Id := N + 294;
+ Name_Parameter_Types : constant Name_Id := N + 295;
+ Name_Reference : constant Name_Id := N + 296;
+ Name_No_Dynamic_Attachment : constant Name_Id := N + 297;
+ Name_No_Dynamic_Interrupts : constant Name_Id := N + 298;
+ Name_No_Requeue : constant Name_Id := N + 299;
+ Name_No_Requeue_Statements : constant Name_Id := N + 300;
+ Name_No_Task_Attributes : constant Name_Id := N + 301;
+ Name_No_Task_Attributes_Package : constant Name_Id := N + 302;
+ Name_Restricted : constant Name_Id := N + 303;
+ Name_Result_Mechanism : constant Name_Id := N + 304;
+ Name_Result_Type : constant Name_Id := N + 305;
+ Name_Runtime : constant Name_Id := N + 306;
+ Name_SB : constant Name_Id := N + 307;
+ Name_Secondary_Stack_Size : constant Name_Id := N + 308;
+ Name_Section : constant Name_Id := N + 309;
+ Name_Semaphore : constant Name_Id := N + 310;
+ Name_Simple_Barriers : constant Name_Id := N + 311;
+ Name_Spec_File_Name : constant Name_Id := N + 312;
+ Name_Static : constant Name_Id := N + 313;
+ Name_Stack_Size : constant Name_Id := N + 314;
+ Name_Subunit_File_Name : constant Name_Id := N + 315;
+ Name_Task_Stack_Size_Default : constant Name_Id := N + 316;
+ Name_Task_Type : constant Name_Id := N + 317;
+ Name_Time_Slicing_Enabled : constant Name_Id := N + 318;
+ Name_Top_Guard : constant Name_Id := N + 319;
+ Name_UBA : constant Name_Id := N + 320;
+ Name_UBS : constant Name_Id := N + 321;
+ Name_UBSB : constant Name_Id := N + 322;
+ Name_Unit_Name : constant Name_Id := N + 323;
+ Name_Unknown : constant Name_Id := N + 324;
+ Name_Unrestricted : constant Name_Id := N + 325;
+ Name_Uppercase : constant Name_Id := N + 326;
+ Name_User : constant Name_Id := N + 327;
+ Name_VAX_Float : constant Name_Id := N + 328;
+ Name_VMS : constant Name_Id := N + 329;
+ Name_Working_Storage : constant Name_Id := N + 330;
-- Names of recognized attributes. The entries with the comment "Ada 83"
-- are attributes that are defined in Ada 83, but not in Ada 95. These
-- The entries marked VMS are recognized only in OpenVMS implementations
-- of GNAT, and are treated as illegal in all other contexts.
- First_Attribute_Name : constant Name_Id := N + 330;
- Name_Abort_Signal : constant Name_Id := N + 330; -- GNAT
- Name_Access : constant Name_Id := N + 331;
- Name_Address : constant Name_Id := N + 332;
- Name_Address_Size : constant Name_Id := N + 333; -- GNAT
- Name_Aft : constant Name_Id := N + 334;
- Name_Alignment : constant Name_Id := N + 335;
- Name_Asm_Input : constant Name_Id := N + 336; -- GNAT
- Name_Asm_Output : constant Name_Id := N + 337; -- GNAT
- Name_AST_Entry : constant Name_Id := N + 338; -- VMS
- Name_Bit : constant Name_Id := N + 339; -- GNAT
- Name_Bit_Order : constant Name_Id := N + 340;
- Name_Bit_Position : constant Name_Id := N + 341; -- GNAT
- Name_Body_Version : constant Name_Id := N + 342;
- Name_Callable : constant Name_Id := N + 343;
- Name_Caller : constant Name_Id := N + 344;
- Name_Code_Address : constant Name_Id := N + 345; -- GNAT
- Name_Component_Size : constant Name_Id := N + 346;
- Name_Compose : constant Name_Id := N + 347;
- Name_Constrained : constant Name_Id := N + 348;
- Name_Count : constant Name_Id := N + 349;
- Name_Default_Bit_Order : constant Name_Id := N + 350; -- GNAT
- Name_Definite : constant Name_Id := N + 351;
- Name_Delta : constant Name_Id := N + 352;
- Name_Denorm : constant Name_Id := N + 353;
- Name_Digits : constant Name_Id := N + 354;
- Name_Elaborated : constant Name_Id := N + 355; -- GNAT
- Name_Emax : constant Name_Id := N + 356; -- Ada 83
- Name_Enum_Rep : constant Name_Id := N + 357; -- GNAT
- Name_Epsilon : constant Name_Id := N + 358; -- Ada 83
- Name_Exponent : constant Name_Id := N + 359;
- Name_External_Tag : constant Name_Id := N + 360;
- Name_First : constant Name_Id := N + 361;
- Name_First_Bit : constant Name_Id := N + 362;
- Name_Fixed_Value : constant Name_Id := N + 363; -- GNAT
- Name_Fore : constant Name_Id := N + 364;
- Name_Has_Discriminants : constant Name_Id := N + 365; -- GNAT
- Name_Identity : constant Name_Id := N + 366;
- Name_Img : constant Name_Id := N + 367; -- GNAT
- Name_Integer_Value : constant Name_Id := N + 368; -- GNAT
- Name_Large : constant Name_Id := N + 369; -- Ada 83
- Name_Last : constant Name_Id := N + 370;
- Name_Last_Bit : constant Name_Id := N + 371;
- Name_Leading_Part : constant Name_Id := N + 372;
- Name_Length : constant Name_Id := N + 373;
- Name_Machine_Emax : constant Name_Id := N + 374;
- Name_Machine_Emin : constant Name_Id := N + 375;
- Name_Machine_Mantissa : constant Name_Id := N + 376;
- Name_Machine_Overflows : constant Name_Id := N + 377;
- Name_Machine_Radix : constant Name_Id := N + 378;
- Name_Machine_Rounds : constant Name_Id := N + 379;
- Name_Machine_Size : constant Name_Id := N + 380; -- GNAT
- Name_Mantissa : constant Name_Id := N + 381; -- Ada 83
- Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 382;
- Name_Maximum_Alignment : constant Name_Id := N + 383; -- GNAT
- Name_Mechanism_Code : constant Name_Id := N + 384; -- GNAT
- Name_Model_Emin : constant Name_Id := N + 385;
- Name_Model_Epsilon : constant Name_Id := N + 386;
- Name_Model_Mantissa : constant Name_Id := N + 387;
- Name_Model_Small : constant Name_Id := N + 388;
- Name_Modulus : constant Name_Id := N + 389;
- Name_Null_Parameter : constant Name_Id := N + 390; -- GNAT
- Name_Object_Size : constant Name_Id := N + 391; -- GNAT
- Name_Partition_ID : constant Name_Id := N + 392;
- Name_Passed_By_Reference : constant Name_Id := N + 393; -- GNAT
- Name_Pool_Address : constant Name_Id := N + 394;
- Name_Pos : constant Name_Id := N + 395;
- Name_Position : constant Name_Id := N + 396;
- Name_Range : constant Name_Id := N + 397;
- Name_Range_Length : constant Name_Id := N + 398; -- GNAT
- Name_Round : constant Name_Id := N + 399;
- Name_Safe_Emax : constant Name_Id := N + 400; -- Ada 83
- Name_Safe_First : constant Name_Id := N + 401;
- Name_Safe_Large : constant Name_Id := N + 402; -- Ada 83
- Name_Safe_Last : constant Name_Id := N + 403;
- Name_Safe_Small : constant Name_Id := N + 404; -- Ada 83
- Name_Scale : constant Name_Id := N + 405;
- Name_Scaling : constant Name_Id := N + 406;
- Name_Signed_Zeros : constant Name_Id := N + 407;
- Name_Size : constant Name_Id := N + 408;
- Name_Small : constant Name_Id := N + 409;
- Name_Storage_Size : constant Name_Id := N + 410;
- Name_Storage_Unit : constant Name_Id := N + 411; -- GNAT
- Name_Tag : constant Name_Id := N + 412;
- Name_Target_Name : constant Name_Id := N + 413; -- GNAT
- Name_Terminated : constant Name_Id := N + 414;
- Name_To_Address : constant Name_Id := N + 415; -- GNAT
- Name_Type_Class : constant Name_Id := N + 416; -- GNAT
- Name_UET_Address : constant Name_Id := N + 417; -- GNAT
- Name_Unbiased_Rounding : constant Name_Id := N + 418;
- Name_Unchecked_Access : constant Name_Id := N + 419;
- Name_Unconstrained_Array : constant Name_Id := N + 420;
- Name_Universal_Literal_String : constant Name_Id := N + 421; -- GNAT
- Name_Unrestricted_Access : constant Name_Id := N + 422; -- GNAT
- Name_VADS_Size : constant Name_Id := N + 423; -- GNAT
- Name_Val : constant Name_Id := N + 424;
- Name_Valid : constant Name_Id := N + 425;
- Name_Value_Size : constant Name_Id := N + 426; -- GNAT
- Name_Version : constant Name_Id := N + 427;
- Name_Wchar_T_Size : constant Name_Id := N + 428; -- GNAT
- Name_Wide_Width : constant Name_Id := N + 429;
- Name_Width : constant Name_Id := N + 430;
- Name_Word_Size : constant Name_Id := N + 431; -- GNAT
+ First_Attribute_Name : constant Name_Id := N + 331;
+ Name_Abort_Signal : constant Name_Id := N + 331; -- GNAT
+ Name_Access : constant Name_Id := N + 332;
+ Name_Address : constant Name_Id := N + 333;
+ Name_Address_Size : constant Name_Id := N + 334; -- GNAT
+ Name_Aft : constant Name_Id := N + 335;
+ Name_Alignment : constant Name_Id := N + 336;
+ Name_Asm_Input : constant Name_Id := N + 337; -- GNAT
+ Name_Asm_Output : constant Name_Id := N + 338; -- GNAT
+ Name_AST_Entry : constant Name_Id := N + 339; -- VMS
+ Name_Bit : constant Name_Id := N + 340; -- GNAT
+ Name_Bit_Order : constant Name_Id := N + 341;
+ Name_Bit_Position : constant Name_Id := N + 342; -- GNAT
+ Name_Body_Version : constant Name_Id := N + 343;
+ Name_Callable : constant Name_Id := N + 344;
+ Name_Caller : constant Name_Id := N + 345;
+ Name_Code_Address : constant Name_Id := N + 346; -- GNAT
+ Name_Component_Size : constant Name_Id := N + 347;
+ Name_Compose : constant Name_Id := N + 348;
+ Name_Constrained : constant Name_Id := N + 349;
+ Name_Count : constant Name_Id := N + 350;
+ Name_Default_Bit_Order : constant Name_Id := N + 351; -- GNAT
+ Name_Definite : constant Name_Id := N + 352;
+ Name_Delta : constant Name_Id := N + 353;
+ Name_Denorm : constant Name_Id := N + 354;
+ Name_Digits : constant Name_Id := N + 355;
+ Name_Elaborated : constant Name_Id := N + 356; -- GNAT
+ Name_Emax : constant Name_Id := N + 357; -- Ada 83
+ Name_Enum_Rep : constant Name_Id := N + 358; -- GNAT
+ Name_Epsilon : constant Name_Id := N + 359; -- Ada 83
+ Name_Exponent : constant Name_Id := N + 360;
+ Name_External_Tag : constant Name_Id := N + 361;
+ Name_First : constant Name_Id := N + 362;
+ Name_First_Bit : constant Name_Id := N + 363;
+ Name_Fixed_Value : constant Name_Id := N + 364; -- GNAT
+ Name_Fore : constant Name_Id := N + 365;
+ Name_Has_Discriminants : constant Name_Id := N + 366; -- GNAT
+ Name_Identity : constant Name_Id := N + 367;
+ Name_Img : constant Name_Id := N + 368; -- GNAT
+ Name_Integer_Value : constant Name_Id := N + 369; -- GNAT
+ Name_Large : constant Name_Id := N + 370; -- Ada 83
+ Name_Last : constant Name_Id := N + 371;
+ Name_Last_Bit : constant Name_Id := N + 372;
+ Name_Leading_Part : constant Name_Id := N + 373;
+ Name_Length : constant Name_Id := N + 374;
+ Name_Machine_Emax : constant Name_Id := N + 375;
+ Name_Machine_Emin : constant Name_Id := N + 376;
+ Name_Machine_Mantissa : constant Name_Id := N + 377;
+ Name_Machine_Overflows : constant Name_Id := N + 378;
+ Name_Machine_Radix : constant Name_Id := N + 379;
+ Name_Machine_Rounds : constant Name_Id := N + 380;
+ Name_Machine_Size : constant Name_Id := N + 381; -- GNAT
+ Name_Mantissa : constant Name_Id := N + 382; -- Ada 83
+ Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 383;
+ Name_Maximum_Alignment : constant Name_Id := N + 384; -- GNAT
+ Name_Mechanism_Code : constant Name_Id := N + 385; -- GNAT
+ Name_Model_Emin : constant Name_Id := N + 386;
+ Name_Model_Epsilon : constant Name_Id := N + 387;
+ Name_Model_Mantissa : constant Name_Id := N + 388;
+ Name_Model_Small : constant Name_Id := N + 389;
+ Name_Modulus : constant Name_Id := N + 390;
+ Name_Null_Parameter : constant Name_Id := N + 391; -- GNAT
+ Name_Object_Size : constant Name_Id := N + 392; -- GNAT
+ Name_Partition_ID : constant Name_Id := N + 393;
+ Name_Passed_By_Reference : constant Name_Id := N + 394; -- GNAT
+ Name_Pool_Address : constant Name_Id := N + 395;
+ Name_Pos : constant Name_Id := N + 396;
+ Name_Position : constant Name_Id := N + 397;
+ Name_Range : constant Name_Id := N + 398;
+ Name_Range_Length : constant Name_Id := N + 399; -- GNAT
+ Name_Round : constant Name_Id := N + 400;
+ Name_Safe_Emax : constant Name_Id := N + 401; -- Ada 83
+ Name_Safe_First : constant Name_Id := N + 402;
+ Name_Safe_Large : constant Name_Id := N + 403; -- Ada 83
+ Name_Safe_Last : constant Name_Id := N + 404;
+ Name_Safe_Small : constant Name_Id := N + 405; -- Ada 83
+ Name_Scale : constant Name_Id := N + 406;
+ Name_Scaling : constant Name_Id := N + 407;
+ Name_Signed_Zeros : constant Name_Id := N + 408;
+ Name_Size : constant Name_Id := N + 409;
+ Name_Small : constant Name_Id := N + 410;
+ Name_Storage_Size : constant Name_Id := N + 411;
+ Name_Storage_Unit : constant Name_Id := N + 412; -- GNAT
+ Name_Tag : constant Name_Id := N + 413;
+ Name_Target_Name : constant Name_Id := N + 414; -- GNAT
+ Name_Terminated : constant Name_Id := N + 415;
+ Name_To_Address : constant Name_Id := N + 416; -- GNAT
+ Name_Type_Class : constant Name_Id := N + 417; -- GNAT
+ Name_UET_Address : constant Name_Id := N + 418; -- GNAT
+ Name_Unbiased_Rounding : constant Name_Id := N + 419;
+ Name_Unchecked_Access : constant Name_Id := N + 420;
+ Name_Unconstrained_Array : constant Name_Id := N + 421;
+ Name_Universal_Literal_String : constant Name_Id := N + 422; -- GNAT
+ Name_Unrestricted_Access : constant Name_Id := N + 423; -- GNAT
+ Name_VADS_Size : constant Name_Id := N + 424; -- GNAT
+ Name_Val : constant Name_Id := N + 425;
+ Name_Valid : constant Name_Id := N + 426;
+ Name_Value_Size : constant Name_Id := N + 427; -- GNAT
+ Name_Version : constant Name_Id := N + 428;
+ Name_Wchar_T_Size : constant Name_Id := N + 429; -- GNAT
+ Name_Wide_Width : constant Name_Id := N + 430;
+ Name_Width : constant Name_Id := N + 431;
+ Name_Word_Size : constant Name_Id := N + 432; -- GNAT
-- Attributes that designate attributes returning renamable functions,
-- i.e. functions that return other than a universal value.
- First_Renamable_Function_Attribute : constant Name_Id := N + 432;
- Name_Adjacent : constant Name_Id := N + 432;
- Name_Ceiling : constant Name_Id := N + 433;
- Name_Copy_Sign : constant Name_Id := N + 434;
- Name_Floor : constant Name_Id := N + 435;
- Name_Fraction : constant Name_Id := N + 436;
- Name_Image : constant Name_Id := N + 437;
- Name_Input : constant Name_Id := N + 438;
- Name_Machine : constant Name_Id := N + 439;
- Name_Max : constant Name_Id := N + 440;
- Name_Min : constant Name_Id := N + 441;
- Name_Model : constant Name_Id := N + 442;
- Name_Pred : constant Name_Id := N + 443;
- Name_Remainder : constant Name_Id := N + 444;
- Name_Rounding : constant Name_Id := N + 445;
- Name_Succ : constant Name_Id := N + 446;
- Name_Truncation : constant Name_Id := N + 447;
- Name_Value : constant Name_Id := N + 448;
- Name_Wide_Image : constant Name_Id := N + 449;
- Name_Wide_Value : constant Name_Id := N + 450;
- Last_Renamable_Function_Attribute : constant Name_Id := N + 450;
+ First_Renamable_Function_Attribute : constant Name_Id := N + 433;
+ Name_Adjacent : constant Name_Id := N + 433;
+ Name_Ceiling : constant Name_Id := N + 434;
+ Name_Copy_Sign : constant Name_Id := N + 435;
+ Name_Floor : constant Name_Id := N + 436;
+ Name_Fraction : constant Name_Id := N + 437;
+ Name_Image : constant Name_Id := N + 438;
+ Name_Input : constant Name_Id := N + 439;
+ Name_Machine : constant Name_Id := N + 440;
+ Name_Max : constant Name_Id := N + 441;
+ Name_Min : constant Name_Id := N + 442;
+ Name_Model : constant Name_Id := N + 443;
+ Name_Pred : constant Name_Id := N + 444;
+ Name_Remainder : constant Name_Id := N + 445;
+ Name_Rounding : constant Name_Id := N + 446;
+ Name_Succ : constant Name_Id := N + 447;
+ Name_Truncation : constant Name_Id := N + 448;
+ Name_Value : constant Name_Id := N + 449;
+ Name_Wide_Image : constant Name_Id := N + 450;
+ Name_Wide_Value : constant Name_Id := N + 451;
+ Last_Renamable_Function_Attribute : constant Name_Id := N + 451;
-- Attributes that designate procedures
- First_Procedure_Attribute : constant Name_Id := N + 451;
- Name_Output : constant Name_Id := N + 451;
- Name_Read : constant Name_Id := N + 452;
- Name_Write : constant Name_Id := N + 453;
- Last_Procedure_Attribute : constant Name_Id := N + 453;
+ First_Procedure_Attribute : constant Name_Id := N + 452;
+ Name_Output : constant Name_Id := N + 452;
+ Name_Read : constant Name_Id := N + 453;
+ Name_Write : constant Name_Id := N + 454;
+ Last_Procedure_Attribute : constant Name_Id := N + 454;
-- Remaining attributes are ones that return entities
- First_Entity_Attribute_Name : constant Name_Id := N + 454;
- Name_Elab_Body : constant Name_Id := N + 454; -- GNAT
- Name_Elab_Spec : constant Name_Id := N + 455; -- GNAT
- Name_Storage_Pool : constant Name_Id := N + 456;
+ First_Entity_Attribute_Name : constant Name_Id := N + 455;
+ Name_Elab_Body : constant Name_Id := N + 455; -- GNAT
+ Name_Elab_Spec : constant Name_Id := N + 456; -- GNAT
+ Name_Storage_Pool : constant Name_Id := N + 457;
-- These attributes are the ones that return types
- First_Type_Attribute_Name : constant Name_Id := N + 457;
- Name_Base : constant Name_Id := N + 457;
- Name_Class : constant Name_Id := N + 458;
- Last_Type_Attribute_Name : constant Name_Id := N + 458;
- Last_Entity_Attribute_Name : constant Name_Id := N + 458;
- Last_Attribute_Name : constant Name_Id := N + 458;
+ First_Type_Attribute_Name : constant Name_Id := N + 458;
+ Name_Base : constant Name_Id := N + 458;
+ Name_Class : constant Name_Id := N + 459;
+ Last_Type_Attribute_Name : constant Name_Id := N + 459;
+ Last_Entity_Attribute_Name : constant Name_Id := N + 459;
+ Last_Attribute_Name : constant Name_Id := N + 459;
-- Names of recognized locking policy identifiers
-- name (e.g. C for Ceiling_Locking). If new policy names are added,
-- the first character must be distinct.
- First_Locking_Policy_Name : constant Name_Id := N + 459;
- Name_Ceiling_Locking : constant Name_Id := N + 459;
- Name_Inheritance_Locking : constant Name_Id := N + 460;
- Last_Locking_Policy_Name : constant Name_Id := N + 460;
+ First_Locking_Policy_Name : constant Name_Id := N + 460;
+ Name_Ceiling_Locking : constant Name_Id := N + 460;
+ Name_Inheritance_Locking : constant Name_Id := N + 461;
+ Last_Locking_Policy_Name : constant Name_Id := N + 461;
-- Names of recognized queuing policy identifiers.
-- name (e.g. F for FIFO_Queuing). If new policy names are added,
-- the first character must be distinct.
- First_Queuing_Policy_Name : constant Name_Id := N + 461;
- Name_FIFO_Queuing : constant Name_Id := N + 461;
- Name_Priority_Queuing : constant Name_Id := N + 462;
- Last_Queuing_Policy_Name : constant Name_Id := N + 462;
+ First_Queuing_Policy_Name : constant Name_Id := N + 462;
+ Name_FIFO_Queuing : constant Name_Id := N + 462;
+ Name_Priority_Queuing : constant Name_Id := N + 463;
+ Last_Queuing_Policy_Name : constant Name_Id := N + 463;
-- Names of recognized task dispatching policy identifiers
-- name (e.g. F for FIFO_WIthinn_Priorities). If new policy names
-- are added, the first character must be distinct.
- First_Task_Dispatching_Policy_Name : constant Name_Id := N + 463;
- Name_FIFO_Within_Priorities : constant Name_Id := N + 463;
- Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 463;
+ First_Task_Dispatching_Policy_Name : constant Name_Id := N + 464;
+ Name_FIFO_Within_Priorities : constant Name_Id := N + 464;
+ Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 464;
-- Names of recognized checks for pragma Suppress
- First_Check_Name : constant Name_Id := N + 464;
- Name_Access_Check : constant Name_Id := N + 464;
- Name_Accessibility_Check : constant Name_Id := N + 465;
- Name_Discriminant_Check : constant Name_Id := N + 466;
- Name_Division_Check : constant Name_Id := N + 467;
- Name_Elaboration_Check : constant Name_Id := N + 468;
- Name_Index_Check : constant Name_Id := N + 469;
- Name_Length_Check : constant Name_Id := N + 470;
- Name_Overflow_Check : constant Name_Id := N + 471;
- Name_Range_Check : constant Name_Id := N + 472;
- Name_Storage_Check : constant Name_Id := N + 473;
- Name_Tag_Check : constant Name_Id := N + 474;
- Name_All_Checks : constant Name_Id := N + 475;
- Last_Check_Name : constant Name_Id := N + 475;
+ First_Check_Name : constant Name_Id := N + 465;
+ Name_Access_Check : constant Name_Id := N + 465;
+ Name_Accessibility_Check : constant Name_Id := N + 466;
+ Name_Discriminant_Check : constant Name_Id := N + 467;
+ Name_Division_Check : constant Name_Id := N + 468;
+ Name_Elaboration_Check : constant Name_Id := N + 469;
+ Name_Index_Check : constant Name_Id := N + 470;
+ Name_Length_Check : constant Name_Id := N + 471;
+ Name_Overflow_Check : constant Name_Id := N + 472;
+ Name_Range_Check : constant Name_Id := N + 473;
+ Name_Storage_Check : constant Name_Id := N + 474;
+ Name_Tag_Check : constant Name_Id := N + 475;
+ Name_All_Checks : constant Name_Id := N + 476;
+ Last_Check_Name : constant Name_Id := N + 476;
-- Names corresponding to reserved keywords, excluding those already
-- declared in the attribute list (Access, Delta, Digits, Range).
- Name_Abort : constant Name_Id := N + 476;
- Name_Abs : constant Name_Id := N + 477;
- Name_Accept : constant Name_Id := N + 478;
- Name_And : constant Name_Id := N + 479;
- Name_All : constant Name_Id := N + 480;
- Name_Array : constant Name_Id := N + 481;
- Name_At : constant Name_Id := N + 482;
- Name_Begin : constant Name_Id := N + 483;
- Name_Body : constant Name_Id := N + 484;
- Name_Case : constant Name_Id := N + 485;
- Name_Constant : constant Name_Id := N + 486;
- Name_Declare : constant Name_Id := N + 487;
- Name_Delay : constant Name_Id := N + 488;
- Name_Do : constant Name_Id := N + 489;
- Name_Else : constant Name_Id := N + 490;
- Name_Elsif : constant Name_Id := N + 491;
- Name_End : constant Name_Id := N + 492;
- Name_Entry : constant Name_Id := N + 493;
- Name_Exception : constant Name_Id := N + 494;
- Name_Exit : constant Name_Id := N + 495;
- Name_For : constant Name_Id := N + 496;
- Name_Function : constant Name_Id := N + 497;
- Name_Generic : constant Name_Id := N + 498;
- Name_Goto : constant Name_Id := N + 499;
- Name_If : constant Name_Id := N + 500;
- Name_In : constant Name_Id := N + 501;
- Name_Is : constant Name_Id := N + 502;
- Name_Limited : constant Name_Id := N + 503;
- Name_Loop : constant Name_Id := N + 504;
- Name_Mod : constant Name_Id := N + 505;
- Name_New : constant Name_Id := N + 506;
- Name_Not : constant Name_Id := N + 507;
- Name_Null : constant Name_Id := N + 508;
- Name_Of : constant Name_Id := N + 509;
- Name_Or : constant Name_Id := N + 510;
- Name_Others : constant Name_Id := N + 511;
- Name_Out : constant Name_Id := N + 512;
- Name_Package : constant Name_Id := N + 513;
- Name_Pragma : constant Name_Id := N + 514;
- Name_Private : constant Name_Id := N + 515;
- Name_Procedure : constant Name_Id := N + 516;
- Name_Raise : constant Name_Id := N + 517;
- Name_Record : constant Name_Id := N + 518;
- Name_Rem : constant Name_Id := N + 519;
- Name_Renames : constant Name_Id := N + 520;
- Name_Return : constant Name_Id := N + 521;
- Name_Reverse : constant Name_Id := N + 522;
- Name_Select : constant Name_Id := N + 523;
- Name_Separate : constant Name_Id := N + 524;
- Name_Subtype : constant Name_Id := N + 525;
- Name_Task : constant Name_Id := N + 526;
- Name_Terminate : constant Name_Id := N + 527;
- Name_Then : constant Name_Id := N + 528;
- Name_Type : constant Name_Id := N + 529;
- Name_Use : constant Name_Id := N + 530;
- Name_When : constant Name_Id := N + 531;
- Name_While : constant Name_Id := N + 532;
- Name_With : constant Name_Id := N + 533;
- Name_Xor : constant Name_Id := N + 534;
+ Name_Abort : constant Name_Id := N + 477;
+ Name_Abs : constant Name_Id := N + 478;
+ Name_Accept : constant Name_Id := N + 479;
+ Name_And : constant Name_Id := N + 480;
+ Name_All : constant Name_Id := N + 481;
+ Name_Array : constant Name_Id := N + 482;
+ Name_At : constant Name_Id := N + 483;
+ Name_Begin : constant Name_Id := N + 484;
+ Name_Body : constant Name_Id := N + 485;
+ Name_Case : constant Name_Id := N + 486;
+ Name_Constant : constant Name_Id := N + 487;
+ Name_Declare : constant Name_Id := N + 488;
+ Name_Delay : constant Name_Id := N + 489;
+ Name_Do : constant Name_Id := N + 490;
+ Name_Else : constant Name_Id := N + 491;
+ Name_Elsif : constant Name_Id := N + 492;
+ Name_End : constant Name_Id := N + 493;
+ Name_Entry : constant Name_Id := N + 494;
+ Name_Exception : constant Name_Id := N + 495;
+ Name_Exit : constant Name_Id := N + 496;
+ Name_For : constant Name_Id := N + 497;
+ Name_Function : constant Name_Id := N + 498;
+ Name_Generic : constant Name_Id := N + 499;
+ Name_Goto : constant Name_Id := N + 500;
+ Name_If : constant Name_Id := N + 501;
+ Name_In : constant Name_Id := N + 502;
+ Name_Is : constant Name_Id := N + 503;
+ Name_Limited : constant Name_Id := N + 504;
+ Name_Loop : constant Name_Id := N + 505;
+ Name_Mod : constant Name_Id := N + 506;
+ Name_New : constant Name_Id := N + 507;
+ Name_Not : constant Name_Id := N + 508;
+ Name_Null : constant Name_Id := N + 509;
+ Name_Of : constant Name_Id := N + 510;
+ Name_Or : constant Name_Id := N + 511;
+ Name_Others : constant Name_Id := N + 512;
+ Name_Out : constant Name_Id := N + 513;
+ Name_Package : constant Name_Id := N + 514;
+ Name_Pragma : constant Name_Id := N + 515;
+ Name_Private : constant Name_Id := N + 516;
+ Name_Procedure : constant Name_Id := N + 517;
+ Name_Raise : constant Name_Id := N + 518;
+ Name_Record : constant Name_Id := N + 519;
+ Name_Rem : constant Name_Id := N + 520;
+ Name_Renames : constant Name_Id := N + 521;
+ Name_Return : constant Name_Id := N + 522;
+ Name_Reverse : constant Name_Id := N + 523;
+ Name_Select : constant Name_Id := N + 524;
+ Name_Separate : constant Name_Id := N + 525;
+ Name_Subtype : constant Name_Id := N + 526;
+ Name_Task : constant Name_Id := N + 527;
+ Name_Terminate : constant Name_Id := N + 528;
+ Name_Then : constant Name_Id := N + 529;
+ Name_Type : constant Name_Id := N + 530;
+ Name_Use : constant Name_Id := N + 531;
+ Name_When : constant Name_Id := N + 532;
+ Name_While : constant Name_Id := N + 533;
+ Name_With : constant Name_Id := N + 534;
+ Name_Xor : constant Name_Id := N + 535;
-- Names of intrinsic subprograms
-- Note: Asm is missing from this list, since Asm is a legitimate
-- convention name. So is To_Adress, which is a GNAT attribute.
- First_Intrinsic_Name : constant Name_Id := N + 535;
- Name_Divide : constant Name_Id := N + 535;
- Name_Enclosing_Entity : constant Name_Id := N + 536;
- Name_Exception_Information : constant Name_Id := N + 537;
- Name_Exception_Message : constant Name_Id := N + 538;
- Name_Exception_Name : constant Name_Id := N + 539;
- Name_File : constant Name_Id := N + 540;
- Name_Import_Address : constant Name_Id := N + 541;
- Name_Import_Largest_Value : constant Name_Id := N + 542;
- Name_Import_Value : constant Name_Id := N + 543;
- Name_Is_Negative : constant Name_Id := N + 544;
- Name_Line : constant Name_Id := N + 545;
- Name_Rotate_Left : constant Name_Id := N + 546;
- Name_Rotate_Right : constant Name_Id := N + 547;
- Name_Shift_Left : constant Name_Id := N + 548;
- Name_Shift_Right : constant Name_Id := N + 549;
- Name_Shift_Right_Arithmetic : constant Name_Id := N + 550;
- Name_Source_Location : constant Name_Id := N + 551;
- Name_Unchecked_Conversion : constant Name_Id := N + 552;
- Name_Unchecked_Deallocation : constant Name_Id := N + 553;
- Name_To_Pointer : constant Name_Id := N + 554;
- Last_Intrinsic_Name : constant Name_Id := N + 554;
+ First_Intrinsic_Name : constant Name_Id := N + 536;
+ Name_Divide : constant Name_Id := N + 536;
+ Name_Enclosing_Entity : constant Name_Id := N + 537;
+ Name_Exception_Information : constant Name_Id := N + 538;
+ Name_Exception_Message : constant Name_Id := N + 539;
+ Name_Exception_Name : constant Name_Id := N + 540;
+ Name_File : constant Name_Id := N + 541;
+ Name_Import_Address : constant Name_Id := N + 542;
+ Name_Import_Largest_Value : constant Name_Id := N + 543;
+ Name_Import_Value : constant Name_Id := N + 544;
+ Name_Is_Negative : constant Name_Id := N + 545;
+ Name_Line : constant Name_Id := N + 546;
+ Name_Rotate_Left : constant Name_Id := N + 547;
+ Name_Rotate_Right : constant Name_Id := N + 548;
+ Name_Shift_Left : constant Name_Id := N + 549;
+ Name_Shift_Right : constant Name_Id := N + 550;
+ Name_Shift_Right_Arithmetic : constant Name_Id := N + 551;
+ Name_Source_Location : constant Name_Id := N + 552;
+ Name_Unchecked_Conversion : constant Name_Id := N + 553;
+ Name_Unchecked_Deallocation : constant Name_Id := N + 554;
+ Name_To_Pointer : constant Name_Id := N + 555;
+ Last_Intrinsic_Name : constant Name_Id := N + 555;
-- Reserved words used only in Ada 95
- First_95_Reserved_Word : constant Name_Id := N + 555;
- Name_Abstract : constant Name_Id := N + 555;
- Name_Aliased : constant Name_Id := N + 556;
- Name_Protected : constant Name_Id := N + 557;
- Name_Until : constant Name_Id := N + 558;
- Name_Requeue : constant Name_Id := N + 559;
- Name_Tagged : constant Name_Id := N + 560;
- Last_95_Reserved_Word : constant Name_Id := N + 560;
+ First_95_Reserved_Word : constant Name_Id := N + 556;
+ Name_Abstract : constant Name_Id := N + 556;
+ Name_Aliased : constant Name_Id := N + 557;
+ Name_Protected : constant Name_Id := N + 558;
+ Name_Until : constant Name_Id := N + 559;
+ Name_Requeue : constant Name_Id := N + 560;
+ Name_Tagged : constant Name_Id := N + 561;
+ Last_95_Reserved_Word : constant Name_Id := N + 561;
subtype Ada_95_Reserved_Words is
Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word;
-- Miscellaneous names used in semantic checking
- Name_Raise_Exception : constant Name_Id := N + 561;
+ Name_Raise_Exception : constant Name_Id := N + 562;
-- Additional reserved words in GNAT Project Files
-- Note that Name_External is already previously declared
- Name_Binder : constant Name_Id := N + 562;
- Name_Body_Suffix : constant Name_Id := N + 563;
- Name_Builder : constant Name_Id := N + 564;
- Name_Compiler : constant Name_Id := N + 565;
- Name_Cross_Reference : constant Name_Id := N + 566;
- Name_Default_Switches : constant Name_Id := N + 567;
- Name_Exec_Dir : constant Name_Id := N + 568;
- Name_Executable : constant Name_Id := N + 569;
- Name_Executable_Suffix : constant Name_Id := N + 570;
- Name_Extends : constant Name_Id := N + 571;
- Name_Finder : constant Name_Id := N + 572;
- Name_Global_Configuration_Pragmas : constant Name_Id := N + 573;
- Name_Gnatls : constant Name_Id := N + 574;
- Name_Gnatstub : constant Name_Id := N + 575;
- Name_Implementation : constant Name_Id := N + 576;
- Name_Implementation_Exceptions : constant Name_Id := N + 577;
- Name_Implementation_Suffix : constant Name_Id := N + 578;
- Name_Languages : constant Name_Id := N + 579;
- Name_Library_Dir : constant Name_Id := N + 580;
- Name_Library_Auto_Init : constant Name_Id := N + 581;
- Name_Library_GCC : constant Name_Id := N + 582;
- Name_Library_Interface : constant Name_Id := N + 583;
- Name_Library_Kind : constant Name_Id := N + 584;
- Name_Library_Name : constant Name_Id := N + 585;
- Name_Library_Options : constant Name_Id := N + 586;
- Name_Library_Reference_Symbol_File : constant Name_Id := N + 587;
- Name_Library_Src_Dir : constant Name_Id := N + 588;
- Name_Library_Symbol_File : constant Name_Id := N + 589;
- Name_Library_Symbol_Policy : constant Name_Id := N + 590;
- Name_Library_Version : constant Name_Id := N + 591;
- Name_Linker : constant Name_Id := N + 592;
- Name_Local_Configuration_Pragmas : constant Name_Id := N + 593;
- Name_Locally_Removed_Files : constant Name_Id := N + 594;
- Name_Naming : constant Name_Id := N + 595;
- Name_Object_Dir : constant Name_Id := N + 596;
- Name_Pretty_Printer : constant Name_Id := N + 597;
- Name_Project : constant Name_Id := N + 598;
- Name_Separate_Suffix : constant Name_Id := N + 599;
- Name_Source_Dirs : constant Name_Id := N + 600;
- Name_Source_Files : constant Name_Id := N + 601;
- Name_Source_List_File : constant Name_Id := N + 602;
- Name_Spec : constant Name_Id := N + 603;
- Name_Spec_Suffix : constant Name_Id := N + 604;
- Name_Specification : constant Name_Id := N + 605;
- Name_Specification_Exceptions : constant Name_Id := N + 606;
- Name_Specification_Suffix : constant Name_Id := N + 607;
- Name_Switches : constant Name_Id := N + 608;
+ Name_Binder : constant Name_Id := N + 563;
+ Name_Body_Suffix : constant Name_Id := N + 564;
+ Name_Builder : constant Name_Id := N + 565;
+ Name_Compiler : constant Name_Id := N + 566;
+ Name_Cross_Reference : constant Name_Id := N + 567;
+ Name_Default_Switches : constant Name_Id := N + 568;
+ Name_Exec_Dir : constant Name_Id := N + 569;
+ Name_Executable : constant Name_Id := N + 570;
+ Name_Executable_Suffix : constant Name_Id := N + 571;
+ Name_Extends : constant Name_Id := N + 572;
+ Name_Finder : constant Name_Id := N + 573;
+ Name_Global_Configuration_Pragmas : constant Name_Id := N + 574;
+ Name_Gnatls : constant Name_Id := N + 575;
+ Name_Gnatstub : constant Name_Id := N + 576;
+ Name_Implementation : constant Name_Id := N + 577;
+ Name_Implementation_Exceptions : constant Name_Id := N + 578;
+ Name_Implementation_Suffix : constant Name_Id := N + 579;
+ Name_Languages : constant Name_Id := N + 580;
+ Name_Library_Dir : constant Name_Id := N + 581;
+ Name_Library_Auto_Init : constant Name_Id := N + 582;
+ Name_Library_GCC : constant Name_Id := N + 583;
+ Name_Library_Interface : constant Name_Id := N + 584;
+ Name_Library_Kind : constant Name_Id := N + 585;
+ Name_Library_Name : constant Name_Id := N + 586;
+ Name_Library_Options : constant Name_Id := N + 587;
+ Name_Library_Reference_Symbol_File : constant Name_Id := N + 588;
+ Name_Library_Src_Dir : constant Name_Id := N + 589;
+ Name_Library_Symbol_File : constant Name_Id := N + 590;
+ Name_Library_Symbol_Policy : constant Name_Id := N + 591;
+ Name_Library_Version : constant Name_Id := N + 592;
+ Name_Linker : constant Name_Id := N + 593;
+ Name_Local_Configuration_Pragmas : constant Name_Id := N + 594;
+ Name_Locally_Removed_Files : constant Name_Id := N + 595;
+ Name_Metrics : constant Name_Id := N + 596;
+ Name_Naming : constant Name_Id := N + 597;
+ Name_Object_Dir : constant Name_Id := N + 598;
+ Name_Pretty_Printer : constant Name_Id := N + 599;
+ Name_Project : constant Name_Id := N + 600;
+ Name_Separate_Suffix : constant Name_Id := N + 601;
+ Name_Source_Dirs : constant Name_Id := N + 602;
+ Name_Source_Files : constant Name_Id := N + 603;
+ Name_Source_List_File : constant Name_Id := N + 604;
+ Name_Spec : constant Name_Id := N + 605;
+ Name_Spec_Suffix : constant Name_Id := N + 606;
+ Name_Specification : constant Name_Id := N + 607;
+ Name_Specification_Exceptions : constant Name_Id := N + 608;
+ Name_Specification_Suffix : constant Name_Id := N + 609;
+ Name_Switches : constant Name_Id := N + 610;
-- Other miscellaneous names used in front end
- Name_Unaligned_Valid : constant Name_Id := N + 609;
+ Name_Unaligned_Valid : constant Name_Id := N + 611;
-- Mark last defined name for consistency check in Snames body
- Last_Predefined_Name : constant Name_Id := N + 609;
+ Last_Predefined_Name : constant Name_Id := N + 611;
subtype Any_Operator_Name is Name_Id range
First_Operator_Name .. Last_Operator_Name;
Pragma_Ada_83,
Pragma_Ada_95,
+ Pragma_Ada_05,
Pragma_C_Pass_By_Copy,
Pragma_Compile_Time_Warning,
Pragma_Component_Alignment,
#define Pragma_Ada_83 0
#define Pragma_Ada_95 1
-#define Pragma_C_Pass_By_Copy 2
-#define Pragma_Compile_Time_Warning 3
-#define Pragma_Component_Alignment 4
-#define Pragma_Convention_Identifier 5
-#define Pragma_Discard_Names 6
-#define Pragma_Elaboration_Checking 7
-#define Pragma_Eliminate 8
-#define Pragma_Explicit_Overriding 9
-#define Pragma_Extend_System 10
-#define Pragma_Extensions_Allowed 11
-#define Pragma_External_Name_Casing 12
-#define Pragma_Float_Representation 13
-#define Pragma_Initialize_Scalars 14
-#define Pragma_Interrupt_State 15
-#define Pragma_License 16
-#define Pragma_Locking_Policy 17
-#define Pragma_Long_Float 18
-#define Pragma_No_Run_Time 19
-#define Pragma_No_Strict_Aliasing 20
-#define Pragma_Normalize_Scalars 21
-#define Pragma_Polling 22
-#define Pragma_Persistent_Data 23
-#define Pragma_Persistent_Object 24
-#define Pragma_Profile 25
-#define Pragma_Propagate_Exceptions 26
-#define Pragma_Queuing_Policy 27
-#define Pragma_Ravenscar 28
-#define Pragma_Restricted_Run_Time 29
-#define Pragma_Restrictions 30
-#define Pragma_Restriction_Warnings 31
-#define Pragma_Reviewable 32
-#define Pragma_Source_File_Name 33
-#define Pragma_Source_File_Name_Project 34
-#define Pragma_Style_Checks 35
-#define Pragma_Suppress 36
-#define Pragma_Suppress_Exception_Locations 37
-#define Pragma_Task_Dispatching_Policy 38
-#define Pragma_Universal_Data 39
-#define Pragma_Unsuppress 40
-#define Pragma_Use_VADS_Size 41
-#define Pragma_Validity_Checks 42
-#define Pragma_Warnings 43
+#define Pragma_Ada_05 2
+#define Pragma_C_Pass_By_Copy 3
+#define Pragma_Compile_Time_Warning 4
+#define Pragma_Component_Alignment 5
+#define Pragma_Convention_Identifier 6
+#define Pragma_Discard_Names 7
+#define Pragma_Elaboration_Checking 8
+#define Pragma_Eliminate 9
+#define Pragma_Explicit_Overriding 10
+#define Pragma_Extend_System 11
+#define Pragma_Extensions_Allowed 12
+#define Pragma_External_Name_Casing 13
+#define Pragma_Float_Representation 14
+#define Pragma_Initialize_Scalars 15
+#define Pragma_Interrupt_State 16
+#define Pragma_License 17
+#define Pragma_Locking_Policy 18
+#define Pragma_Long_Float 19
+#define Pragma_No_Run_Time 20
+#define Pragma_No_Strict_Aliasing 21
+#define Pragma_Normalize_Scalars 22
+#define Pragma_Polling 23
+#define Pragma_Persistent_Data 24
+#define Pragma_Persistent_Object 25
+#define Pragma_Profile 26
+#define Pragma_Propagate_Exceptions 27
+#define Pragma_Queuing_Policy 28
+#define Pragma_Ravenscar 29
+#define Pragma_Restricted_Run_Time 30
+#define Pragma_Restrictions 31
+#define Pragma_Restriction_Warnings 32
+#define Pragma_Reviewable 33
+#define Pragma_Source_File_Name 34
+#define Pragma_Source_File_Name_Project 35
+#define Pragma_Style_Checks 36
+#define Pragma_Suppress 37
+#define Pragma_Suppress_Exception_Locations 38
+#define Pragma_Task_Dispatching_Policy 39
+#define Pragma_Universal_Data 40
+#define Pragma_Unsuppress 41
+#define Pragma_Use_VADS_Size 42
+#define Pragma_Validity_Checks 43
+#define Pragma_Warnings 44
/* Remaining pragmas */
-#define Pragma_Abort_Defer 44
-#define Pragma_All_Calls_Remote 45
-#define Pragma_Annotate 46
-#define Pragma_Assert 47
-#define Pragma_Asynchronous 48
-#define Pragma_Atomic 49
-#define Pragma_Atomic_Components 50
-#define Pragma_Attach_Handler 51
-#define Pragma_Comment 52
-#define Pragma_Common_Object 53
-#define Pragma_Complex_Representation 54
-#define Pragma_Controlled 55
-#define Pragma_Convention 56
-#define Pragma_CPP_Class 57
-#define Pragma_CPP_Constructor 58
-#define Pragma_CPP_Virtual 59
-#define Pragma_CPP_Vtable 60
-#define Pragma_Debug 61
-#define Pragma_Elaborate 62
-#define Pragma_Elaborate_All 63
-#define Pragma_Elaborate_Body 64
-#define Pragma_Export 65
-#define Pragma_Export_Exception 66
-#define Pragma_Export_Function 67
-#define Pragma_Export_Object 68
-#define Pragma_Export_Procedure 69
-#define Pragma_Export_Value 70
-#define Pragma_Export_Valued_Procedure 71
-#define Pragma_External 72
-#define Pragma_Finalize_Storage_Only 73
-#define Pragma_Ident 74
-#define Pragma_Import 75
-#define Pragma_Import_Exception 76
-#define Pragma_Import_Function 77
-#define Pragma_Import_Object 78
-#define Pragma_Import_Procedure 79
-#define Pragma_Import_Valued_Procedure 80
-#define Pragma_Inline 81
-#define Pragma_Inline_Always 82
-#define Pragma_Inline_Generic 83
-#define Pragma_Inspection_Point 84
-#define Pragma_Interface 85
-#define Pragma_Interface_Name 86
-#define Pragma_Interrupt_Handler 87
-#define Pragma_Interrupt_Priority 88
-#define Pragma_Java_Constructor 89
-#define Pragma_Java_Interface 90
-#define Pragma_Keep_Names 91
-#define Pragma_Link_With 92
-#define Pragma_Linker_Alias 93
-#define Pragma_Linker_Options 94
-#define Pragma_Linker_Section 95
-#define Pragma_List 96
-#define Pragma_Machine_Attribute 97
-#define Pragma_Main 98
-#define Pragma_Main_Storage 99
-#define Pragma_Memory_Size 100
-#define Pragma_No_Return 101
-#define Pragma_Obsolescent 102
-#define Pragma_Optimize 103
-#define Pragma_Optional_Overriding 104
-#define Pragma_Overriding 105
-#define Pragma_Pack 106
-#define Pragma_Page 107
-#define Pragma_Passive 108
-#define Pragma_Preelaborate 109
-#define Pragma_Priority 110
-#define Pragma_Psect_Object 111
-#define Pragma_Pure 112
-#define Pragma_Pure_Function 113
-#define Pragma_Remote_Call_Interface 114
-#define Pragma_Remote_Types 115
-#define Pragma_Share_Generic 116
-#define Pragma_Shared 117
-#define Pragma_Shared_Passive 118
-#define Pragma_Source_Reference 119
-#define Pragma_Stream_Convert 120
-#define Pragma_Subtitle 121
-#define Pragma_Suppress_All 122
-#define Pragma_Suppress_Debug_Info 123
-#define Pragma_Suppress_Initialization 124
-#define Pragma_System_Name 125
-#define Pragma_Task_Info 126
-#define Pragma_Task_Name 127
-#define Pragma_Task_Storage 128
-#define Pragma_Thread_Body 129
-#define Pragma_Time_Slice 130
-#define Pragma_Title 131
-#define Pragma_Unchecked_Union 132
-#define Pragma_Unimplemented_Unit 133
-#define Pragma_Unreferenced 134
-#define Pragma_Unreserve_All_Interrupts 135
-#define Pragma_Volatile 136
-#define Pragma_Volatile_Components 137
-#define Pragma_Weak_External 138
+#define Pragma_Abort_Defer 45
+#define Pragma_All_Calls_Remote 46
+#define Pragma_Annotate 47
+#define Pragma_Assert 48
+#define Pragma_Asynchronous 49
+#define Pragma_Atomic 50
+#define Pragma_Atomic_Components 51
+#define Pragma_Attach_Handler 52
+#define Pragma_Comment 53
+#define Pragma_Common_Object 54
+#define Pragma_Complex_Representation 55
+#define Pragma_Controlled 56
+#define Pragma_Convention 57
+#define Pragma_CPP_Class 58
+#define Pragma_CPP_Constructor 59
+#define Pragma_CPP_Virtual 60
+#define Pragma_CPP_Vtable 61
+#define Pragma_Debug 62
+#define Pragma_Elaborate 63
+#define Pragma_Elaborate_All 64
+#define Pragma_Elaborate_Body 65
+#define Pragma_Export 66
+#define Pragma_Export_Exception 67
+#define Pragma_Export_Function 68
+#define Pragma_Export_Object 69
+#define Pragma_Export_Procedure 70
+#define Pragma_Export_Value 71
+#define Pragma_Export_Valued_Procedure 72
+#define Pragma_External 73
+#define Pragma_Finalize_Storage_Only 74
+#define Pragma_Ident 75
+#define Pragma_Import 76
+#define Pragma_Import_Exception 77
+#define Pragma_Import_Function 78
+#define Pragma_Import_Object 79
+#define Pragma_Import_Procedure 80
+#define Pragma_Import_Valued_Procedure 81
+#define Pragma_Inline 82
+#define Pragma_Inline_Always 83
+#define Pragma_Inline_Generic 84
+#define Pragma_Inspection_Point 85
+#define Pragma_Interface 86
+#define Pragma_Interface_Name 87
+#define Pragma_Interrupt_Handler 88
+#define Pragma_Interrupt_Priority 89
+#define Pragma_Java_Constructor 90
+#define Pragma_Java_Interface 91
+#define Pragma_Keep_Names 92
+#define Pragma_Link_With 93
+#define Pragma_Linker_Alias 94
+#define Pragma_Linker_Options 95
+#define Pragma_Linker_Section 96
+#define Pragma_List 97
+#define Pragma_Machine_Attribute 98
+#define Pragma_Main 99
+#define Pragma_Main_Storage 100
+#define Pragma_Memory_Size 101
+#define Pragma_No_Return 102
+#define Pragma_Obsolescent 103
+#define Pragma_Optimize 104
+#define Pragma_Optional_Overriding 105
+#define Pragma_Overriding 106
+#define Pragma_Pack 107
+#define Pragma_Page 108
+#define Pragma_Passive 109
+#define Pragma_Preelaborate 110
+#define Pragma_Priority 111
+#define Pragma_Psect_Object 112
+#define Pragma_Pure 113
+#define Pragma_Pure_Function 114
+#define Pragma_Remote_Call_Interface 115
+#define Pragma_Remote_Types 116
+#define Pragma_Share_Generic 117
+#define Pragma_Shared 118
+#define Pragma_Shared_Passive 119
+#define Pragma_Source_Reference 120
+#define Pragma_Stream_Convert 121
+#define Pragma_Subtitle 122
+#define Pragma_Suppress_All 123
+#define Pragma_Suppress_Debug_Info 124
+#define Pragma_Suppress_Initialization 125
+#define Pragma_System_Name 126
+#define Pragma_Task_Info 127
+#define Pragma_Task_Name 128
+#define Pragma_Task_Storage 129
+#define Pragma_Thread_Body 130
+#define Pragma_Time_Slice 131
+#define Pragma_Title 132
+#define Pragma_Unchecked_Union 133
+#define Pragma_Unimplemented_Unit 134
+#define Pragma_Unreferenced 135
+#define Pragma_Unreserve_All_Interrupts 136
+#define Pragma_Volatile 137
+#define Pragma_Volatile_Components 138
+#define Pragma_Weak_External 139
/* The following are deliberately out of alphabetical order, see Snames */
-#define Pragma_AST_Entry 139
-#define Pragma_Storage_Size 140
-#define Pragma_Storage_Unit 141
+#define Pragma_AST_Entry 140
+#define Pragma_Storage_Size 141
+#define Pragma_Storage_Unit 142
/* Define the numeric values for the conventions. */
when N_Access_Definition =>
- -- Ada 0Y (AI-254)
+ -- Ada 2005 (AI-254)
if Present (Access_To_Subprogram_Definition (Node)) then
Sprint_Node (Access_To_Subprogram_Definition (Node));
else
- -- Ada 0Y (AI-231)
+ -- Ada 2005 (AI-231)
if Null_Exclusion_Present (Node) then
Write_Str ("not null ");
when N_Access_Function_Definition =>
- -- Ada 0Y (AI-231)
+ -- Ada 2005 (AI-231)
if Null_Exclusion_Present (Node) then
Write_Str ("not null ");
Sprint_Node (Subtype_Mark (Node));
when N_Access_Procedure_Definition =>
- -- Ada 0Y (AI-231)
+
+ -- Ada 2005 (AI-231)
if Null_Exclusion_Present (Node) then
Write_Str ("not null ");
Write_Str_With_Col_Check ("constant ");
end if;
- -- Ada 0Y (AI-231)
+ -- Ada 2005 (AI-231)
if Null_Exclusion_Present (Node) then
Write_Str ("not null ");
when N_Allocator =>
Write_Str_With_Col_Check_Sloc ("new ");
- -- Ada 0Y (AI-231)
+
+ -- Ada 2005 (AI-231)
if Null_Exclusion_Present (Node) then
Write_Str ("not null ");
Sprint_Bar_List (Choices (Node));
Write_Str (" => ");
- -- Ada 0Y (AI-287): Print the mbox if present
+ -- Ada 2005 (AI-287): Print the mbox if present
if Box_Present (Node) then
Write_Str_With_Col_Check ("<>");
when N_Component_Definition =>
Set_Debug_Sloc;
- -- Ada 0Y (AI-230): Access definition components
+ -- Ada 2005 (AI-230): Access definition components
if Present (Access_Definition (Node)) then
Sprint_Node (Access_Definition (Node));
Write_Str_With_Col_Check ("aliased ");
end if;
- -- Ada 0Y (AI-231)
+ -- Ada 2005 (AI-231)
if Null_Exclusion_Present (Node) then
Write_Str (" not null ");
Write_Str_With_Col_Check_Sloc ("new ");
- -- Ada 0Y (AI-231)
+ -- Ada 2005 (AI-231)
if Null_Exclusion_Present (Node) then
Write_Str_With_Col_Check ("not null ");
Write_Str_With_Col_Check ("constant ");
end if;
- -- Ada 0Y (AI-231)
+ -- Ada 2005 (AI-231)
if Null_Exclusion_Present (Node) then
Write_Str_With_Col_Check ("not null ");
Sprint_Node (Defining_Identifier (Node));
Write_Str (" : ");
- -- Ada 0Y (AI-230): Access renamings
+ -- Ada 2005 (AI-230): Access renamings
if Present (Access_Definition (Node)) then
Sprint_Node (Access_Definition (Node));
Write_Str_With_Col_Check ("out ");
end if;
- -- Ada 0Y (AI-231)
+ -- Ada 2005 (AI-231)
if Null_Exclusion_Present (Node) then
Write_Str ("not null ");
Write_Id (Defining_Identifier (Node));
Write_Str (" is ");
- -- Ada 0Y (AI-231)
+ -- Ada 2005 (AI-231)
if Null_Exclusion_Present (Node) then
Write_Str ("not null ");
else
if First_Name (Node) or else not Dump_Original_Only then
- -- Ada 0Y (AI-50217): Print limited with_clauses
+ -- Ada 2005 (AI-50217): Print limited with_clauses
if Private_Present (Node) and Limited_Present (Node) then
Write_Indent_Str ("limited private with ");
when 'X' =>
Ptr := Ptr + 1;
Extensions_Allowed := True;
+ Ada_Version := Ada_Version_Type'Last;
-- Processing for y switch
-- Processing for 83 switch
when '8' =>
-
if Ptr = Max then
raise Bad_Switch;
end if;
raise Bad_Switch;
else
Ptr := Ptr + 1;
- Ada_95 := False;
- Ada_83 := True;
+ Ada_Version := Ada_83;
+ end if;
+
+ -- Processing for 95 switch
+
+ when '9' =>
+ if Ptr = Max then
+ raise Bad_Switch;
+ end if;
+
+ Ptr := Ptr + 1;
+
+ if Switch_Chars (Ptr) /= '5' then
+ raise Bad_Switch;
+ else
+ Ptr := Ptr + 1;
+ Ada_Version := Ada_95;
+ end if;
+
+ -- Processing for 05 switch
+
+ when '0' =>
+ if Ptr = Max then
+ raise Bad_Switch;
+ end if;
+
+ Ptr := Ptr + 1;
+
+ if Switch_Chars (Ptr) /= '5' then
+ raise Bad_Switch;
+ else
+ Ptr := Ptr + 1;
+ Ada_Version := Ada_05;
end if;
-- Ignore extra switch character
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (OpenVMS 64bit GCC_ZCX DEC Threads Version) --
+-- --
+-- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := Integer'Last;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 0.01;
+
+ -- Storage-related Declarations
+
+ type Address is new Long_Integer;
+ Null_Address : constant Address;
+ -- Although this is declared as an integer type, no arithmetic operations
+ -- are available (see abstract declarations below), and furthermore there
+ -- is special processing in the compiler that prevents the use of integer
+ -- literals with this type (use To_Address to convert integer literals).
+ --
+ -- Conversion to and from Short_Address is however freely permitted, and
+ -- is indeed the reason that Address is declared as an integer type. See
+ --
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 64;
+ Memory_Size : constant := 2 ** 64;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Abstract declarations for arithmetic operations on type address.
+ -- These declarations are needed when Address is non-private. They
+ -- avoid excessive visibility of arithmetic operations on address
+ -- which are typically available elsewhere (e.g. Storage_Elements)
+ -- and which would cause excessive ambiguities in application code.
+
+ function "+" (Left, Right : Address) return Address is abstract;
+ function "-" (Left, Right : Address) return Address is abstract;
+ function "/" (Left, Right : Address) return Address is abstract;
+ function "*" (Left, Right : Address) return Address is abstract;
+ function "mod" (Left, Right : Address) return Address is abstract;
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := Low_Order_First;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer range 0 .. 31;
+ subtype Priority is Any_Priority range 0 .. 30;
+ subtype Interrupt_Priority is Any_Priority range 31 .. 31;
+
+ Default_Priority : constant Priority := 15;
+
+private
+
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ AAMP : constant Boolean := False;
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
+ Denorm : constant Boolean := False;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := True;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := True;
+ Stack_Check_Probes : constant Boolean := True;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := True;
+ GCC_ZCX_Support : constant Boolean := True;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := False;
+
+ --------------------------
+ -- Underlying Priorities --
+ ---------------------------
+
+ -- Important note: this section of the file must come AFTER the
+ -- definition of the system implementation parameters to ensure
+ -- that the value of these parameters is available for analysis
+ -- of the declarations here (using Rtsfind at compile time).
+
+ -- The underlying priorities table provides a generalized mechanism
+ -- for mapping from Ada priorities to system priorities. In some
+ -- cases a 1-1 mapping is not the convenient or optimal choice.
+
+ -- For DEC Threads OpenVMS, we use the full range of 31 priorities
+ -- in the Ada model, but map them by compression onto the more limited
+ -- range of priorities available in OpenVMS.
+
+ -- To replace the default values of the Underlying_Priorities mapping,
+ -- copy this source file into your build directory, edit the file to
+ -- reflect your desired behavior, and recompile with the command:
+
+ -- $ gcc -c -O3 -gnatpgn system.ads
+
+ -- then recompile the run-time parts that depend on this package:
+
+ -- $ gnatmake -a -gnatn -O3 <your application>
+
+ -- then force rebuilding your application if you need different options:
+
+ -- $ gnatmake -f <your options> <your application>
+
+ type Priorities_Mapping is array (Any_Priority) of Integer;
+ pragma Suppress_Initialization (Priorities_Mapping);
+ -- Suppress initialization in case gnat.adc specifies Normalize_Scalars
+
+ Underlying_Priorities : constant Priorities_Mapping :=
+
+ (Priority'First => 16,
+
+ 1 => 17,
+ 2 => 18,
+ 3 => 18,
+ 4 => 18,
+ 5 => 18,
+ 6 => 19,
+ 7 => 19,
+ 8 => 19,
+ 9 => 20,
+ 10 => 20,
+ 11 => 21,
+ 12 => 21,
+ 13 => 22,
+ 14 => 23,
+
+ Default_Priority => 24,
+
+ 16 => 25,
+ 17 => 25,
+ 18 => 25,
+ 19 => 26,
+ 20 => 26,
+ 21 => 26,
+ 22 => 27,
+ 23 => 27,
+ 24 => 27,
+ 25 => 28,
+ 26 => 28,
+ 27 => 29,
+ 28 => 29,
+ 29 => 30,
+
+ Priority'Last => 30,
+
+ Interrupt_Priority => 31);
+
+ ----------------------------
+ -- Special VMS Interfaces --
+ ----------------------------
+
+ procedure Lib_Stop (I : in Integer);
+ pragma Interface (C, Lib_Stop);
+ pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value));
+ -- Interface to VMS condition handling. Used by RTSfind and pragma
+ -- {Import,Export}_Exception. Put here because this is the only
+ -- VMS specific package that doesn't drag in tasking.
+
+end System;
static tree tree_transform (Node_Id);
static rtx first_nondeleted_insn (rtx);
static tree start_block_stmt (void);
-static tree end_block_stmt (void);
+static tree end_block_stmt (bool);
static tree build_block_stmt (List_Id);
static tree make_expr_stmt_from_rtl (rtx, Node_Id);
static void elaborate_all_entities (Node_Id);
start_block_stmt ();
gnu_root = tree_transform (gnat_node);
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
/* If we return a statement, generate code for it. */
if (IS_STMT (gnu_root))
start_block_stmt ();
gnu_root = tree_transform (gnat_node);
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
if (gnu_root == error_mark_node)
{
tree gnu_expr_stmt = make_expr_stmt_from_rtl (insns, gnat_node);
TREE_CHAIN (gnu_expr_stmt) = gnu_root;
- gnu_root = build_nt (BLOCK_STMT, gnu_expr_stmt);
- TREE_TYPE (gnu_root) = void_type_node;
+ gnu_root = build_nt (BLOCK_STMT, gnu_expr_stmt, NULL_TREE);
TREE_SLOC (gnu_root) = Sloc (gnat_node);
}
else
Present (gnat_when);
gnat_when = Next_Non_Pragma (gnat_when))
{
+ tree gnu_temp_stmt, gnu_block;
+
/* First compile all the different case choices for the current
WHEN alternative. */
set of statements instead of the block containing the Case
statement. */
gnat_pushlevel ();
- expand_start_bindings (0);
+ start_block_stmt ();
+
for (gnat_statement = First (Statements (gnat_when));
Present (gnat_statement);
gnat_statement = Next (gnat_statement))
- gnat_to_code (gnat_statement);
+ add_stmt (gnat_to_gnu (gnat_statement));
/* Communicate to GCC that we are done with the current WHEN,
i.e. insert a "break" statement. */
- expand_exit_something ();
- expand_end_bindings (NULL_TREE, block_has_vars (), -1);
- gnat_poplevel ();
+ gnu_temp_stmt = build_nt (BREAK_STMT);
+ TREE_SLOC (gnu_temp_stmt) = Sloc (gnat_when);
+ add_stmt (gnu_temp_stmt);
+
+ gnu_block = gnat_poplevel ();
+ gnu_temp_stmt = end_block_stmt (gnu_block != 0);
+ if (gnu_block)
+ BLOCK_STMT_BLOCK (gnu_temp_stmt) = gnu_block;
+
+ expand_expr_stmt (gnu_temp_stmt);
}
expand_end_case (gnu_expr);
/* Declare the loop index and set it to its initial value. */
start_block_stmt ();
gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
- expand_expr_stmt (end_block_stmt ());
+ expand_expr_stmt (end_block_stmt (false));
if (DECL_BY_REF_P (gnu_loop_var))
gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE,
gnu_loop_var);
expand_start_bindings (0);
start_block_stmt ();
process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
gnat_to_code (Handled_Statement_Sequence (gnat_node));
expand_end_bindings (NULL_TREE, block_has_vars (), -1);
gnat_poplevel ();
gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
}
- gnat_expand_stmt (end_block_stmt());
+ gnat_expand_stmt (end_block_stmt (false));
start_block_stmt ();
process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
/* Generate the code of the subprogram itself. A return statement
will be present and any OUT parameters will be handled there. */
gnu_result = chainon (nreverse (gnu_before_list),
nreverse (gnu_after_list));
if (TREE_CHAIN (gnu_result))
- gnu_result = build_nt (BLOCK_STMT, gnu_result);
+ gnu_result = build_nt (BLOCK_STMT, gnu_result, NULL_TREE);
}
break;
start_block_stmt ();
process_decls (Visible_Declarations (gnat_node),
Private_Declarations (gnat_node), Empty, 1, 1);
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
break;
case N_Package_Body:
start_block_stmt ();
process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
if (Present (Handled_Statement_Sequence (gnat_node)))
{
start_block_stmt();
process_decls (Declarations (Aux_Decls_Node (gnat_node)),
Empty, Empty, 1, 1);
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
gnat_to_code (Unit (gnat_node));
start_block_stmt ();
add_decl_stmt (gnu_cleanup_decl, gnat_node);
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call);
}
start_block_stmt ();
add_decl_stmt (gnu_jmpsave_decl, gnat_node);
add_decl_stmt (gnu_jmpbuf_decl, gnat_node);
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
TREE_VALUE (gnu_block_stack) = gnu_jmpbuf_decl;
gnu_except_ptr_stack);
start_block_stmt ();
add_decl_stmt (TREE_VALUE (gnu_except_ptr_stack), gnat_node);
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
/* Generate code for each handler. The N_Exception_Handler case
below does the real work. We ignore the dummy exception handler
if (Present (First_Real_Statement (gnat_node)))
process_decls (Statements (gnat_node), Empty,
First_Real_Statement (gnat_node), 1, 1);
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
/* Generate code for each statement in the block. */
for (gnat_temp = (Present (First_Real_Statement (gnat_node))
start_block_stmt ();
add_decl_stmt (gnu_incoming_exc_ptr, gnat_node);
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
expand_expr_stmt
(build_call_1_expr (begin_handler_decl, gnu_incoming_exc_ptr));
expand_decl_cleanup
process_freeze_entity (gnat_node);
start_block_stmt ();
process_decls (Actions (gnat_node), Empty, Empty, 1, 1);
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
break;
case N_Itype_Reference:
TREE_TYPE (gnu_block_stmt) = void_type_node;
}
- BLOCK_STMT_LIST (gnu_block_stmt) = 0;
+ BLOCK_STMT_LIST (gnu_block_stmt) = NULL_TREE;
+ BLOCK_STMT_BLOCK (gnu_block_stmt) = NULL_TREE;
TREE_CHAIN (gnu_block_stmt) = gnu_block_stmt_node;
gnu_block_stmt_node = gnu_block_stmt;
{
TREE_CHAIN (gnu_stmt) = BLOCK_STMT_LIST (gnu_block_stmt_node);
BLOCK_STMT_LIST (gnu_block_stmt_node) = gnu_stmt;
+ TREE_TYPE (gnu_stmt) = void_type_node;
}
/* If this is a DECL_STMT for a variable with DECL_INIT_BY_ASSIGN_P set,
}
/* Return the BLOCK_STMT that corresponds to the statement that add_stmt
- has been emitting or just a single statement if only one. */
+ has been emitting or just a single statement if only one. If FORCE
+ is true, then always emit the BLOCK_STMT. */
static tree
-end_block_stmt ()
+end_block_stmt (bool force)
{
tree gnu_block_stmt = gnu_block_stmt_node;
tree gnu_retval = gnu_block_stmt;
/* If we have only one statement, return it and free this node. Otherwise,
finish setting up this node and return it. If we have no statements,
return a NULL_STMT. */
- if (BLOCK_STMT_LIST (gnu_block_stmt) == 0)
+ if (!force && BLOCK_STMT_LIST (gnu_block_stmt) == 0)
{
gnu_retval = build_nt (NULL_STMT);
TREE_TYPE (gnu_retval) = void_type_node;
}
- else if (TREE_CHAIN (BLOCK_STMT_LIST (gnu_block_stmt)) == 0)
+ else if (!force && TREE_CHAIN (BLOCK_STMT_LIST (gnu_block_stmt)) == 0)
gnu_retval = BLOCK_STMT_LIST (gnu_block_stmt);
else
{
gnat_node = Next (gnat_node))
add_stmt (gnat_to_gnu (gnat_node));
- gnu_result = end_block_stmt ();
+ gnu_result = end_block_stmt (false);
return TREE_CODE (gnu_result) == NULL_STMT ? NULL_TREE : gnu_result;
}
break;
case BLOCK_STMT:
+ if (BLOCK_STMT_BLOCK (gnu_stmt))
+ expand_start_bindings_and_block (0, BLOCK_STMT_BLOCK (gnu_stmt));
+
for (gnu_elmt = BLOCK_STMT_LIST (gnu_stmt); gnu_elmt;
gnu_elmt = TREE_CHAIN (gnu_elmt))
gnat_expand_stmt (gnu_elmt);
+
+ if (BLOCK_STMT_BLOCK (gnu_stmt))
+ expand_end_bindings (NULL_TREE, 1, -1);
break;
case IF_STMT:
}
break;
+ case BREAK_STMT:
+ expand_exit_something ();
+ break;
+
default:
abort ();
}
{
start_block_stmt ();
process_freeze_entity (gnat_decl);
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
process_decls (Actions (gnat_decl), Empty, Empty, 1, 0);
}
/* Concurrent stubs stand for the corresponding subprogram bodies,
which are deferred like other bodies. */
- else if (Nkind (gnat_decl) == N_Task_Body_Stub
- || Nkind (gnat_decl) == N_Protected_Body_Stub)
- ;
-
+ else if (Nkind (gnat_decl) == N_Task_Body_Stub
+ || Nkind (gnat_decl) == N_Protected_Body_Stub)
+ ;
else
{
start_block_stmt ();
gnat_to_code (gnat_decl);
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
}
}
TREE_TYPE (gnu_new));
}
- gnat_expand_stmt (end_block_stmt ());
+ gnat_expand_stmt (end_block_stmt (false));
}
\f
/* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
current_binding_level = newlevel;
}
-/* Exit a binding level. */
+/* Exit a binding level. Return the BLOCK node, if any. */
-void
+tree
gnat_poplevel ()
{
struct ada_binding_level *level = current_binding_level;
parent block. Otherwise, add it to the list of its parent. */
if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL)
;
- else if (BLOCK_VARS (block) == 0)
+ else if (BLOCK_VARS (block) == NULL_TREE)
{
BLOCK_SUBBLOCKS (level->chain->block)
= chainon (BLOCK_SUBBLOCKS (block),
BLOCK_SUBBLOCKS (level->chain->block));
TREE_CHAIN (block) = free_block_chain;
free_block_chain = block;
+ block = NULL_TREE;
}
else
{
current_binding_level = level->chain;
level->chain = free_binding_level;
free_binding_level = level;
+ return block;
}
/* Insert BLOCK at the end of the list of subblocks of the
Params => new Parameter_Array'(1 => Unlimited_Files),
Defext => " "),
+ Metric =>
+ (Cname => new S'("METRIC"),
+ Usage => new S'("GNAT METRIC /qualifiers source_file"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatmetric"),
+ Unixsws => null,
+ Switches => Metric_Switches'Access,
+ Params => new Parameter_Array'(1 => Unlimited_Files),
+ Defext => " "),
+
Name =>
(Cname => new S'("NAME"),
Usage => new S'("GNAT NAME /qualifiers naming-pattern "
-- --
-- S p e c --
-- --
--- Copyright (C) 2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
type Command_Type is
(Bind, Chop, Clean, Compile, Elim, Find, Krunch, Library, Link, List,
- Make, Name, Preprocess, Pretty, Shared, Stub, Xref, Undefined);
+ Make, Name, Preprocess, Pretty, Shared, Stub, Metric, Xref, Undefined);
type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
-- Alternate command libel for non VMS system
-- Ada 95 program.
S_GCC_Ada_95 : aliased constant S := "/95 " &
- "!-gnat83";
+ "-gnat95";
-- /95 (D)
--
- -- Same as /NO83.
- --
- -- /NO95
+ -- Allows GNAT to recognize the full range of Ada 95 constructs.
+ -- This is the normal default for GNAT Pro.
+
+ S_GCC_Ada_05 : aliased constant S := "/05 " &
+ "-gnat05";
+ -- /05 (D)
--
- -- Same as /83.
+ -- Allows GNAT to recognize all implemented proposed Ada 2005
+ -- extensions. See features file for list of implemented features.
S_GCC_Asm : aliased constant S := "/ASM " &
"-S,!-c";
-- /ASM
--
-- Use to cause the assembler source file to be generated, using S as the
- -- filetype, instead of the object file. This may be useful if you need
+ -- filetype, instead of the object file. This may be useful if you need
-- to examine the generated assembly code.
S_GCC_Checks : aliased constant S := "/CHECKS=" &
GCC_Switches : aliased constant Switches :=
(S_GCC_Ada_83 'Access,
S_GCC_Ada_95 'Access,
+ S_GCC_Ada_05 'Access,
S_GCC_Asm 'Access,
S_GCC_Checks 'Access,
S_GCC_ChecksX 'Access,
S_Make_Use_Map 'Access,
S_Make_Verbose 'Access);
+ ------------------------------
+ -- Switches for GNAT METRIC --
+ ------------------------------
+
+ S_Metric_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" &
+ "-gnatec>";
+ -- /CONFIGURATION_PRAGMAS_FILE=file
+ --
+ -- Specify a configuration pragmas file that need to be taken into account
+
+ S_Metric_Current : aliased constant S := "/CURRENT_DIRECTORY " &
+ "!-I-";
+ -- /CURRENT_DIRECTORY (D)
+ --
+ -- Look for files in the directory where GNAT METRIC was invoked
+ --
+ -- /NOCURRENT_DIRECTORY
+ --
+ -- Do not look for files in the directory where GNAT METRIC was invoked
+
+ S_Metric_Debug : aliased constant S := "/DEBUG_OUTPUT " &
+ "-dv";
+ -- /DEBUG_OUTPUT
+
+ S_Metric_Element : aliased constant S := "/ELEMENT_METRICS=" &
+ "ALL " &
+ "!-ed,!-es,!-enl,!-eis," &
+ "!-eas,!-eit,!-eat,!-enu " &
+ "DECLARATION_TOTAL " &
+ "-ed " &
+ "STATEMENT_TOTAL " &
+ "-es " &
+ "LOOP_NESTING_MAX " &
+ "-enl " &
+ "INT_SUBPROGRAMS " &
+ "-eis " &
+ "SUBPROGRAMS_ALL " &
+ "-eas " &
+ "INT_TYPES " &
+ "-eit " &
+ "TYPES_ALL " &
+ "-eat " &
+ "PROGRAM_NESTING_MAX " &
+ "-enu";
+ -- /ELEMENT_METRICS=(option, option ...)
+
+ S_Metric_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
+ "-X" & '"';
+ -- /EXTERNAL_REFERENCE="name=val"
+ --
+ -- Specifies an external reference to the project manager. Useful only if
+ -- /PROJECT_FILE is used.
+ --
+ -- Example:
+ -- /EXTERNAL_REFERENCE="DEBUG=TRUE"
+
+ S_Metric_Format : aliased constant S := "/FORMAT_OUTPUT=" &
+ "DEFAULT " &
+ "!-x,!-nt,!-sfn " &
+ "XML " &
+ "-x " &
+ "NO_TEXT " &
+ "-nt " &
+ "SHORT_SOURCE_FILE_NAME " &
+ "-sfn";
+ -- /FORMAT_OUTPUT=(option, option ...)
+
+ S_Metric_Globout : aliased constant S := "/GLOBAL_OUTPUT=@" &
+ "-og@";
+ -- /GLOBAL_OUTPUT=filename
+
+ S_Metric_Line : aliased constant S := "/LINE_METRICS=" &
+ "ALL " &
+ "!-la,!-lcode,!-lcomm," &
+ "!-leol,!-lb " &
+ "LINES_ALL " &
+ "-la " &
+ "CODE_LINES " &
+ "-lcode " &
+ "COMENT_LINES " &
+ "-lcomm " &
+ "MIXED_CODE_COMMENTS " &
+ "-leol " &
+ "BLANK_LINES " &
+ "-lb ";
+ -- /LINE_METRICS=(option, option ...)
+
+ S_Metric_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
+ "DEFAULT " &
+ "-vP0 " &
+ "MEDIUM " &
+ "-vP1 " &
+ "HIGH " &
+ "-vP2";
+ -- /MESSAGES_PROJECT_FILE[=messages-option]
+ --
+ -- Specifies the "verbosity" of the parsing of project files.
+ -- messages-option may be one of the following:
+ --
+ -- DEFAULT (D) No messages are output if there is no error or warning.
+ --
+ -- MEDIUM A small number of messages are output.
+ --
+ -- HIGH A great number of messages are output, most of them not
+ -- being useful for the user.
+
+ S_Metric_Project : aliased constant S := "/PROJECT_FILE=<" &
+ "-P>";
+ -- /PROJECT_FILE=filename
+ --
+ -- Specifies the main project file to be used. The project files rooted
+ -- at the main project file will be parsed before the invocation of the
+ -- binder.
+
+ S_Metric_Quiet : aliased constant S := "/QUIET " &
+ "-q";
+ -- /QUIET
+
+ S_Metric_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+ -- /SEARCH=(directory[,...])
+
+ S_Metric_Suffix : aliased constant S := "/SUFFIX_DETAILS=" & '"' &
+ "-o" & '"';
+ -- /SUFFIX_DETAILS=suffix
+
+ S_Metric_Suppress : aliased constant S := "/SUPPRESS=" &
+ "NOTHING " &
+ "!-nocc,!-noec,!-nonl," &
+ "!-ne,!-nolocal " &
+ "CYCLOMATIC_COMPLEXITY " &
+ "-nocc " &
+ "ESSENTIAL_COMPLEXITY " &
+ "-noec " &
+ "MAXIMAL_LOOP_NESTING " &
+ "-nonl " &
+ "EXITS_AS_GOTOS " &
+ "-ne " &
+ "LOCAL_DETAILS " &
+ "-nolocal ";
+ -- /SUPPRESS=(option, option ...)
+
+ S_Metric_Verbose : aliased constant S := "/VERBOSE " &
+ "-v";
+ -- /VERBOSE
+
+ S_Metric_XMLout : aliased constant S := "/XML_OUTPUT=@" &
+ "-ox@";
+ -- /XML_OUTPUT=filename
+
+ Metric_Switches : aliased constant Switches :=
+ (S_Metric_Config 'Access,
+ S_Metric_Current 'Access,
+ S_Metric_Debug 'Access,
+ S_Metric_Element 'Access,
+ S_Metric_Ext 'Access,
+ S_Metric_Format 'Access,
+ S_Metric_Globout 'Access,
+ S_Metric_Line 'Access,
+ S_Metric_Mess 'Access,
+ S_Metric_Project 'Access,
+ S_Metric_Quiet 'Access,
+ S_Metric_Search 'Access,
+ S_Metric_Suffix 'Access,
+ S_Metric_Suppress 'Access,
+ S_Metric_Verbose 'Access,
+ S_Metric_XMLout 'Access);
+
----------------------------
-- Switches for GNAT NAME --
----------------------------
projects / gcc.git / commitdiff