mirrors/gcc
0
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-11-27 13:54:19 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2004-06-14  Pascal Obry  <obry@gnat.com>

	* gnat_ugn.texi: Document relocatable vs. dynamic Library_Kind on
	Windows.  Fix minor typo.

	* mlib-tgt-mingw.adb: New implementation using the GCC -shared option
	which is now supported on Windows. With this implementation using the
	Library Project feature is no different on Windows than on UNIX.

2004-06-14  Vincent Celier  <celier@gnat.com>

	* makegpr.adb (Compile_Sources): Nothing to do when there are no
	non-Ada sources.

	* mlib-tgt-vxworks.adb (Library_Exists_For): Remove incorrect comment

	* prj-part.adb (Parse_Single_Project): When a duplicate project name is
	found, show the project name and the path of the previously parsed
	project file.

2004-06-14  Ed Schonberg  <schonberg@gnat.com>

	* exp_ch6.adb (Add_Call_By_Copy_Code): For an out-parameter that is an
	array, avoid copying the actual before the call.

2004-06-14  Thomas Quinot  <quinot@act-europe.fr>

	* g-debpoo.adb: Remove alignment assumptions from GNAT.Debug_Pools.
	Instead, allocate memory on worst-case alignment assumptions, and then
	return an aligned address within the allocated zone.

2004-06-14  Robert Dewar  <dewar@gnat.com>

	* bindgen.adb (Gen_Adainit_Ada): Do not generate external references to
	elab entities in predefined units in No_Run_Time_Mode.
	(Gen_Adainit_C): Same fix
	(Gen_Elab_Calls_Ada): Do not generate calls to elaborate predefined
	units in No_Run_Time_Mode
	(Gen_Elab_Calls_C): Same fix

	* symbols-vms-alpha.adb: Minor reformatting

	* g-debpoo.ads: Minor reformatting

	* lib.adb (In_Same_Extended_Unit): Version working on node id's

	* lib.ads (In_Same_Extended_Unit): Version working on node id's

	* lib-xref.adb: Minor cleanup, use new version of In_Same_Extended_Unit
	working on nodes.

	* make.adb: Minor reformatting

	* par-ch12.adb: Minor reformatting

	* par-prag.adb: Add dummy entry for pragma Profile_Warnings

	* prj-strt.adb: Minor reformatting

	* restrict.ads, restrict.adb: Redo handling of profile restrictions to
	be more general.

	* sem_attr.adb: Minor reformatting

	* sem_ch7.adb: Minor reformatting

	* sem_elab.adb (Check_A_Call): Deal with problem of calling init proc
	for type in the same unit as the object declaration.

	* sem_prag.adb (Check_Arg_Is_External_Name): New procedure, allows
	static string expressions and not just string literals.
	Minor reformatting
	(Set_Warning): Reset restriction warning flag for restriction pragma
	Implement pragma Profile_Warnings
	Implement pragma Profile (Restricted)
	Give obolescent messages for old restrictions and pragmas

	* snames.h, snames.ads, snames.adb: Add new entry for pragma
	Profile_Warnings.

	* s-rident.ads: Add declarations for restrictions required by profile
	Restricted and profile Ravenscar.

	* targparm.ads, targparm.adb: Allow pragma Profile in system.ads

	* gnat_ugn.texi: Correct some missing entries in the list of GNAT
	configuration pragmas.

From-SVN: r83099
This commit is contained in:
Arnaud Charlet 2004-06-14 15:19:14 +02:00
parent 14ba6d00aa
commit cc335f4371
30 changed files with 1455 additions and 921 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
gcc/ada/ChangeLog
View File

@ -1,3 +1,91 @@
2004-06-14 Pascal Obry <obry@gnat.com>
* gnat_ugn.texi: Document relocatable vs. dynamic Library_Kind on
Windows. Fix minor typo.
* mlib-tgt-mingw.adb: New implementation using the GCC -shared option
which is now supported on Windows. With this implementation using the
Library Project feature is no different on Windows than on UNIX.
2004-06-14 Vincent Celier <celier@gnat.com>
* makegpr.adb (Compile_Sources): Nothing to do when there are no
non-Ada sources.
* mlib-tgt-vxworks.adb (Library_Exists_For): Remove incorrect comment
* prj-part.adb (Parse_Single_Project): When a duplicate project name is
found, show the project name and the path of the previously parsed
project file.
2004-06-14 Ed Schonberg <schonberg@gnat.com>
* exp_ch6.adb (Add_Call_By_Copy_Code): For an out-parameter that is an
array, avoid copying the actual before the call.
2004-06-14 Thomas Quinot <quinot@act-europe.fr>
* g-debpoo.adb: Remove alignment assumptions from GNAT.Debug_Pools.
Instead, allocate memory on worst-case alignment assumptions, and then
return an aligned address within the allocated zone.
2004-06-14 Robert Dewar <dewar@gnat.com>
* bindgen.adb (Gen_Adainit_Ada): Do not generate external references to
elab entities in predefined units in No_Run_Time_Mode.
(Gen_Adainit_C): Same fix
(Gen_Elab_Calls_Ada): Do not generate calls to elaborate predefined
units in No_Run_Time_Mode
(Gen_Elab_Calls_C): Same fix
* symbols-vms-alpha.adb: Minor reformatting
* g-debpoo.ads: Minor reformatting
* lib.adb (In_Same_Extended_Unit): Version working on node id's
* lib.ads (In_Same_Extended_Unit): Version working on node id's
* lib-xref.adb: Minor cleanup, use new version of In_Same_Extended_Unit
working on nodes.
* make.adb: Minor reformatting
* par-ch12.adb: Minor reformatting
* par-prag.adb: Add dummy entry for pragma Profile_Warnings
* prj-strt.adb: Minor reformatting
* restrict.ads, restrict.adb: Redo handling of profile restrictions to
be more general.
* sem_attr.adb: Minor reformatting
* sem_ch7.adb: Minor reformatting
* sem_elab.adb (Check_A_Call): Deal with problem of calling init proc
for type in the same unit as the object declaration.
* sem_prag.adb (Check_Arg_Is_External_Name): New procedure, allows
static string expressions and not just string literals.
Minor reformatting
(Set_Warning): Reset restriction warning flag for restriction pragma
Implement pragma Profile_Warnings
Implement pragma Profile (Restricted)
Give obolescent messages for old restrictions and pragmas
* snames.h, snames.ads, snames.adb: Add new entry for pragma
Profile_Warnings.
* s-rident.ads: Add declarations for restrictions required by profile
Restricted and profile Ravenscar.
* targparm.ads, targparm.adb: Allow pragma Profile in system.ads
* gnat_ugn.texi: Correct some missing entries in the list of GNAT
configuration pragmas.
2004-06-11 Vincent Celier <celier@gnat.com>
* mlib-tgt-vms-alpha.adb (Build_Dynamic_Library): Issue switch -R to

49
gcc/ada/bindgen.adb
View File

@ -371,7 +371,21 @@ package body Bindgen is
U : Unit_Record renames Units.Table (Unum);
begin
if U.Set_Elab_Entity and then not U.Interface then
-- Check for Elab_Entity to be set for this unit
if U.Set_Elab_Entity
-- Don't generate reference for stand alone library
and then not U.Interface
-- Don't generate reference for predefined file in No_Run_Time
-- mode, since we don't include the object files in this case
and then not
(No_Run_Time_Mode
and then Is_Predefined_File_Name (U.Sfile))
then
Set_String (" ");
Set_String ("E");
Set_Unit_Number (Unum);
@ -667,8 +681,23 @@ package body Bindgen is
declare
Unum : constant Unit_Id := Elab_Order.Table (E);
U : Unit_Record renames Units.Table (Unum);
begin
if U.Set_Elab_Entity and then not U.Interface then
-- Check for Elab entity to be set for this unit
if U.Set_Elab_Entity
-- Don't generate reference for stand alone library
and then not U.Interface
-- Don't generate reference for predefined file in No_Run_Time
-- mode, since we don't include the object files in this case
and then not
(No_Run_Time_Mode
and then Is_Predefined_File_Name (U.Sfile))
then
Set_String (" extern char ");
Get_Name_String (U.Uname);
Set_Unit_Name;
@ -894,9 +923,14 @@ package body Bindgen is
Unum_Spec := Unum;
end if;
-- Nothing to do if predefined unit in no run time mode
if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
null;
-- Case of no elaboration code
if U.No_Elab then
elsif U.No_Elab then
-- The only case in which we have to do something is if
-- this is a body, with a separate spec, where the separate
@ -989,7 +1023,6 @@ package body Bindgen is
procedure Gen_Elab_Calls_C is
begin
for E in Elab_Order.First .. Elab_Order.Last loop
declare
Unum : constant Unit_Id := Elab_Order.Table (E);
@ -1008,9 +1041,14 @@ package body Bindgen is
Unum_Spec := Unum;
end if;
-- Nothing to do if predefined unit in no run time mode
if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
null;
-- Case of no elaboration code
if U.No_Elab then
elsif U.No_Elab then
-- The only case in which we have to do something is if
-- this is a body, with a separate spec, where the separate
@ -1867,6 +1905,7 @@ package body Bindgen is
or else GNAT.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len))
then
Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
if Output_Object_List then
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Eol;

