diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-03-05 10:58:59 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-03-05 10:58:59 +0000 |
| commit | 3d8754627a1fb3e4975ecefa3fad4d69bf56f8f4 (patch) | |
| tree | d7e76278139b8a14ab79056f737b24f8081eaf15 /gcc | |
| parent | fc87cdcc12914bdb6e8752f0b412868485b8c255 (diff) | |
| download | gcc-3d8754627a1fb3e4975ecefa3fad4d69bf56f8f4.tar.gz | |
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 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 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@78964 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
63 files changed, 1640 insertions, 1111 deletions
diff --git a/gcc/ada/56taprop.adb b/gcc/ada/56taprop.adb index ffaf40a8470..b4098264262 100644 --- a/gcc/ada/56taprop.adb +++ b/gcc/ada/56taprop.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -79,7 +79,6 @@ with System.Soft_Links; with System.OS_Primitives; -- used for Delay_Modes -with Unchecked_Conversion; with Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -186,8 +185,6 @@ 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 -- ------------------- @@ -215,8 +212,10 @@ package body System.Task_Primitives.Operations is -- 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; @@ -896,9 +895,6 @@ package body System.Task_Primitives.Operations is 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 diff --git a/gcc/ada/5ataprop.adb b/gcc/ada/5ataprop.adb index d67490fadd8..20821fda298 100644 --- a/gcc/ada/5ataprop.adb +++ b/gcc/ada/5ataprop.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -82,7 +82,6 @@ with System.Soft_Links; with System.OS_Primitives; -- used for Delay_Modes -with Unchecked_Conversion; with Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -178,8 +177,6 @@ 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 -- ------------------- @@ -807,9 +804,6 @@ package body System.Task_Primitives.Operations is 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 diff --git a/gcc/ada/5atpopsp.adb b/gcc/ada/5atpopsp.adb index 68b54c8c386..d80cf0464d7 100644 --- a/gcc/ada/5atpopsp.adb +++ b/gcc/ada/5atpopsp.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -99,7 +99,7 @@ package body Specific is -- 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; diff --git a/gcc/ada/5iosinte.ads b/gcc/ada/5iosinte.ads index 7b5de13b92c..c8f06916f13 100644 --- a/gcc/ada/5iosinte.ads +++ b/gcc/ada/5iosinte.ads @@ -273,9 +273,12 @@ package System.OS_Interface is 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; @@ -498,8 +501,6 @@ 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; diff --git a/gcc/ada/5itaprop.adb b/gcc/ada/5itaprop.adb index b967c18a950..84eb3514f83 100644 --- a/gcc/ada/5itaprop.adb +++ b/gcc/ada/5itaprop.adb @@ -189,8 +189,6 @@ package body System.Task_Primitives.Operations is 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); @@ -839,9 +837,6 @@ package body System.Task_Primitives.Operations is 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); diff --git a/gcc/ada/5sosinte.ads b/gcc/ada/5sosinte.ads index eaba6c8d567..b5754630372 100644 --- a/gcc/ada/5sosinte.ads +++ b/gcc/ada/5sosinte.ads @@ -308,8 +308,11 @@ package System.OS_Interface is 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; @@ -540,8 +543,6 @@ 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; diff --git a/gcc/ada/5staprop.adb b/gcc/ada/5staprop.adb index 69f0b220ae0..dcabcd12135 100644 --- a/gcc/ada/5staprop.adb +++ b/gcc/ada/5staprop.adb @@ -86,7 +86,6 @@ with System.Soft_Links; with System.OS_Primitives; -- used for Delay_Modes -with Unchecked_Conversion; with Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -173,14 +172,14 @@ 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; @@ -190,22 +189,13 @@ package body System.Task_Primitives.Operations is -- 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; @@ -218,12 +208,12 @@ package body System.Task_Primitives.Operations is 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); @@ -278,11 +268,6 @@ package body System.Task_Primitives.Operations is 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 -- ------------------- @@ -1365,8 +1350,7 @@ package body System.Task_Primitives.Operations is function Check_Initialize_Lock (L : Lock_Ptr; - Level : Lock_Level) - return Boolean + Level : Lock_Level) return Boolean is Self_ID : constant Task_ID := Self; @@ -1416,7 +1400,7 @@ package body System.Task_Primitives.Operations is -- 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; @@ -1457,7 +1441,7 @@ package body System.Task_Primitives.Operations is -- 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; @@ -1524,8 +1508,7 @@ package body System.Task_Primitives.Operations is function Record_Wakeup (L : Lock_Ptr; - Reason : Task_States) - return Boolean + Reason : Task_States) return Boolean is pragma Unreferenced (Reason); @@ -1535,7 +1518,7 @@ package body System.Task_Primitives.Operations is 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; @@ -1560,15 +1543,14 @@ package body System.Task_Primitives.Operations is 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; @@ -1727,8 +1709,7 @@ package body System.Task_Primitives.Operations is 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 @@ -1744,8 +1725,7 @@ package body System.Task_Primitives.Operations is 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 diff --git a/gcc/ada/5staspri.ads b/gcc/ada/5staspri.ads index b1cb08b1df1..335079b7cec 100644 --- a/gcc/ada/5staspri.ads +++ b/gcc/ada/5staspri.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -31,9 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- 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. @@ -46,12 +44,14 @@ with System.OS_Interface; -- 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; @@ -60,6 +60,8 @@ package System.Task_Primitives is -- 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). @@ -81,15 +83,18 @@ private 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; @@ -109,16 +114,16 @@ private 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; diff --git a/gcc/ada/5wtaprop.adb b/gcc/ada/5wtaprop.adb index bbbb2494112..755872bcd84 100644 --- a/gcc/ada/5wtaprop.adb +++ b/gcc/ada/5wtaprop.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -75,7 +75,6 @@ with System.OS_Primitives; with System.Task_Info; -- used for Unspecified_Task_Info -with Unchecked_Conversion; with Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -171,14 +170,6 @@ 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 -- ---------------------------------- @@ -377,8 +368,7 @@ package body System.Task_Primitives.Operations is ---------- 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); @@ -862,9 +852,6 @@ package body System.Task_Primitives.Operations is 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); @@ -1091,8 +1078,7 @@ package body System.Task_Primitives.Operations is 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 @@ -1108,8 +1094,7 @@ package body System.Task_Primitives.Operations is 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 diff --git a/gcc/ada/7stpopsp.adb b/gcc/ada/7stpopsp.adb index fb8d7314353..f7a67a074ca 100644 --- a/gcc/ada/7stpopsp.adb +++ b/gcc/ada/7stpopsp.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -73,9 +73,8 @@ package body Specific is ---------- 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; diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 20f8dbb8e12..b41f0200ffc 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,127 @@ +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 diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in index 69cc77b8bfb..94d3c33d52d 100644 --- a/gcc/ada/Make-lang.in +++ b/gcc/ada/Make-lang.in @@ -3221,21 +3221,21 @@ ada/sem_ch7.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \ 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 \ diff --git a/gcc/ada/a-strsea.adb b/gcc/ada/a-strsea.adb index 29db92a87c9..62089c31f8e 100644 --- a/gcc/ada/a-strsea.adb +++ b/gcc/ada/a-strsea.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -49,8 +49,7 @@ package body Ada.Strings.Search is 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. @@ -62,8 +61,7 @@ package body Ada.Strings.Search is function Belongs (Element : Character; Set : Maps.Character_Set; - Test : Membership) - return Boolean + Test : Membership) return Boolean is begin if Test = Inside then @@ -78,10 +76,9 @@ package body Ada.Strings.Search is ----------- 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; @@ -113,10 +110,9 @@ package body Ada.Strings.Search is 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; @@ -156,9 +152,8 @@ package body Ada.Strings.Search is 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; @@ -177,9 +172,9 @@ package body Ada.Strings.Search is ---------------- 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 @@ -214,11 +209,10 @@ package body Ada.Strings.Search 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); @@ -266,11 +260,11 @@ package body Ada.Strings.Search is 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; @@ -324,11 +318,10 @@ package body Ada.Strings.Search is 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 @@ -360,9 +353,8 @@ package body Ada.Strings.Search is --------------------- 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 diff --git a/gcc/ada/a-strsea.ads b/gcc/ada/a-strsea.ads index 7096ccffc94..c176d12d626 100644 --- a/gcc/ada/a-strsea.ads +++ b/gcc/ada/a-strsea.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -44,53 +44,45 @@ private package Ada.Strings.Search is 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); diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index f88874d79fa..a2e40f8d4ef 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -87,25 +87,15 @@ package body Ada.Tags is 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 -- @@ -128,8 +118,8 @@ package body Ada.Tags is 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 ( @@ -139,7 +129,7 @@ package body Ada.Tags is 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); @@ -156,7 +146,7 @@ package body Ada.Tags is -- 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; @@ -188,7 +178,7 @@ package body Ada.Tags is -- 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))); @@ -260,7 +250,7 @@ package body Ada.Tags is -- 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; @@ -269,7 +259,7 @@ package body Ada.Tags is -- 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; @@ -289,8 +279,7 @@ package body Ada.Tags is function Get_Prim_Op_Address (T : Tag; - Position : Positive) - return S.Address + Position : Positive) return System.Address is begin return T.Prims_Ptr (Position); @@ -318,7 +307,7 @@ package body Ada.Tags is -- 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; @@ -343,7 +332,7 @@ package body Ada.Tags is -- 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; @@ -411,15 +400,16 @@ package body Ada.Tags is -- 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 @@ -455,7 +445,7 @@ package body Ada.Tags is -- 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; @@ -464,7 +454,7 @@ package body Ada.Tags is -- 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; @@ -488,7 +478,7 @@ package body Ada.Tags is procedure Set_Prim_Op_Address (T : Tag; Position : Positive; - Value : S.Address) + Value : System.Address) is begin T.Prims_Ptr (Position) := Value; @@ -520,7 +510,7 @@ package body Ada.Tags is -- 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; diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 8dc78c6797a..6dd97ff6642 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- @@ -37,6 +37,7 @@ with System; with System.Storage_Elements; +with Unchecked_Conversion; package Ada.Tags is @@ -78,25 +79,23 @@ private -- 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) @@ -117,7 +116,7 @@ private 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 @@ -129,14 +128,13 @@ private -- 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 @@ -167,20 +165,20 @@ private 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 @@ -194,24 +192,24 @@ private 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; @@ -219,6 +217,15 @@ private 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); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index e9a0ddce3a5..543aa2caa94 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -367,6 +367,7 @@ package body Einfo is -- 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 @@ -421,7 +422,6 @@ package body Einfo is -- Remaining flags are currently unused and available - -- (unused) Flag136 -- (unused) Flag183 -------------------------------- @@ -1793,6 +1793,12 @@ package body Einfo is 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)); @@ -3735,6 +3741,13 @@ package body Einfo is 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); @@ -6226,6 +6239,7 @@ package body Einfo is 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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index cff7039b23f..795d69e5ad1 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -1533,6 +1533,13 @@ package Einfo is -- 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 @@ -2600,6 +2607,16 @@ package Einfo is -- 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. @@ -3997,6 +4014,7 @@ package Einfo is -- 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 @@ -5154,6 +5172,7 @@ package Einfo is 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; @@ -5626,6 +5645,7 @@ package Einfo is 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); @@ -6152,6 +6172,7 @@ package Einfo is 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); @@ -6457,6 +6478,7 @@ package Einfo is 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); diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 75ebfe908a6..e307bb039be 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -288,7 +288,7 @@ package Errout is -- "/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"; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 25b934b3528..b0af72df446 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -77,9 +77,11 @@ package Erroutc is 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 diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index ecdcf191fb0..18b63471447 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -139,10 +139,12 @@ extern void Get_External_Name_With_Suffix (Entity_Id, Fat_Pointer); #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: */ diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/g-dyntab.adb index 1fba1b1133b..25320dca7de 100644 --- a/gcc/ada/g-dyntab.adb +++ b/gcc/ada/g-dyntab.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -51,9 +51,15 @@ package body GNAT.Dynamic_Tables is -- 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 -- -------------- diff --git a/gcc/ada/g-table.adb b/gcc/ada/g-table.adb index e3eaa23b039..793f6e29820 100644 --- a/gcc/ada/g-table.adb +++ b/gcc/ada/g-table.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -60,9 +60,16 @@ package body GNAT.Table is -- 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 -- -------------- diff --git a/gcc/ada/g-thread.adb b/gcc/ada/g-thread.adb index 1d71f379ed4..98e663dc978 100644 --- a/gcc/ada/g-thread.adb +++ b/gcc/ada/g-thread.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -47,6 +47,10 @@ package body GNAT.Threads is 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); @@ -54,6 +58,8 @@ package body GNAT.Threads is (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 diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 313da2b06e0..f3ff3632c36 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -34,6 +34,7 @@ with Opt; 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; @@ -836,7 +837,7 @@ begin 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); @@ -1325,6 +1326,47 @@ begin 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 diff --git a/gcc/ada/i-cpoint.adb b/gcc/ada/i-cpoint.adb index 5f7891c1304..8dc5acd0c74 100644 --- a/gcc/ada/i-cpoint.adb +++ b/gcc/ada/i-cpoint.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -55,7 +55,7 @@ package body Interfaces.C.Pointers is -- "+" -- --------- - 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; @@ -64,7 +64,7 @@ package body Interfaces.C.Pointers is 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; @@ -77,7 +77,7 @@ package body Interfaces.C.Pointers is -- "-" -- --------- - 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; @@ -86,7 +86,7 @@ package body Interfaces.C.Pointers is 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; @@ -100,9 +100,9 @@ package body Interfaces.C.Pointers is ---------------- 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; @@ -125,10 +125,10 @@ package body Interfaces.C.Pointers is --------------------------- 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; @@ -172,9 +172,8 @@ package body Interfaces.C.Pointers is ----------- 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; @@ -207,9 +206,8 @@ package body Interfaces.C.Pointers is 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; @@ -255,9 +253,8 @@ package body Interfaces.C.Pointers is -------------------- 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; diff --git a/gcc/ada/i-cpoint.ads b/gcc/ada/i-cpoint.ads index 67c610c1bcd..1e997386d3c 100644 --- a/gcc/ada/i-cpoint.ads +++ b/gcc/ada/i-cpoint.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- @@ -46,15 +46,17 @@ pragma Preelaborate (Pointers); 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; @@ -62,10 +64,10 @@ pragma Preelaborate (Pointers); -- 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); @@ -76,20 +78,19 @@ pragma Preelaborate (Pointers); 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 ("+"); diff --git a/gcc/ada/i-cstrin.adb b/gcc/ada/i-cstrin.adb index 0b7805bae74..26bde07c2ab 100644 --- a/gcc/ada/i-cstrin.adb +++ b/gcc/ada/i-cstrin.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -38,6 +38,12 @@ with Unchecked_Conversion; 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); @@ -99,7 +105,7 @@ package body Interfaces.C.Strings is -- 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; @@ -135,7 +141,7 @@ package body Interfaces.C.Strings is -- 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; @@ -177,7 +183,7 @@ package body Interfaces.C.Strings is -- 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 @@ -199,9 +205,8 @@ package body Interfaces.C.Strings is ------------------ 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 @@ -212,7 +217,6 @@ package body Interfaces.C.Strings is raise Terminator_Error; else return To_chars_ptr (Item (Item'First)'Address); - end if; end To_Chars_Ptr; @@ -221,9 +225,9 @@ package body Interfaces.C.Strings is ------------ 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; @@ -240,10 +244,10 @@ package body Interfaces.C.Strings is 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); @@ -253,7 +257,7 @@ package body Interfaces.C.Strings is -- 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 @@ -271,9 +275,8 @@ package body Interfaces.C.Strings is 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 @@ -304,18 +307,18 @@ package body Interfaces.C.Strings is 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; diff --git a/gcc/ada/i-cstrin.ads b/gcc/ada/i-cstrin.ads index 2f42cdea7d4..e9d9abbe8e1 100644 --- a/gcc/ada/i-cstrin.ads +++ b/gcc/ada/i-cstrin.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- @@ -40,6 +40,15 @@ pragma Preelaborate (Strings); 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; @@ -47,50 +56,52 @@ pragma Preelaborate (Strings); 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; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 882fe6cab9a..9c0cd18985d 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -1000,9 +1000,9 @@ package body Make is 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 @@ -5095,8 +5095,8 @@ package body Make is 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 diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 4dc56be381d..2c78b75b2a7 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -659,14 +659,6 @@ package Opt is -- 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 @@ -677,6 +669,18 @@ package Opt is -- 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. diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index ac2a5275d15..93cdb12a0e1 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -2157,9 +2157,14 @@ package body Osint is 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; diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb index 017030e05d3..475f0c35509 100644 --- a/gcc/ada/par-ch10.adb +++ b/gcc/ada/par-ch10.adb @@ -748,16 +748,20 @@ package body Ch10 is -- 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; @@ -781,14 +785,21 @@ package body Ch10 is -- 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; @@ -797,9 +808,31 @@ package body Ch10 is 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 @@ -852,6 +885,7 @@ package body Ch10 is 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 diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 24e44c8aec1..fef50e03f81 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -940,6 +940,7 @@ begin Pragma_No_Return | Pragma_Obsolescent | Pragma_No_Run_Time | + Pragma_No_Strict_Aliasing | Pragma_Normalize_Scalars | Pragma_Optimize | Pragma_Optional_Overriding | diff --git a/gcc/ada/prj-com.ads b/gcc/ada/prj-com.ads index a7420447011..123ff290f67 100644 --- a/gcc/ada/prj-com.ads +++ b/gcc/ada/prj-com.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -98,5 +98,22 @@ package Prj.Com is 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; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 5c42d5cea38..aed4838cf62 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -222,7 +222,6 @@ package body Prj.Nmsc is end if; end Compute_Directory_Last; - ------------------------------- -- Prepare_Naming_Exceptions -- ------------------------------- @@ -1085,7 +1084,6 @@ package body Prj.Nmsc is (Name_Locally_Removed_Files, Data.Decl.Attributes); - begin pragma Assert (Sources.Kind = List, @@ -3662,6 +3660,8 @@ package body Prj.Nmsc is 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)); @@ -3814,19 +3814,36 @@ package body Prj.Nmsc is -- 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; diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb index 5d06b3a551d..a6c00bfcd19 100644 --- a/gcc/ada/s-finimp.adb +++ b/gcc/ada/s-finimp.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -33,10 +33,12 @@ 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; @@ -51,16 +53,10 @@ package body System.Finalization_Implementation is -- 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; @@ -423,7 +419,7 @@ package body System.Finalization_Implementation is -- 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; @@ -513,9 +509,10 @@ package body System.Finalization_Implementation is 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); diff --git a/gcc/ada/s-finroo.ads b/gcc/ada/s-finroo.ads index 9d620f1e534..c4d35567d5f 100644 --- a/gcc/ada/s-finroo.ads +++ b/gcc/ada/s-finroo.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -31,7 +31,11 @@ -- -- ------------------------------------------------------------------------------ +-- 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); @@ -39,6 +43,12 @@ 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) diff --git a/gcc/ada/s-restri.ads b/gcc/ada/s-restri.ads index 2160f07a96e..f6532f3cb38 100644 --- a/gcc/ada/s-restri.ads +++ b/gcc/ada/s-restri.ads @@ -19,6 +19,13 @@ -- 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. -- -- -- diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb index 5a0d1074972..eb87d302dbe 100644 --- a/gcc/ada/s-tasini.adb +++ b/gcc/ada/s-tasini.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -951,8 +951,7 @@ package body System.Tasking.Initialization is 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; diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index 04a7657bc68..3e4cf782747 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -125,7 +125,7 @@ package System.Tasking is -- 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); ----------------------- @@ -728,6 +728,12 @@ package System.Tasking is ------------------------------------ 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 -- diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb index 7d0a0ae736e..8d4c5e23247 100644 --- a/gcc/ada/s-tasren.adb +++ b/gcc/ada/s-tasren.adb @@ -66,6 +66,7 @@ with System.Tasking.Utilities; -- 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 @@ -452,7 +453,9 @@ package body System.Tasking.Rendezvous is 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; @@ -463,9 +466,6 @@ package body System.Tasking.Rendezvous is 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; @@ -808,7 +808,9 @@ package body System.Tasking.Rendezvous is -- ??? 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); @@ -1347,10 +1349,9 @@ package body System.Tasking.Rendezvous is 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; @@ -1710,11 +1711,9 @@ package body System.Tasking.Rendezvous is 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; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 14826330e72..cc946115a8e 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -98,10 +98,10 @@ with System.Finalization_Implementation; -- 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 diff --git a/gcc/ada/s-tataat.adb b/gcc/ada/s-tataat.adb index 120fa21f544..b3660f3b04c 100644 --- a/gcc/ada/s-tataat.adb +++ b/gcc/ada/s-tataat.adb @@ -7,7 +7,7 @@ -- 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- -- @@ -51,10 +51,6 @@ package body System.Tasking.Task_Attributes is 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 diff --git a/gcc/ada/s-tataat.ads b/gcc/ada/s-tataat.ads index 8893cdacf46..622e0ebee59 100644 --- a/gcc/ada/s-tataat.ads +++ b/gcc/ada/s-tataat.ads @@ -7,7 +7,7 @@ -- 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- -- @@ -50,6 +50,11 @@ package System.Tasking.Task_Attributes is 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; diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb index cf15ed9f88a..5bbe18ebcca 100644 --- a/gcc/ada/s-tpobop.adb +++ b/gcc/ada/s-tpobop.adb @@ -80,6 +80,9 @@ with System.Tasking.Queuing; 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 @@ -400,16 +403,16 @@ package body System.Tasking.Protected_Objects.Operations is 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); @@ -729,17 +732,25 @@ package body System.Tasking.Protected_Objects.Operations is 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); @@ -986,25 +997,29 @@ package body System.Tasking.Protected_Objects.Operations is 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); diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index c6fa436ffb7..f8d93f36b9a 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -135,9 +135,15 @@ package body Sem_Ch10 is -- 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 @@ -2483,7 +2489,7 @@ package body Sem_Ch10 is 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; @@ -2497,7 +2503,6 @@ package body Sem_Ch10 is 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; @@ -2515,7 +2520,6 @@ package body Sem_Ch10 is 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); @@ -2551,6 +2555,7 @@ package body Sem_Ch10 is 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; @@ -2777,6 +2782,7 @@ package body Sem_Ch10 is 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; @@ -3134,10 +3140,34 @@ package body Sem_Ch10 is 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 -- ---------------------- @@ -3161,11 +3191,9 @@ package body Sem_Ch10 is begin Par := U_Name; - while Present (Par) and then Par /= Standard_Standard loop - if Par = E then return True; end if; @@ -3183,9 +3211,7 @@ package body Sem_Ch10 is -- 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) @@ -3235,7 +3261,6 @@ package body Sem_Ch10 is then Set_Is_Immediately_Visible (Scope (Id)); end if; - end if; Next (Item); @@ -3259,6 +3284,10 @@ package body Sem_Ch10 is -- 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); @@ -3435,7 +3464,10 @@ package body Sem_Ch10 is -- 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); @@ -3460,13 +3492,17 @@ package body Sem_Ch10 is 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 @@ -3498,7 +3534,12 @@ package body Sem_Ch10 is 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; diff --git a/gcc/ada/sem_ch10.ads b/gcc/ada/sem_ch10.ads index 1737bc1e976..13afefce063 100644 --- a/gcc/ada/sem_ch10.ads +++ b/gcc/ada/sem_ch10.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -40,6 +40,11 @@ package Sem_Ch10 is -- 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 diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 7e4428f7762..2a48fb9450e 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -30,7 +30,6 @@ with Einfo; use Einfo; 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; @@ -3853,15 +3852,31 @@ package body Sem_Ch13 is 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; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index b675cc1f50a..fc3b12e70dd 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -959,9 +959,16 @@ package body Sem_Ch3 is -- 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) @@ -2620,6 +2627,12 @@ package body Sem_Ch3 is 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); @@ -4672,8 +4685,16 @@ package body Sem_Ch3 is 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)); @@ -5002,9 +5023,17 @@ package body Sem_Ch3 is 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) @@ -7636,7 +7665,15 @@ package body Sem_Ch3 is 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; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 7c408bf33d3..c83e2360fa7 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -48,6 +48,7 @@ with Sem_Cat; use Sem_Cat; 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; @@ -299,6 +300,7 @@ package body Sem_Ch7 is 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 @@ -856,12 +858,17 @@ package body Sem_Ch7 is 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. @@ -1593,7 +1600,8 @@ package body Sem_Ch7 is 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; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index acf7ae1e771..f0aad749e98 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -2333,7 +2333,6 @@ package body Sem_Prag is 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) @@ -3431,7 +3430,6 @@ package body Sem_Prag is 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; @@ -7484,6 +7482,36 @@ package body Sem_Prag is 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 -- ----------------- @@ -9899,6 +9927,7 @@ package body Sem_Prag is 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, diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 4ebb16fc902..e090cb54148 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -6356,19 +6356,20 @@ package Sinfo is -- 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 diff --git a/gcc/ada/sinput-c.adb b/gcc/ada/sinput-c.adb index b443b4bf885..370429a0109 100644 --- a/gcc/ada/sinput-c.adb +++ b/gcc/ada/sinput-c.adb @@ -2,11 +2,11 @@ -- -- -- 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- -- @@ -129,9 +129,15 @@ package body Sinput.C is 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; diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb index aa05461a282..68da3074d25 100644 --- a/gcc/ada/sinput-l.adb +++ b/gcc/ada/sinput-l.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -244,9 +244,15 @@ package body Sinput.L is 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 @@ -539,9 +545,16 @@ package body Sinput.L is 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); diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index 3ab47c7106a..f7fb3ced3e1 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -56,6 +56,10 @@ package body Sinput is -- 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); @@ -68,6 +72,8 @@ package body Sinput is function To_Pointer is new Unchecked_Conversion (Address, Logical_Lines_Table_Ptr); + pragma Warnings (On); + --------------------------- -- Add_Line_Tables_Entry -- --------------------------- @@ -760,9 +766,15 @@ package body Sinput is 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 @@ -841,9 +853,15 @@ package body Sinput is 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 @@ -881,9 +899,15 @@ package body Sinput is 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; diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index 52daeecc654..70b9608a538 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -169,6 +169,7 @@ package body Snames is "locking_policy#" & "long_float#" & "no_run_time#" & + "no_strict_aliasing#" & "normalize_scalars#" & "polling#" & "persistent_data#" & diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index 473077b41e1..2985ddbfd22 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -315,36 +315,37 @@ package Snames is 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 @@ -352,78 +353,78 @@ package Snames is -- 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 @@ -433,27 +434,27 @@ package Snames is -- 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 @@ -464,98 +465,98 @@ package Snames is -- 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 @@ -569,158 +570,158 @@ package Snames is -- 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 @@ -728,10 +729,10 @@ package Snames is -- 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. @@ -739,10 +740,10 @@ package Snames is -- 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 @@ -750,193 +751,193 @@ package Snames is -- 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; @@ -1159,6 +1160,7 @@ package Snames is Pragma_Locking_Policy, Pragma_Long_Float, Pragma_No_Run_Time, + Pragma_No_Strict_Aliasing, Pragma_Normalize_Scalars, Pragma_Polling, Pragma_Persistent_Data, diff --git a/gcc/ada/snames.h b/gcc/ada/snames.h index a10c25d56b9..58dc87f4fad 100644 --- a/gcc/ada/snames.h +++ b/gcc/ada/snames.h @@ -216,133 +216,134 @@ extern unsigned char Get_Pragma_Id (int); #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. */ diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb index 30c068f6eae..3f547a330e1 100644 --- a/gcc/ada/table.adb +++ b/gcc/ada/table.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -66,9 +66,16 @@ package body Table is -- 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 -- ------------ diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index ba8d16405c2..20d1fdc5a54 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -4027,9 +4027,35 @@ tree_transform (Node_Id gnat_node) 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: @@ -5396,7 +5422,7 @@ build_unit_elab (Entity_Id gnat_unit, int body_p, tree gnu_elab_list) /* 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; diff --git a/gcc/ada/vms_conv.adb b/gcc/ada/vms_conv.adb index f0fe8a138a9..1bd4d6dced7 100644 --- a/gcc/ada/vms_conv.adb +++ b/gcc/ada/vms_conv.adb @@ -337,7 +337,7 @@ package body VMS_Conv is 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 => diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index caba275c142..232940d05a4 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -1543,6 +1543,8 @@ package VMS_Data is "-O1,!-O0,!-O2,!-O3 " & "UNROLL_LOOPS " & "-funroll-loops " & + "NO_STRICT_ALIASING " & + "-fno-strict-aliasing " & "INLINING " & "-O3,!-O0,!-O1,!-O2"; -- /NOOPTIMIZE (D) @@ -1554,20 +1556,31 @@ package VMS_Data is -- 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"; @@ -4460,6 +4473,12 @@ package VMS_Data is -- 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 @@ -4508,6 +4527,12 @@ package VMS_Data is -- 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[,...]) @@ -4565,11 +4590,13 @@ package VMS_Data is 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, |