-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
with System.OS_Primitives;
-- used for Delay_Modes
-with Unchecked_Conversion;
with Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
procedure Set_OS_Priority (T : Task_ID; Prio : System.Any_Priority);
-- This procedure calls the scheduler of the OS to set thread's priority
- function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
-
-------------------
-- Abort_Handler --
-------------------
-- Make sure signals used for RTS internal purpose are unmasked
- Result := pthread_sigmask (SIG_UNBLOCK,
- Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
+ Result :=
+ pthread_sigmask (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access,
+ Old_Set'Unchecked_Access);
pragma Assert (Result = 0);
raise Standard'Abort_Signal;
Adjusted_Stack_Size : Interfaces.C.size_t;
Result : Interfaces.C.int;
- function Thread_Body_Access is new
- Unchecked_Conversion (System.Address, Thread_Body);
-
use System.Task_Info;
begin
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
with System.OS_Primitives;
-- used for Delay_Modes
-with Unchecked_Conversion;
with Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
procedure Abort_Handler (Sig : Signal);
-- Signal handler used to implement asynchronous abortion.
- function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
-
-------------------
-- Abort_Handler --
-------------------
Result : Interfaces.C.int;
Param : aliased System.OS_Interface.struct_sched_param;
- function Thread_Body_Access is new
- Unchecked_Conversion (System.Address, Thread_Body);
-
use System.Task_Info;
begin
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- If the key value is Null, then it is a non-Ada task.
if Result /= System.Null_Address then
- return To_Task_Id (Result);
+ return To_Task_ID (Result);
else
return Register_Foreign_Thread;
end if;
function Thread_Body_Access is new
Unchecked_Conversion (System.Address, Thread_Body);
- type pthread_t is private;
+ type pthread_t is new unsigned_long;
subtype Thread_Id is pthread_t;
+ function To_pthread_t is new Unchecked_Conversion
+ (unsigned_long, pthread_t);
+
type pthread_mutex_t is limited private;
type pthread_cond_t is limited private;
type pthread_attr_t is limited private;
end record;
pragma Convention (C, pthread_mutexattr_t);
- type pthread_t is new unsigned_long;
-
type struct_pthread_fast_lock is record
status : long;
spinlock : int;
procedure Abort_Handler (signo : Signal);
- function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
-
function To_pthread_t is new Unchecked_Conversion
(unsigned_long, System.OS_Interface.pthread_t);
Attributes : aliased pthread_attr_t;
Result : Interfaces.C.int;
- function Thread_Body_Access is new
- Unchecked_Conversion (System.Address, Thread_Body);
-
begin
if Stack_Size = Unspecified_Size then
Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
THR_NEW_LWP : constant := 2;
USYNC_THREAD : constant := 0;
- type thread_t is private;
+ type thread_t is new unsigned;
subtype Thread_Id is thread_t;
+ -- These types should be commented ???
+
+ function To_thread_t is new Unchecked_Conversion (Integer, thread_t);
type mutex_t is limited private;
end record;
pragma Convention (C, struct_timeval);
- type thread_t is new unsigned;
-
type array_type_9 is array (0 .. 3) of unsigned_char;
type record_type_3 is record
flag : array_type_9;
with System.OS_Primitives;
-- used for Delay_Modes
-with Unchecked_Conversion;
with Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
-- Local Subprograms --
-----------------------
- function sysconf (name : System.OS_Interface.int)
- return processorid_t;
+ function sysconf (name : System.OS_Interface.int) return processorid_t;
pragma Import (C, sysconf, "sysconf");
SC_NPROCESSORS_CONF : constant System.OS_Interface.int := 14;
- function Num_Procs (name : System.OS_Interface.int := SC_NPROCESSORS_CONF)
- return processorid_t renames sysconf;
+ function Num_Procs
+ (name : System.OS_Interface.int := SC_NPROCESSORS_CONF)
+ return processorid_t renames sysconf;
procedure Abort_Handler
(Sig : Signal;
-- the raising of the Abort_Signal exception.
-- See also comments in 7staprop.adb
- function To_thread_t is new Unchecked_Conversion
- (Integer, System.OS_Interface.thread_t);
-
- function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
-
- function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
-
- function Thread_Body_Access is
- new Unchecked_Conversion (System.Address, Thread_Body);
-
------------
-- Checks --
------------
- function Check_Initialize_Lock (L : Lock_Ptr; Level : Lock_Level)
- return Boolean;
+ function Check_Initialize_Lock
+ (L : Lock_Ptr;
+ Level : Lock_Level) return Boolean;
pragma Inline (Check_Initialize_Lock);
function Check_Lock (L : Lock_Ptr) return Boolean;
pragma Inline (Check_Sleep);
function Record_Wakeup
- (L : Lock_Ptr;
+ (L : Lock_Ptr;
Reason : Task_States) return Boolean;
pragma Inline (Record_Wakeup);
function Check_Wakeup
- (T : Task_ID;
+ (T : Task_ID;
Reason : Task_States) return Boolean;
pragma Inline (Check_Wakeup);
Lock_Count : Integer := 0;
Unlock_Count : Integer := 0;
- function To_Lock_Ptr is
- new Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr);
- function To_Owner_ID is
- new Unchecked_Conversion (Task_ID, Owner_ID);
-
-------------------
-- Abort_Handler --
-------------------
function Check_Initialize_Lock
(L : Lock_Ptr;
- Level : Lock_Level)
- return Boolean
+ Level : Lock_Level) return Boolean
is
Self_ID : constant Task_ID := Self;
-- Check that caller is not holding this lock already
- if L.Owner = To_Owner_ID (Self_ID) then
+ if L.Owner = To_Owner_ID (To_Address (Self_ID)) then
return False;
end if;
-- Record new owner
- L.Owner := To_Owner_ID (Self_ID);
+ L.Owner := To_Owner_ID (To_Address (Self_ID));
if Single_Lock then
return True;
function Record_Wakeup
(L : Lock_Ptr;
- Reason : Task_States)
- return Boolean
+ Reason : Task_States) return Boolean
is
pragma Unreferenced (Reason);
begin
-- Record new owner
- L.Owner := To_Owner_ID (Self_ID);
+ L.Owner := To_Owner_ID (To_Address (Self_ID));
if Single_Lock then
return True;
function Check_Wakeup
(T : Task_ID;
- Reason : Task_States)
- return Boolean
+ Reason : Task_States) return Boolean
is
Self_ID : constant Task_ID := Self;
begin
-- Is caller holding T's lock?
- if T.Common.LL.L.Owner /= To_Owner_ID (Self_ID) then
+ if T.Common.LL.L.Owner /= To_Owner_ID (To_Address (Self_ID)) then
return False;
end if;
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 /= 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 T.Common.LL.Thread /= Thread_Self then
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
--- This is a Solaris version of this package.
--- It was created by hand for use with new "checked"
--- GNULLI primitives.
+-- This is a Solaris version of this package
-- This package provides low-level support for most tasking features.
-- cond_t
-- thread_t
+with Unchecked_Conversion;
+
package System.Task_Primitives is
pragma Preelaborate;
type Lock is limited private;
type Lock_Ptr is access all Lock;
- -- Should be used for implementation of protected objects.
+ -- Should be used for implementation of protected objects
type RTS_Lock is limited private;
type RTS_Lock_Ptr is access all RTS_Lock;
-- one serves only as a semaphore so that do not check for
-- ceiling violations.
+ function To_Lock_Ptr is new Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr);
+
type Task_Body_Access is access procedure;
-- Pointer to the task body's entry point (or possibly a wrapper
-- declared local to the GNARL).
type Owner_ID is access all Owner_Int;
+ function To_Owner_ID is
+ new Unchecked_Conversion (System.Address, Owner_ID);
+
type Lock is record
- L : aliased Base_Lock;
- Ceiling : System.Any_Priority := System.Any_Priority'First;
+ L : aliased Base_Lock;
+ Ceiling : System.Any_Priority := System.Any_Priority'First;
Saved_Priority : System.Any_Priority := System.Any_Priority'First;
- Owner : Owner_ID;
- Next : Lock_Ptr;
- Level : Private_Task_Serial_Number := 0;
- Buddy : Owner_ID;
- Frozen : Boolean := False;
+ Owner : Owner_ID;
+ Next : Lock_Ptr;
+ Level : Private_Task_Serial_Number := 0;
+ Buddy : Owner_ID;
+ Frozen : Boolean := False;
end record;
type RTS_Lock is new Lock;
LWP : System.OS_Interface.lwpid_t;
-- The LWP id of the thread. Set by self in Enter_Task.
- CV : aliased System.OS_Interface.cond_t;
- L : aliased RTS_Lock;
- -- protection for all components is lock L
+ CV : aliased System.OS_Interface.cond_t;
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
Active_Priority : System.Any_Priority := System.Any_Priority'First;
-- Simulated active priority,
-- used only if Priority_Ceiling_Support is True.
Locking : Lock_Ptr;
- Locks : Lock_Ptr;
+ Locks : Lock_Ptr;
Wakeups : Natural := 0;
end record;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
with System.Task_Info;
-- used for Unspecified_Task_Info
-with Unchecked_Conversion;
with Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
(Thread : Thread_Id) return Task_ID is separate;
----------------------------------
- -- Utility Conversion Functions --
- ----------------------------------
-
- function To_Task_Id is new Unchecked_Conversion (System.Address, Task_ID);
-
- function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
-
- ----------------------------------
-- Condition Variable Functions --
----------------------------------
----------
function Self return Task_ID is
- Self_Id : constant Task_ID := To_Task_Id (TlsGetValue (TlsIndex));
-
+ Self_Id : constant Task_ID := To_Task_ID (TlsGetValue (TlsIndex));
begin
if Self_Id = null then
return Register_Foreign_Thread (GetCurrentThread);
Result : DWORD;
Entry_Point : PTHREAD_START_ROUTINE;
- function To_PTHREAD_START_ROUTINE is new
- Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE);
-
begin
pTaskParameter := To_Address (T);
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 /= 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 T.Common.LL.Thread /= Thread_Self then
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Fundation, Inc. --
+-- Copyright (C) 1992-2004, Free Software Fundation, Inc. --
-- --
-- GNARL 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- --
----------
function Self return Task_ID is
-
begin
- return To_Task_Id (pthread_getspecific (ATCB_Key));
+ return To_Task_ID (pthread_getspecific (ATCB_Key));
end Self;
end Specific;
+2004-03-05 Robert Dewar <dewar@gnat.com>
+
+ * 56taprop.adb, 5ataprop.adb: Remove unneeded unchecked conversions
+
+ * a-tags.adb, a-tags.ads, s-finimp.adb, s-finroo.ads,
+ i-cpoint.ads, i-cpoint.adb, i-cstrin.adb, i-cstrin.ads,
+ 5iosinte.ads, 5sosinte.ads, 5staspri.ads, 5itaprop.adb,
+ 5staprop.adb, 5wtaprop.adb, s-tataat.ads, s-tataat.adb: Move
+ unchecked conversion to spec to avoid warnings.
+
+ * s-tasini.adb, s-taskin.ads, 5atpopsp.adb: Correct spelling Task_Id
+ to Task_ID
+
+ * 7stpopsp.adb: Correct casing in To_Task_ID call
+
+ * a-strsea.ads, a-strsea.adb: Minor reformatting
+
+ * einfo.ads, einfo.adb: Define new flag No_Strict_Aliasing
+
+ * errout.ads: Switch for VMS is now NO_STRICT_ALIASING.
+ Adjust Max_Msg_Length to be clearly large enough.
+
+ * fe.h: Define In_Same_Source_Unit
+
+ * osint.adb: Add pragma Warnings Off to suppress warnings
+ * g-dyntab.adb, g-table.adb, g-thread.adb: Add Warnings (Off) to kill
+ aliasing warnings.
+
+ * opt.ads: Put entries in alpha order. Add entry for No_Strict_Aliasing
+
+ * par-prag.adb: Add dummy entry for No_Strict_Aliasing pragma
+
+ * sem_ch13.adb: Generate validate unchecked conversion nodes for gcc.
+
+ * sem_ch3.adb: Set No_Strict_Aliasing flag if config pragma set.
+
+ * sem_prag.adb: Implement pragma No_Strict_Aliasing.
+
+ * sinfo.ads: Remove obsolete comment on validate unchecked conversion
+ node. We now do generate them for gcc back end.
+
+ * table.adb, sinput.adb: Add pragma Warnings Off to suppress aliasing
+ warning.
+
+ * sinput-c.adb: Fix bad name in header.
+ Add pragma Warnings Off to suppress aliasing warning.
+
+ * sinput-l.adb: Add pragma Warnings Off to suppress aliasing warning.
+
+ * snames.h, snames.ads, snames.adb: Add entry for pragma
+ No_Strict_Aliasing.
+
+2004-03-05 Vincent Celier <celier@gnat.com>
+
+ * prj-com.ads: Add hash table Files_Htable to check when a file name
+ is already a source of another project.
+
+ * prj-nmsc.adb (Record_Source): Before recording a new source, check
+ if its file name is not already a source of another project. Report an
+ error if it is.
+
+ * gnatcmd.adb: When GNAT PRETTY is invoked with a project file and no
+ source file name, call gnatpp with all the sources of the main project.
+
+ * vms_conv.adb (Initialize): GNAT PRETTY may be called with any number
+ of file names.
+
+ * vms_data.ads: Correct documentation of new /OPTIMIZE keyword
+ NO_STRICT_ALIASING. Add new qualifier for GNAT PRETTY:
+ /RUNTIME_SYSTEM=, converted to --RTS=
+ /NOTABS, converted to -notabs
+
+2004-03-05 Pascal Obry <obry@gnat.com>
+
+ * make.adb: Minor reformatting.
+
+2004-03-05 Ed Schonberg <schonberg@gnat.com>
+
+ Part of implemention of AI-262.
+ * par-ch10.adb (P_Context_Clause): Recognize private with_clauses.
+
+ * sem_ch10.ads, sem_ch10.adb: (Install_Private_With_Clauses): New
+ procedure.
+
+ * sem_ch3.adb (Analyze_Component_Declaration): Improve error message
+ when component type is a partially constrained class-wide subtype.
+ (Constrain_Discriminated_Type): If parent type has unknown
+ discriminants, a constraint is illegal, even if full view has
+ discriminants.
+ (Build_Derived_Record_Type): Inherit discriminants when deriving a type
+ with unknown discriminants whose full view is a discriminated record.
+
+ * sem_ch7.adb (Preserve_Full_Attributes): Preserve Has_Discriminants
+ flag, to handle properly derivations of tagged types with unknown
+ discriminants.
+ (Analyze_Package_Spec, Analyze_Package_Body): Install
+ Private_With_Clauses before analyzing private part or body.
+
+ * einfo.ads: Indicate that both Has_Unknown_Discriminants and
+ Has_Discriminants can be true for a given type (documentation).
+
+2004-03-05 Arnaud Charlet <charlet@act-europe.fr>
+
+ * s-restri.ads: Fix license (GPL->GMGPL).
+
+ * s-tassta.adb: Minor reformatting.
+
+ * s-tasren.adb: Replace manual handling of Self_Id.ATC_Nesting_Level
+ by calls to Exit_One_ATC_Level, since additional clean up is performed
+ by this function.
+
+ * s-tpobop.adb: Replace manual handling of Self_Id.ATC_Nesting_Level
+ by calls to Exit_One_ATC_Level, since additional clean up is performed
+ by this function.
+
+2004-03-05 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
+
+ * trans.c: Reflect GCC changes to fix bootstrap problem.
+ Add warning for suspicious aliasing unchecked conversion.
+
+2004-03-05 GNAT Script <nobody@gnat.com>
+
+ * Make-lang.in: Makefile automatically updated
+
2004-03-02 Emmanuel Briot <briot@act-europe.fr>
* ali.adb (Read_Instantiation_Instance): Do not modify the
ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \
ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \
- ada/scng.adb ada/sem.ads ada/sem_cat.ads ada/sem_ch12.ads \
- ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch7.adb \
- ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \
- ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \
- ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \
- ada/snames.adb ada/stand.ads ada/stringt.ads ada/style.ads \
- ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \
- ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \
- ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
- ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads ada/widechar.ads
+ ada/scng.adb ada/sem.ads ada/sem_cat.ads ada/sem_ch10.ads \
+ ada/sem_ch12.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \
+ ada/sem_ch7.adb ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads \
+ ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \
+ ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \
+ ada/snames.ads ada/snames.adb ada/stand.ads ada/stringt.ads \
+ ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \
+ ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \
+ ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/widechar.ads
ada/sem_ch8.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \
-- --
-- B o d y --
-- --
--- Copyright (C) 1992,1993,1994,1995,1996 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- --
function Belongs
(Element : Character;
Set : Maps.Character_Set;
- Test : Membership)
- return Boolean;
+ Test : Membership) return Boolean;
pragma Inline (Belongs);
-- Determines if the given element is in (Test = Inside) or not in
-- (Test = Outside) the given character set.
function Belongs
(Element : Character;
Set : Maps.Character_Set;
- Test : Membership)
- return Boolean
+ Test : Membership) return Boolean
is
begin
if Test = Inside then
-----------
function Count
- (Source : in String;
- Pattern : in String;
- Mapping : in Maps.Character_Mapping := Maps.Identity)
- return Natural
+ (Source : String;
+ Pattern : String;
+ Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
is
N : Natural;
J : Natural;
end Count;
function Count
- (Source : in String;
- Pattern : in String;
- Mapping : in Maps.Character_Mapping_Function)
- return Natural
+ (Source : String;
+ Pattern : String;
+ Mapping : Maps.Character_Mapping_Function) return Natural
is
Mapped_Source : String (Source'Range);
N : Natural;
end Count;
function Count
- (Source : in String;
- Set : in Maps.Character_Set)
- return Natural
+ (Source : String;
+ Set : Maps.Character_Set) return Natural
is
N : Natural := 0;
----------------
procedure Find_Token
- (Source : in String;
- Set : in Maps.Character_Set;
- Test : in Membership;
+ (Source : String;
+ Set : Maps.Character_Set;
+ Test : Membership;
First : out Positive;
Last : out Natural)
is
-----------
function Index
- (Source : in String;
- Pattern : in String;
- Going : in Direction := Forward;
- Mapping : in Maps.Character_Mapping := Maps.Identity)
- return Natural
+ (Source : String;
+ Pattern : String;
+ Going : Direction := Forward;
+ Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
is
Cur_Index : Natural;
Mapped_Source : String (Source'Range);
return 0;
end Index;
- function Index (Source : in String;
- Pattern : in String;
- Going : in Direction := Forward;
- Mapping : in Maps.Character_Mapping_Function)
- return Natural
+ function Index
+ (Source : String;
+ Pattern : String;
+ Going : Direction := Forward;
+ Mapping : Maps.Character_Mapping_Function) return Natural
is
Mapped_Source : String (Source'Range);
Cur_Index : Natural;
end Index;
function Index
- (Source : in String;
- Set : in Maps.Character_Set;
- Test : in Membership := Inside;
- Going : in Direction := Forward)
- return Natural
+ (Source : String;
+ Set : Maps.Character_Set;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural
is
begin
-- Forwards case
---------------------
function Index_Non_Blank
- (Source : in String;
- Going : in Direction := Forward)
- return Natural
+ (Source : String;
+ Going : Direction := Forward) return Natural
is
begin
if Going = Forward then
-- --
-- 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- --
pragma Preelaborate (Search);
function Index
- (Source : in String;
- Pattern : in String;
- Going : in Direction := Forward;
- Mapping : in Maps.Character_Mapping := Maps.Identity)
- return Natural;
+ (Source : String;
+ Pattern : String;
+ Going : Direction := Forward;
+ Mapping : Maps.Character_Mapping := Maps.Identity) return Natural;
function Index
- (Source : in String;
- Pattern : in String;
- Going : in Direction := Forward;
- Mapping : in Maps.Character_Mapping_Function)
- return Natural;
+ (Source : String;
+ Pattern : String;
+ Going : Direction := Forward;
+ Mapping : Maps.Character_Mapping_Function) return Natural;
function Index
- (Source : in String;
- Set : in Maps.Character_Set;
- Test : in Membership := Inside;
- Going : in Direction := Forward)
- return Natural;
+ (Source : String;
+ Set : Maps.Character_Set;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
function Index_Non_Blank
- (Source : in String;
- Going : in Direction := Forward)
- return Natural;
+ (Source : String;
+ Going : Direction := Forward) return Natural;
function Count
- (Source : in String;
- Pattern : in String;
- Mapping : in Maps.Character_Mapping := Maps.Identity)
- return Natural;
+ (Source : String;
+ Pattern : String;
+ Mapping : Maps.Character_Mapping := Maps.Identity) return Natural;
function Count
- (Source : in String;
- Pattern : in String;
- Mapping : in Maps.Character_Mapping_Function)
- return Natural;
+ (Source : String;
+ Pattern : String;
+ Mapping : Maps.Character_Mapping_Function) return Natural;
function Count
- (Source : in String;
- Set : in Maps.Character_Set)
- return Natural;
-
+ (Source : String;
+ Set : Maps.Character_Set) return Natural;
procedure Find_Token
- (Source : in String;
- Set : in Maps.Character_Set;
- Test : in Membership;
+ (Source : String;
+ Set : Maps.Character_Set;
+ Test : Membership;
First : out Positive;
Last : out Natural);
-- --
-- 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- --
Prims_Ptr : Address_Array (Positive);
end record;
- -------------------------------------------
- -- Unchecked Conversions for Tag and TSD --
- -------------------------------------------
-
- function To_Type_Specific_Data_Ptr is
- new Unchecked_Conversion (S.Address, Type_Specific_Data_Ptr);
-
- function To_Address is
- new Unchecked_Conversion (Type_Specific_Data_Ptr, S.Address);
-
---------------------------------------------
-- Unchecked Conversions for String Fields --
---------------------------------------------
function To_Cstring_Ptr is
- new Unchecked_Conversion (S.Address, Cstring_Ptr);
+ new Unchecked_Conversion (System.Address, Cstring_Ptr);
function To_Address is
- new Unchecked_Conversion (Cstring_Ptr, S.Address);
+ new Unchecked_Conversion (Cstring_Ptr, System.Address);
-----------------------
-- Local Subprograms --
package HTable_Subprograms is
procedure Set_HT_Link (T : Tag; Next : Tag);
function Get_HT_Link (T : Tag) return Tag;
- function Hash (F : S.Address) return HTable_Headers;
- function Equal (A, B : S.Address) return Boolean;
+ function Hash (F : System.Address) return HTable_Headers;
+ function Equal (A, B : System.Address) return Boolean;
end HTable_Subprograms;
package External_Tag_HTable is new System.HTable.Static_HTable (
Null_Ptr => null,
Set_Next => HTable_Subprograms.Set_HT_Link,
Next => HTable_Subprograms.Get_HT_Link,
- Key => S.Address,
+ Key => System.Address,
Get_Key => Get_External_Tag,
Hash => HTable_Subprograms.Hash,
Equal => HTable_Subprograms.Equal);
-- Equal --
-----------
- function Equal (A, B : S.Address) return Boolean is
+ function Equal (A, B : System.Address) return Boolean is
Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
J : Integer := 1;
-- Hash --
----------
- function Hash (F : S.Address) return HTable_Headers is
+ function Hash (F : System.Address) return HTable_Headers is
function H is new System.HTable.Hash (HTable_Headers);
Str : constant Cstring_Ptr := To_Cstring_Ptr (F);
Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
-- Get_Expanded_Name --
-----------------------
- function Get_Expanded_Name (T : Tag) return S.Address is
+ function Get_Expanded_Name (T : Tag) return System.Address is
begin
return To_Address (T.TSD.Expanded_Name);
end Get_Expanded_Name;
-- Get_External_Tag --
----------------------
- function Get_External_Tag (T : Tag) return S.Address is
+ function Get_External_Tag (T : Tag) return System.Address is
begin
return To_Address (T.TSD.External_Tag);
end Get_External_Tag;
function Get_Prim_Op_Address
(T : Tag;
- Position : Positive)
- return S.Address
+ Position : Positive) return System.Address
is
begin
return T.Prims_Ptr (Position);
-- Get_TSD --
-------------
- function Get_TSD (T : Tag) return S.Address is
+ function Get_TSD (T : Tag) return System.Address is
begin
return To_Address (T.TSD);
end Get_TSD;
-- Inherit_TSD --
-----------------
- procedure Inherit_TSD (Old_TSD : S.Address; New_Tag : Tag) is
+ procedure Inherit_TSD (Old_TSD : System.Address; New_Tag : Tag) is
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (Old_TSD);
New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
-- Parent_Size --
-----------------
- type Acc_Size is access function (A : S.Address) return Long_Long_Integer;
- function To_Acc_Size is new Unchecked_Conversion (S.Address, Acc_Size);
+ type Acc_Size
+ is access function (A : System.Address) return Long_Long_Integer;
+
+ function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
-- The profile of the implicitly defined _size primitive
function Parent_Size
- (Obj : S.Address;
- T : Tag)
- return SSE.Storage_Count is
-
+ (Obj : System.Address;
+ T : Tag) return SSE.Storage_Count
+ is
Parent_Tag : constant Tag := T.TSD.Ancestor_Tags (1);
-- The tag of the parent type through the dispatch table
-- Set_Expanded_Name --
-----------------------
- procedure Set_Expanded_Name (T : Tag; Value : S.Address) is
+ procedure Set_Expanded_Name (T : Tag; Value : System.Address) is
begin
T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
end Set_Expanded_Name;
-- Set_External_Tag --
----------------------
- procedure Set_External_Tag (T : Tag; Value : S.Address) is
+ procedure Set_External_Tag (T : Tag; Value : System.Address) is
begin
T.TSD.External_Tag := To_Cstring_Ptr (Value);
end Set_External_Tag;
procedure Set_Prim_Op_Address
(T : Tag;
Position : Positive;
- Value : S.Address)
+ Value : System.Address)
is
begin
T.Prims_Ptr (Position) := Value;
-- Set_TSD --
-------------
- procedure Set_TSD (T : Tag; Value : S.Address) is
+ procedure Set_TSD (T : Tag; Value : System.Address) is
begin
T.TSD := To_Type_Specific_Data_Ptr (Value);
end Set_TSD;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 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 --
with System;
with System.Storage_Elements;
+with Unchecked_Conversion;
package Ada.Tags is
-- initialize those structures and uses the GET functions to
-- retreive the information when needed
- package S renames System;
package SSE renames System.Storage_Elements;
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
-- Given the tag of an object and the tag associated to a type, return
-- true if Obj is in Typ'Class.
- function Get_Expanded_Name (T : Tag) return S.Address;
+ function Get_Expanded_Name (T : Tag) return System.Address;
-- Retrieve the address of a null terminated string containing
-- the expanded name
- function Get_External_Tag (T : Tag) return S.Address;
+ function Get_External_Tag (T : Tag) return System.Address;
-- Retrieve the address of a null terminated string containing
-- the external name
function Get_Prim_Op_Address
(T : Tag;
- Position : Positive)
- return S.Address;
+ Position : Positive) return System.Address;
-- Given a pointer to a dispatch Table (T) and a position in the DT
-- this function returns the address of the virtual function stored
-- in it (used for dispatching calls)
function Get_Remotely_Callable (T : Tag) return Boolean;
-- Return the value previously set by Set_Remotely_Callable
- function Get_TSD (T : Tag) return S.Address;
+ function Get_TSD (T : Tag) return System.Address;
-- Given a pointer T to a dispatch Table, retreives the address of the
-- record containing the Type Specific Data generated by GNAT
-- of the direct ancestor and the number of primitive ops that are
-- inherited (Entry_Count).
- procedure Inherit_TSD (Old_TSD : S.Address; New_Tag : Tag);
+ procedure Inherit_TSD (Old_TSD : System.Address; New_Tag : Tag);
-- Entry point used to initialize the TSD of a type knowing the
-- TSD of the direct ancestor.
function Parent_Size
- (Obj : S.Address;
- T : Tag)
- return SSE.Storage_Count;
+ (Obj : System.Address;
+ T : Tag) return SSE.Storage_Count;
-- Computes the size the ancestor part of a tagged extension object
-- whose address is 'obj' by calling the indirectly _size function of
-- the ancestor. The ancestor is the parent of the type represented by
procedure Set_Prim_Op_Address
(T : Tag;
Position : Positive;
- Value : S.Address);
+ Value : System.Address);
-- Given a pointer to a dispatch Table (T) and a position in the
-- dispatch Table put the address of the virtual function in it
-- (used for overriding)
- procedure Set_TSD (T : Tag; Value : S.Address);
+ procedure Set_TSD (T : Tag; Value : System.Address);
-- Given a pointer T to a dispatch Table, stores the address of the record
-- containing the Type Specific Data generated by GNAT
- procedure Set_Expanded_Name (T : Tag; Value : S.Address);
+ procedure Set_Expanded_Name (T : Tag; Value : System.Address);
-- Set the address of the string containing the expanded name
-- in the Dispatch table
- procedure Set_External_Tag (T : Tag; Value : S.Address);
+ procedure Set_External_Tag (T : Tag; Value : System.Address);
-- Set the address of the string containing the external tag
-- in the Dispatch table
DT_Prologue_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
- (Standard'Address_Size / S.Storage_Unit);
+ (Standard'Address_Size / System.Storage_Unit);
-- Size of the first part of the dispatch table
DT_Entry_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
- (Standard'Address_Size / S.Storage_Unit);
+ (Standard'Address_Size / System.Storage_Unit);
-- Size of each primitive operation entry in the Dispatch Table.
TSD_Prologue_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
- (6 * Standard'Address_Size / S.Storage_Unit);
+ (6 * Standard'Address_Size / System.Storage_Unit);
-- Size of the first part of the type specific data
TSD_Entry_Size : constant SSE.Storage_Count :=
- SSE.Storage_Count (Standard'Address_Size / S.Storage_Unit);
+ SSE.Storage_Count (Standard'Address_Size / System.Storage_Unit);
-- Size of each ancestor tag entry in the TSD
- type Address_Array is array (Natural range <>) of S.Address;
+ type Address_Array is array (Natural range <>) of System.Address;
type Dispatch_Table;
type Tag is access all Dispatch_Table;
type Type_Specific_Data;
type Type_Specific_Data_Ptr is access all Type_Specific_Data;
+ function To_Type_Specific_Data_Ptr is
+ new Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
+
+ function To_Address is
+ new Unchecked_Conversion (Type_Specific_Data_Ptr, System.Address);
+
+ -- Primitive dispatching operations are always inlined, to facilitate
+ -- use in a minimal/no run-time environment for high integrity use.
+
pragma Inline_Always (CW_Membership);
pragma Inline_Always (Get_Expanded_Name);
pragma Inline_Always (Get_Inheritance_Depth);
-- Is_VMS_Exception Flag133
-- Is_Optional_Parameter Flag134
-- Has_Aliased_Components Flag135
+ -- No_Strict_Aliasing Flag136
-- Is_Machine_Code_Subprogram Flag137
-- Is_Packed_Array_Type Flag138
-- Has_Biased_Representation Flag139
-- Remaining flags are currently unused and available
- -- (unused) Flag136
-- (unused) Flag183
--------------------------------
return Flag113 (Id);
end No_Return;
+ function No_Strict_Aliasing (Id : E) return B is
+ begin
+ pragma Assert (Is_Access_Type (Id));
+ return Flag136 (Base_Type (Id));
+ end No_Strict_Aliasing;
+
function Non_Binary_Modulus (Id : E) return B is
begin
pragma Assert (Is_Modular_Integer_Type (Id));
Set_Flag113 (Id, V);
end Set_No_Return;
+ procedure Set_No_Strict_Aliasing (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Access_Type (Id) and then Base_Type (Id) = Id);
+ Set_Flag136 (Id, V);
+ end Set_No_Strict_Aliasing;
+
+
procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Modular_Integer_Type);
W ("Never_Set_In_Source", Flag115 (Id));
W ("No_Pool_Assigned", Flag131 (Id));
W ("No_Return", Flag113 (Id));
+ W ("No_Strict_Aliasing", Flag136 (Id));
W ("Non_Binary_Modulus", Flag58 (Id));
W ("Nonzero_Is_True", Flag162 (Id));
W ("Reachable", Flag49 (Id));
-- --
-- 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- --
-- either from their declaration or through type derivation. The use
-- of this flag exactly meets the spec in RM 3.7(26). Note that all
-- class-wide types are considered to have unknown discriminants.
+-- Note that both Has_Discriminants and Has_Unknown_Discriminants may
+-- be true for a type. Class-wide types and their subtypes have
+-- unknown discriminants and can have declared ones as well. Private
+-- types declared with unknown discriminants may have a full view that
+-- has explicit discriminants, and both flag will be set on the partial
+-- view, to insure that discriminants are properly inherited in certain
+-- contexts.
-- Has_Volatile_Components (Flag87) [implementation base type only]
-- Present in all types and objects. Set only for an array type or
-- the maximum size such records (needed for allocation purposes when
-- there are default discriminants, and also for the 'Size value).
+-- No_Strict_Aliasing (Flag136) [base type only]
+-- Present in access types. Set to direct the back end to avoid any
+-- optimizations based on an assumption about the aliasing status of
+-- objects designated by the access type. For the case of the gcc
+-- back end, the effect is as though all references to objects of
+-- the type were compiled with -fno-strict-aliasing. This flag is
+-- set if an unchecked conversion with the access type as a target
+-- type occurs in the same source unit as the declaration of the
+-- access type, or if an explicit pragma No_Strict_Aliasing applies.
+
-- Number_Dimensions (synthesized)
-- Applies to array types and subtypes. Returns the number of dimensions
-- of the array type or subtype as a value of type Pos.
-- Has_Storage_Size_Clause (Flag23) (base type only)
-- Is_Access_Constant (Flag69)
-- No_Pool_Assigned (Flag131) (base type only)
+ -- No_Strict_Aliasing (Flag136) (base type only)
-- (plus type attributes)
-- E_Access_Attribute_Type
function Next_Inlined_Subprogram (Id : E) return E;
function No_Pool_Assigned (Id : E) return B;
function No_Return (Id : E) return B;
+ function No_Strict_Aliasing (Id : E) return B;
function Non_Binary_Modulus (Id : E) return B;
function Non_Limited_View (Id : E) return E;
function Nonzero_Is_True (Id : E) return B;
procedure Set_Next_Inlined_Subprogram (Id : E; V : E);
procedure Set_No_Pool_Assigned (Id : E; V : B := True);
procedure Set_No_Return (Id : E; V : B := True);
+ procedure Set_No_Strict_Aliasing (Id : E; V : B := True);
procedure Set_Non_Binary_Modulus (Id : E; V : B := True);
procedure Set_Non_Limited_View (Id : E; V : E);
procedure Set_Nonzero_Is_True (Id : E; V : B := True);
pragma Inline (Next_Literal);
pragma Inline (No_Pool_Assigned);
pragma Inline (No_Return);
+ pragma Inline (No_Strict_Aliasing);
pragma Inline (Non_Binary_Modulus);
pragma Inline (Non_Limited_View);
pragma Inline (Nonzero_Is_True);
pragma Inline (Set_Next_Inlined_Subprogram);
pragma Inline (Set_No_Pool_Assigned);
pragma Inline (Set_No_Return);
+ pragma Inline (Set_No_Strict_Aliasing);
pragma Inline (Set_Non_Binary_Modulus);
pragma Inline (Set_Non_Limited_View);
pragma Inline (Set_Nonzero_Is_True);
-- "/yyy qualifier", where yyy is the corresponding Vname? entry.
Gname1 : aliased constant String := "fno-strict-aliasing";
- Vname1 : aliased constant String := "OPTIMIZE=NO_ALIASING";
+ Vname1 : aliased constant String := "OPTIMIZE=NO_STRICT_ALIASING";
Gname2 : aliased constant String := "gnatX";
Vname2 : aliased constant String := "EXTENSIONS_ALLOWED";
-- --
-- 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- --
Manual_Quote_Mode : Boolean := False;
-- Set True in manual quotation mode
- Max_Msg_Length : constant := 80 + 2 * Hostparm.Max_Line_Length;
+ Max_Msg_Length : constant := 256 + 2 * Hostparm.Max_Line_Length;
-- Maximum length of error message. The addition of Max_Line_Length
-- ensures that two insertion tokens of maximum length can be accomodated.
+ -- The value of 256 is an arbitrary value that should be more than long
+ -- enough to accomodate any reasonable message.
Msg_Buffer : String (1 .. Max_Msg_Length);
-- Buffer used to prepare error messages
#define Cunit lib__cunit
#define Ident_String lib__ident_string
#define In_Extended_Main_Code_Unit lib__in_extended_main_code_unit
+#define In_Same_Source_Unit lib__in_same_source_unit
extern Node_Id Cunit (Unit_Number_Type);
extern Node_Id Ident_String (Unit_Number_Type);
extern Boolean In_Extended_Main_Code_Unit (Entity_Id);
+extern Boolean In_Same_Source_Unit (Node_Id, Node_Id);
/* opt: */
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-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- --
-- in Max. Works correctly to do an initial allocation if the table
-- is currently null.
+ pragma Warnings (Off);
+ -- These unchecked conversions are in fact safe, since they never
+ -- generate improperly aliased pointer values.
+
function To_Address is new Unchecked_Conversion (Table_Ptr, Address);
function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr);
+ pragma Warnings (On);
+
--------------
-- Allocate --
--------------
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-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- --
-- in Max. Works correctly to do an initial allocation if the table
-- is currently null.
+ pragma Warnings (Off);
+ -- Turn off warnings. The following unchecked conversions are only used
+ -- internally in this package, and cannot never result in any instances
+ -- of improperly aliased pointers for the client of the package.
+
function To_Address is new Unchecked_Conversion (Table_Ptr, Address);
function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr);
+ pragma Warnings (On);
+
--------------
-- Allocate --
--------------
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-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- --
type Thread_Id_Ptr is access all Thread_Id;
+ pragma Warnings (Off);
+ -- The following unchecked conversions are aliasing safe, since they
+ -- are never used to create pointers to improperly aliased data.
+
function To_Addr is new Unchecked_Conversion (Task_Id, Address);
function To_Id is new Unchecked_Conversion (Address, Task_Id);
function To_Id is new Unchecked_Conversion (Address, Tasking.Task_ID);
(Address, Ada.Task_Identification.Task_Id);
function To_Thread is new Unchecked_Conversion (Address, Thread_Id_Ptr);
+ pragma Warnings (On);
+
type Code_Proc is access procedure (Id : Address; Parm : Void_Ptr);
task type Thread
with Osint; use Osint;
with Output;
with Prj; use Prj;
+with Prj.Com;
with Prj.Env;
with Prj.Ext; use Prj.Ext;
with Prj.Pars;
Default_Switches_Array :=
Prj.Util.Value_Of
(Name => Name_Default_Switches,
- In_Arrays => Packages.Table (Pkg).Decl.Arrays);
+ In_Arrays => Element.Decl.Arrays);
The_Switches := Prj.Util.Value_Of
(Index => Name_Ada,
In_Array => Default_Switches_Array);
end if;
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.
+
+ if The_Command = Pretty then
+ declare
+ Add_Sources : Boolean := True;
+ Unit_Data : Prj.Com.Unit_Data;
+ begin
+ -- Check if there is at least one argument that is not a switch
+
+ for Index in 1 .. Last_Switches.Last loop
+ if Last_Switches.Table (Index)(1) = '-' then
+ Add_Sources := False;
+ exit;
+ end if;
+ end loop;
+
+ -- If all arguments were switches, add the path names of
+ -- all the sources of the main project.
+
+ if Add_Sources then
+ for Unit in 1 .. Prj.Com.Units.Last loop
+ Unit_Data := Prj.Com.Units.Table (Unit);
+
+ for Kind in Prj.Com.Spec_Or_Body loop
+
+ -- Put only sources that belong to the main project
+
+ if Unit_Data.File_Names (Kind).Project = Project then
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'
+ (Get_Name_String
+ (Unit_Data.File_Names (Kind).Display_Path));
+ end if;
+ end loop;
+ end loop;
+ end if;
+ end;
+ end if;
end if;
-- Gather all the arguments and invoke the executable
-- --
-- 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- --
-- "+" --
---------
- function "+" (Left : in Pointer; Right : in ptrdiff_t) return Pointer is
+ function "+" (Left : Pointer; Right : ptrdiff_t) return Pointer is
begin
if Left = null then
raise Pointer_Error;
return To_Pointer (To_Addr (Left) + To_Addr (Elmt_Size * Right));
end "+";
- function "+" (Left : in ptrdiff_t; Right : in Pointer) return Pointer is
+ function "+" (Left : ptrdiff_t; Right : Pointer) return Pointer is
begin
if Right = null then
raise Pointer_Error;
-- "-" --
---------
- function "-" (Left : in Pointer; Right : in ptrdiff_t) return Pointer is
+ function "-" (Left : Pointer; Right : ptrdiff_t) return Pointer is
begin
if Left = null then
raise Pointer_Error;
return To_Pointer (To_Addr (Left) - To_Addr (Right * Elmt_Size));
end "-";
- function "-" (Left : in Pointer; Right : in Pointer) return ptrdiff_t is
+ function "-" (Left : Pointer; Right : Pointer) return ptrdiff_t is
begin
if Left = null or else Right = null then
raise Pointer_Error;
----------------
procedure Copy_Array
- (Source : in Pointer;
- Target : in Pointer;
- Length : in ptrdiff_t)
+ (Source : Pointer;
+ Target : Pointer;
+ Length : ptrdiff_t)
is
T : Pointer := Target;
S : Pointer := Source;
---------------------------
procedure Copy_Terminated_Array
- (Source : in Pointer;
- Target : in Pointer;
- Limit : in ptrdiff_t := ptrdiff_t'Last;
- Terminator : in Element := Default_Terminator)
+ (Source : Pointer;
+ Target : Pointer;
+ Limit : ptrdiff_t := ptrdiff_t'Last;
+ Terminator : Element := Default_Terminator)
is
S : Pointer := Source;
T : Pointer := Target;
-----------
function Value
- (Ref : in Pointer;
- Terminator : in Element := Default_Terminator)
- return Element_Array
+ (Ref : Pointer;
+ Terminator : Element := Default_Terminator) return Element_Array
is
P : Pointer;
L : constant Index_Base := Index'First;
end Value;
function Value
- (Ref : in Pointer;
- Length : in ptrdiff_t)
- return Element_Array
+ (Ref : Pointer;
+ Length : ptrdiff_t) return Element_Array
is
L : Index_Base;
H : Index_Base;
--------------------
function Virtual_Length
- (Ref : in Pointer;
- Terminator : in Element := Default_Terminator)
- return ptrdiff_t
+ (Ref : Pointer;
+ Terminator : Element := Default_Terminator) return ptrdiff_t
is
P : Pointer;
C : ptrdiff_t;
-- --
-- S p e c --
-- --
--- Copyright (C) 1993-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1993-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 --
type Pointer is access all Element;
+ pragma No_Strict_Aliasing (Pointer);
+ -- We turn off any strict aliasing assumptions for the pointer type,
+ -- since it is possible to create "improperly" aliased values.
+
function Value
- (Ref : in Pointer;
- Terminator : in Element := Default_Terminator)
- return Element_Array;
+ (Ref : Pointer;
+ Terminator : Element := Default_Terminator) return Element_Array;
function Value
- (Ref : in Pointer;
- Length : in ptrdiff_t)
- return Element_Array;
+ (Ref : Pointer;
+ Length : ptrdiff_t) return Element_Array;
Pointer_Error : exception;
-- C-style Pointer Arithmetic --
--------------------------------
- function "+" (Left : in Pointer; Right : in ptrdiff_t) return Pointer;
- function "+" (Left : in ptrdiff_t; Right : in Pointer) return Pointer;
- function "-" (Left : in Pointer; Right : in ptrdiff_t) return Pointer;
- function "-" (Left : in Pointer; Right : in Pointer) return ptrdiff_t;
+ function "+" (Left : Pointer; Right : ptrdiff_t) return Pointer;
+ function "+" (Left : ptrdiff_t; Right : Pointer) return Pointer;
+ function "-" (Left : Pointer; Right : ptrdiff_t) return Pointer;
+ function "-" (Left : Pointer; Right : Pointer) return ptrdiff_t;
procedure Increment (Ref : in out Pointer);
procedure Decrement (Ref : in out Pointer);
pragma Convention (Intrinsic, Decrement);
function Virtual_Length
- (Ref : in Pointer;
- Terminator : in Element := Default_Terminator)
- return ptrdiff_t;
+ (Ref : Pointer;
+ Terminator : Element := Default_Terminator) return ptrdiff_t;
procedure Copy_Terminated_Array
- (Source : in Pointer;
- Target : in Pointer;
- Limit : in ptrdiff_t := ptrdiff_t'Last;
- Terminator : in Element := Default_Terminator);
+ (Source : Pointer;
+ Target : Pointer;
+ Limit : ptrdiff_t := ptrdiff_t'Last;
+ Terminator : Element := Default_Terminator);
procedure Copy_Array
- (Source : in Pointer;
- Target : in Pointer;
- Length : in ptrdiff_t);
+ (Source : Pointer;
+ Target : Pointer;
+ Length : ptrdiff_t);
private
pragma Inline ("+");
-- --
-- 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- --
package body Interfaces.C.Strings is
+ -- Note that the type chars_ptr has a pragma No_Strict_Aliasing in
+ -- the spec, to prevent any assumptions about aliasing for values
+ -- of this type, since arbitrary addresses can be converted, and it
+ -- is quite likely that this type will in fact be used for aliasing
+ -- values of other types.
+
function To_chars_ptr is
new Unchecked_Conversion (Address, chars_ptr);
-- New_Char_Array --
--------------------
- function New_Char_Array (Chars : in char_array) return chars_ptr is
+ function New_Char_Array (Chars : char_array) return chars_ptr is
Index : size_t;
Pointer : chars_ptr;
-- New_String --
----------------
- function New_String (Str : in String) return chars_ptr is
+ function New_String (Str : String) return chars_ptr is
begin
return New_Char_Array (To_C (Str));
end New_String;
-- Strlen --
------------
- function Strlen (Item : in chars_ptr) return size_t is
+ function Strlen (Item : chars_ptr) return size_t is
Item_Index : size_t := 0;
begin
------------------
function To_Chars_Ptr
- (Item : in char_array_access;
- Nul_Check : in Boolean := False)
- return chars_ptr
+ (Item : char_array_access;
+ Nul_Check : Boolean := False) return chars_ptr
is
begin
if Item = null then
raise Terminator_Error;
else
return To_chars_ptr (Item (Item'First)'Address);
-
end if;
end To_Chars_Ptr;
------------
procedure Update
- (Item : in chars_ptr;
- Offset : in size_t;
- Chars : in char_array;
+ (Item : chars_ptr;
+ Offset : size_t;
+ Chars : char_array;
Check : Boolean := True)
is
Index : chars_ptr := Item + Offset;
end Update;
procedure Update
- (Item : in chars_ptr;
- Offset : in size_t;
- Str : in String;
- Check : in Boolean := True)
+ (Item : chars_ptr;
+ Offset : size_t;
+ Str : String;
+ Check : Boolean := True)
is
begin
Update (Item, Offset, To_C (Str), Check);
-- Value --
-----------
- function Value (Item : in chars_ptr) return char_array is
+ function Value (Item : chars_ptr) return char_array is
Result : char_array (0 .. Strlen (Item));
begin
end Value;
function Value
- (Item : in chars_ptr;
- Length : in size_t)
- return char_array
+ (Item : chars_ptr;
+ Length : size_t) return char_array
is
begin
if Item = Null_Ptr then
end;
end Value;
- function Value (Item : in chars_ptr) return String is
+ function Value (Item : chars_ptr) return String is
begin
return To_Ada (Value (Item));
end Value;
- -- As per AI-00177, this is equivalent to
- -- To_Ada (Value (Item, Length) & nul);
-
- function Value (Item : in chars_ptr; Length : in size_t) return String is
+ function Value (Item : chars_ptr; Length : size_t) return String is
Result : char_array (0 .. Length);
begin
+ -- As per AI-00177, this is equivalent to
+ -- To_Ada (Value (Item, Length) & nul);
+
if Item = Null_Ptr then
raise Dereference_Error;
end if;
-- --
-- S p e c --
-- --
--- Copyright (C) 1993-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1993-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 --
type char_array_access is access all char_array;
+ pragma Warnings (Off);
+ pragma No_Strict_Aliasing (char_array_access);
+ pragma Warnings (On);
+ -- Since this type is used for external interfacing, with the pointer
+ -- coming from who knows where, it seems a good idea to turn off any
+ -- strict aliasing assumptions for this type. We turn off warnings for
+ -- this pragma to deal with being compiled with an earlier GNAT version
+ -- that does not recognize this pragma.
+
type chars_ptr is private;
type chars_ptr_array is array (size_t range <>) of chars_ptr;
Null_Ptr : constant chars_ptr;
function To_Chars_Ptr
- (Item : in char_array_access;
- Nul_Check : in Boolean := False)
- return chars_ptr;
+ (Item : char_array_access;
+ Nul_Check : Boolean := False) return chars_ptr;
- function New_Char_Array (Chars : in char_array) return chars_ptr;
+ function New_Char_Array (Chars : char_array) return chars_ptr;
- function New_String (Str : in String) return chars_ptr;
+ function New_String (Str : String) return chars_ptr;
procedure Free (Item : in out chars_ptr);
Dereference_Error : exception;
- function Value (Item : in chars_ptr) return char_array;
+ function Value (Item : chars_ptr) return char_array;
function Value
- (Item : in chars_ptr;
- Length : in size_t)
- return char_array;
+ (Item : chars_ptr;
+ Length : size_t) return char_array;
- function Value (Item : in chars_ptr) return String;
+ function Value (Item : chars_ptr) return String;
function Value
- (Item : in chars_ptr;
- Length : in size_t)
- return String;
+ (Item : chars_ptr;
+ Length : size_t) return String;
- function Strlen (Item : in chars_ptr) return size_t;
+ function Strlen (Item : chars_ptr) return size_t;
procedure Update
- (Item : in chars_ptr;
- Offset : in size_t;
- Chars : in char_array;
+ (Item : chars_ptr;
+ Offset : size_t;
+ Chars : char_array;
Check : Boolean := True);
procedure Update
- (Item : in chars_ptr;
- Offset : in size_t;
- Str : in String;
- Check : in Boolean := True);
+ (Item : chars_ptr;
+ Offset : size_t;
+ Str : String;
+ Check : Boolean := True);
Update_Error : exception;
private
type chars_ptr is access all Character;
+ pragma No_Strict_Aliasing (chars_ptr);
+ -- Since this type is used for external interfacing, with the pointer
+ -- coming from who knows where, it seems a good idea to turn off any
+ -- strict aliasing assumptions for this type.
+
Null_Ptr : constant chars_ptr := null;
end Interfaces.C.Strings;
File_Name : String;
Program : Make_Program_Type)
is
- Switches : Variable_Value;
- Switch_List : String_List_Id;
- Element : String_Element;
+ Switches : Variable_Value;
+ Switch_List : String_List_Id;
+ Element : String_Element;
begin
if File_Name'Length > 0 then
if Run_Path_Option and Path_Option /= null then
declare
- Option : String_Access;
- Length : Natural := Path_Option'Length;
+ Option : String_Access;
+ Length : Natural := Path_Option'Length;
Current : Natural;
begin
-- GNATMAKE
-- Set to True if minimal recompilation mode requested.
- No_Stdlib : Boolean := False;
- -- GNATMAKE, GNATBIND, GNATFIND, GNATXREF
- -- Set to True if no default library search dirs added to search list.
-
- No_Stdinc : Boolean := False;
- -- GNAT, GNATBIND, GNATMAKE, GNATFIND, GNATXREF
- -- Set to True if no default source search dirs added to search list.
-
No_Main_Subprogram : Boolean := False;
-- GNATMAKE, GNATBIND
-- Set to True if compilation/binding of a program without main
-- This flag is set True if a No_Run_Time pragma is encountered. See
-- spec of Rtsfind for a full description of handling of this pragma.
+ No_Stdinc : Boolean := False;
+ -- GNAT, GNATBIND, GNATMAKE, GNATFIND, GNATXREF
+ -- Set to True if no default source search dirs added to search list
+
+ No_Stdlib : Boolean := False;
+ -- GNATMAKE, GNATBIND, GNATFIND, GNATXREF
+ -- Set to True if no default library search dirs added to search list
+
+ No_Strict_Aliasing : Boolean := False;
+ -- GNAT
+ -- Set True if pragma No_Strict_Aliasing with no parameters encountered
+
Normalize_Scalars : Boolean := False;
-- GNAT, GNATBIND
-- Set True if a pragma Normalize_Scalars applies to the current unit.
-- --
-- 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- --
declare
pragma Suppress (All_Checks);
+ pragma Warnings (Off);
+ -- This use of unchecked conversion is aliasing safe
+
function To_Source_Buffer_Ptr is new
Unchecked_Conversion (Address, Source_Buffer_Ptr);
+ pragma Warnings (On);
+
begin
Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
end;
-- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE
-- WITH_CLAUSE ::=
- -- with library_unit_NAME {,library_unit_NAME};
+ -- [LIMITED] [PRIVATE] with library_unit_NAME {,library_unit_NAME};
+ -- Note: the two qualifiers are ADA0Y extensions.
-- WITH_TYPE_CLAUSE ::=
-- with type type_NAME is access; | with type type_NAME is tagged;
+ -- Note: this form is obsolete (old GNAT extension).
-- Error recovery: Cannot raise Error_Resync
function P_Context_Clause return List_Id is
Item_List : List_Id;
Has_Limited : Boolean := False;
+ Has_Private : Boolean := False;
+ Scan_State : Saved_Scan_State;
With_Node : Node_Id;
First_Flag : Boolean;
-- Processing for WITH clause
- -- Ada0Y (AI-50217): First check for LIMITED WITH
+ -- Ada0Y (AI-50217): First check for LIMITED WITH, PRIVATE WITH,
+ -- or both.
if Token = Tok_Limited then
Has_Limited := True;
+ Has_Private := False;
Scan; -- past LIMITED
-- In the context, LIMITED can only appear in a with_clause
+ if Token = Tok_Private then
+ Has_Private := True;
+ Scan; -- past PRIVATE
+ end if;
+
if Token /= Tok_With then
Error_Msg_SC ("unexpected LIMITED ignored");
end if;
Error_Msg_SP ("`LIMITED WITH` is an Ada0X extension");
Error_Msg_SP
("\unit must be compiled with -gnatX switch");
+
end if;
+
+ elsif Token = Tok_Private then
+ Has_Limited := False;
+ Has_Private := True;
+ Save_Scan_State (Scan_State);
+ Scan; -- past PRIVATE
+
+ if Token /= Tok_With then
+
+ -- Keyword is beginning of private child unit.
+
+ Restore_Scan_State (Scan_State); -- to PRIVATE
+ return Item_List;
+
+ elsif not Extensions_Allowed then
+ Error_Msg_SP ("`PRIVATE WITH` is an Ada0X extension");
+ Error_Msg_SP
+ ("\unit must be compiled with -gnatX switch");
+ end if;
+
else
Has_Limited := False;
+ Has_Private := False;
end if;
if Token = Tok_With then
Set_Name (With_Node, P_Qualified_Simple_Name);
Set_First_Name (With_Node, First_Flag);
Set_Limited_Present (With_Node, Has_Limited);
+ Set_Private_Present (With_Node, Has_Private);
First_Flag := False;
exit when Token /= Tok_Comma;
Scan; -- past comma
Pragma_No_Return |
Pragma_Obsolescent |
Pragma_No_Run_Time |
+ Pragma_No_Strict_Aliasing |
Pragma_Normalize_Scalars |
Pragma_Optimize |
Pragma_Optional_Overriding |
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-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- --
Key => Name_Id,
Hash => Hash,
Equal => "=");
+ -- Mapping of unit names to indexes in the Units table
+
+ type Unit_Project is record
+ Unit : Unit_Id := No_Unit;
+ Project : Project_Id := No_Project;
+ end record;
+
+ No_Unit_Project : constant Unit_Project := (No_Unit, No_Project);
+
+ package Files_Htable is new GNAT.HTable.Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Unit_Project,
+ No_Element => No_Unit_Project,
+ Key => Name_Id,
+ Hash => Hash,
+ Equal => "=");
+ -- Mapping of file names to indexes in the Units table
end Prj.Com;
end if;
end Compute_Directory_Last;
-
-------------------------------
-- Prepare_Naming_Exceptions --
-------------------------------
(Name_Locally_Removed_Files,
Data.Decl.Attributes);
-
begin
pragma Assert
(Sources.Kind = List,
Previous_Source : constant String_List_Id := Current_Source;
Except_Name : Name_Id := No_Name;
+ Unit_Prj : Unit_Project;
+
begin
Get_Name_String (File_Name);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
-- It is a new unit, create a new record
else
- Units.Increment_Last;
- The_Unit := Units.Last;
- Units_Htable.Set (Unit_Name, The_Unit);
- The_Unit_Data.Name := Unit_Name;
- The_Unit_Data.File_Names (Unit_Kind) :=
- (Name => Canonical_File_Name,
- Display_Name => File_Name,
- Path => Canonical_Path_Name,
- Display_Path => Path_Name,
- Project => Project,
- Needs_Pragma => Needs_Pragma);
- Units.Table (The_Unit) := The_Unit_Data;
- Source_Recorded := True;
+ -- First, check if there is no other unit with this file name
+ -- in another project. If it is, report an error.
+
+ Unit_Prj := Files_Htable.Get (Canonical_File_Name);
+
+ if Unit_Prj /= No_Unit_Project then
+ Error_Msg_Name_1 := File_Name;
+ Error_Msg_Name_2 := Projects.Table (Unit_Prj.Project).Name;
+ Error_Msg
+ (Project,
+ "{ is already a source of project {",
+ Location);
+
+ else
+ Units.Increment_Last;
+ The_Unit := Units.Last;
+ Units_Htable.Set (Unit_Name, The_Unit);
+ Unit_Prj := (Unit => The_Unit, Project => Project);
+ Files_Htable.Set (Canonical_File_Name, Unit_Prj);
+ The_Unit_Data.Name := Unit_Name;
+ The_Unit_Data.File_Names (Unit_Kind) :=
+ (Name => Canonical_File_Name,
+ Display_Name => File_Name,
+ Path => Canonical_Path_Name,
+ Display_Path => Path_Name,
+ Project => Project,
+ Needs_Pragma => Needs_Pragma);
+ Units.Table (The_Unit) := The_Unit_Data;
+ Source_Recorded := True;
+ end if;
end if;
end;
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- --
with Ada.Exceptions;
with Ada.Tags;
-with Ada.Unchecked_Conversion;
+
with System.Storage_Elements;
with System.Soft_Links;
+with Unchecked_Conversion;
+
package body System.Finalization_Implementation is
use Ada.Exceptions;
-- Local Subprograms --
-----------------------
- function To_Finalizable_Ptr is
- new Ada.Unchecked_Conversion (Address, Finalizable_Ptr);
-
- function To_Addr is
- new Ada.Unchecked_Conversion (Finalizable_Ptr, Address);
-
type RC_Ptr is access all Record_Controller;
function To_RC_Ptr is
- new Ada.Unchecked_Conversion (Address, RC_Ptr);
+ new Unchecked_Conversion (Address, RC_Ptr);
procedure Raise_Exception_No_Defer
(E : in Exception_Id;
-- raised.
function To_Ptr is new
- Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
+ Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
X : constant Exception_Id :=
To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id;
Parent : Parent_Type;
Controller : Faked_Record_Controller;
end record;
+
type Obj_Ptr is access all Faked_Type_Of_Obj;
function To_Obj_Ptr is
- new Ada.Unchecked_Conversion (Address, Obj_Ptr);
+ new Unchecked_Conversion (Address, Obj_Ptr);
begin
return To_RC_Ptr (To_Obj_Ptr (Obj).Controller'Address);
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
+-- This unit provides the basic support for controlled (finalizable) types
+
with Ada.Streams;
+with Unchecked_Conversion;
+
package System.Finalization_Root is
pragma Preelaborate (Finalization_Root);
type Finalizable_Ptr is access all Root_Controlled'Class;
+ function To_Finalizable_Ptr is
+ new Unchecked_Conversion (Address, Finalizable_Ptr);
+
+ function To_Addr is
+ new Unchecked_Conversion (Finalizable_Ptr, Address);
+
type Empty_Root_Controlled is abstract tagged null record;
-- Just for the sake of Controlled equality (see Ada.Finalization)
-- 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. --
-- --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
end Get_Stack_Info;
procedure Set_Exc_Stack_Addr (Self_ID : Address; Addr : Address) is
- Me : Task_ID := To_Task_Id (Self_ID);
-
+ Me : Task_ID := To_Task_ID (Self_ID);
begin
if Me = Null_Task then
Me := STPO.Self;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This is the compiler interface version of this function. Do not call
-- from the run-time system.
- function To_Task_Id is new Unchecked_Conversion (System.Address, Task_ID);
+ function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
-----------------------
------------------------------------
type Access_Address is access all System.Address;
+ -- Comment on what this is used for ???
+
+ pragma No_Strict_Aliasing (Access_Address);
+ -- This type is used in contexts where aliasing may be an issue (see
+ -- for example s-tataat.adb), so we avoid any incorrect aliasing
+ -- assumptions.
----------------------------------------------
-- Ada_Task_Control_Block (ATCB) definition --
-- used for Check_Exception
-- Make_Passive
-- Wakeup_Entry_Caller
+-- Exit_One_ATC_Level
with System.Tasking.Protected_Objects.Operations;
-- used for PO_Do_Or_Queue
if not Task_Do_Or_Queue
(Self_Id, Entry_Call, With_Abort => True)
then
- Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1;
+ STPO.Write_Lock (Self_Id);
+ Utilities.Exit_One_ATC_Level (Self_Id);
+ STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
end if;
Initialization.Undefer_Abort (Self_Id);
- pragma Debug
- (Debug.Trace (Self_Id, "CS: exited to ATC level: " &
- ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
raise Tasking_Error;
end if;
-- ??? In some cases abort is deferred more than once. Need to
-- figure out why this happens.
- Self_Id.Deferral_Level := 1;
+ if Self_Id.Deferral_Level > 1 then
+ Self_Id.Deferral_Level := 1;
+ end if;
Initialization.Undefer_Abort (Self_Id);
if not Task_Do_Or_Queue
(Self_Id, Entry_Call, With_Abort => True)
then
- Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1;
- pragma Debug
- (Debug.Trace (Self_Id, "TEC: exited to ATC level: " &
- ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
+ STPO.Write_Lock (Self_Id);
+ Utilities.Exit_One_ATC_Level (Self_Id);
+ STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
if not Task_Do_Or_Queue
(Self_Id, Entry_Call, With_Abort => True)
then
- Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1;
-
- pragma Debug
- (Debug.Trace (Self_Id, "TTEC: exited to ATC level: " &
- ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
+ STPO.Write_Lock (Self_Id);
+ Utilities.Exit_One_ATC_Level (Self_Id);
+ STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- Used for System.Finalization_Implementation.Finalize_Global_List
with System.Secondary_Stack;
--- used for SS_Init;
+-- used for SS_Init
with System.Storage_Elements;
--- used for Storage_Array;
+-- used for Storage_Array
with System.Standard_Library;
-- used for Exception_Trace
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2003, Ada Core Technologies --
+-- Copyright (C) 1995-2004, Ada Core Technologies --
-- --
-- GNARL 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 Task_Primitives.Operations;
use Tasking.Initialization;
- function To_Access_Node is new Unchecked_Conversion
- (Access_Address, Access_Node);
- -- Tetch pointer to indirect attribute list
-
function To_Access_Address is new Unchecked_Conversion
(Access_Node, Access_Address);
-- Store pointer to indirect attribute list
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2003, Ada Core Technologies --
+-- Copyright (C) 1995-2004, Ada Core Technologies --
-- --
-- GNARL 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 Access_Node is access all Node;
-- This needs comments ???
+ function To_Access_Node is new Unchecked_Conversion
+ (Access_Address, Access_Node);
+ -- Used to fetch pointer to indirect attribute list. Declaration is
+ -- in spec to avoid any problems with aliasing assumptions.
+
type Dummy_Wrapper;
type Access_Dummy_Wrapper is access all Dummy_Wrapper;
for Access_Dummy_Wrapper'Storage_Size use 0;
with System.Tasking.Rendezvous;
-- used for Task_Do_Or_Queue
+with System.Tasking.Utilities;
+-- used for Exit_One_ATC_Level
+
with System.Tasking.Debug;
-- used for Trace
Update_For_Queue_To_PO (Entry_Call, With_Abort);
else
- -- ?????
- -- Can we convert this recursion to a loop?
+ -- Can we convert this recursion to a loop???
PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, With_Abort);
end if;
end if;
end if;
- elsif Entry_Call.Mode /= Conditional_Call or else
- not With_Abort then
+ elsif Entry_Call.Mode /= Conditional_Call
+ or else not With_Abort
+ then
Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call);
Update_For_Queue_To_PO (Entry_Call, With_Abort);
Initially_Abortable := Entry_Call.State = Now_Abortable;
PO_Service_Entries (Self_ID, Object);
- -- Try to prevent waiting later (in Cancel_Protected_Entry_Call)
+ -- Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call)
-- for completed or cancelled calls. (This is a heuristic, only.)
if Entry_Call.State >= Done then
-- Once State >= Done it will not change any more.
- Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1;
- pragma Debug
- (Debug.Trace (Self_ID, "PEC: exited to ATC level: " &
- ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
+ if Single_Lock then
+ STPO.Lock_RTS;
+ end if;
+
+ STPO.Write_Lock (Self_ID);
+ Utilities.Exit_One_ATC_Level (Self_ID);
+ STPO.Unlock (Self_ID);
+
+ if Single_Lock then
+ STPO.Unlock_RTS;
+ end if;
+
Block.Enqueued := False;
Block.Cancelled := Entry_Call.State = Cancelled;
Initialization.Undefer_Abort (Self_ID);
PO_Do_Or_Queue (Self_Id, Object, Entry_Call, With_Abort => True);
PO_Service_Entries (Self_Id, Object);
+ if Single_Lock then
+ STPO.Lock_RTS;
+ else
+ STPO.Write_Lock (Self_Id);
+ end if;
+
-- Try to avoid waiting for completed or cancelled calls.
if Entry_Call.State >= Done then
- Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1;
- pragma Debug
- (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " &
- ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
+ Utilities.Exit_One_ATC_Level (Self_Id);
+
+ if Single_Lock then
+ STPO.Unlock_RTS;
+ else
+ STPO.Unlock (Self_Id);
+ end if;
+
Entry_Call_Successful := Entry_Call.State = Done;
Initialization.Undefer_Abort (Self_Id);
Entry_Calls.Check_Exception (Self_Id, Entry_Call);
return;
end if;
- if Single_Lock then
- STPO.Lock_RTS;
- else
- STPO.Write_Lock (Self_Id);
- end if;
-
Entry_Calls.Wait_For_Completion_With_Timeout
(Entry_Call, Timeout, Mode, Yielded);
-- Place shadow entities for a limited_with package in the visibility
-- structures for the current compilation. Implements Ada0Y (AI-50217).
- procedure Install_Withed_Unit (With_Clause : Node_Id);
+ procedure Install_Withed_Unit
+ (With_Clause : Node_Id;
+ Private_With_OK : Boolean := False);
+
-- If the unit is not a child unit, make unit immediately visible.
-- The caller ensures that the unit is not already currently installed.
+ -- The flag Private_With_OK is set true in Install_Private_With_Clauses,
+ -- which is called when compiling the private part of a package, or
+ -- installing the private declarations of a parent unit.
procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean);
-- This procedure establishes the context for the compilation of a child
P_Name : constant Entity_Id := Get_Parent_Entity (P_Unit);
Withn : Node_Id;
- function Build_Ancestor_Name (P : Node_Id) return Node_Id;
+ function Build_Ancestor_Name (P : Node_Id) return Node_Id;
-- Build prefix of child unit name. Recurse if needed.
function Build_Unit_Name return Node_Id;
function Build_Ancestor_Name (P : Node_Id) return Node_Id is
P_Ref : constant Node_Id :=
New_Reference_To (Defining_Entity (P), Loc);
-
begin
if No (Parent_Spec (P)) then
return P_Ref;
function Build_Unit_Name return Node_Id is
Result : Node_Id;
-
begin
if No (Parent_Spec (P_Unit)) then
return New_Reference_To (P_Name, Loc);
if Is_Child_Spec (P_Unit) then
Implicit_With_On_Parent (P_Unit, N);
end if;
+
New_Nodes_OK := New_Nodes_OK - 1;
end Implicit_With_On_Parent;
if not (Private_Present (Parent (Lib_Spec))) then
P_Name := Defining_Entity (P);
Install_Private_Declarations (P_Name);
+ Install_Private_With_Clauses (P_Name);
Set_Use (Private_Declarations (Specification (P)));
end if;
or else Private_Present (Parent (Lib_Unit))
then
Install_Private_Declarations (P_Name);
+ Install_Private_With_Clauses (P_Name);
Set_Use (Private_Declarations (P_Spec));
end if;
end Install_Parents;
+ ----------------------------------
+ -- Install_Private_With_Clauses --
+ ----------------------------------
+
+ procedure Install_Private_With_Clauses (P : Entity_Id) is
+ Decl : constant Node_Id := Unit_Declaration_Node (P);
+ Clause : Node_Id;
+
+ begin
+ if Nkind (Parent (Decl)) = N_Compilation_Unit then
+ Clause := First (Context_Items (Parent (Decl)));
+ while Present (Clause) loop
+ if Nkind (Clause) = N_With_Clause
+ and then Private_Present (Clause)
+ then
+ Install_Withed_Unit (Clause, Private_With_OK => True);
+ end if;
+
+ Next (Clause);
+ end loop;
+ end if;
+ end Install_Private_With_Clauses;
+
----------------------
-- Install_Siblings --
----------------------
begin
Par := U_Name;
-
while Present (Par)
and then Par /= Standard_Standard
loop
-
if Par = E then
return True;
end if;
-- scope of each entity is an ancestor of the current unit.
Item := First (Context_Items (N));
-
while Present (Item) loop
-
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
and then not Limited_Present (Item)
then
Set_Is_Immediately_Visible (Scope (Id));
end if;
-
end if;
Next (Item);
-- Check that the shadow entity is not already in the homonym
-- chain, for example through a limited_with clause in a parent unit.
+ --------------
+ -- In_Chain --
+ --------------
+
function In_Chain (E : Entity_Id) return Boolean is
H : Entity_Id := Current_Entity (E);
-- Install_Withed_Unit --
-------------------------
- procedure Install_Withed_Unit (With_Clause : Node_Id) is
+ procedure Install_Withed_Unit
+ (With_Clause : Node_Id;
+ Private_With_OK : Boolean := False)
+ is
Uname : constant Entity_Id := Entity (Name (With_Clause));
P : constant Entity_Id := Scope (Uname);
end if;
if P /= Standard_Standard then
+ if Private_Present (With_Clause)
+ and then not (Private_With_OK)
+ then
+ return;
-- If the unit is not analyzed after analysis of the with clause,
-- and it is an instantiation, then it awaits a body and is the main
-- unit. Its appearance in the context of some other unit indicates
-- a circular dependency (DEC suite perversity).
- if not Analyzed (Uname)
+ elsif not Analyzed (Uname)
and then Nkind (Parent (Uname)) = N_Package_Instantiation
then
Error_Msg_N
end if;
elsif not Is_Immediately_Visible (Uname) then
- Set_Is_Immediately_Visible (Uname);
+ if not Private_Present (With_Clause)
+ or else Private_With_OK
+ then
+ Set_Is_Immediately_Visible (Uname);
+ end if;
+
Set_Context_Installed (With_Clause);
end if;
-- --
-- S p e c --
-- --
--- 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- --
-- unit into the visibility chains. This is done before analyzing a unit.
-- For a child unit, install context of parents as well.
+ procedure Install_Private_With_Clauses (P : Entity_Id);
+ -- Install the private with_clauses of a compilation unit, when compiling
+ -- its private part, compiling a private child unit, or compiling the
+ -- private declarations of a public child unit.
+
procedure Remove_Context (N : Node_Id);
-- Removes the entities from the context clause of the given compilation
-- unit from the visibility chains. This is done on exit from a unit as
with Errout; use Errout;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
-with Hostparm; use Hostparm;
with Lib; use Lib;
with Nlists; use Nlists;
with Nmake; use Nmake;
end if;
end if;
- -- Generate N_Validate_Unchecked_Conversion node for back end if
- -- the back end needs to perform special validation checks. At the
- -- current time, only the JVM version requires such checks.
+ -- In GNAT mode, if target is an access type, access type must be
+ -- declared in the same source unit as the unchecked conversion.
- if Java_VM then
- Vnode :=
- Make_Validate_Unchecked_Conversion (Sloc (N));
- Set_Source_Type (Vnode, Source);
- Set_Target_Type (Vnode, Target);
+-- if GNAT_Mode and then Is_Access_Type (Target) then
+-- if not In_Same_Source_Unit (Target, N) then
+-- Error_Msg_NE
+-- ("unchecked conversion not in same unit as&", N, Target);
+-- end if;
+-- end if;
+
+ -- Generate N_Validate_Unchecked_Conversion node for back end in
+ -- case the back end needs to perform special validation checks.
+
+ -- Shouldn't this be in exp_ch13, since the check only gets done
+ -- if we have full expansion and the back end is called ???
+
+ Vnode :=
+ Make_Validate_Unchecked_Conversion (Sloc (N));
+ Set_Source_Type (Vnode, Source);
+ Set_Target_Type (Vnode, Target);
+
+ -- If the unchecked conversion node is in a list, just insert before
+ -- it. If not we have some strange case, not worth bothering about.
+
+ if Is_List_Member (N) then
Insert_After (N, Vnode);
end if;
end Validate_Unchecked_Conversion;
-- and thus unconstrained. Regular components must be constrained.
if Is_Indefinite_Subtype (T) and then Chars (Id) /= Name_uParent then
- Error_Msg_N
- ("unconstrained subtype in component declaration",
- Subtype_Indication (Component_Definition (N)));
+ if Is_Class_Wide_Type (T) then
+ Error_Msg_N
+ ("class-wide subtype with unknown discriminants" &
+ " in component declaration",
+ Subtype_Indication (Component_Definition (N)));
+ else
+ Error_Msg_N
+ ("unconstrained subtype in component declaration",
+ Subtype_Indication (Component_Definition (N)));
+ end if;
-- Components cannot be abstract, except for the special case of
-- the _Parent field (case of extending an abstract tagged type)
Add_RACW_Features (Def_Id);
end if;
+ -- Set no strict aliasing flag if config pragma seen
+
+ if Opt.No_Strict_Aliasing then
+ Set_No_Strict_Aliasing (Base_Type (Def_Id));
+ end if;
+
when N_Array_Type_Definition =>
Array_Type_Declaration (T, Def);
Indic := Subtype_Indication (Type_Def);
Constraint_Present := (Nkind (Indic) = N_Subtype_Indication);
+ -- Check that the type has visible discriminants. The type may be
+ -- a private type with unknown discriminants whose full view has
+ -- discriminants which are invisible.
+
if Constraint_Present then
- if not Has_Discriminants (Parent_Base) then
+ if not Has_Discriminants (Parent_Base)
+ or else
+ (Has_Unknown_Discriminants (Parent_Base)
+ and then Is_Private_Type (Parent_Base))
+ then
Error_Msg_N
("invalid constraint: type has no discriminant",
Constraint (Indic));
Set_Has_Unknown_Discriminants
(Derived_Type, Has_Unknown_Discriminants (Parent_Type)
or else Unknown_Discriminants_Present (N));
- else
- Set_Has_Unknown_Discriminants
- (Derived_Type, Has_Unknown_Discriminants (Parent_Type));
+
+ -- The partial view of the parent may have unknown discriminants,
+ -- but if the full view has discriminants and the parent type is
+ -- in scope they must be inherited.
+
+ elsif Has_Unknown_Discriminants (Parent_Type)
+ and then
+ (not Has_Discriminants (Parent_Type)
+ or else not In_Open_Scopes (Scope (Parent_Type)))
+ then
+ Set_Has_Unknown_Discriminants (Derived_Type);
end if;
if not Has_Unknown_Discriminants (Derived_Type)
T := Designated_Type (T);
end if;
- if not Has_Discriminants (T) then
+ -- Check that the type has visible discriminants. The type may be
+ -- a private type with unknown discriminants whose full view has
+ -- discriminants which are invisible.
+
+ if not Has_Discriminants (T)
+ or else
+ (Has_Unknown_Discriminants (T)
+ and then Is_Private_Type (T))
+ then
Error_Msg_N ("invalid constraint: type has no discriminant", C);
Fixup_Bad_Constraint;
return;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch10; use Sem_Ch10;
with Sem_Ch12; use Sem_Ch12;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
Install_Visible_Declarations (Spec_Id);
Install_Private_Declarations (Spec_Id);
+ Install_Private_With_Clauses (Spec_Id);
Install_Composite_Operations (Spec_Id);
if Ekind (Spec_Id) = E_Generic_Package then
Public_Child := True;
Par := Scope (Par);
Install_Private_Declarations (Par);
+ Install_Private_With_Clauses (Par);
Pack_Decl := Unit_Declaration_Node (Par);
Set_Use (Private_Declarations (Specification (Pack_Decl)));
end loop;
end;
end if;
+ if Is_Compilation_Unit (Id) then
+ Install_Private_With_Clauses (Id);
+ end if;
+
-- Analyze private part if present. The flag In_Private_Part is
-- reset in End_Package_Scope.
end if;
Set_First_Entity (Priv, First_Entity (Full));
- Set_Last_Entity (Priv, Last_Entity (Full));
+ Set_Last_Entity (Priv, Last_Entity (Full));
+ Set_Has_Discriminants (Priv, Has_Discriminants (Full));
end if;
end Preserve_Full_Attributes;
and then Paren_Count (Arg_Parameter_Types) = 0
then
Ptype := First (Expressions (Arg_Parameter_Types));
-
while Present (Ptype) or else Present (Formal) loop
if No (Ptype)
or else No (Formal)
if not Is_Check_Name (Chars (Expression (Arg1))) then
Error_Pragma_Arg
("argument of pragma% is not valid check name", Arg1);
-
else
C := Get_Check_Id (Chars (Expression (Arg1)));
end if;
end if;
end No_Return;
+ ------------------------
+ -- No_Strict_Aliasing --
+ ------------------------
+
+ when Pragma_No_Strict_Aliasing => No_Strict_Alias : declare
+ E_Id : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_At_Most_N_Arguments (1);
+
+ if Arg_Count = 0 then
+ Check_Valid_Configuration_Pragma;
+ Opt.No_Strict_Aliasing := True;
+
+ else
+ Check_Optional_Identifier (Arg2, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Entity (Expression (Arg1));
+
+ if E_Id = Any_Type then
+ return;
+ elsif No (E_Id) or else not Is_Access_Type (E_Id) then
+ Error_Pragma_Arg ("pragma% requires access type", Arg1);
+ end if;
+
+ Set_No_Strict_Aliasing (Base_Type (E_Id));
+ end if;
+ end No_Strict_Alias;
+
-----------------
-- Obsolescent --
-----------------
Pragma_Memory_Size => -1,
Pragma_No_Return => 0,
Pragma_No_Run_Time => -1,
+ Pragma_No_Strict_Aliasing => -1,
Pragma_Normalize_Scalars => -1,
Pragma_Obsolescent => 0,
Pragma_Optimize => -1,
-- The front end also deals with specific cases that are not allowed
-- e.g. involving unconstrained array types.
- -- For the case of the standard gigi backend, this means that all
- -- checks are done in the front-end.
+ -- However, some checks, e.g. the check for suspicious aliasing
+ -- when converting to a pointer type, can more conveniently be
+ -- performed in the back end where alias sets are known.
- -- However, in the case of specialized back-ends, notably the JVM
- -- backend for JGNAT, additional requirements and restrictions apply
+ -- In addition, for specialized back ends, notably the JVM-based
+ -- back end for JGNAT, additional requirements and restrictions apply
-- to unchecked conversion, and these are most conveniently performed
-- in the specialized back-end.
- -- To accommodate this requirement, for such back ends, the following
- -- special node is generated recording an unchecked conversion that
- -- needs to be validated. The back end should post an appropriate
- -- error message if the unchecked conversion is invalid or warrants
- -- a special warning message.
+ -- To accommodate this requirement, the following special node is
+ -- generated recording an unchecked conversion that needs to be
+ -- validated. The back end should post an appropriate error message
+ -- error message if the unchecked conversion is invalid or a warning
+ -- message if a special warning is warranted.
-- Source_Type and Target_Type point to the entities for the two
-- types involved in the unchecked conversion instantiation that
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- S I N P U T . P --
+-- S I N P U T . C --
-- --
-- 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- --
declare
pragma Suppress (All_Checks);
+ pragma Warnings (Off);
+ -- The following unchecked conversion is aliased safe, since it
+ -- is not used to create improperly aliased pointer values.
+
function To_Source_Buffer_Ptr is new
Ada.Unchecked_Conversion (Address, Source_Buffer_Ptr);
+ pragma Warnings (On);
+
begin
Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
end;
-- --
-- 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- --
declare
pragma Suppress (All_Checks);
+ pragma Warnings (Off);
+ -- This unchecked conversion is aliasing safe, since it is never
+ -- used to create improperly aliased pointer values.
+
function To_Source_Buffer_Ptr is new
Unchecked_Conversion (Address, Source_Buffer_Ptr);
+ pragma Warnings (On);
+
begin
Source_File.Table (Xnew).Source_Text :=
To_Source_Buffer_Ptr
declare
pragma Suppress (All_Checks);
+ pragma Warnings (Off);
+ -- This unchecked conversion is aliasing safe, since
+ -- it is never used to create improperly aliased
+ -- pointer values.
+
function To_Source_Buffer_Ptr is new
Unchecked_Conversion (Address, Source_Buffer_Ptr);
+ pragma Warnings (On);
+
begin
Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
-- --
-- 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- --
-- Routines to support conversion between types Lines_Table_Ptr,
-- Logical_Lines_Table_Ptr and System.Address.
+ pragma Warnings (Off);
+ -- These unchecked conversions are aliasing safe, since they are never
+ -- used to construct improperly aliased pointer values.
+
function To_Address is
new Unchecked_Conversion (Lines_Table_Ptr, Address);
function To_Pointer is
new Unchecked_Conversion (Address, Logical_Lines_Table_Ptr);
+ pragma Warnings (On);
+
---------------------------
-- Add_Line_Tables_Entry --
---------------------------
procedure Free_Ptr is new Unchecked_Deallocation
(Big_Source_Buffer, Source_Buffer_Ptr);
+ pragma Warnings (Off);
+ -- This unchecked conversion is aliasing safe, since it is not
+ -- used to create improperly aliased pointer values.
+
function To_Source_Buffer_Ptr is new
Unchecked_Conversion (Address, Source_Buffer_Ptr);
+ pragma Warnings (On);
+
Tmp1 : Source_Buffer_Ptr;
begin
declare
pragma Suppress (All_Checks);
+ pragma Warnings (Off);
+ -- This unchecked conversion is aliasing safe since it
+ -- not used to create improperly aliased pointer values.
+
function To_Source_Buffer_Ptr is new
Unchecked_Conversion (Address, Source_Buffer_Ptr);
+ pragma Warnings (On);
+
begin
S.Source_Text :=
To_Source_Buffer_Ptr
pragma Suppress (All_Checks);
+ pragma Warnings (Off);
+ -- This unchecked conversion is aliasing safe, since it is
+ -- never used to create improperly aliased pointer values.
+
function To_Source_Buffer_Ptr is new
Unchecked_Conversion (Address, Source_Buffer_Ptr);
+ pragma Warnings (On);
+
begin
T := new B;
"locking_policy#" &
"long_float#" &
"no_run_time#" &
+ "no_strict_aliasing#" &
"normalize_scalars#" &
"polling#" &
"persistent_data#" &
Name_Locking_Policy : constant Name_Id := N + 109;
Name_Long_Float : constant Name_Id := N + 110; -- VMS
Name_No_Run_Time : constant Name_Id := N + 111; -- GNAT
- Name_Normalize_Scalars : constant Name_Id := N + 112;
- Name_Polling : constant Name_Id := N + 113; -- GNAT
- Name_Persistent_Data : constant Name_Id := N + 114; -- GNAT
- Name_Persistent_Object : constant Name_Id := N + 115; -- GNAT
- Name_Profile : constant Name_Id := N + 116; -- Ada0Y
- Name_Propagate_Exceptions : constant Name_Id := N + 117; -- GNAT
- Name_Queuing_Policy : constant Name_Id := N + 118;
- Name_Ravenscar : constant Name_Id := N + 119;
- Name_Restricted_Run_Time : constant Name_Id := N + 120;
- Name_Restrictions : constant Name_Id := N + 121;
- Name_Restriction_Warnings : constant Name_Id := N + 122; -- GNAT
- Name_Reviewable : constant Name_Id := N + 123;
- Name_Source_File_Name : constant Name_Id := N + 124; -- GNAT
- Name_Source_File_Name_Project : constant Name_Id := N + 125; -- GNAT
- Name_Style_Checks : constant Name_Id := N + 126; -- GNAT
- Name_Suppress : constant Name_Id := N + 127;
- Name_Suppress_Exception_Locations : constant Name_Id := N + 128; -- GNAT
- Name_Task_Dispatching_Policy : constant Name_Id := N + 129;
- Name_Universal_Data : constant Name_Id := N + 130; -- AAMP
- Name_Unsuppress : constant Name_Id := N + 131; -- GNAT
- Name_Use_VADS_Size : constant Name_Id := N + 132; -- GNAT
- Name_Validity_Checks : constant Name_Id := N + 133; -- GNAT
- Name_Warnings : constant Name_Id := N + 134; -- GNAT
- Last_Configuration_Pragma_Name : constant Name_Id := N + 134;
+ Name_No_Strict_Aliasing : constant Name_Id := N + 112; -- GNAT
+ Name_Normalize_Scalars : constant Name_Id := N + 113;
+ Name_Polling : constant Name_Id := N + 114; -- GNAT
+ Name_Persistent_Data : constant Name_Id := N + 115; -- GNAT
+ Name_Persistent_Object : constant Name_Id := N + 116; -- GNAT
+ Name_Profile : constant Name_Id := N + 117; -- Ada0Y
+ Name_Propagate_Exceptions : constant Name_Id := N + 118; -- GNAT
+ Name_Queuing_Policy : constant Name_Id := N + 119;
+ Name_Ravenscar : constant Name_Id := N + 120;
+ Name_Restricted_Run_Time : constant Name_Id := N + 121;
+ Name_Restrictions : constant Name_Id := N + 122;
+ Name_Restriction_Warnings : constant Name_Id := N + 123; -- GNAT
+ Name_Reviewable : constant Name_Id := N + 124;
+ Name_Source_File_Name : constant Name_Id := N + 125; -- GNAT
+ Name_Source_File_Name_Project : constant Name_Id := N + 126; -- GNAT
+ Name_Style_Checks : constant Name_Id := N + 127; -- GNAT
+ Name_Suppress : constant Name_Id := N + 128;
+ Name_Suppress_Exception_Locations : constant Name_Id := N + 129; -- GNAT
+ Name_Task_Dispatching_Policy : constant Name_Id := N + 130;
+ Name_Universal_Data : constant Name_Id := N + 131; -- AAMP
+ Name_Unsuppress : constant Name_Id := N + 132; -- GNAT
+ Name_Use_VADS_Size : constant Name_Id := N + 133; -- GNAT
+ Name_Validity_Checks : constant Name_Id := N + 134; -- GNAT
+ Name_Warnings : constant Name_Id := N + 135; -- GNAT
+ Last_Configuration_Pragma_Name : constant Name_Id := N + 135;
-- Remaining pragma names
- Name_Abort_Defer : constant Name_Id := N + 135; -- GNAT
- Name_All_Calls_Remote : constant Name_Id := N + 136;
- Name_Annotate : constant Name_Id := N + 137; -- GNAT
+ Name_Abort_Defer : constant Name_Id := N + 136; -- GNAT
+ Name_All_Calls_Remote : constant Name_Id := N + 137;
+ Name_Annotate : constant Name_Id := N + 138; -- 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 + 138; -- GNAT
- Name_Asynchronous : constant Name_Id := N + 139;
- Name_Atomic : constant Name_Id := N + 140;
- Name_Atomic_Components : constant Name_Id := N + 141;
- Name_Attach_Handler : constant Name_Id := N + 142;
- Name_Comment : constant Name_Id := N + 143; -- GNAT
- Name_Common_Object : constant Name_Id := N + 144; -- GNAT
- Name_Complex_Representation : constant Name_Id := N + 145; -- GNAT
- Name_Controlled : constant Name_Id := N + 146;
- Name_Convention : constant Name_Id := N + 147;
- Name_CPP_Class : constant Name_Id := N + 148; -- GNAT
- Name_CPP_Constructor : constant Name_Id := N + 149; -- GNAT
- Name_CPP_Virtual : constant Name_Id := N + 150; -- GNAT
- Name_CPP_Vtable : constant Name_Id := N + 151; -- GNAT
- Name_Debug : constant Name_Id := N + 152; -- GNAT
- Name_Elaborate : constant Name_Id := N + 153; -- Ada 83
- Name_Elaborate_All : constant Name_Id := N + 154;
- Name_Elaborate_Body : constant Name_Id := N + 155;
- Name_Export : constant Name_Id := N + 156;
- Name_Export_Exception : constant Name_Id := N + 157; -- VMS
- Name_Export_Function : constant Name_Id := N + 158; -- GNAT
- Name_Export_Object : constant Name_Id := N + 159; -- GNAT
- Name_Export_Procedure : constant Name_Id := N + 160; -- GNAT
- Name_Export_Value : constant Name_Id := N + 161; -- GNAT
- Name_Export_Valued_Procedure : constant Name_Id := N + 162; -- GNAT
- Name_External : constant Name_Id := N + 163; -- GNAT
- Name_Finalize_Storage_Only : constant Name_Id := N + 164; -- GNAT
- Name_Ident : constant Name_Id := N + 165; -- VMS
- Name_Import : constant Name_Id := N + 166;
- Name_Import_Exception : constant Name_Id := N + 167; -- VMS
- Name_Import_Function : constant Name_Id := N + 168; -- GNAT
- Name_Import_Object : constant Name_Id := N + 169; -- GNAT
- Name_Import_Procedure : constant Name_Id := N + 170; -- GNAT
- Name_Import_Valued_Procedure : constant Name_Id := N + 171; -- GNAT
- Name_Inline : constant Name_Id := N + 172;
- Name_Inline_Always : constant Name_Id := N + 173; -- GNAT
- Name_Inline_Generic : constant Name_Id := N + 174; -- GNAT
- Name_Inspection_Point : constant Name_Id := N + 175;
- Name_Interface : constant Name_Id := N + 176; -- Ada 83
- Name_Interface_Name : constant Name_Id := N + 177; -- GNAT
- Name_Interrupt_Handler : constant Name_Id := N + 178;
- Name_Interrupt_Priority : constant Name_Id := N + 179;
- Name_Java_Constructor : constant Name_Id := N + 180; -- GNAT
- Name_Java_Interface : constant Name_Id := N + 181; -- GNAT
- Name_Keep_Names : constant Name_Id := N + 182; -- GNAT
- Name_Link_With : constant Name_Id := N + 183; -- GNAT
- Name_Linker_Alias : constant Name_Id := N + 184; -- GNAT
- Name_Linker_Options : constant Name_Id := N + 185;
- Name_Linker_Section : constant Name_Id := N + 186; -- GNAT
- Name_List : constant Name_Id := N + 187;
- Name_Machine_Attribute : constant Name_Id := N + 188; -- GNAT
- Name_Main : constant Name_Id := N + 189; -- GNAT
- Name_Main_Storage : constant Name_Id := N + 190; -- GNAT
- Name_Memory_Size : constant Name_Id := N + 191; -- Ada 83
- Name_No_Return : constant Name_Id := N + 192; -- GNAT
- Name_Obsolescent : constant Name_Id := N + 193; -- GNAT
- Name_Optimize : constant Name_Id := N + 194;
- Name_Optional_Overriding : constant Name_Id := N + 195;
- Name_Overriding : constant Name_Id := N + 196;
- Name_Pack : constant Name_Id := N + 197;
- Name_Page : constant Name_Id := N + 198;
- Name_Passive : constant Name_Id := N + 199; -- GNAT
- Name_Preelaborate : constant Name_Id := N + 200;
- Name_Priority : constant Name_Id := N + 201;
- Name_Psect_Object : constant Name_Id := N + 202; -- VMS
- Name_Pure : constant Name_Id := N + 203;
- Name_Pure_Function : constant Name_Id := N + 204; -- GNAT
- Name_Remote_Call_Interface : constant Name_Id := N + 205;
- Name_Remote_Types : constant Name_Id := N + 206;
- Name_Share_Generic : constant Name_Id := N + 207; -- GNAT
- Name_Shared : constant Name_Id := N + 208; -- Ada 83
- Name_Shared_Passive : constant Name_Id := N + 209;
+ Name_Assert : constant Name_Id := N + 139; -- GNAT
+ Name_Asynchronous : constant Name_Id := N + 140;
+ Name_Atomic : constant Name_Id := N + 141;
+ Name_Atomic_Components : constant Name_Id := N + 142;
+ Name_Attach_Handler : constant Name_Id := N + 143;
+ Name_Comment : constant Name_Id := N + 144; -- GNAT
+ Name_Common_Object : constant Name_Id := N + 145; -- GNAT
+ Name_Complex_Representation : constant Name_Id := N + 146; -- GNAT
+ Name_Controlled : constant Name_Id := N + 147;
+ Name_Convention : constant Name_Id := N + 148;
+ Name_CPP_Class : constant Name_Id := N + 149; -- GNAT
+ Name_CPP_Constructor : constant Name_Id := N + 150; -- GNAT
+ Name_CPP_Virtual : constant Name_Id := N + 151; -- GNAT
+ Name_CPP_Vtable : constant Name_Id := N + 152; -- GNAT
+ Name_Debug : constant Name_Id := N + 153; -- GNAT
+ Name_Elaborate : constant Name_Id := N + 154; -- Ada 83
+ Name_Elaborate_All : constant Name_Id := N + 155;
+ Name_Elaborate_Body : constant Name_Id := N + 156;
+ Name_Export : constant Name_Id := N + 157;
+ Name_Export_Exception : constant Name_Id := N + 158; -- VMS
+ Name_Export_Function : constant Name_Id := N + 159; -- GNAT
+ Name_Export_Object : constant Name_Id := N + 160; -- GNAT
+ Name_Export_Procedure : constant Name_Id := N + 161; -- GNAT
+ Name_Export_Value : constant Name_Id := N + 162; -- GNAT
+ Name_Export_Valued_Procedure : constant Name_Id := N + 163; -- GNAT
+ Name_External : constant Name_Id := N + 164; -- GNAT
+ Name_Finalize_Storage_Only : constant Name_Id := N + 165; -- GNAT
+ Name_Ident : constant Name_Id := N + 166; -- VMS
+ Name_Import : constant Name_Id := N + 167;
+ Name_Import_Exception : constant Name_Id := N + 168; -- VMS
+ Name_Import_Function : constant Name_Id := N + 169; -- GNAT
+ Name_Import_Object : constant Name_Id := N + 170; -- GNAT
+ Name_Import_Procedure : constant Name_Id := N + 171; -- GNAT
+ Name_Import_Valued_Procedure : constant Name_Id := N + 172; -- GNAT
+ Name_Inline : constant Name_Id := N + 173;
+ Name_Inline_Always : constant Name_Id := N + 174; -- GNAT
+ Name_Inline_Generic : constant Name_Id := N + 175; -- GNAT
+ Name_Inspection_Point : constant Name_Id := N + 176;
+ Name_Interface : constant Name_Id := N + 177; -- Ada 83
+ Name_Interface_Name : constant Name_Id := N + 178; -- GNAT
+ Name_Interrupt_Handler : constant Name_Id := N + 179;
+ Name_Interrupt_Priority : constant Name_Id := N + 180;
+ Name_Java_Constructor : constant Name_Id := N + 181; -- GNAT
+ Name_Java_Interface : constant Name_Id := N + 182; -- GNAT
+ Name_Keep_Names : constant Name_Id := N + 183; -- GNAT
+ Name_Link_With : constant Name_Id := N + 184; -- GNAT
+ Name_Linker_Alias : constant Name_Id := N + 185; -- GNAT
+ Name_Linker_Options : constant Name_Id := N + 186;
+ Name_Linker_Section : constant Name_Id := N + 187; -- GNAT
+ Name_List : constant Name_Id := N + 188;
+ Name_Machine_Attribute : constant Name_Id := N + 189; -- GNAT
+ Name_Main : constant Name_Id := N + 190; -- GNAT
+ Name_Main_Storage : constant Name_Id := N + 191; -- GNAT
+ Name_Memory_Size : constant Name_Id := N + 192; -- Ada 83
+ Name_No_Return : constant Name_Id := N + 193; -- GNAT
+ Name_Obsolescent : constant Name_Id := N + 194; -- GNAT
+ Name_Optimize : constant Name_Id := N + 195;
+ Name_Optional_Overriding : constant Name_Id := N + 196;
+ Name_Overriding : constant Name_Id := N + 197;
+ Name_Pack : constant Name_Id := N + 198;
+ Name_Page : constant Name_Id := N + 199;
+ Name_Passive : constant Name_Id := N + 200; -- GNAT
+ Name_Preelaborate : constant Name_Id := N + 201;
+ Name_Priority : constant Name_Id := N + 202;
+ Name_Psect_Object : constant Name_Id := N + 203; -- VMS
+ Name_Pure : constant Name_Id := N + 204;
+ Name_Pure_Function : constant Name_Id := N + 205; -- GNAT
+ Name_Remote_Call_Interface : constant Name_Id := N + 206;
+ Name_Remote_Types : constant Name_Id := N + 207;
+ Name_Share_Generic : constant Name_Id := N + 208; -- GNAT
+ Name_Shared : constant Name_Id := N + 209; -- Ada 83
+ Name_Shared_Passive : constant Name_Id := N + 210;
-- 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 + 210; -- GNAT
- Name_Stream_Convert : constant Name_Id := N + 211; -- GNAT
- Name_Subtitle : constant Name_Id := N + 212; -- GNAT
- Name_Suppress_All : constant Name_Id := N + 213; -- GNAT
- Name_Suppress_Debug_Info : constant Name_Id := N + 214; -- GNAT
- Name_Suppress_Initialization : constant Name_Id := N + 215; -- GNAT
- Name_System_Name : constant Name_Id := N + 216; -- Ada 83
- Name_Task_Info : constant Name_Id := N + 217; -- GNAT
- Name_Task_Name : constant Name_Id := N + 218; -- GNAT
- Name_Task_Storage : constant Name_Id := N + 219; -- VMS
- Name_Thread_Body : constant Name_Id := N + 220; -- GNAT
- Name_Time_Slice : constant Name_Id := N + 221; -- GNAT
- Name_Title : constant Name_Id := N + 222; -- GNAT
- Name_Unchecked_Union : constant Name_Id := N + 223; -- GNAT
- Name_Unimplemented_Unit : constant Name_Id := N + 224; -- GNAT
- Name_Unreferenced : constant Name_Id := N + 225; -- GNAT
- Name_Unreserve_All_Interrupts : constant Name_Id := N + 226; -- GNAT
- Name_Volatile : constant Name_Id := N + 227;
- Name_Volatile_Components : constant Name_Id := N + 228;
- Name_Weak_External : constant Name_Id := N + 229; -- GNAT
- Last_Pragma_Name : constant Name_Id := N + 229;
+ Name_Source_Reference : constant Name_Id := N + 211; -- GNAT
+ Name_Stream_Convert : constant Name_Id := N + 212; -- GNAT
+ Name_Subtitle : constant Name_Id := N + 213; -- GNAT
+ Name_Suppress_All : constant Name_Id := N + 214; -- GNAT
+ Name_Suppress_Debug_Info : constant Name_Id := N + 215; -- GNAT
+ Name_Suppress_Initialization : constant Name_Id := N + 216; -- GNAT
+ Name_System_Name : constant Name_Id := N + 217; -- Ada 83
+ Name_Task_Info : constant Name_Id := N + 218; -- GNAT
+ Name_Task_Name : constant Name_Id := N + 219; -- GNAT
+ Name_Task_Storage : constant Name_Id := N + 220; -- VMS
+ Name_Thread_Body : constant Name_Id := N + 221; -- GNAT
+ Name_Time_Slice : constant Name_Id := N + 222; -- GNAT
+ Name_Title : constant Name_Id := N + 223; -- GNAT
+ Name_Unchecked_Union : constant Name_Id := N + 224; -- GNAT
+ Name_Unimplemented_Unit : constant Name_Id := N + 225; -- GNAT
+ Name_Unreferenced : constant Name_Id := N + 226; -- GNAT
+ Name_Unreserve_All_Interrupts : constant Name_Id := N + 227; -- GNAT
+ Name_Volatile : constant Name_Id := N + 228;
+ Name_Volatile_Components : constant Name_Id := N + 229;
+ Name_Weak_External : constant Name_Id := N + 230; -- GNAT
+ Last_Pragma_Name : constant Name_Id := N + 230;
-- 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 + 230;
- Name_Ada : constant Name_Id := N + 230;
- Name_Assembler : constant Name_Id := N + 231;
- Name_COBOL : constant Name_Id := N + 232;
- Name_CPP : constant Name_Id := N + 233;
- Name_Fortran : constant Name_Id := N + 234;
- Name_Intrinsic : constant Name_Id := N + 235;
- Name_Java : constant Name_Id := N + 236;
- Name_Stdcall : constant Name_Id := N + 237;
- Name_Stubbed : constant Name_Id := N + 238;
- Last_Convention_Name : constant Name_Id := N + 238;
+ First_Convention_Name : constant Name_Id := N + 231;
+ Name_Ada : constant Name_Id := N + 231;
+ Name_Assembler : constant Name_Id := N + 232;
+ Name_COBOL : constant Name_Id := N + 233;
+ Name_CPP : constant Name_Id := N + 234;
+ Name_Fortran : constant Name_Id := N + 235;
+ Name_Intrinsic : constant Name_Id := N + 236;
+ Name_Java : constant Name_Id := N + 237;
+ Name_Stdcall : constant Name_Id := N + 238;
+ Name_Stubbed : constant Name_Id := N + 239;
+ Last_Convention_Name : constant Name_Id := N + 239;
-- The following names are preset as synonyms for Assembler
- Name_Asm : constant Name_Id := N + 239;
- Name_Assembly : constant Name_Id := N + 240;
+ Name_Asm : constant Name_Id := N + 240;
+ Name_Assembly : constant Name_Id := N + 241;
-- The following names are preset as synonyms for C
- Name_Default : constant Name_Id := N + 241;
+ Name_Default : constant Name_Id := N + 242;
-- Name_Exernal (previously defined as pragma)
-- The following names are present as synonyms for Stdcall
- Name_DLL : constant Name_Id := N + 242;
- Name_Win32 : constant Name_Id := N + 243;
+ Name_DLL : constant Name_Id := N + 243;
+ Name_Win32 : constant Name_Id := N + 244;
-- Other special names used in processing pragmas
- Name_As_Is : constant Name_Id := N + 244;
- Name_Body_File_Name : constant Name_Id := N + 245;
- Name_Casing : constant Name_Id := N + 246;
- Name_Code : constant Name_Id := N + 247;
- Name_Component : constant Name_Id := N + 248;
- Name_Component_Size_4 : constant Name_Id := N + 249;
- Name_Copy : constant Name_Id := N + 250;
- Name_D_Float : constant Name_Id := N + 251;
- Name_Descriptor : constant Name_Id := N + 252;
- Name_Dot_Replacement : constant Name_Id := N + 253;
- Name_Dynamic : constant Name_Id := N + 254;
- Name_Entity : constant Name_Id := N + 255;
- Name_External_Name : constant Name_Id := N + 256;
- Name_First_Optional_Parameter : constant Name_Id := N + 257;
- Name_Form : constant Name_Id := N + 258;
- Name_G_Float : constant Name_Id := N + 259;
- Name_Gcc : constant Name_Id := N + 260;
- Name_Gnat : constant Name_Id := N + 261;
- Name_GPL : constant Name_Id := N + 262;
- Name_IEEE_Float : constant Name_Id := N + 263;
- Name_Homonym_Number : constant Name_Id := N + 264;
- Name_Internal : constant Name_Id := N + 265;
- Name_Link_Name : constant Name_Id := N + 266;
- Name_Lowercase : constant Name_Id := N + 267;
- Name_Max_Size : constant Name_Id := N + 268;
- Name_Mechanism : constant Name_Id := N + 269;
- Name_Mixedcase : constant Name_Id := N + 270;
- Name_Modified_GPL : constant Name_Id := N + 271;
- Name_Name : constant Name_Id := N + 272;
- Name_NCA : constant Name_Id := N + 273;
- Name_No : constant Name_Id := N + 274;
- Name_On : constant Name_Id := N + 275;
- Name_Parameter_Types : constant Name_Id := N + 276;
- Name_Reference : constant Name_Id := N + 277;
- Name_No_Requeue : constant Name_Id := N + 278;
- Name_No_Task_Attributes : constant Name_Id := N + 279;
- Name_Restricted : constant Name_Id := N + 280;
- Name_Result_Mechanism : constant Name_Id := N + 281;
- Name_Result_Type : constant Name_Id := N + 282;
- Name_Runtime : constant Name_Id := N + 283;
- Name_SB : constant Name_Id := N + 284;
- Name_Secondary_Stack_Size : constant Name_Id := N + 285;
- Name_Section : constant Name_Id := N + 286;
- Name_Semaphore : constant Name_Id := N + 287;
- Name_Spec_File_Name : constant Name_Id := N + 288;
- Name_Static : constant Name_Id := N + 289;
- Name_Stack_Size : constant Name_Id := N + 290;
- Name_Subunit_File_Name : constant Name_Id := N + 291;
- Name_Task_Stack_Size_Default : constant Name_Id := N + 292;
- Name_Task_Type : constant Name_Id := N + 293;
- Name_Time_Slicing_Enabled : constant Name_Id := N + 294;
- Name_Top_Guard : constant Name_Id := N + 295;
- Name_UBA : constant Name_Id := N + 296;
- Name_UBS : constant Name_Id := N + 297;
- Name_UBSB : constant Name_Id := N + 298;
- Name_Unit_Name : constant Name_Id := N + 299;
- Name_Unknown : constant Name_Id := N + 300;
- Name_Unrestricted : constant Name_Id := N + 301;
- Name_Uppercase : constant Name_Id := N + 302;
- Name_User : constant Name_Id := N + 303;
- Name_VAX_Float : constant Name_Id := N + 304;
- Name_VMS : constant Name_Id := N + 305;
- Name_Working_Storage : constant Name_Id := N + 306;
+ Name_As_Is : constant Name_Id := N + 245;
+ Name_Body_File_Name : constant Name_Id := N + 246;
+ Name_Casing : constant Name_Id := N + 247;
+ Name_Code : constant Name_Id := N + 248;
+ Name_Component : constant Name_Id := N + 249;
+ Name_Component_Size_4 : constant Name_Id := N + 250;
+ Name_Copy : constant Name_Id := N + 251;
+ Name_D_Float : constant Name_Id := N + 252;
+ Name_Descriptor : constant Name_Id := N + 253;
+ Name_Dot_Replacement : constant Name_Id := N + 254;
+ Name_Dynamic : constant Name_Id := N + 255;
+ Name_Entity : constant Name_Id := N + 256;
+ Name_External_Name : constant Name_Id := N + 257;
+ Name_First_Optional_Parameter : constant Name_Id := N + 258;
+ Name_Form : constant Name_Id := N + 259;
+ Name_G_Float : constant Name_Id := N + 260;
+ Name_Gcc : constant Name_Id := N + 261;
+ Name_Gnat : constant Name_Id := N + 262;
+ Name_GPL : constant Name_Id := N + 263;
+ Name_IEEE_Float : constant Name_Id := N + 264;
+ Name_Homonym_Number : constant Name_Id := N + 265;
+ Name_Internal : constant Name_Id := N + 266;
+ Name_Link_Name : constant Name_Id := N + 267;
+ Name_Lowercase : constant Name_Id := N + 268;
+ Name_Max_Size : constant Name_Id := N + 269;
+ Name_Mechanism : constant Name_Id := N + 270;
+ Name_Mixedcase : constant Name_Id := N + 271;
+ Name_Modified_GPL : constant Name_Id := N + 272;
+ Name_Name : constant Name_Id := N + 273;
+ Name_NCA : constant Name_Id := N + 274;
+ Name_No : constant Name_Id := N + 275;
+ Name_On : constant Name_Id := N + 276;
+ Name_Parameter_Types : constant Name_Id := N + 277;
+ Name_Reference : constant Name_Id := N + 278;
+ Name_No_Requeue : constant Name_Id := N + 279;
+ Name_No_Task_Attributes : constant Name_Id := N + 280;
+ Name_Restricted : constant Name_Id := N + 281;
+ Name_Result_Mechanism : constant Name_Id := N + 282;
+ Name_Result_Type : constant Name_Id := N + 283;
+ Name_Runtime : constant Name_Id := N + 284;
+ Name_SB : constant Name_Id := N + 285;
+ Name_Secondary_Stack_Size : constant Name_Id := N + 286;
+ Name_Section : constant Name_Id := N + 287;
+ Name_Semaphore : constant Name_Id := N + 288;
+ Name_Spec_File_Name : constant Name_Id := N + 289;
+ Name_Static : constant Name_Id := N + 290;
+ Name_Stack_Size : constant Name_Id := N + 291;
+ Name_Subunit_File_Name : constant Name_Id := N + 292;
+ Name_Task_Stack_Size_Default : constant Name_Id := N + 293;
+ Name_Task_Type : constant Name_Id := N + 294;
+ Name_Time_Slicing_Enabled : constant Name_Id := N + 295;
+ Name_Top_Guard : constant Name_Id := N + 296;
+ Name_UBA : constant Name_Id := N + 297;
+ Name_UBS : constant Name_Id := N + 298;
+ Name_UBSB : constant Name_Id := N + 299;
+ Name_Unit_Name : constant Name_Id := N + 300;
+ Name_Unknown : constant Name_Id := N + 301;
+ Name_Unrestricted : constant Name_Id := N + 302;
+ Name_Uppercase : constant Name_Id := N + 303;
+ Name_User : constant Name_Id := N + 304;
+ Name_VAX_Float : constant Name_Id := N + 305;
+ Name_VMS : constant Name_Id := N + 306;
+ Name_Working_Storage : constant Name_Id := N + 307;
-- 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 + 307;
- Name_Abort_Signal : constant Name_Id := N + 307; -- GNAT
- Name_Access : constant Name_Id := N + 308;
- Name_Address : constant Name_Id := N + 309;
- Name_Address_Size : constant Name_Id := N + 310; -- GNAT
- Name_Aft : constant Name_Id := N + 311;
- Name_Alignment : constant Name_Id := N + 312;
- Name_Asm_Input : constant Name_Id := N + 313; -- GNAT
- Name_Asm_Output : constant Name_Id := N + 314; -- GNAT
- Name_AST_Entry : constant Name_Id := N + 315; -- VMS
- Name_Bit : constant Name_Id := N + 316; -- GNAT
- Name_Bit_Order : constant Name_Id := N + 317;
- Name_Bit_Position : constant Name_Id := N + 318; -- GNAT
- Name_Body_Version : constant Name_Id := N + 319;
- Name_Callable : constant Name_Id := N + 320;
- Name_Caller : constant Name_Id := N + 321;
- Name_Code_Address : constant Name_Id := N + 322; -- GNAT
- Name_Component_Size : constant Name_Id := N + 323;
- Name_Compose : constant Name_Id := N + 324;
- Name_Constrained : constant Name_Id := N + 325;
- Name_Count : constant Name_Id := N + 326;
- Name_Default_Bit_Order : constant Name_Id := N + 327; -- GNAT
- Name_Definite : constant Name_Id := N + 328;
- Name_Delta : constant Name_Id := N + 329;
- Name_Denorm : constant Name_Id := N + 330;
- Name_Digits : constant Name_Id := N + 331;
- Name_Elaborated : constant Name_Id := N + 332; -- GNAT
- Name_Emax : constant Name_Id := N + 333; -- Ada 83
- Name_Enum_Rep : constant Name_Id := N + 334; -- GNAT
- Name_Epsilon : constant Name_Id := N + 335; -- Ada 83
- Name_Exponent : constant Name_Id := N + 336;
- Name_External_Tag : constant Name_Id := N + 337;
- Name_First : constant Name_Id := N + 338;
- Name_First_Bit : constant Name_Id := N + 339;
- Name_Fixed_Value : constant Name_Id := N + 340; -- GNAT
- Name_Fore : constant Name_Id := N + 341;
- Name_Has_Discriminants : constant Name_Id := N + 342; -- GNAT
- Name_Identity : constant Name_Id := N + 343;
- Name_Img : constant Name_Id := N + 344; -- GNAT
- Name_Integer_Value : constant Name_Id := N + 345; -- GNAT
- Name_Large : constant Name_Id := N + 346; -- Ada 83
- Name_Last : constant Name_Id := N + 347;
- Name_Last_Bit : constant Name_Id := N + 348;
- Name_Leading_Part : constant Name_Id := N + 349;
- Name_Length : constant Name_Id := N + 350;
- Name_Machine_Emax : constant Name_Id := N + 351;
- Name_Machine_Emin : constant Name_Id := N + 352;
- Name_Machine_Mantissa : constant Name_Id := N + 353;
- Name_Machine_Overflows : constant Name_Id := N + 354;
- Name_Machine_Radix : constant Name_Id := N + 355;
- Name_Machine_Rounds : constant Name_Id := N + 356;
- Name_Machine_Size : constant Name_Id := N + 357; -- GNAT
- Name_Mantissa : constant Name_Id := N + 358; -- Ada 83
- Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 359;
- Name_Maximum_Alignment : constant Name_Id := N + 360; -- GNAT
- Name_Mechanism_Code : constant Name_Id := N + 361; -- GNAT
- Name_Model_Emin : constant Name_Id := N + 362;
- Name_Model_Epsilon : constant Name_Id := N + 363;
- Name_Model_Mantissa : constant Name_Id := N + 364;
- Name_Model_Small : constant Name_Id := N + 365;
- Name_Modulus : constant Name_Id := N + 366;
- Name_Null_Parameter : constant Name_Id := N + 367; -- GNAT
- Name_Object_Size : constant Name_Id := N + 368; -- GNAT
- Name_Partition_ID : constant Name_Id := N + 369;
- Name_Passed_By_Reference : constant Name_Id := N + 370; -- GNAT
- Name_Pool_Address : constant Name_Id := N + 371;
- Name_Pos : constant Name_Id := N + 372;
- Name_Position : constant Name_Id := N + 373;
- Name_Range : constant Name_Id := N + 374;
- Name_Range_Length : constant Name_Id := N + 375; -- GNAT
- Name_Round : constant Name_Id := N + 376;
- Name_Safe_Emax : constant Name_Id := N + 377; -- Ada 83
- Name_Safe_First : constant Name_Id := N + 378;
- Name_Safe_Large : constant Name_Id := N + 379; -- Ada 83
- Name_Safe_Last : constant Name_Id := N + 380;
- Name_Safe_Small : constant Name_Id := N + 381; -- Ada 83
- Name_Scale : constant Name_Id := N + 382;
- Name_Scaling : constant Name_Id := N + 383;
- Name_Signed_Zeros : constant Name_Id := N + 384;
- Name_Size : constant Name_Id := N + 385;
- Name_Small : constant Name_Id := N + 386;
- Name_Storage_Size : constant Name_Id := N + 387;
- Name_Storage_Unit : constant Name_Id := N + 388; -- GNAT
- Name_Tag : constant Name_Id := N + 389;
- Name_Target_Name : constant Name_Id := N + 390; -- GNAT
- Name_Terminated : constant Name_Id := N + 391;
- Name_To_Address : constant Name_Id := N + 392; -- GNAT
- Name_Type_Class : constant Name_Id := N + 393; -- GNAT
- Name_UET_Address : constant Name_Id := N + 394; -- GNAT
- Name_Unbiased_Rounding : constant Name_Id := N + 395;
- Name_Unchecked_Access : constant Name_Id := N + 396;
- Name_Unconstrained_Array : constant Name_Id := N + 397;
- Name_Universal_Literal_String : constant Name_Id := N + 398; -- GNAT
- Name_Unrestricted_Access : constant Name_Id := N + 399; -- GNAT
- Name_VADS_Size : constant Name_Id := N + 400; -- GNAT
- Name_Val : constant Name_Id := N + 401;
- Name_Valid : constant Name_Id := N + 402;
- Name_Value_Size : constant Name_Id := N + 403; -- GNAT
- Name_Version : constant Name_Id := N + 404;
- Name_Wchar_T_Size : constant Name_Id := N + 405; -- GNAT
- Name_Wide_Width : constant Name_Id := N + 406;
- Name_Width : constant Name_Id := N + 407;
- Name_Word_Size : constant Name_Id := N + 408; -- GNAT
+ First_Attribute_Name : constant Name_Id := N + 308;
+ Name_Abort_Signal : constant Name_Id := N + 308; -- GNAT
+ Name_Access : constant Name_Id := N + 309;
+ Name_Address : constant Name_Id := N + 310;
+ Name_Address_Size : constant Name_Id := N + 311; -- GNAT
+ Name_Aft : constant Name_Id := N + 312;
+ Name_Alignment : constant Name_Id := N + 313;
+ Name_Asm_Input : constant Name_Id := N + 314; -- GNAT
+ Name_Asm_Output : constant Name_Id := N + 315; -- GNAT
+ Name_AST_Entry : constant Name_Id := N + 316; -- VMS
+ Name_Bit : constant Name_Id := N + 317; -- GNAT
+ Name_Bit_Order : constant Name_Id := N + 318;
+ Name_Bit_Position : constant Name_Id := N + 319; -- GNAT
+ Name_Body_Version : constant Name_Id := N + 320;
+ Name_Callable : constant Name_Id := N + 321;
+ Name_Caller : constant Name_Id := N + 322;
+ Name_Code_Address : constant Name_Id := N + 323; -- GNAT
+ Name_Component_Size : constant Name_Id := N + 324;
+ Name_Compose : constant Name_Id := N + 325;
+ Name_Constrained : constant Name_Id := N + 326;
+ Name_Count : constant Name_Id := N + 327;
+ Name_Default_Bit_Order : constant Name_Id := N + 328; -- GNAT
+ Name_Definite : constant Name_Id := N + 329;
+ Name_Delta : constant Name_Id := N + 330;
+ Name_Denorm : constant Name_Id := N + 331;
+ Name_Digits : constant Name_Id := N + 332;
+ Name_Elaborated : constant Name_Id := N + 333; -- GNAT
+ Name_Emax : constant Name_Id := N + 334; -- Ada 83
+ Name_Enum_Rep : constant Name_Id := N + 335; -- GNAT
+ Name_Epsilon : constant Name_Id := N + 336; -- Ada 83
+ Name_Exponent : constant Name_Id := N + 337;
+ Name_External_Tag : constant Name_Id := N + 338;
+ Name_First : constant Name_Id := N + 339;
+ Name_First_Bit : constant Name_Id := N + 340;
+ Name_Fixed_Value : constant Name_Id := N + 341; -- GNAT
+ Name_Fore : constant Name_Id := N + 342;
+ Name_Has_Discriminants : constant Name_Id := N + 343; -- GNAT
+ Name_Identity : constant Name_Id := N + 344;
+ Name_Img : constant Name_Id := N + 345; -- GNAT
+ Name_Integer_Value : constant Name_Id := N + 346; -- GNAT
+ Name_Large : constant Name_Id := N + 347; -- Ada 83
+ Name_Last : constant Name_Id := N + 348;
+ Name_Last_Bit : constant Name_Id := N + 349;
+ Name_Leading_Part : constant Name_Id := N + 350;
+ Name_Length : constant Name_Id := N + 351;
+ Name_Machine_Emax : constant Name_Id := N + 352;
+ Name_Machine_Emin : constant Name_Id := N + 353;
+ Name_Machine_Mantissa : constant Name_Id := N + 354;
+ Name_Machine_Overflows : constant Name_Id := N + 355;
+ Name_Machine_Radix : constant Name_Id := N + 356;
+ Name_Machine_Rounds : constant Name_Id := N + 357;
+ Name_Machine_Size : constant Name_Id := N + 358; -- GNAT
+ Name_Mantissa : constant Name_Id := N + 359; -- Ada 83
+ Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 360;
+ Name_Maximum_Alignment : constant Name_Id := N + 361; -- GNAT
+ Name_Mechanism_Code : constant Name_Id := N + 362; -- GNAT
+ Name_Model_Emin : constant Name_Id := N + 363;
+ Name_Model_Epsilon : constant Name_Id := N + 364;
+ Name_Model_Mantissa : constant Name_Id := N + 365;
+ Name_Model_Small : constant Name_Id := N + 366;
+ Name_Modulus : constant Name_Id := N + 367;
+ Name_Null_Parameter : constant Name_Id := N + 368; -- GNAT
+ Name_Object_Size : constant Name_Id := N + 369; -- GNAT
+ Name_Partition_ID : constant Name_Id := N + 370;
+ Name_Passed_By_Reference : constant Name_Id := N + 371; -- GNAT
+ Name_Pool_Address : constant Name_Id := N + 372;
+ Name_Pos : constant Name_Id := N + 373;
+ Name_Position : constant Name_Id := N + 374;
+ Name_Range : constant Name_Id := N + 375;
+ Name_Range_Length : constant Name_Id := N + 376; -- GNAT
+ Name_Round : constant Name_Id := N + 377;
+ Name_Safe_Emax : constant Name_Id := N + 378; -- Ada 83
+ Name_Safe_First : constant Name_Id := N + 379;
+ Name_Safe_Large : constant Name_Id := N + 380; -- Ada 83
+ Name_Safe_Last : constant Name_Id := N + 381;
+ Name_Safe_Small : constant Name_Id := N + 382; -- Ada 83
+ Name_Scale : constant Name_Id := N + 383;
+ Name_Scaling : constant Name_Id := N + 384;
+ Name_Signed_Zeros : constant Name_Id := N + 385;
+ Name_Size : constant Name_Id := N + 386;
+ Name_Small : constant Name_Id := N + 387;
+ Name_Storage_Size : constant Name_Id := N + 388;
+ Name_Storage_Unit : constant Name_Id := N + 389; -- GNAT
+ Name_Tag : constant Name_Id := N + 390;
+ Name_Target_Name : constant Name_Id := N + 391; -- GNAT
+ Name_Terminated : constant Name_Id := N + 392;
+ Name_To_Address : constant Name_Id := N + 393; -- GNAT
+ Name_Type_Class : constant Name_Id := N + 394; -- GNAT
+ Name_UET_Address : constant Name_Id := N + 395; -- GNAT
+ Name_Unbiased_Rounding : constant Name_Id := N + 396;
+ Name_Unchecked_Access : constant Name_Id := N + 397;
+ Name_Unconstrained_Array : constant Name_Id := N + 398;
+ Name_Universal_Literal_String : constant Name_Id := N + 399; -- GNAT
+ Name_Unrestricted_Access : constant Name_Id := N + 400; -- GNAT
+ Name_VADS_Size : constant Name_Id := N + 401; -- GNAT
+ Name_Val : constant Name_Id := N + 402;
+ Name_Valid : constant Name_Id := N + 403;
+ Name_Value_Size : constant Name_Id := N + 404; -- GNAT
+ Name_Version : constant Name_Id := N + 405;
+ Name_Wchar_T_Size : constant Name_Id := N + 406; -- GNAT
+ Name_Wide_Width : constant Name_Id := N + 407;
+ Name_Width : constant Name_Id := N + 408;
+ Name_Word_Size : constant Name_Id := N + 409; -- 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 + 409;
- Name_Adjacent : constant Name_Id := N + 409;
- Name_Ceiling : constant Name_Id := N + 410;
- Name_Copy_Sign : constant Name_Id := N + 411;
- Name_Floor : constant Name_Id := N + 412;
- Name_Fraction : constant Name_Id := N + 413;
- Name_Image : constant Name_Id := N + 414;
- Name_Input : constant Name_Id := N + 415;
- Name_Machine : constant Name_Id := N + 416;
- Name_Max : constant Name_Id := N + 417;
- Name_Min : constant Name_Id := N + 418;
- Name_Model : constant Name_Id := N + 419;
- Name_Pred : constant Name_Id := N + 420;
- Name_Remainder : constant Name_Id := N + 421;
- Name_Rounding : constant Name_Id := N + 422;
- Name_Succ : constant Name_Id := N + 423;
- Name_Truncation : constant Name_Id := N + 424;
- Name_Value : constant Name_Id := N + 425;
- Name_Wide_Image : constant Name_Id := N + 426;
- Name_Wide_Value : constant Name_Id := N + 427;
- Last_Renamable_Function_Attribute : constant Name_Id := N + 427;
+ First_Renamable_Function_Attribute : constant Name_Id := N + 410;
+ Name_Adjacent : constant Name_Id := N + 410;
+ Name_Ceiling : constant Name_Id := N + 411;
+ Name_Copy_Sign : constant Name_Id := N + 412;
+ Name_Floor : constant Name_Id := N + 413;
+ Name_Fraction : constant Name_Id := N + 414;
+ Name_Image : constant Name_Id := N + 415;
+ Name_Input : constant Name_Id := N + 416;
+ Name_Machine : constant Name_Id := N + 417;
+ Name_Max : constant Name_Id := N + 418;
+ Name_Min : constant Name_Id := N + 419;
+ Name_Model : constant Name_Id := N + 420;
+ Name_Pred : constant Name_Id := N + 421;
+ Name_Remainder : constant Name_Id := N + 422;
+ Name_Rounding : constant Name_Id := N + 423;
+ Name_Succ : constant Name_Id := N + 424;
+ Name_Truncation : constant Name_Id := N + 425;
+ Name_Value : constant Name_Id := N + 426;
+ Name_Wide_Image : constant Name_Id := N + 427;
+ Name_Wide_Value : constant Name_Id := N + 428;
+ Last_Renamable_Function_Attribute : constant Name_Id := N + 428;
-- Attributes that designate procedures
- First_Procedure_Attribute : constant Name_Id := N + 428;
- Name_Output : constant Name_Id := N + 428;
- Name_Read : constant Name_Id := N + 429;
- Name_Write : constant Name_Id := N + 430;
- Last_Procedure_Attribute : constant Name_Id := N + 430;
+ First_Procedure_Attribute : constant Name_Id := N + 429;
+ Name_Output : constant Name_Id := N + 429;
+ Name_Read : constant Name_Id := N + 430;
+ Name_Write : constant Name_Id := N + 431;
+ Last_Procedure_Attribute : constant Name_Id := N + 431;
-- Remaining attributes are ones that return entities
- First_Entity_Attribute_Name : constant Name_Id := N + 431;
- Name_Elab_Body : constant Name_Id := N + 431; -- GNAT
- Name_Elab_Spec : constant Name_Id := N + 432; -- GNAT
- Name_Storage_Pool : constant Name_Id := N + 433;
+ First_Entity_Attribute_Name : constant Name_Id := N + 432;
+ Name_Elab_Body : constant Name_Id := N + 432; -- GNAT
+ Name_Elab_Spec : constant Name_Id := N + 433; -- GNAT
+ Name_Storage_Pool : constant Name_Id := N + 434;
-- These attributes are the ones that return types
- First_Type_Attribute_Name : constant Name_Id := N + 434;
- Name_Base : constant Name_Id := N + 434;
- Name_Class : constant Name_Id := N + 435;
- Last_Type_Attribute_Name : constant Name_Id := N + 435;
- Last_Entity_Attribute_Name : constant Name_Id := N + 435;
- Last_Attribute_Name : constant Name_Id := N + 435;
+ First_Type_Attribute_Name : constant Name_Id := N + 435;
+ Name_Base : constant Name_Id := N + 435;
+ Name_Class : constant Name_Id := N + 436;
+ Last_Type_Attribute_Name : constant Name_Id := N + 436;
+ Last_Entity_Attribute_Name : constant Name_Id := N + 436;
+ Last_Attribute_Name : constant Name_Id := N + 436;
-- 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 + 436;
- Name_Ceiling_Locking : constant Name_Id := N + 436;
- Name_Inheritance_Locking : constant Name_Id := N + 437;
- Last_Locking_Policy_Name : constant Name_Id := N + 437;
+ First_Locking_Policy_Name : constant Name_Id := N + 437;
+ Name_Ceiling_Locking : constant Name_Id := N + 437;
+ Name_Inheritance_Locking : constant Name_Id := N + 438;
+ Last_Locking_Policy_Name : constant Name_Id := N + 438;
-- 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 + 438;
- Name_FIFO_Queuing : constant Name_Id := N + 438;
- Name_Priority_Queuing : constant Name_Id := N + 439;
- Last_Queuing_Policy_Name : constant Name_Id := N + 439;
+ First_Queuing_Policy_Name : constant Name_Id := N + 439;
+ Name_FIFO_Queuing : constant Name_Id := N + 439;
+ Name_Priority_Queuing : constant Name_Id := N + 440;
+ Last_Queuing_Policy_Name : constant Name_Id := N + 440;
-- 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 + 440;
- Name_FIFO_Within_Priorities : constant Name_Id := N + 440;
- Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 440;
+ First_Task_Dispatching_Policy_Name : constant Name_Id := N + 441;
+ Name_FIFO_Within_Priorities : constant Name_Id := N + 441;
+ Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 441;
-- Names of recognized checks for pragma Suppress
- First_Check_Name : constant Name_Id := N + 441;
- Name_Access_Check : constant Name_Id := N + 441;
- Name_Accessibility_Check : constant Name_Id := N + 442;
- Name_Discriminant_Check : constant Name_Id := N + 443;
- Name_Division_Check : constant Name_Id := N + 444;
- Name_Elaboration_Check : constant Name_Id := N + 445;
- Name_Index_Check : constant Name_Id := N + 446;
- Name_Length_Check : constant Name_Id := N + 447;
- Name_Overflow_Check : constant Name_Id := N + 448;
- Name_Range_Check : constant Name_Id := N + 449;
- Name_Storage_Check : constant Name_Id := N + 450;
- Name_Tag_Check : constant Name_Id := N + 451;
- Name_All_Checks : constant Name_Id := N + 452;
- Last_Check_Name : constant Name_Id := N + 452;
+ First_Check_Name : constant Name_Id := N + 442;
+ Name_Access_Check : constant Name_Id := N + 442;
+ Name_Accessibility_Check : constant Name_Id := N + 443;
+ Name_Discriminant_Check : constant Name_Id := N + 444;
+ Name_Division_Check : constant Name_Id := N + 445;
+ Name_Elaboration_Check : constant Name_Id := N + 446;
+ Name_Index_Check : constant Name_Id := N + 447;
+ Name_Length_Check : constant Name_Id := N + 448;
+ Name_Overflow_Check : constant Name_Id := N + 449;
+ Name_Range_Check : constant Name_Id := N + 450;
+ Name_Storage_Check : constant Name_Id := N + 451;
+ Name_Tag_Check : constant Name_Id := N + 452;
+ Name_All_Checks : constant Name_Id := N + 453;
+ Last_Check_Name : constant Name_Id := N + 453;
-- Names corresponding to reserved keywords, excluding those already
-- declared in the attribute list (Access, Delta, Digits, Range).
- Name_Abort : constant Name_Id := N + 453;
- Name_Abs : constant Name_Id := N + 454;
- Name_Accept : constant Name_Id := N + 455;
- Name_And : constant Name_Id := N + 456;
- Name_All : constant Name_Id := N + 457;
- Name_Array : constant Name_Id := N + 458;
- Name_At : constant Name_Id := N + 459;
- Name_Begin : constant Name_Id := N + 460;
- Name_Body : constant Name_Id := N + 461;
- Name_Case : constant Name_Id := N + 462;
- Name_Constant : constant Name_Id := N + 463;
- Name_Declare : constant Name_Id := N + 464;
- Name_Delay : constant Name_Id := N + 465;
- Name_Do : constant Name_Id := N + 466;
- Name_Else : constant Name_Id := N + 467;
- Name_Elsif : constant Name_Id := N + 468;
- Name_End : constant Name_Id := N + 469;
- Name_Entry : constant Name_Id := N + 470;
- Name_Exception : constant Name_Id := N + 471;
- Name_Exit : constant Name_Id := N + 472;
- Name_For : constant Name_Id := N + 473;
- Name_Function : constant Name_Id := N + 474;
- Name_Generic : constant Name_Id := N + 475;
- Name_Goto : constant Name_Id := N + 476;
- Name_If : constant Name_Id := N + 477;
- Name_In : constant Name_Id := N + 478;
- Name_Is : constant Name_Id := N + 479;
- Name_Limited : constant Name_Id := N + 480;
- Name_Loop : constant Name_Id := N + 481;
- Name_Mod : constant Name_Id := N + 482;
- Name_New : constant Name_Id := N + 483;
- Name_Not : constant Name_Id := N + 484;
- Name_Null : constant Name_Id := N + 485;
- Name_Of : constant Name_Id := N + 486;
- Name_Or : constant Name_Id := N + 487;
- Name_Others : constant Name_Id := N + 488;
- Name_Out : constant Name_Id := N + 489;
- Name_Package : constant Name_Id := N + 490;
- Name_Pragma : constant Name_Id := N + 491;
- Name_Private : constant Name_Id := N + 492;
- Name_Procedure : constant Name_Id := N + 493;
- Name_Raise : constant Name_Id := N + 494;
- Name_Record : constant Name_Id := N + 495;
- Name_Rem : constant Name_Id := N + 496;
- Name_Renames : constant Name_Id := N + 497;
- Name_Return : constant Name_Id := N + 498;
- Name_Reverse : constant Name_Id := N + 499;
- Name_Select : constant Name_Id := N + 500;
- Name_Separate : constant Name_Id := N + 501;
- Name_Subtype : constant Name_Id := N + 502;
- Name_Task : constant Name_Id := N + 503;
- Name_Terminate : constant Name_Id := N + 504;
- Name_Then : constant Name_Id := N + 505;
- Name_Type : constant Name_Id := N + 506;
- Name_Use : constant Name_Id := N + 507;
- Name_When : constant Name_Id := N + 508;
- Name_While : constant Name_Id := N + 509;
- Name_With : constant Name_Id := N + 510;
- Name_Xor : constant Name_Id := N + 511;
+ Name_Abort : constant Name_Id := N + 454;
+ Name_Abs : constant Name_Id := N + 455;
+ Name_Accept : constant Name_Id := N + 456;
+ Name_And : constant Name_Id := N + 457;
+ Name_All : constant Name_Id := N + 458;
+ Name_Array : constant Name_Id := N + 459;
+ Name_At : constant Name_Id := N + 460;
+ Name_Begin : constant Name_Id := N + 461;
+ Name_Body : constant Name_Id := N + 462;
+ Name_Case : constant Name_Id := N + 463;
+ Name_Constant : constant Name_Id := N + 464;
+ Name_Declare : constant Name_Id := N + 465;
+ Name_Delay : constant Name_Id := N + 466;
+ Name_Do : constant Name_Id := N + 467;
+ Name_Else : constant Name_Id := N + 468;
+ Name_Elsif : constant Name_Id := N + 469;
+ Name_End : constant Name_Id := N + 470;
+ Name_Entry : constant Name_Id := N + 471;
+ Name_Exception : constant Name_Id := N + 472;
+ Name_Exit : constant Name_Id := N + 473;
+ Name_For : constant Name_Id := N + 474;
+ Name_Function : constant Name_Id := N + 475;
+ Name_Generic : constant Name_Id := N + 476;
+ Name_Goto : constant Name_Id := N + 477;
+ Name_If : constant Name_Id := N + 478;
+ Name_In : constant Name_Id := N + 479;
+ Name_Is : constant Name_Id := N + 480;
+ Name_Limited : constant Name_Id := N + 481;
+ Name_Loop : constant Name_Id := N + 482;
+ Name_Mod : constant Name_Id := N + 483;
+ Name_New : constant Name_Id := N + 484;
+ Name_Not : constant Name_Id := N + 485;
+ Name_Null : constant Name_Id := N + 486;
+ Name_Of : constant Name_Id := N + 487;
+ Name_Or : constant Name_Id := N + 488;
+ Name_Others : constant Name_Id := N + 489;
+ Name_Out : constant Name_Id := N + 490;
+ Name_Package : constant Name_Id := N + 491;
+ Name_Pragma : constant Name_Id := N + 492;
+ Name_Private : constant Name_Id := N + 493;
+ Name_Procedure : constant Name_Id := N + 494;
+ Name_Raise : constant Name_Id := N + 495;
+ Name_Record : constant Name_Id := N + 496;
+ Name_Rem : constant Name_Id := N + 497;
+ Name_Renames : constant Name_Id := N + 498;
+ Name_Return : constant Name_Id := N + 499;
+ Name_Reverse : constant Name_Id := N + 500;
+ Name_Select : constant Name_Id := N + 501;
+ Name_Separate : constant Name_Id := N + 502;
+ Name_Subtype : constant Name_Id := N + 503;
+ Name_Task : constant Name_Id := N + 504;
+ Name_Terminate : constant Name_Id := N + 505;
+ Name_Then : constant Name_Id := N + 506;
+ Name_Type : constant Name_Id := N + 507;
+ Name_Use : constant Name_Id := N + 508;
+ Name_When : constant Name_Id := N + 509;
+ Name_While : constant Name_Id := N + 510;
+ Name_With : constant Name_Id := N + 511;
+ Name_Xor : constant Name_Id := N + 512;
-- 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 + 512;
- Name_Divide : constant Name_Id := N + 512;
- Name_Enclosing_Entity : constant Name_Id := N + 513;
- Name_Exception_Information : constant Name_Id := N + 514;
- Name_Exception_Message : constant Name_Id := N + 515;
- Name_Exception_Name : constant Name_Id := N + 516;
- Name_File : constant Name_Id := N + 517;
- Name_Import_Address : constant Name_Id := N + 518;
- Name_Import_Largest_Value : constant Name_Id := N + 519;
- Name_Import_Value : constant Name_Id := N + 520;
- Name_Is_Negative : constant Name_Id := N + 521;
- Name_Line : constant Name_Id := N + 522;
- Name_Rotate_Left : constant Name_Id := N + 523;
- Name_Rotate_Right : constant Name_Id := N + 524;
- Name_Shift_Left : constant Name_Id := N + 525;
- Name_Shift_Right : constant Name_Id := N + 526;
- Name_Shift_Right_Arithmetic : constant Name_Id := N + 527;
- Name_Source_Location : constant Name_Id := N + 528;
- Name_Unchecked_Conversion : constant Name_Id := N + 529;
- Name_Unchecked_Deallocation : constant Name_Id := N + 530;
- Name_To_Pointer : constant Name_Id := N + 531;
- Last_Intrinsic_Name : constant Name_Id := N + 531;
+ First_Intrinsic_Name : constant Name_Id := N + 513;
+ Name_Divide : constant Name_Id := N + 513;
+ Name_Enclosing_Entity : constant Name_Id := N + 514;
+ Name_Exception_Information : constant Name_Id := N + 515;
+ Name_Exception_Message : constant Name_Id := N + 516;
+ Name_Exception_Name : constant Name_Id := N + 517;
+ Name_File : constant Name_Id := N + 518;
+ Name_Import_Address : constant Name_Id := N + 519;
+ Name_Import_Largest_Value : constant Name_Id := N + 520;
+ Name_Import_Value : constant Name_Id := N + 521;
+ Name_Is_Negative : constant Name_Id := N + 522;
+ Name_Line : constant Name_Id := N + 523;
+ Name_Rotate_Left : constant Name_Id := N + 524;
+ Name_Rotate_Right : constant Name_Id := N + 525;
+ Name_Shift_Left : constant Name_Id := N + 526;
+ Name_Shift_Right : constant Name_Id := N + 527;
+ Name_Shift_Right_Arithmetic : constant Name_Id := N + 528;
+ Name_Source_Location : constant Name_Id := N + 529;
+ Name_Unchecked_Conversion : constant Name_Id := N + 530;
+ Name_Unchecked_Deallocation : constant Name_Id := N + 531;
+ Name_To_Pointer : constant Name_Id := N + 532;
+ Last_Intrinsic_Name : constant Name_Id := N + 532;
-- Reserved words used only in Ada 95
- First_95_Reserved_Word : constant Name_Id := N + 532;
- Name_Abstract : constant Name_Id := N + 532;
- Name_Aliased : constant Name_Id := N + 533;
- Name_Protected : constant Name_Id := N + 534;
- Name_Until : constant Name_Id := N + 535;
- Name_Requeue : constant Name_Id := N + 536;
- Name_Tagged : constant Name_Id := N + 537;
- Last_95_Reserved_Word : constant Name_Id := N + 537;
+ First_95_Reserved_Word : constant Name_Id := N + 533;
+ Name_Abstract : constant Name_Id := N + 533;
+ Name_Aliased : constant Name_Id := N + 534;
+ Name_Protected : constant Name_Id := N + 535;
+ Name_Until : constant Name_Id := N + 536;
+ Name_Requeue : constant Name_Id := N + 537;
+ Name_Tagged : constant Name_Id := N + 538;
+ Last_95_Reserved_Word : constant Name_Id := N + 538;
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 + 538;
+ Name_Raise_Exception : constant Name_Id := N + 539;
-- Additional reserved words in GNAT Project Files
-- Note that Name_External is already previously declared
- Name_Binder : constant Name_Id := N + 539;
- Name_Body_Suffix : constant Name_Id := N + 540;
- Name_Builder : constant Name_Id := N + 541;
- Name_Compiler : constant Name_Id := N + 542;
- Name_Cross_Reference : constant Name_Id := N + 543;
- Name_Default_Switches : constant Name_Id := N + 544;
- Name_Exec_Dir : constant Name_Id := N + 545;
- Name_Executable : constant Name_Id := N + 546;
- Name_Executable_Suffix : constant Name_Id := N + 547;
- Name_Extends : constant Name_Id := N + 548;
- Name_Finder : constant Name_Id := N + 549;
- Name_Global_Configuration_Pragmas : constant Name_Id := N + 550;
- Name_Gnatls : constant Name_Id := N + 551;
- Name_Gnatstub : constant Name_Id := N + 552;
- Name_Implementation : constant Name_Id := N + 553;
- Name_Implementation_Exceptions : constant Name_Id := N + 554;
- Name_Implementation_Suffix : constant Name_Id := N + 555;
- Name_Languages : constant Name_Id := N + 556;
- Name_Library_Dir : constant Name_Id := N + 557;
- Name_Library_Auto_Init : constant Name_Id := N + 558;
- Name_Library_GCC : constant Name_Id := N + 559;
- Name_Library_Interface : constant Name_Id := N + 560;
- Name_Library_Kind : constant Name_Id := N + 561;
- Name_Library_Name : constant Name_Id := N + 562;
- Name_Library_Options : constant Name_Id := N + 563;
- Name_Library_Reference_Symbol_File : constant Name_Id := N + 564;
- Name_Library_Src_Dir : constant Name_Id := N + 565;
- Name_Library_Symbol_File : constant Name_Id := N + 566;
- Name_Library_Symbol_Policy : constant Name_Id := N + 567;
- Name_Library_Version : constant Name_Id := N + 568;
- Name_Linker : constant Name_Id := N + 569;
- Name_Local_Configuration_Pragmas : constant Name_Id := N + 570;
- Name_Locally_Removed_Files : constant Name_Id := N + 571;
- Name_Naming : constant Name_Id := N + 572;
- Name_Object_Dir : constant Name_Id := N + 573;
- Name_Pretty_Printer : constant Name_Id := N + 574;
- Name_Project : constant Name_Id := N + 575;
- Name_Separate_Suffix : constant Name_Id := N + 576;
- Name_Source_Dirs : constant Name_Id := N + 577;
- Name_Source_Files : constant Name_Id := N + 578;
- Name_Source_List_File : constant Name_Id := N + 579;
- Name_Spec : constant Name_Id := N + 580;
- Name_Spec_Suffix : constant Name_Id := N + 581;
- Name_Specification : constant Name_Id := N + 582;
- Name_Specification_Exceptions : constant Name_Id := N + 583;
- Name_Specification_Suffix : constant Name_Id := N + 584;
- Name_Switches : constant Name_Id := N + 585;
+ Name_Binder : constant Name_Id := N + 540;
+ Name_Body_Suffix : constant Name_Id := N + 541;
+ Name_Builder : constant Name_Id := N + 542;
+ Name_Compiler : constant Name_Id := N + 543;
+ Name_Cross_Reference : constant Name_Id := N + 544;
+ Name_Default_Switches : constant Name_Id := N + 545;
+ Name_Exec_Dir : constant Name_Id := N + 546;
+ Name_Executable : constant Name_Id := N + 547;
+ Name_Executable_Suffix : constant Name_Id := N + 548;
+ Name_Extends : constant Name_Id := N + 549;
+ Name_Finder : constant Name_Id := N + 550;
+ Name_Global_Configuration_Pragmas : constant Name_Id := N + 551;
+ Name_Gnatls : constant Name_Id := N + 552;
+ Name_Gnatstub : constant Name_Id := N + 553;
+ Name_Implementation : constant Name_Id := N + 554;
+ Name_Implementation_Exceptions : constant Name_Id := N + 555;
+ Name_Implementation_Suffix : constant Name_Id := N + 556;
+ Name_Languages : constant Name_Id := N + 557;
+ Name_Library_Dir : constant Name_Id := N + 558;
+ Name_Library_Auto_Init : constant Name_Id := N + 559;
+ Name_Library_GCC : constant Name_Id := N + 560;
+ Name_Library_Interface : constant Name_Id := N + 561;
+ Name_Library_Kind : constant Name_Id := N + 562;
+ Name_Library_Name : constant Name_Id := N + 563;
+ Name_Library_Options : constant Name_Id := N + 564;
+ Name_Library_Reference_Symbol_File : constant Name_Id := N + 565;
+ Name_Library_Src_Dir : constant Name_Id := N + 566;
+ Name_Library_Symbol_File : constant Name_Id := N + 567;
+ Name_Library_Symbol_Policy : constant Name_Id := N + 568;
+ Name_Library_Version : constant Name_Id := N + 569;
+ Name_Linker : constant Name_Id := N + 570;
+ Name_Local_Configuration_Pragmas : constant Name_Id := N + 571;
+ Name_Locally_Removed_Files : constant Name_Id := N + 572;
+ Name_Naming : constant Name_Id := N + 573;
+ Name_Object_Dir : constant Name_Id := N + 574;
+ Name_Pretty_Printer : constant Name_Id := N + 575;
+ Name_Project : constant Name_Id := N + 576;
+ Name_Separate_Suffix : constant Name_Id := N + 577;
+ Name_Source_Dirs : constant Name_Id := N + 578;
+ Name_Source_Files : constant Name_Id := N + 579;
+ Name_Source_List_File : constant Name_Id := N + 580;
+ Name_Spec : constant Name_Id := N + 581;
+ Name_Spec_Suffix : constant Name_Id := N + 582;
+ Name_Specification : constant Name_Id := N + 583;
+ Name_Specification_Exceptions : constant Name_Id := N + 584;
+ Name_Specification_Suffix : constant Name_Id := N + 585;
+ Name_Switches : constant Name_Id := N + 586;
-- Other miscellaneous names used in front end
- Name_Unaligned_Valid : constant Name_Id := N + 586;
+ Name_Unaligned_Valid : constant Name_Id := N + 587;
-- Mark last defined name for consistency check in Snames body
- Last_Predefined_Name : constant Name_Id := N + 586;
+ Last_Predefined_Name : constant Name_Id := N + 587;
subtype Any_Operator_Name is Name_Id range
First_Operator_Name .. Last_Operator_Name;
Pragma_Locking_Policy,
Pragma_Long_Float,
Pragma_No_Run_Time,
+ Pragma_No_Strict_Aliasing,
Pragma_Normalize_Scalars,
Pragma_Polling,
Pragma_Persistent_Data,
#define Pragma_Locking_Policy 17
#define Pragma_Long_Float 18
#define Pragma_No_Run_Time 19
-#define Pragma_Normalize_Scalars 20
-#define Pragma_Polling 21
-#define Pragma_Persistent_Data 22
-#define Pragma_Persistent_Object 23
-#define Pragma_Profile 24
-#define Pragma_Propagate_Exceptions 25
-#define Pragma_Queuing_Policy 26
-#define Pragma_Ravenscar 27
-#define Pragma_Restricted_Run_Time 28
-#define Pragma_Restrictions 29
-#define Pragma_Restriction_Warnings 30
-#define Pragma_Reviewable 31
-#define Pragma_Source_File_Name 32
-#define Pragma_Source_File_Name_Project 33
-#define Pragma_Style_Checks 34
-#define Pragma_Suppress 35
-#define Pragma_Suppress_Exception_Locations 36
-#define Pragma_Task_Dispatching_Policy 37
-#define Pragma_Universal_Data 38
-#define Pragma_Unsuppress 39
-#define Pragma_Use_VADS_Size 40
-#define Pragma_Validity_Checks 41
-#define Pragma_Warnings 42
+#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
/* Remaining pragmas */
-#define Pragma_Abort_Defer 43
-#define Pragma_All_Calls_Remote 44
-#define Pragma_Annotate 45
-#define Pragma_Assert 46
-#define Pragma_Asynchronous 47
-#define Pragma_Atomic 48
-#define Pragma_Atomic_Components 49
-#define Pragma_Attach_Handler 50
-#define Pragma_Comment 51
-#define Pragma_Common_Object 52
-#define Pragma_Complex_Representation 53
-#define Pragma_Controlled 54
-#define Pragma_Convention 55
-#define Pragma_CPP_Class 56
-#define Pragma_CPP_Constructor 57
-#define Pragma_CPP_Virtual 58
-#define Pragma_CPP_Vtable 59
-#define Pragma_Debug 60
-#define Pragma_Elaborate 61
-#define Pragma_Elaborate_All 62
-#define Pragma_Elaborate_Body 63
-#define Pragma_Export 64
-#define Pragma_Export_Exception 65
-#define Pragma_Export_Function 66
-#define Pragma_Export_Object 67
-#define Pragma_Export_Procedure 68
-#define Pragma_Export_Value 69
-#define Pragma_Export_Valued_Procedure 70
-#define Pragma_External 71
-#define Pragma_Finalize_Storage_Only 72
-#define Pragma_Ident 73
-#define Pragma_Import 74
-#define Pragma_Import_Exception 75
-#define Pragma_Import_Function 76
-#define Pragma_Import_Object 77
-#define Pragma_Import_Procedure 78
-#define Pragma_Import_Valued_Procedure 79
-#define Pragma_Inline 80
-#define Pragma_Inline_Always 81
-#define Pragma_Inline_Generic 82
-#define Pragma_Inspection_Point 83
-#define Pragma_Interface 84
-#define Pragma_Interface_Name 85
-#define Pragma_Interrupt_Handler 86
-#define Pragma_Interrupt_Priority 87
-#define Pragma_Java_Constructor 88
-#define Pragma_Java_Interface 89
-#define Pragma_Keep_Names 90
-#define Pragma_Link_With 91
-#define Pragma_Linker_Alias 92
-#define Pragma_Linker_Options 93
-#define Pragma_Linker_Section 94
-#define Pragma_List 95
-#define Pragma_Machine_Attribute 96
-#define Pragma_Main 97
-#define Pragma_Main_Storage 98
-#define Pragma_Memory_Size 99
-#define Pragma_No_Return 100
-#define Pragma_Obsolescent 101
-#define Pragma_Optimize 102
-#define Pragma_Optional_Overriding 103
-#define Pragma_Overriding 104
-#define Pragma_Pack 105
-#define Pragma_Page 106
-#define Pragma_Passive 107
-#define Pragma_Preelaborate 108
-#define Pragma_Priority 109
-#define Pragma_Psect_Object 110
-#define Pragma_Pure 111
-#define Pragma_Pure_Function 112
-#define Pragma_Remote_Call_Interface 113
-#define Pragma_Remote_Types 114
-#define Pragma_Share_Generic 115
-#define Pragma_Shared 116
-#define Pragma_Shared_Passive 117
-#define Pragma_Source_Reference 118
-#define Pragma_Stream_Convert 119
-#define Pragma_Subtitle 120
-#define Pragma_Suppress_All 121
-#define Pragma_Suppress_Debug_Info 122
-#define Pragma_Suppress_Initialization 123
-#define Pragma_System_Name 124
-#define Pragma_Task_Info 125
-#define Pragma_Task_Name 126
-#define Pragma_Task_Storage 127
-#define Pragma_Thread_Body 128
-#define Pragma_Time_Slice 129
-#define Pragma_Title 130
-#define Pragma_Unchecked_Union 131
-#define Pragma_Unimplemented_Unit 132
-#define Pragma_Unreferenced 133
-#define Pragma_Unreserve_All_Interrupts 134
-#define Pragma_Volatile 135
-#define Pragma_Volatile_Components 136
-#define Pragma_Weak_External 137
+#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
/* The following are deliberately out of alphabetical order, see Snames */
-#define Pragma_AST_Entry 138
-#define Pragma_Storage_Size 139
-#define Pragma_Storage_Unit 140
+#define Pragma_AST_Entry 139
+#define Pragma_Storage_Size 140
+#define Pragma_Storage_Unit 141
/* Define the numeric values for the conventions. */
-- --
-- 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- --
-- Return Null_Address if the table length is zero,
-- Table (First)'Address if not.
+ pragma Warnings (Off);
+ -- Turn off warnings. The following unchecked conversions are only used
+ -- internally in this package, and cannot never result in any instances
+ -- of improperly aliased pointers for the client of the package.
+
function To_Address is new Unchecked_Conversion (Table_Ptr, Address);
function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr);
+ pragma Warnings (On);
+
------------
-- Append --
------------
gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
break;
- /* Nothing to do, since front end does all validation using the
- values that Gigi back-annotates. */
case N_Validate_Unchecked_Conversion:
+ /* If the result is a pointer type, see if we are either converting
+ from a non-pointer or from a pointer to a type with a different
+ alias set and warn if so. If the result defined in the same unit as
+ this unchecked convertion, we can allow this because we can know to
+ make that type have alias set 0. */
+ {
+ tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
+ tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node));
+
+ if (POINTER_TYPE_P (gnu_target_type)
+ && !In_Same_Source_Unit (Target_Type (gnat_node), gnat_node)
+ && get_alias_set (TREE_TYPE (gnu_target_type)) != 0
+ && !No_Strict_Aliasing (Underlying_Type (Target_Type (gnat_node)))
+ && (!POINTER_TYPE_P (gnu_source_type)
+ || (get_alias_set (TREE_TYPE (gnu_source_type))
+ != get_alias_set (TREE_TYPE (gnu_target_type)))))
+ {
+ post_error_ne
+ ("?possible aliasing problem for type&",
+ gnat_node, Target_Type (gnat_node));
+ post_error
+ ("\\?use -fno-strict-aliasing switch for references",
+ gnat_node);
+ post_error_ne
+ ("\\?or use `pragma No_Strict_Aliasing (&);`",
+ gnat_node, Target_Type (gnat_node));
+ }
+ }
break;
case N_Raise_Statement:
/* See if any non-NOTE insns were generated. */
for (insn = NEXT_INSN (insn); insn; insn = NEXT_INSN (insn))
- if (GET_RTX_CLASS (GET_CODE (insn)) == 'i')
+ if (GET_RTX_CLASS (GET_CODE (insn)) == RTX_INSN)
{
result = 0;
break;
Unixcmd => new S'("gnatpp"),
Unixsws => null,
Switches => Pretty_Switches'Access,
- Params => new Parameter_Array'(1 => File),
+ Params => new Parameter_Array'(1 => Unlimited_Files),
Defext => " "),
Shared =>
"-O1,!-O0,!-O2,!-O3 " &
"UNROLL_LOOPS " &
"-funroll-loops " &
+ "NO_STRICT_ALIASING " &
+ "-fno-strict-aliasing " &
"INLINING " &
"-O3,!-O0,!-O1,!-O2";
-- /NOOPTIMIZE (D)
-- ALL (D) Perform most optimizations, including those that
-- may be expensive.
--
- -- NONE Do not do any optimizations. Same as /NOOPTIMIZE.
+ -- NONE Do not do any optimizations. Same as /NOOPTIMIZE.
--
-- SOME Perform some optimizations, but omit ones that
- -- are costly.
+ -- are costly in compilation time.
--
-- DEVELOPMENT Same as SOME.
--
-- INLINING Full optimization, and also attempt automatic inlining
-- of small subprograms within a unit
--
- -- UNROLL_LOOPS Try to unroll loops. This keyword may be specified
- -- with any keyword above other than NONE. Loop
+ -- UNROLL_LOOPS Try to unroll loops. This keyword may be specified
+ -- with any keyword above other than NONE. Loop
-- unrolling usually, but not always, improves the
-- performance of programs.
+ --
+ -- NO_STRICT_ALIASING
+ -- Suppress aliasing analysis. When optimization is
+ -- enabled (ALL or SOME above), the compiler assumes
+ -- that pointers do in fact point to legitimate values
+ -- of the pointer type (allocated from the proper pool).
+ -- If this assumption is violated, e.g. by the use of
+ -- unchecked conversion, then it may be necessary to
+ -- suppress this assumption using this keyword (which
+ -- may be specified only in conjunction with any
+ -- keyword above, other than NONE).
S_GCC_OptX : aliased constant S := "/NOOPTIMIZE " &
"-O0,!-O1,!-O2,!-O3";
-- source. This qualifier /NO_MISSED_LABELS suppresses this insertion,
-- so that the formatted source reflects the original.
+ S_Pretty_Notabs : aliased constant S := "/NOTABS " &
+ "-notabs";
+ -- /NOTABS
+ --
+ -- Replace all tabulations in comments with spaces.
+
S_Pretty_Output : aliased constant S := "/OUTPUT=@" &
"-o@";
-- /OUTPUT=file
-- argument source into filename.NPP. If filename.NPP already exists,
-- report an error and exit.
+ S_Pretty_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" &
+ "--RTS=|";
+ -- /RUNTIME_SYSTEM=xxx
+ --
+ -- Compile against an alternate runtime system named xxx or RTS-xxx.
+
S_Pretty_Search : aliased constant S := "/SEARCH=*" &
"-I*";
-- /SEARCH=(directory[,...])
S_Pretty_Mess 'Access,
S_Pretty_Names 'Access,
S_Pretty_No_Labels 'Access,
+ S_Pretty_Notabs 'Access,
S_Pretty_Output 'Access,
S_Pretty_Override 'Access,
S_Pretty_Pragma 'Access,
S_Pretty_Replace 'Access,
S_Pretty_Project 'Access,
+ S_Pretty_RTS 'Access,
S_Pretty_Search 'Access,
S_Pretty_Specific 'Access,
S_Pretty_Standard 'Access,
OSDN Git Service