58
gcc/ada/exp_ch6.adb
View File

@ -529,12 +529,13 @@ package body Exp_Ch6 is
---------------------------
procedure Add_Call_By_Copy_Code is
Expr : Node_Id;
Init : Node_Id;
Temp : Entity_Id;
Var : Entity_Id;
V_Typ : Entity_Id;
Crep : Boolean;
Expr : Node_Id;
Init : Node_Id;
Temp : Entity_Id;
Indic : Node_Id := New_Occurrence_Of (Etype (Formal), Loc);
Var : Entity_Id;
V_Typ : Entity_Id;
Crep : Boolean;
begin
Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
@ -560,10 +561,14 @@ package body Exp_Ch6 is
-- parameter where the formal is an unconstrained array (in the
-- latter case, we have to pass in an object with bounds).
-- If this is an out parameter, the initial copy is wasteful, so as
-- an optimization for the one-dimensional case we extract the
-- bounds of the actual and build an uninitialized temporary of the
-- right size.
if Ekind (Formal) = E_In_Out_Parameter
or else (Is_Array_Type (Etype (Formal))
and then
not Is_Constrained (Etype (Formal)))
and then not Is_Constrained (Etype (Formal)))
then
if Nkind (Actual) = N_Type_Conversion then
if Conversion_OK (Actual) then
@ -573,6 +578,33 @@ package body Exp_Ch6 is
Init := Convert_To
(Etype (Formal), New_Occurrence_Of (Var, Loc));
end if;
elsif Ekind (Formal) = E_Out_Parameter
and then Number_Dimensions (Etype (Formal)) = 1
and then not Has_Non_Null_Base_Init_Proc (Etype (Formal))
then
-- Actual is a one-dimensional array or slice, and the type
-- requires no initialization. Create a temporary of the
-- right size, but do copy actual into it (optimization).
Init := Empty;
Indic :=
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Etype (Formal), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Var, Loc),
Attribute_name => Name_First),
High_Bound =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Var, Loc),
Attribute_Name => Name_Last)))));
else
Init := New_Occurrence_Of (Var, Loc);
end if;
@ -607,8 +639,7 @@ package body Exp_Ch6 is
N_Node :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition =>
New_Occurrence_Of (Etype (Formal), Loc),
Object_Definition => Indic,
Expression => Init);
Set_Assignment_OK (N_Node);
Insert_Action (N, N_Node);
@ -2527,9 +2558,12 @@ package body Exp_Ch6 is
-- In this case, for optimization purposes, we do not need to
-- continue the traversal once more than one use is encountered.
----------------
-- Count_Uses --
----------------
function Count_Uses (N : Node_Id) return Traverse_Result is
begin
-- The original node is an identifier
if Nkind (N) = N_Identifier
@ -2565,10 +2599,8 @@ package body Exp_Ch6 is
-- Start of processing for Formal_Is_Used_Once
begin
Count_Formal_Uses (Orig_Bod);
return Use_Counter = 1;
end Formal_Is_Used_Once;
-- Start of processing for Expand_Inlined_Call

72
gcc/ada/g-debpoo.adb
View File

@ -146,7 +146,10 @@ package body GNAT.Debug_Pools is
-- Traceback_Htable_Elem_Ptr.
type Allocation_Header is record
Block_Size : Storage_Offset;
Allocation_Address : System.Address;
-- Address of the block returned by malloc, possibly unaligned.
Block_Size : Storage_Offset;
-- Needed only for advanced freeing algorithms (traverse all allocated
-- blocks for potential references). This value is negated when the
-- chunk of memory has been logically freed by the application. This
@ -154,7 +157,7 @@ package body GNAT.Debug_Pools is
Alloc_Traceback : Traceback_Htable_Elem_Ptr;
Dealloc_Traceback : Traceback_Ptr_Or_Address;
-- Pointer to the traceback for the allocation (if the memory chunck is
-- Pointer to the traceback for the allocation (if the memory chunk is
-- still valid), or to the first deallocation otherwise. Make sure this
-- is a thin pointer to save space.
--
@ -183,21 +186,23 @@ package body GNAT.Debug_Pools is
function To_Traceback is new Ada.Unchecked_Conversion
(Traceback_Htable_Elem_Ptr, Traceback_Ptr_Or_Address);
Header_Offset : constant Storage_Count
:= Default_Alignment *
((Allocation_Header'Size / System.Storage_Unit + Default_Alignment - 1)
/ Default_Alignment);
-- Offset of user data after allocation header.
Minimum_Allocation : constant Storage_Count :=
Default_Alignment *
(Allocation_Header'Size /
System.Storage_Unit /
Default_Alignment) +
Default_Alignment;
-- Extra bytes to allocate to store the header. The header needs to be
-- correctly aligned as well, so we have to allocate multiples of the
-- alignment.
Default_Alignment - 1
+ Header_Offset;
-- Minimal allocation: size of allocation_header rounded up to next
-- multiple of default alignment + worst-case padding.
-----------------------
-- Allocations table --
-----------------------
-- This table is indexed on addresses modulo Minimum_Allocation, and
-- This table is indexed on addresses modulo Default_Alignment, and
-- for each index it indicates whether that memory block is valid.
-- Its behavior is similar to GNAT.Table, except that we need to pack
-- the table to save space, so we cannot reuse GNAT.Table as is.
@ -249,7 +254,7 @@ package body GNAT.Debug_Pools is
Edata : System.Address := System.Null_Address;
-- Address in memory that matches the index 0 in Valid_Blocks. It is named
-- after the symbol _edata, which, on most systems, indicate the lowest
-- possible address returned by malloc (). Unfortunately, this symbol
-- possible address returned by malloc. Unfortunately, this symbol
-- doesn't exist on windows, so we cannot use it instead of this variable.
-----------------------
@ -341,7 +346,7 @@ package body GNAT.Debug_Pools is
function Convert is new Ada.Unchecked_Conversion
(System.Address, Allocation_Header_Access);
begin
return Convert (Address - Minimum_Allocation);
return Convert (Address - Header_Offset);
end Header_Of;
--------------
@ -670,8 +675,6 @@ package body GNAT.Debug_Pools is
type Local_Storage_Array is new Storage_Array
(1 .. Size_In_Storage_Elements + Minimum_Allocation);
for Local_Storage_Array'Alignment use Standard'Maximum_Alignment;
-- For performance reasons, make sure the alignment is maximized.
type Ptr is access Local_Storage_Array;
-- On some systems, we might want to physically protect pages
@ -716,7 +719,14 @@ package body GNAT.Debug_Pools is
P := new Local_Storage_Array;
end;
Storage_Address := P.all'Address + Minimum_Allocation;
Storage_Address := System.Null_Address + Default_Alignment
* (((P.all'Address + Default_Alignment - 1) - System.Null_Address)
/ Default_Alignment)
+ Header_Offset;
pragma Assert ((Storage_Address - System.Null_Address)
mod Default_Alignment = 0);
pragma Assert (Storage_Address + Size_In_Storage_Elements
<= P.all'Address + P'Length);
Trace := Find_Or_Create_Traceback
(Pool, Alloc, Size_In_Storage_Elements,
@ -728,10 +738,11 @@ package body GNAT.Debug_Pools is
-- Default_Alignment.
Header_Of (Storage_Address).all :=
(Alloc_Traceback => Trace,
Dealloc_Traceback => To_Traceback (null),
Next => Pool.First_Used_Block,
Block_Size => Size_In_Storage_Elements);
(Allocation_Address => P.all'Address,
Alloc_Traceback => Trace,
Dealloc_Traceback => To_Traceback (null),
Next => Pool.First_Used_Block,
Block_Size => Size_In_Storage_Elements);
pragma Warnings (On);
@ -928,7 +939,7 @@ package body GNAT.Debug_Pools is
end;
Next := Header.Next;
System.Memory.Free (Header.all'Address);
System.Memory.Free (Header.Allocation_Address);
Set_Valid (Tmp, False);
-- Remove this block from the list.
@ -1141,15 +1152,16 @@ package body GNAT.Debug_Pools is
-- Update the header
Header.all :=
(Alloc_Traceback => Header.Alloc_Traceback,
Dealloc_Traceback => To_Traceback
(Find_Or_Create_Traceback
(Pool, Dealloc,
Size_In_Storage_Elements,
Deallocate_Label'Address,
Code_Address_For_Deallocate_End)),
Next => System.Null_Address,
Block_Size => -Size_In_Storage_Elements);
(Allocation_Address => Header.Allocation_Address,
Alloc_Traceback => Header.Alloc_Traceback,
Dealloc_Traceback => To_Traceback
(Find_Or_Create_Traceback
(Pool, Dealloc,
Size_In_Storage_Elements,
Deallocate_Label'Address,
Code_Address_For_Deallocate_End)),
Next => System.Null_Address,
Block_Size => -Size_In_Storage_Elements);
if Pool.Reset_Content_On_Free then
Set_Dead_Beef (Storage_Address, Size_In_Storage_Elements);

4
gcc/ada/g-debpoo.ads
View File

@ -260,8 +260,8 @@ private
Alignment : Storage_Count);
-- Mark a block of memory as invalid. It might not be physically removed
-- immediately, depending on the setup of the debug pool, so that checks
-- are still possible.
-- The parameters have the same semantics as defined in the ARM95.
-- are still possible. The parameters have the same semantics as defined
-- in the RM.
function Storage_Size (Pool : Debug_Pool) return SSC;
-- Return the maximal size of data that can be allocated through Pool.

11
gcc/ada/gnat_ugn.texi
View File

@ -9996,10 +9996,13 @@ recognized by @code{GNAT}:
Normalize_Scalars
Polling
Profile
Profile_Warnings
Propagate_Exceptions
Queuing_Policy
Ravenscar
Restricted_Run_Time
Restrictions
Restrictions_Warnings
Reviewable
Source_File_Name
Style_Checks
@ -12452,6 +12455,12 @@ Depending on the operating system, there may or may not be a distinction
between dynamic and relocatable libraries. For Unix and VMS Unix there is no
such distinction.
@ifset unw
On Windows @code{"relocatable"} will build a relocatable @code{DLL}
and @code{"dynamic"} will build a non-relocatable @code{DLL}.
@pxref{Introduction to Dynamic Link Libraries (DLLs)}.
@end ifset
If you need to build both a static and a dynamic library, you should use two
different object directories, since in some cases some extra code needs to
be generated for the latter. For such cases, it is recommended to either use
@ -13155,7 +13164,7 @@ When a library project file is specified, switches ^-b^/ACTION=BIND^ and
^-l^/ACTION=LINK^ have special meanings.
@itemize @bullet
@item ^-b^/ACTION=BIND^ is only allwed for stand-alone libraries. It indicates
@item ^-b^/ACTION=BIND^ is only allowed for stand-alone libraries. It indicates
to @command{gnatmake} that @command{gnatbind} should be invoked for the
library.

2
gcc/ada/lib-xref.adb
View File

@ -357,7 +357,7 @@ package body Lib.Xref is
-- this source unit (occasion for possible warning to be issued)
if Has_Pragma_Unreferenced (E)
and then In_Same_Extended_Unit (Sloc (E), Sloc (N))
and then In_Same_Extended_Unit (E, N)
then
-- A reference as a named parameter in a call does not count
-- as a violation of pragma Unreferenced for this purpose.

9
gcc/ada/lib.adb
View File

@ -640,7 +640,7 @@ package body Lib is
else
return
In_Same_Extended_Unit (Sloc (N), Sloc (Cunit (Main_Unit)));
In_Same_Extended_Unit (N, Cunit (Main_Unit));
end if;
end In_Extended_Main_Code_Unit;
@ -765,6 +765,13 @@ package body Lib is
-- In_Same_Extended_Unit --
---------------------------
function In_Same_Extended_Unit
(N1, N2 : Node_Or_Entity_Id) return Boolean
is
begin
return Check_Same_Extended_Unit (Sloc (N1), Sloc (N2)) /= No;
end In_Same_Extended_Unit;
function In_Same_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is
begin
return Check_Same_Extended_Unit (S1, S2) /= No;

11
gcc/ada/lib.ads
View File

@ -454,10 +454,19 @@ package Lib is
-- code unit, the criterion being that Get_Code_Unit yields the same
-- value for each argument.
function In_Same_Extended_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean;
pragma Inline (In_Same_Extended_Unit);
-- Determines if two nodes or entities N1 and N2 are in the same
-- extended unit, where an extended unit is defined as a unit and all
-- its subunits (considered recursively, i.e. subunits of subunits are
-- included). Returns true if S1 and S2 are in the same extended unit
-- and False otherwise.
function In_Same_Extended_Unit (S1, S2 : Source_Ptr) return Boolean;
pragma Inline (In_Same_Extended_Unit);
-- Determines if the two source locations S1 and S2 are in the same
-- extended unit, where an extended unit is defined as a unit and all
-- its subunits (considered recursively, i.e. subunits or subunits are
-- its subunits (considered recursively, i.e. subunits of subunits are
-- included). Returns true if S1 and S2 are in the same extended unit
-- and False otherwise.

9
gcc/ada/make.adb
View File

@ -5587,14 +5587,19 @@ package body Make is
if not OpenVMS then
declare
Command : constant String := Command_Name;
begin
for Index in reverse Command'Range loop
if Command (Index) = Directory_Separator then
declare
Absolute_Dir : constant String :=
Normalize_Pathname (Command (Command'First .. Index));
Normalize_Pathname
(Command (Command'First .. Index));
PATH : constant String :=
Absolute_Dir & Path_Separator & Getenv ("PATH").all;
Absolute_Dir &
Path_Separator &
Getenv ("PATH").all;
begin
Setenv ("PATH", PATH);

74
gcc/ada/makegpr.adb
View File

@ -2139,7 +2139,9 @@ package body Makegpr is
Local_Errors := False;
Data := Projects.Table (Project);
if not Data.Virtual then
-- Nothing to do when no sources of language other than Ada
if (not Data.Virtual) and then Data.Sources_Present then
-- If the imported directory switches are unknown, compute them
@ -2149,51 +2151,47 @@ package body Makegpr is
Projects.Table (Project) := Data;
end if;
-- Nothing to do when no sources of language other than Ada
Need_To_Rebuild_Archive := Force_Compilations;
if Data.Sources_Present then
Need_To_Rebuild_Archive := Force_Compilations;
-- Compilation will occur in the object directory
-- Compilation will occur in the object directory
Change_Dir (Get_Name_String (Data.Object_Directory));
Change_Dir (Get_Name_String (Data.Object_Directory));
Source_Id := Data.First_Other_Source;
Source_Id := Data.First_Other_Source;
-- Process each source one by one
-- Process each source one by one
while Source_Id /= No_Other_Source loop
Source := Other_Sources.Table (Source_Id);
Need_To_Compile := Force_Compilations;
while Source_Id /= No_Other_Source loop
Source := Other_Sources.Table (Source_Id);
Need_To_Compile := Force_Compilations;
-- Check if compilation is needed
-- Check if compilation is needed
if not Need_To_Compile then
Check_Compilation_Needed (Source, Need_To_Compile);
end if;
-- Proceed, if compilation is needed
if Need_To_Compile then
-- If a source is compiled/recompiled, of course the
-- archive will need to be built/rebuilt.
Need_To_Rebuild_Archive := True;
Compile (Source_Id, Data, Local_Errors);
end if;
-- Next source, if any
Source_Id := Source.Next;
end loop;
-- If there was no compilation error, build/rebuild the archive
-- if necessary.
if not Local_Errors then
Build_Archive (Project, Need_To_Rebuild_Archive);
if not Need_To_Compile then
Check_Compilation_Needed (Source, Need_To_Compile);
end if;
-- Proceed, if compilation is needed
if Need_To_Compile then
-- If a source is compiled/recompiled, of course the
-- archive will need to be built/rebuilt.
Need_To_Rebuild_Archive := True;
Compile (Source_Id, Data, Local_Errors);
end if;
-- Next source, if any
Source_Id := Source.Next;
end loop;
-- If there was no compilation error, build/rebuild the archive
-- if necessary.
if not Local_Errors then
Build_Archive (Project, Need_To_Rebuild_Archive);
end if;
end if;
end loop;

189
gcc/ada/mlib-tgt-mingw.adb
View File

@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2004, Ada Core Technologies, Inc. --
-- Copyright (C) 2002-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- --
@ -28,7 +28,8 @@
-- This package provides a set of target dependent routines to build
-- static, dynamic and shared libraries.
-- This is the Windows version of the body.
-- This is the Windows version of the body. Works only with GCC versions
-- supporting the "-shared" option.
with Namet; use Namet;
with Opt;
@ -37,12 +38,14 @@ with Prj.Com;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with MDLL;
with MDLL.Utl;
with MLib.Fil;
with MLib.Utl;
package body MLib.Tgt is
package Files renames MLib.Fil;
package Tools renames MLib.Utl;
---------------------
-- Archive_Builder --
---------------------
@ -98,73 +101,121 @@ package body MLib.Tgt is
Relocatable : Boolean := False;
Auto_Init : Boolean := False)
is
pragma Unreferenced (Ofiles);
pragma Unreferenced (Interfaces);
pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Driver_Name);
pragma Unreferenced (Lib_Version);
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Auto_Init);
pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Interfaces);
pragma Unreferenced (Lib_Version);
Imp_File : constant String :=
"lib" & MLib.Fil.Ext_To (Lib_Filename, Archive_Ext);
-- Name of the import library
Strip_Name : constant String := "strip";
Strip_Exec : String_Access;
DLL_File : constant String := MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
-- Name of the DLL file
procedure Strip_Reloc (Lib_File : String);
-- Strip .reloc section to build a non relocatable DLL
Lib_File : constant String := Lib_Dir & Directory_Separator & DLL_File;
-- Full path of the DLL file
-----------------
-- Strip_Reloc --
-----------------
Success : Boolean;
procedure Strip_Reloc (Lib_File : String) is
Arguments : Argument_List (1 .. 3);
Success : Boolean;
Line_Length : Natural;
begin
-- Look for strip executable
Strip_Exec := Locate_Exec_On_Path (Strip_Name);
if Strip_Exec = null then
Fail (Strip_Name, " not found in path");
elsif Opt.Verbose_Mode then
Write_Str ("found ");
Write_Line (Strip_Exec.all);
end if;
-- Call it: strip -R .reloc <dll>
Arguments (1) := new String'("-R");
Arguments (2) := new String'(".reloc");
Arguments (3) := new String'(Lib_File);
if not Opt.Quiet_Output then
Write_Str (Strip_Exec.all);
Line_Length := Strip_Exec'Length;
for K in Arguments'Range loop
-- Make sure the Output buffer does not overflow
if Line_Length + 1 + Arguments (K)'Length >
Integer (Opt.Max_Line_Length)
then
Write_Eol;
Line_Length := 0;
end if;
Write_Char (' ');
Write_Str (Arguments (K).all);
Line_Length := Line_Length + 1 + Arguments (K)'Length;
end loop;
Write_Eol;
end if;
Spawn (Strip_Exec.all, Arguments, Success);
if not Success then
Fail (Strip_Name, " execution error.");
end if;
for K in Arguments'Range loop
Free (Arguments (K));
end loop;
end Strip_Reloc;
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
Files.Ext_To (Lib_Filename, DLL_Ext);
I_Base : aliased String := "-Wl,--image-base," & Lib_Address;
Options_2 : Argument_List (1 .. 1);
O_Index : Natural := 0;
-- Start of processing for Build_Dynamic_Library
begin
if Opt.Verbose_Mode then
if Relocatable then
Write_Str ("building relocatable shared library ");
else
Write_Str ("building non-relocatable shared library ");
Write_Str ("building ");
if not Relocatable then
Write_Str ("non-");
end if;
Write_Str ("relocatable shared library ");
Write_Line (Lib_File);
end if;
MDLL.Verbose := Opt.Verbose_Mode;
MDLL.Quiet := not MDLL.Verbose;
MDLL.Utl.Locate;
MDLL.Build_Dynamic_Library
(Foreign, Afiles,
MDLL.Null_Argument_List, MDLL.Null_Argument_List, Options,
Lib_Filename, Lib_Filename & ".def",
Lib_Address, True, Relocatable);
-- Move the DLL and import library in the lib directory
Copy_File (DLL_File, Lib_Dir, Success, Mode => Overwrite);
if not Success then
Fail ("could not copy DLL to library dir");
if not Relocatable then
O_Index := O_Index + 1;
Options_2 (O_Index) := I_Base'Unchecked_Access;
end if;
Copy_File (Imp_File, Lib_Dir, Success, Mode => Overwrite);
Tools.Gcc
(Output_File => Lib_File,
Objects => Ofiles,
Options => Options,
Driver_Name => Driver_Name,
Options_2 => Options_2 (1 .. O_Index));
if not Success then
Fail ("could not copy import library to library dir");
end if;
if not Relocatable then
-- Delete files
-- Strip reloc symbols from the DLL
Delete_File (DLL_File, Success);
if not Success then
Fail ("could not delete DLL from build dir");
end if;
Delete_File (Imp_File, Success);
if not Success then
Fail ("could not delete import library from build dir");
Strip_Reloc (Lib_File);
end if;
end Build_Dynamic_Library;
@ -192,7 +243,7 @@ package body MLib.Tgt is
function Dynamic_Option return String is
begin
return "";
return "-shared";
end Dynamic_Option;
-------------------
@ -219,7 +270,7 @@ package body MLib.Tgt is
function Is_Archive_Ext (Ext : String) return Boolean is
begin
return Ext = ".a";
return Ext = ".a" or else Ext = ".dll";
end Is_Archive_Ext;
-------------
@ -245,24 +296,21 @@ package body MLib.Tgt is
else
declare
Lib_Dir : constant String :=
Get_Name_String (Projects.Table (Project).Library_Dir);
Get_Name_String
(Projects.Table (Project).Library_Dir);
Lib_Name : constant String :=
Get_Name_String (Projects.Table (Project).Library_Name);
Get_Name_String
(Projects.Table (Project).Library_Name);
begin
if Projects.Table (Project).Library_Kind = Static then
-- Static libraries are named : lib<name>.a
return Is_Regular_File
(Lib_Dir & Directory_Separator & "lib" &
MLib.Fil.Ext_To (Lib_Name, Archive_Ext));
else
-- Shared libraries are named : <name>.dll
return Is_Regular_File
(Lib_Dir & Directory_Separator &
(Lib_Dir & Directory_Separator & "lib" &
MLib.Fil.Ext_To (Lib_Name, DLL_Ext));
end if;
end;
@ -283,23 +331,16 @@ package body MLib.Tgt is
else
declare
Lib_Name : constant String :=
Get_Name_String
(Projects.Table (Project).Library_Name);
Get_Name_String (Projects.Table (Project).Library_Name);
begin
Name_Len := 3;
Name_Buffer (1 .. Name_Len) := "lib";
if Projects.Table (Project).Library_Kind = Static then
-- Static libraries are named : lib<name>.a
Name_Len := 3;
Name_Buffer (1 .. Name_Len) := "lib";
Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
else
-- Shared libraries are named : <name>.dll
Name_Len := 0;
Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
end if;

2
gcc/ada/mlib-tgt-vxworks.adb
View File

@ -222,7 +222,7 @@ package body MLib.Tgt is
if not Projects.Table (Project).Library then
Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " &
"for non library project");
return False; -- To avoid warning;
return False;
else
declare

4
gcc/ada/par-ch12.adb
View File

@ -203,8 +203,8 @@ package body Ch12 is
Set_Specification (Gen_Decl, P_Subprogram_Specification);
if Nkind (Defining_Unit_Name (Specification (Gen_Decl)))
= N_Defining_Program_Unit_Name
if Nkind (Defining_Unit_Name (Specification (Gen_Decl))) =
N_Defining_Program_Unit_Name
and then Scope.Last > 0
then
Error_Msg_SP ("child unit allowed only at library level");

1
gcc/ada/par-prag.adb
View File

@ -994,6 +994,7 @@ begin
Pragma_Preelaborate |
Pragma_Priority |
Pragma_Profile |
Pragma_Profile_Warnings |
Pragma_Propagate_Exceptions |
Pragma_Psect_Object |
Pragma_Pure |

13
gcc/ada/prj-part.adb
View File

@ -1164,8 +1164,9 @@ package body Prj.Part is
end;
declare
Project_Name : Name_Id :=
Tree_Private_Part.Projects_Htable.Get_First.Name;
Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
Tree_Private_Part.Projects_Htable.Get_First;
Project_Name : Name_Id := Name_And_Node.Name;
begin
-- Check if we already have a project with this name
@ -1173,13 +1174,17 @@ package body Prj.Part is
while Project_Name /= No_Name
and then Project_Name /= Name_Of_Project
loop
Project_Name := Tree_Private_Part.Projects_Htable.Get_Next.Name;
Name_And_Node := Tree_Private_Part.Projects_Htable.Get_Next;
Project_Name := Name_And_Node.Name;
end loop;
-- Report an error if we already have a project with this name
if Project_Name /= No_Name then
Error_Msg ("duplicate project name", Token_Ptr);
Error_Msg_Name_1 := Project_Name;
Error_Msg ("duplicate project name {", Location_Of (Project));
Error_Msg_Name_1 := Path_Name_Of (Name_And_Node.Node);
Error_Msg ("\already in {", Location_Of (Project));
else
-- Otherwise, add the name of the project to the hash table, so

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

@ -282,6 +282,7 @@ package body Prj.Strt is
end loop;
-- If only one is not used, report a single warning for this value
if Non_Used = 1 then
Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String;
Error_Msg ("?value { is not used as label", Case_Location);

167
gcc/ada/restrict.adb
View File

@ -31,12 +31,24 @@ with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Lib; use Lib;
with Namet; use Namet;
with Opt; use Opt;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Snames; use Snames;
with Uname; use Uname;
package body Restrict is
Restricted_Profile_Result : Boolean := False;
-- This switch memoizes the result of Restricted_Profile function
-- calls for improved efficiency. Its setting is valid only if
-- Restricted_Profile_Cached is True. Note that if this switch
-- is ever set True, it need never be turned off again.
Restricted_Profile_Cached : Boolean := False;
-- This flag is set to True if the Restricted_Profile_Result
-- contains the correct cached result of Restricted_Profile calls.
-----------------------
-- Local Subprograms --
-----------------------
@ -361,57 +373,75 @@ package body Restrict is
-- Note: body of this function must be coordinated with list of
-- renaming declarations in System.Rident.
function Process_Restriction_Synonyms (Id : Name_Id) return Name_Id is
function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
is
Old_Name : constant Name_Id := Chars (N);
New_Name : Name_Id;
begin
case Id is
case Old_Name is
when Name_Boolean_Entry_Barriers =>
return Name_Simple_Barriers;
New_Name := Name_Simple_Barriers;
when Name_Max_Entry_Queue_Depth =>
return Name_Max_Entry_Queue_Length;
New_Name := Name_Max_Entry_Queue_Length;
when Name_No_Dynamic_Interrupts =>
return Name_No_Dynamic_Attachment;
New_Name := Name_No_Dynamic_Attachment;
when Name_No_Requeue =>
return Name_No_Requeue_Statements;
New_Name := Name_No_Requeue_Statements;
when Name_No_Task_Attributes =>
return Name_No_Task_Attributes_Package;
New_Name := Name_No_Task_Attributes_Package;
when others =>
return Id;
return Old_Name;
end case;
if Warn_On_Obsolescent_Feature then
Error_Msg_Name_1 := Old_Name;
Error_Msg_N ("restriction identifier % is obsolescent?", N);
Error_Msg_Name_1 := New_Name;
Error_Msg_N ("|use restriction identifier % instead", N);
end if;
return New_Name;
end Process_Restriction_Synonyms;
------------------------
-- Restricted_Profile --
------------------------
-- This implementation must be coordinated with Set_Restricted_Profile
function Restricted_Profile return Boolean is
begin
return Restrictions.Set (No_Abort_Statements)
and then Restrictions.Set (No_Asynchronous_Control)
and then Restrictions.Set (No_Entry_Queue)
and then Restrictions.Set (No_Task_Hierarchy)
and then Restrictions.Set (No_Task_Allocators)
and then Restrictions.Set (No_Dynamic_Priorities)
and then Restrictions.Set (No_Terminate_Alternatives)
and then Restrictions.Set (No_Dynamic_Attachment)
and then Restrictions.Set (No_Protected_Type_Allocators)
and then Restrictions.Set (No_Local_Protected_Objects)
and then Restrictions.Set (No_Requeue_Statements)
and then Restrictions.Set (No_Task_Attributes_Package)
and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
and then Restrictions.Set (Max_Task_Entries)
and then Restrictions.Set (Max_Protected_Entries)
and then Restrictions.Set (Max_Select_Alternatives)
and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0
and then Restrictions.Value (Max_Task_Entries) = 0
and then Restrictions.Value (Max_Protected_Entries) <= 1
and then Restrictions.Value (Max_Select_Alternatives) = 0;
if Restricted_Profile_Cached then
return Restricted_Profile_Result;
else
Restricted_Profile_Result := True;
Restricted_Profile_Cached := True;
declare
R : Restriction_Flags renames Profile_Info (Restricted).Set;
V : Restriction_Values renames Profile_Info (Restricted).Value;
begin
for J in R'Range loop
if R (J)
and then (Restrictions.Set (J) = False
or else Restriction_Warnings (J)
or else
(J in All_Parameter_Restrictions
and then Restrictions.Value (J) > V (J)))
then
Restricted_Profile_Result := False;
exit;
end if;
end loop;
return Restricted_Profile_Result;
end;
end if;
end Restricted_Profile;
------------------------
@ -466,52 +496,31 @@ package body Restrict is
Error_Msg_N (B (1 .. P), N);
end Restriction_Msg;
-------------------
-- Set_Ravenscar --
-------------------
------------------------------
-- Set_Profile_Restrictions --
------------------------------
procedure Set_Profile_Restrictions
(P : Profile_Name;
N : Node_Id;
Warn : Boolean)
is
R : Restriction_Flags renames Profile_Info (P).Set;
V : Restriction_Values renames Profile_Info (P).Value;
procedure Set_Ravenscar (N : Node_Id) is
begin
Set_Restricted_Profile (N);
Set_Restriction (Simple_Barriers, N);
Set_Restriction (No_Select_Statements, N);
Set_Restriction (No_Calendar, N);
Set_Restriction (No_Entry_Queue, N);
Set_Restriction (No_Relative_Delay, N);
Set_Restriction (No_Task_Termination, N);
Set_Restriction (No_Implicit_Heap_Allocations, N);
end Set_Ravenscar;
for J in R'Range loop
if R (J) then
if J in All_Boolean_Restrictions then
Set_Restriction (J, N);
else
Set_Restriction (J, N, V (J));
end if;
----------------------------
-- Set_Restricted_Profile --
----------------------------
-- This must be coordinated with Restricted_Profile
procedure Set_Restricted_Profile (N : Node_Id) is
begin
-- Set Boolean restrictions for Restricted Profile
Set_Restriction (No_Abort_Statements, N);
Set_Restriction (No_Asynchronous_Control, N);
Set_Restriction (No_Entry_Queue, N);
Set_Restriction (No_Task_Hierarchy, N);
Set_Restriction (No_Task_Allocators, N);
Set_Restriction (No_Dynamic_Priorities, N);
Set_Restriction (No_Terminate_Alternatives, N);
Set_Restriction (No_Dynamic_Attachment, N);
Set_Restriction (No_Protected_Type_Allocators, N);
Set_Restriction (No_Local_Protected_Objects, N);
Set_Restriction (No_Requeue_Statements, N);
Set_Restriction (No_Task_Attributes_Package, N);
-- Set parameter restrictions
Set_Restriction (Max_Asynchronous_Select_Nesting, N, 0);
Set_Restriction (Max_Task_Entries, N, 0);
Set_Restriction (Max_Select_Alternatives, N, 0);
Set_Restriction (Max_Protected_Entries, N, 1);
end Set_Restricted_Profile;
Restriction_Warnings (J) := Warn;
end if;
end loop;
end Set_Profile_Restrictions;
---------------------
-- Set_Restriction --
@ -526,6 +535,12 @@ package body Restrict is
begin
Restrictions.Set (R) := True;
if Restricted_Profile_Cached and Restricted_Profile_Result then
null;
else
Restricted_Profile_Cached := False;
end if;
-- Set location, but preserve location of system
-- restriction for nice error msg with run time name
@ -557,6 +572,12 @@ package body Restrict is
V : Integer)
is
begin
if Restricted_Profile_Cached and Restricted_Profile_Result then
null;
else
Restricted_Profile_Cached := False;
end if;
if Restrictions.Set (R) then
if V < Restrictions.Value (R) then
Restrictions.Value (R) := V;

34
gcc/ada/restrict.ads
View File

@ -200,11 +200,11 @@ package Restrict is
-- handlers are present. This function is called by Gigi when it needs to
-- expand an AT END clean up identifier with no exception handler.
function Process_Restriction_Synonyms (Id : Name_Id) return Name_Id;
-- Id is the name of a restriction. If it is one of synonyms that we
-- allow for historical purposes (for list see System.Rident), then
-- the proper official name is returned. Otherwise the argument is
-- returned unchanged.
function Process_Restriction_Synonyms (N : Node_Id) return Name_Id;
-- Id is a node whose Chars field contains the name of a restriction.
-- If it is one of synonyms that we allow for historical purposes (for
-- list see System.Rident), then the proper official name is returned.
-- Otherwise the Chars field of the argument is returned unchanged.
function Restriction_Active (R : All_Restrictions) return Boolean;
pragma Inline (Restriction_Active);
@ -213,13 +213,20 @@ package Restrict is
-- active. Always use Check_Restriction to record a violation.
function Restricted_Profile return Boolean;
-- Tests to see if tasking operations follow the GNAT restricted run time
-- profile.
-- Tests if set of restrictions corresponding to Profile (Restricted) is
-- currently in effect (set by pragma Profile, or by an appropriate set
-- of individual Restrictions pragms). Returns True only if all the
-- required restrictions are set.
procedure Set_Ravenscar (N : Node_Id);
-- Enables the set of restrictions for Ravenscar. N is the corresponding
-- pragma node, which is used for error messages on any constructs that
-- violate the profile.
procedure Set_Profile_Restrictions
(P : Profile_Name;
N : Node_Id;
Warn : Boolean);
-- Sets the set of restrictions associated with the given profile
-- name. N is the node of the construct to which error messages
-- are to be attached as required. Warn is set True for the case
-- of Profile_Warnings where the restrictions are set as warnings
-- rather than legality requirements.
procedure Set_Restriction
(R : All_Boolean_Restrictions;
@ -235,11 +242,6 @@ package Restrict is
-- Similar to the above, except that this is used for the case of a
-- parameter restriction, and the corresponding value V is given.
procedure Set_Restricted_Profile (N : Node_Id);
-- Enables the set of restrictions for pragma Restricted_Run_Time. N is
-- the corresponding pragma node, which is used for error messages on
-- constructs that violate the profile.
function Tasking_Allowed return Boolean;
pragma Inline (Tasking_Allowed);
-- Tests to see if tasking operations are allowed by the current

108
gcc/ada/s-rident.ads
View File

@ -283,4 +283,112 @@ package System.Rident is
-- that the actual violation count is at least 3 but might be higher.
end record;
----------------------------------
-- Profile Definitions and Data --
----------------------------------
type Profile_Name is (Ravenscar, Restricted);
-- Names of recognized pfofiles
type Profile_Data is record
Set : Restriction_Flags;
-- Set to True if given restriction must be set for the profile,
-- and False if it need not be set (False does not mean that it
-- must not be set, just that it need not be set). If the flag
-- is True for a parameter restriction, then the Value array
-- gives the maximum value permitted by the profile.
Value : Restriction_Values;
-- An entry in this array is meaningful only if the corresponding
-- flag in Set is True. In that case, the value in this array is
-- the maximum value of the parameter permitted by the profile.
end record;
Profile_Info : array (Profile_Name) of Profile_Data :=
-- Restricted Profile
(Restricted =>
-- Restrictions for Restricted profile
(Set =>
(No_Abort_Statements => True,
No_Asynchronous_Control => True,
No_Dynamic_Attachment => True,
No_Dynamic_Priorities => True,
No_Entry_Queue => True,
No_Local_Protected_Objects => True,
No_Protected_Type_Allocators => True,
No_Requeue_Statements => True,
No_Task_Allocators => True,
No_Task_Attributes_Package => True,
No_Task_Hierarchy => True,
No_Terminate_Alternatives => True,
Max_Asynchronous_Select_Nesting => True,
Max_Protected_Entries => True,
Max_Select_Alternatives => True,
Max_Task_Entries => True,
others => False),
-- Value settings for Restricted profile
Value =>
(Max_Asynchronous_Select_Nesting => 0,
Max_Protected_Entries => 1,
Max_Select_Alternatives => 0,
Max_Task_Entries => 0,
others => 0)),
-- Ravenscar Profile
-- Note: the table entries here only represent the
-- required restriction profile for Ravenscar. The
-- full Ravenscar profile also requires:
-- pragma Dispatching_Policy (FIFO_Within_Priorities);
-- pragma Locking_Policy (Ceiling_Locking);
-- pragma Detect_Blocking_Mode ???
Ravenscar =>
-- Restrictions for Ravenscar = Restricted profile ..
(Set =>
(No_Abort_Statements => True,
No_Asynchronous_Control => True,
No_Dynamic_Attachment => True,
No_Dynamic_Priorities => True,
No_Entry_Queue => True,
No_Local_Protected_Objects => True,
No_Protected_Type_Allocators => True,
No_Requeue_Statements => True,
No_Task_Allocators => True,
No_Task_Attributes_Package => True,
No_Task_Hierarchy => True,
No_Terminate_Alternatives => True,
Max_Asynchronous_Select_Nesting => True,
Max_Protected_Entries => True,
Max_Select_Alternatives => True,
Max_Task_Entries => True,
-- plus these additional restrictions:
No_Calendar => True,
No_Implicit_Heap_Allocations => True,
No_Relative_Delay => True,
No_Select_Statements => True,
No_Task_Termination => True,
Simple_Barriers => True,
others => False),
-- Value settings for Ravenscar (same as Restricted)
Value =>
(Max_Asynchronous_Select_Nesting => 0,
Max_Protected_Entries => 1,
Max_Select_Alternatives => 0,
Max_Task_Entries => 0,
others => 0)));
end System.Rident;

1
gcc/ada/sem_attr.adb
View File

@ -862,6 +862,7 @@ package body Sem_Attr is
-- Case of an expression
Resolve (P);
if Is_Access_Type (P_Type) then
-- If there is an implicit dereference, then we must freeze

6
gcc/ada/sem_ch7.adb
View File

@ -805,8 +805,8 @@ package body Sem_Ch7 is
procedure Inspect_Deferred_Constant_Completion is
Decl : Node_Id;
begin
begin
Decl := First (Priv_Decls);
while Present (Decl) loop
@ -828,7 +828,6 @@ package body Sem_Ch7 is
Error_Msg_N
("constant declaration requires initialization expression",
Defining_Identifier (Decl));
end if;
Decl := Next (Decl);
@ -929,8 +928,7 @@ package body Sem_Ch7 is
Analyze_Declarations (Priv_Decls);
-- Check the private declarations for incomplete deferred
-- constants.
-- Check the private declarations for incomplete deferred constants
Inspect_Deferred_Constant_Completion;

14
gcc/ada/sem_elab.adb
View File

@ -359,7 +359,7 @@ package body Sem_Elab is
return;
end if;
-- Nothing to do for imported entities,
-- Nothing to do for imported entities
if Is_Imported (Ent) then
return;
@ -426,8 +426,8 @@ package body Sem_Elab is
-- If the generic entity is within a deeper instance than we are, then
-- either the instantiation to which we refer itself caused an ABE, in
-- which case that will be handled separately. Otherwise, we know that
-- the body we need appears as needed at the point of the instantiation.
-- which case that will be handled separately, or else we know that the
-- body we need appears as needed at the point of the instantiation.
-- However, this assumption is only valid if we are in static mode.
if not Dynamic_Elaboration_Checks
@ -638,11 +638,13 @@ package body Sem_Elab is
-- Find top level scope for called entity (not following renamings
-- or derivations). This is where the Elaborate_All will go if it
-- is needed. We start with the called entity, except in the case
-- of initialization procedures, where the init proc is in the root
-- package, where we start fromn the entity of the name in the call.
-- of an initialization procedure outside the current package, where
-- the init proc is in the root package, and we start from the entity
-- of the name in the call.
if Is_Entity_Name (Name (N))
and then Is_Init_Proc (Entity (Name (N)))
and then not In_Same_Extended_Unit (N, Entity (Name (N)))
then
W_Scope := Scope (Entity (Name (N)));
else
@ -810,7 +812,7 @@ package body Sem_Elab is
-- current declarative part
if not Same_Elaboration_Scope (Current_Scope, Scope (Ent))
or else not In_Same_Extended_Unit (Sloc (N), Sloc (Ent))
or else not In_Same_Extended_Unit (N, Ent)
then
return;
end if;

142
gcc/ada/sem_prag.adb
View File

@ -244,6 +244,12 @@ package body Sem_Prag is
-- in which case the check is applied to the expression of the
-- association or an expression directly.
procedure Check_Arg_Is_External_Name (Arg : Node_Id);
-- Check that an argument has the right form for an EXTERNAL_NAME
-- parameter of an extended import/export pragma. The rule is that
-- the name must be an identifier or string literal (in Ada 83 mode)
-- or a static string expression (in Ada 95 mode).
procedure Check_Arg_Is_Identifier (Arg : Node_Id);
-- Check the specified argument Arg to make sure that it is an
-- identifier. If not give error and raise Pragma_Exit.
@ -589,13 +595,61 @@ package body Sem_Prag is
end if;
end Check_Arg_Count;
--------------------------------
-- Check_Arg_Is_External_Name --
--------------------------------
procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
begin
if Nkind (Argx) = N_Identifier then
return;
else
Analyze_And_Resolve (Argx, Standard_String);
if Is_OK_Static_Expression (Argx) then
return;
elsif Etype (Argx) = Any_Type then
raise Pragma_Exit;
-- An interesting special case, if we have a string literal and
-- we are in Ada 83 mode, then we allow it even though it will
-- not be flagged as static. This allows expected Ada 83 mode
-- use of external names which are string literals, even though
-- technically these are not static in Ada 83.
elsif Ada_Version = Ada_83
and then Nkind (Argx) = N_String_Literal
then
return;
-- Static expression that raises Constraint_Error. This has
-- already been flagged, so just exit from pragma processing.
elsif Is_Static_Expression (Argx) then
raise Pragma_Exit;
-- Here we have a real error (non-static expression)
else
Error_Msg_Name_1 := Chars (N);
Flag_Non_Static_Expr
("argument for pragma% must be a identifier or " &
"static string expression!", Argx);
raise Pragma_Exit;
end if;
end if;
end Check_Arg_Is_External_Name;
-----------------------------
-- Check_Arg_Is_Identifier --
-----------------------------
procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
begin
if Nkind (Argx) /= N_Identifier then
Error_Pragma_Arg
@ -609,7 +663,6 @@ package body Sem_Prag is
procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
begin
if Nkind (Argx) /= N_Integer_Literal then
Error_Pragma_Arg
@ -2084,13 +2137,8 @@ package body Sem_Prag is
Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
if Present (Arg_Size)
and then Nkind (Arg_Size) /= N_Identifier
and then Nkind (Arg_Size) /= N_String_Literal
then
Error_Pragma_Arg
("pragma% Size argument must be identifier or string literal",
Arg_Size);
if Present (Arg_Size) then
Check_Arg_Is_External_Name (Arg_Size);
end if;
-- Export_Object case
@ -3271,7 +3319,8 @@ package body Sem_Prag is
Val : Uint;
procedure Set_Warning (R : All_Restrictions);
-- If this is a Restriction_Warnings pragma, set warning flag
-- If this is a Restriction_Warnings pragma, set warning flag,
-- otherwise reset the flag.
-----------------
-- Set_Warning --
@ -3281,6 +3330,8 @@ package body Sem_Prag is
begin
if Prag_Id = Pragma_Restriction_Warnings then
Restriction_Warnings (R) := True;
else
Restriction_Warnings (R) := False;
end if;
end Set_Warning;
@ -3306,7 +3357,7 @@ package body Sem_Prag is
R_Id :=
Get_Restriction_Id
(Process_Restriction_Synonyms (Chars (Expr)));
(Process_Restriction_Synonyms (Expr));
if R_Id not in All_Boolean_Restrictions then
Error_Pragma_Arg
@ -3334,7 +3385,7 @@ package body Sem_Prag is
-- Case of restriction identifier present
else
R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Id));
R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
Analyze_And_Resolve (Expr, Any_Integer);
if R_Id not in All_Parameter_Restrictions then
@ -3609,8 +3660,11 @@ package body Sem_Prag is
begin
if No (Arg_External) then
return;
end if;
elsif Nkind (Arg_External) = N_String_Literal then
Check_Arg_Is_External_Name (Arg_External);
if Nkind (Arg_External) = N_String_Literal then
if String_Length (Strval (Arg_External)) = 0 then
return;
else
@ -3620,10 +3674,12 @@ package body Sem_Prag is
elsif Nkind (Arg_External) = N_Identifier then
New_Name := Get_Default_External_Name (Arg_External);
-- Check_Arg_Is_External_Name should let through only
-- identifiers and string literals or static string
-- expressions (which are folded to string literals).
else
Error_Pragma_Arg
("incorrect form for External parameter for pragma%",
Arg_External);
raise Program_Error;
end if;
-- If we already have an external name set (by a prior normal
@ -3848,7 +3904,7 @@ package body Sem_Prag is
-- Set Detect_Blocking mode ???
-- Set required restrictions (see Restrict.Set_Ravenscar for details)
-- Set required restrictions (see System.Rident for detailed list)
procedure Set_Ravenscar_Profile (N : Node_Id) is
begin
@ -3896,7 +3952,7 @@ package body Sem_Prag is
-- Set the corresponding restrictions
Set_Ravenscar (N);
Set_Profile_Restrictions (Ravenscar, N, Warn => False);
end Set_Ravenscar_Profile;
-- Start of processing for Analyze_Pragma
@ -8095,10 +8151,9 @@ package body Sem_Prag is
-- pragma Profile (profile_IDENTIFIER);
-- profile_IDENTIFIER => Ravenscar
-- profile_IDENTIFIER => Protected | Ravenscar
when Pragma_Profile =>
GNAT_Pragma;
Check_Arg_Count (1);
Check_Valid_Configuration_Pragma;
Check_No_Identifiers;
@ -8108,6 +8163,36 @@ package body Sem_Prag is
begin
if Chars (Argx) = Name_Ravenscar then
Set_Ravenscar_Profile (N);
elsif Chars (Argx) = Name_Restricted then
Set_Profile_Restrictions (Restricted, N, Warn => False);
else
Error_Pragma_Arg ("& is not a valid profile", Argx);
end if;
end;
----------------------
-- Profile_Warnings --
----------------------
-- pragma Profile_Warnings (profile_IDENTIFIER);
-- profile_IDENTIFIER => Protected | Ravenscar
when Pragma_Profile_Warnings =>
GNAT_Pragma;
Check_Arg_Count (1);
Check_Valid_Configuration_Pragma;
Check_No_Identifiers;
declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
begin
if Chars (Argx) = Name_Ravenscar then
Set_Profile_Restrictions (Ravenscar, N, Warn => True);
elsif Chars (Argx) = Name_Restricted then
Set_Profile_Restrictions (Restricted, N, Warn => True);
else
Error_Pragma_Arg ("& is not a valid profile", Argx);
end if;
@ -8579,6 +8664,13 @@ package body Sem_Prag is
Check_Valid_Configuration_Pragma;
Set_Ravenscar_Profile (N);
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("pragma Ravenscar is an obsolescent feature?", N);
Error_Msg_N
("|use pragma Profile (Ravenscar) instead", N);
end if;
-------------------------
-- Restricted_Run_Time --
-------------------------
@ -8589,7 +8681,14 @@ package body Sem_Prag is
GNAT_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
Set_Restricted_Profile (N);
Set_Profile_Restrictions (Restricted, N, Warn => False);
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("pragma Restricted_Run_Time is an obsolescent feature?", N);
Error_Msg_N
("|use pragma Profile (Restricted) instead", N);
end if;
------------------
-- Restrictions --
@ -10158,6 +10257,7 @@ package body Sem_Prag is
Pragma_Preelaborate => -1,
Pragma_Priority => -1,
Pragma_Profile => 0,
Pragma_Profile_Warnings => 0,
Pragma_Propagate_Exceptions => -1,
Pragma_Psect_Object => -1,
Pragma_Pure => 0,

1
gcc/ada/snames.adb
View File

@ -191,6 +191,7 @@ package body Snames is
"persistent_data#" &
"persistent_object#" &
"profile#" &
"profile_warnings#" &
"propagate_exceptions#" &
"queuing_policy#" &
"ravenscar#" &

1018
gcc/ada/snames.ads
View File

File diff suppressed because it is too large Load Diff

233
gcc/ada/snames.h
View File

@ -223,128 +223,129 @@ extern unsigned char Get_Pragma_Id (int);
#define Pragma_Persistent_Data 24
#define Pragma_Persistent_Object 25
#define Pragma_Profile 26
#define Pragma_Propagate_Exceptions 27
#define Pragma_Queuing_Policy 28
#define Pragma_Ravenscar 29
#define Pragma_Restricted_Run_Time 30
#define Pragma_Restrictions 31
#define Pragma_Restriction_Warnings 32
#define Pragma_Reviewable 33
#define Pragma_Source_File_Name 34
#define Pragma_Source_File_Name_Project 35
#define Pragma_Style_Checks 36
#define Pragma_Suppress 37
#define Pragma_Suppress_Exception_Locations 38
#define Pragma_Task_Dispatching_Policy 39
#define Pragma_Universal_Data 40
#define Pragma_Unsuppress 41
#define Pragma_Use_VADS_Size 42
#define Pragma_Validity_Checks 43
#define Pragma_Warnings 44
#define Pragma_Profile_Warnings 27
#define Pragma_Propagate_Exceptions 28
#define Pragma_Queuing_Policy 29
#define Pragma_Ravenscar 30
#define Pragma_Restricted_Run_Time 31
#define Pragma_Restrictions 32
#define Pragma_Restriction_Warnings 33
#define Pragma_Reviewable 34
#define Pragma_Source_File_Name 35
#define Pragma_Source_File_Name_Project 36
#define Pragma_Style_Checks 37
#define Pragma_Suppress 38
#define Pragma_Suppress_Exception_Locations 39
#define Pragma_Task_Dispatching_Policy 40
#define Pragma_Universal_Data 41
#define Pragma_Unsuppress 42
#define Pragma_Use_VADS_Size 43
#define Pragma_Validity_Checks 44
#define Pragma_Warnings 45
/* Remaining pragmas */
#define Pragma_Abort_Defer 45
#define Pragma_All_Calls_Remote 46
#define Pragma_Annotate 47
#define Pragma_Assert 48
#define Pragma_Asynchronous 49
#define Pragma_Atomic 50
#define Pragma_Atomic_Components 51
#define Pragma_Attach_Handler 52
#define Pragma_Comment 53
#define Pragma_Common_Object 54
#define Pragma_Complex_Representation 55
#define Pragma_Controlled 56
#define Pragma_Convention 57
#define Pragma_CPP_Class 58
#define Pragma_CPP_Constructor 59
#define Pragma_CPP_Virtual 60
#define Pragma_CPP_Vtable 61
#define Pragma_Debug 62
#define Pragma_Elaborate 63
#define Pragma_Elaborate_All 64
#define Pragma_Elaborate_Body 65
#define Pragma_Export 66
#define Pragma_Export_Exception 67
#define Pragma_Export_Function 68
#define Pragma_Export_Object 69
#define Pragma_Export_Procedure 70
#define Pragma_Export_Value 71
#define Pragma_Export_Valued_Procedure 72
#define Pragma_External 73
#define Pragma_Finalize_Storage_Only 74
#define Pragma_Ident 75
#define Pragma_Import 76
#define Pragma_Import_Exception 77
#define Pragma_Import_Function 78
#define Pragma_Import_Object 79
#define Pragma_Import_Procedure 80
#define Pragma_Import_Valued_Procedure 81
#define Pragma_Inline 82
#define Pragma_Inline_Always 83
#define Pragma_Inline_Generic 84
#define Pragma_Inspection_Point 85
#define Pragma_Interface 86
#define Pragma_Interface_Name 87
#define Pragma_Interrupt_Handler 88
#define Pragma_Interrupt_Priority 89
#define Pragma_Java_Constructor 90
#define Pragma_Java_Interface 91
#define Pragma_Keep_Names 92
#define Pragma_Link_With 93
#define Pragma_Linker_Alias 94
#define Pragma_Linker_Options 95
#define Pragma_Linker_Section 96
#define Pragma_List 97
#define Pragma_Machine_Attribute 98
#define Pragma_Main 99
#define Pragma_Main_Storage 100
#define Pragma_Memory_Size 101
#define Pragma_No_Return 102
#define Pragma_Obsolescent 103
#define Pragma_Optimize 104
#define Pragma_Optional_Overriding 105
#define Pragma_Overriding 106
#define Pragma_Pack 107
#define Pragma_Page 108
#define Pragma_Passive 109
#define Pragma_Preelaborate 110
#define Pragma_Priority 111
#define Pragma_Psect_Object 112
#define Pragma_Pure 113
#define Pragma_Pure_Function 114
#define Pragma_Remote_Call_Interface 115
#define Pragma_Remote_Types 116
#define Pragma_Share_Generic 117
#define Pragma_Shared 118
#define Pragma_Shared_Passive 119
#define Pragma_Source_Reference 120
#define Pragma_Stream_Convert 121
#define Pragma_Subtitle 122
#define Pragma_Suppress_All 123
#define Pragma_Suppress_Debug_Info 124
#define Pragma_Suppress_Initialization 125
#define Pragma_System_Name 126
#define Pragma_Task_Info 127
#define Pragma_Task_Name 128
#define Pragma_Task_Storage 129
#define Pragma_Thread_Body 130
#define Pragma_Time_Slice 131
#define Pragma_Title 132
#define Pragma_Unchecked_Union 133
#define Pragma_Unimplemented_Unit 134
#define Pragma_Unreferenced 135
#define Pragma_Unreserve_All_Interrupts 136
#define Pragma_Volatile 137
#define Pragma_Volatile_Components 138
#define Pragma_Weak_External 139
#define Pragma_Abort_Defer 46
#define Pragma_All_Calls_Remote 47
#define Pragma_Annotate 48
#define Pragma_Assert 49
#define Pragma_Asynchronous 50
#define Pragma_Atomic 51
#define Pragma_Atomic_Components 52
#define Pragma_Attach_Handler 53
#define Pragma_Comment 54
#define Pragma_Common_Object 55
#define Pragma_Complex_Representation 56
#define Pragma_Controlled 57
#define Pragma_Convention 58
#define Pragma_CPP_Class 59
#define Pragma_CPP_Constructor 60
#define Pragma_CPP_Virtual 61
#define Pragma_CPP_Vtable 62
#define Pragma_Debug 63
#define Pragma_Elaborate 64
#define Pragma_Elaborate_All 65
#define Pragma_Elaborate_Body 66
#define Pragma_Export 67
#define Pragma_Export_Exception 68
#define Pragma_Export_Function 69
#define Pragma_Export_Object 70
#define Pragma_Export_Procedure 71
#define Pragma_Export_Value 72
#define Pragma_Export_Valued_Procedure 73
#define Pragma_External 74
#define Pragma_Finalize_Storage_Only 75
#define Pragma_Ident 76
#define Pragma_Import 77
#define Pragma_Import_Exception 78
#define Pragma_Import_Function 79
#define Pragma_Import_Object 80
#define Pragma_Import_Procedure 81
#define Pragma_Import_Valued_Procedure 82
#define Pragma_Inline 83
#define Pragma_Inline_Always 84
#define Pragma_Inline_Generic 85
#define Pragma_Inspection_Point 86
#define Pragma_Interface 87
#define Pragma_Interface_Name 88
#define Pragma_Interrupt_Handler 89
#define Pragma_Interrupt_Priority 90
#define Pragma_Java_Constructor 91
#define Pragma_Java_Interface 92
#define Pragma_Keep_Names 93
#define Pragma_Link_With 94
#define Pragma_Linker_Alias 95
#define Pragma_Linker_Options 96
#define Pragma_Linker_Section 97
#define Pragma_List 98
#define Pragma_Machine_Attribute 99
#define Pragma_Main 100
#define Pragma_Main_Storage 101
#define Pragma_Memory_Size 102
#define Pragma_No_Return 103
#define Pragma_Obsolescent 104
#define Pragma_Optimize 105
#define Pragma_Optional_Overriding 106
#define Pragma_Overriding 107
#define Pragma_Pack 108
#define Pragma_Page 109
#define Pragma_Passive 110
#define Pragma_Preelaborate 111
#define Pragma_Priority 112
#define Pragma_Psect_Object 113
#define Pragma_Pure 114
#define Pragma_Pure_Function 115
#define Pragma_Remote_Call_Interface 116
#define Pragma_Remote_Types 117
#define Pragma_Share_Generic 118
#define Pragma_Shared 119
#define Pragma_Shared_Passive 120
#define Pragma_Source_Reference 121
#define Pragma_Stream_Convert 122
#define Pragma_Subtitle 123
#define Pragma_Suppress_All 124
#define Pragma_Suppress_Debug_Info 125
#define Pragma_Suppress_Initialization 126
#define Pragma_System_Name 127
#define Pragma_Task_Info 128
#define Pragma_Task_Name 129
#define Pragma_Task_Storage 130
#define Pragma_Thread_Body 131
#define Pragma_Time_Slice 132
#define Pragma_Title 133
#define Pragma_Unchecked_Union 134
#define Pragma_Unimplemented_Unit 135
#define Pragma_Unreferenced 136
#define Pragma_Unreserve_All_Interrupts 137
#define Pragma_Volatile 138
#define Pragma_Volatile_Components 139
#define Pragma_Weak_External 140
/* The following are deliberately out of alphabetical order, see Snames */
#define Pragma_AST_Entry 140
#define Pragma_Storage_Size 141
#define Pragma_Storage_Unit 142
#define Pragma_AST_Entry 141
#define Pragma_Storage_Size 142
#define Pragma_Storage_Unit 143
/* Define the numeric values for the conventions. */

3
gcc/ada/symbols-vms-alpha.adb
View File

@ -718,8 +718,7 @@ package body Symbols is
Put (File, Case_Sensitive);
Put_Line (File, "yes");
-- Put a line in the symbol file for each symbol in the symbol
-- table.
-- Put a line in the symbol file for each symbol in symbol table
for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop
if Original_Symbols.Table (Index).Present then

47
gcc/ada/targparm.adb
View File

@ -152,6 +152,33 @@ package body Targparm is
HIM_Str'Access,
LSI_Str'Access);
-----------------------
-- Local Subprograms --
-----------------------
procedure Set_Profile_Restrictions (P : Profile_Name);
-- Set Restrictions_On_Target for the given profile
------------------------------
-- Set_Profile_Restrictions --
------------------------------
procedure Set_Profile_Restrictions (P : Profile_Name) is
R : Restriction_Flags renames Profile_Info (P).Set;
V : Restriction_Values renames Profile_Info (P).Value;
begin
for J in R'Range loop
if R (J) then
Restrictions_On_Target.Set (J) := True;
if J in All_Parameter_Restrictions then
Restrictions_On_Target.Value (J) := V (J);
end if;
end if;
end loop;
end Set_Profile_Restrictions;
---------------------------
-- Get_Target_Parameters --
---------------------------
@ -215,6 +242,26 @@ package body Targparm is
if System_Text (P) = '-' then
goto Line_Loop_Continue;
-- Test for pragma Profile (Ravenscar);
elsif System_Text (P .. P + 26) =
"pragma Profile (Ravenscar);"
then
Set_Profile_Restrictions (Ravenscar);
Opt.Task_Dispatching_Policy := 'F';
Opt.Locking_Policy := 'C';
P := P + 27;
goto Line_Loop_Continue;
-- Test for pragma Profile (Restricted);
elsif System_Text (P .. P + 27) =
"pragma Profile (Restricted);"
then
Set_Profile_Restrictions (Restricted);
P := P + 28;
goto Line_Loop_Continue;
-- Test for pragma Restrictions
elsif System_Text (P .. P + 20) = "pragma Restrictions (" then

5
gcc/ada/targparm.ads
View File

@ -104,6 +104,9 @@ package Targparm is
-- if a pragma Suppress_Exception_Locations appears, then the flag
-- Opt.Exception_Locations_Suppressed is set to True.
-- If a pragma Profile with a valid profile argument appears, then
-- the appropriate restrictions and policy flags are set.
-- The only other pragma allowed is a pragma Restrictions that specifies
-- a restriction that will be imposed on all units in the partition. Note
-- that in this context, only one restriction can be specified in a single
@ -112,6 +115,8 @@ package Targparm is
Restrictions_On_Target : Restrictions_Info;
-- Records restrictions specified by system.ads. Only the Set and Value
-- members are modified. The Violated and Count fields are never modified.
-- Note that entries can be set either by a pragma Restrictions or by
-- a pragma Profile.
-------------------
-- Run Time Name --