OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2011-08-29  Hristian Kirtchev  <kirtchev@adacore.com>

	* s-finmas.adb (Finalize): Check Finalize_Address of the master rather
	than the current node.
	* s-finmas.ads: Move field Finalize_Address from type FM_Node to
	Finalization_Master. The list headers have two fields instead of three.
	This should fix alignment issue but subpool allocations are now
	unusable. Alphabetize subprograms.
	* s-stposu.adb (Allocate_Any_Controlled): Use the offset rather than
	the size of the header when converting the beginning of the object to
	a FM_Node. Set the master's Finalize_Address attribute if not already
	set.
	(Deallocate_Any_Controlled): Use the offset rather than the size of the
	header when converting the beginning of the object to a FM_Node.

2011-08-29  Gary Dismukes  <dismukes@adacore.com>

	* exp_ch11.adb (Expand_N_Raise_Statement): Don't suppress expansion of
	reraise when compiling for CodePeer.

2011-08-29  Arnaud Charlet  <charlet@adacore.com>

	* a-iteint.ads, Makefile.rtl: Add missing compilation of a-iteint.ads,
	now needed by a-convec.adb. Fix warning.

2011-08-29  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_util.adb (Build_Allocate_Deallocate_Proc): Add a guard for the
	processing of TSS routine Finalize_Address when compiling in
	CodePeer_Mode.

2011-08-29  Thomas Quinot  <quinot@adacore.com>

	* a-strunb.ads, einfo.ads, g-comlin.ads, sem_ch6.adb,
	sem_warn.adb: Minor reformatting.

2011-08-29  Emmanuel Briot  <briot@adacore.com>

	* prj-conf.adb (Get_Config_Switches): Also collect the list of
	languages from aggregated projects.

2011-08-29  Yannick Moy  <moy@adacore.com>

	* lib-xref-alfa.adb, lib-xref.ads (Traverse_Declarations_Or_Statements,
	Traverse_Handled_Statement_Sequence, Traverse_Package_Body,
	Traverse_Package_Declaration, Traverse_Subprogram_Body,
	Traverse_Compilation_Unit): Add a parameter Inside_Stubs so that bodies
	for stubs are traversed too when parameter is set
	(Traverse_All_Compilation_Units): Traverse without going inside stubs
	(Traverse_Declarations_Or_Statements): Do the special traversing for
	stubs when required.
	* sem_util.adb, sem_util.ads (Get_Body_From_Stub): New function to
	return subprogram or package body from stub.
	(Is_Subprogram_Stub_Without_Prior_Declaration): New function to detect
	stubs without prior subprogram decl.

2011-08-29  Vasiliy Fofanov  <fofanov@adacore.com>

	* gnat_ugn.texi: Fix typo.

From-SVN: r178219
This commit is contained in:
Arnaud Charlet 2011-08-29 15:01:34 +02:00
parent e9c9d12236
commit 60370fb127
19 changed files with 284 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
gcc/ada/ChangeLog
View File

@ -1,3 +1,63 @@
2011-08-29 Hristian Kirtchev <kirtchev@adacore.com>
* s-finmas.adb (Finalize): Check Finalize_Address of the master rather
than the current node.
* s-finmas.ads: Move field Finalize_Address from type FM_Node to
Finalization_Master. The list headers have two fields instead of three.
This should fix alignment issue but subpool allocations are now
unusable. Alphabetize subprograms.
* s-stposu.adb (Allocate_Any_Controlled): Use the offset rather than
the size of the header when converting the beginning of the object to
a FM_Node. Set the master's Finalize_Address attribute if not already
set.
(Deallocate_Any_Controlled): Use the offset rather than the size of the
header when converting the beginning of the object to a FM_Node.
2011-08-29 Gary Dismukes <dismukes@adacore.com>
* exp_ch11.adb (Expand_N_Raise_Statement): Don't suppress expansion of
reraise when compiling for CodePeer.
2011-08-29 Arnaud Charlet <charlet@adacore.com>
* a-iteint.ads, Makefile.rtl: Add missing compilation of a-iteint.ads,
now needed by a-convec.adb. Fix warning.
2011-08-29 Hristian Kirtchev <kirtchev@adacore.com>
* exp_util.adb (Build_Allocate_Deallocate_Proc): Add a guard for the
processing of TSS routine Finalize_Address when compiling in
CodePeer_Mode.
2011-08-29 Thomas Quinot <quinot@adacore.com>
* a-strunb.ads, einfo.ads, g-comlin.ads, sem_ch6.adb,
sem_warn.adb: Minor reformatting.
2011-08-29 Emmanuel Briot <briot@adacore.com>
* prj-conf.adb (Get_Config_Switches): Also collect the list of
languages from aggregated projects.
2011-08-29 Yannick Moy <moy@adacore.com>
* lib-xref-alfa.adb, lib-xref.ads (Traverse_Declarations_Or_Statements,
Traverse_Handled_Statement_Sequence, Traverse_Package_Body,
Traverse_Package_Declaration, Traverse_Subprogram_Body,
Traverse_Compilation_Unit): Add a parameter Inside_Stubs so that bodies
for stubs are traversed too when parameter is set
(Traverse_All_Compilation_Units): Traverse without going inside stubs
(Traverse_Declarations_Or_Statements): Do the special traversing for
stubs when required.
* sem_util.adb, sem_util.ads (Get_Body_From_Stub): New function to
return subprogram or package body from stub.
(Is_Subprogram_Stub_Without_Prior_Declaration): New function to detect
stubs without prior subprogram decl.
2011-08-29 Vasiliy Fofanov <fofanov@adacore.com>
* gnat_ugn.texi: Fix typo.
2011-08-29 Hristian Kirtchev <kirtchev@adacore.com>
* s-stposu.adb (Allocate_Any_Controlled): Reimplement the mechanism

1
gcc/ada/Makefile.rtl
View File

@ -161,6 +161,7 @@ GNATRTL_NONTASKING_OBJS= \
a-fzteio$(objext) \
a-inteio$(objext) \
a-ioexce$(objext) \
a-iteint$(objext) \
a-iwteio$(objext) \
a-izteio$(objext) \
a-lcteio$(objext) \

1
gcc/ada/a-iteint.ads
View File

@ -33,6 +33,7 @@
generic
type Cursor;
with function Has_Element (Position : Cursor) return Boolean;
pragma Unreferenced (Has_Element);
package Ada.Iterator_Interfaces is
pragma Pure;

4
gcc/ada/a-strunb.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2011, 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 --
@ -433,5 +433,5 @@ private
Null_Unbounded_String : constant Unbounded_String :=
(AF.Controlled with
Reference => Null_String'Access,
Last => 0);
Last => 0);
end Ada.Strings.Unbounded;

22
gcc/ada/einfo.ads
View File

@ -1237,10 +1237,10 @@ package Einfo is
-- representation pragmas nodes and representation clause nodes that
-- apply to the entity, linked using Next_Rep_Item, with Empty marking
-- the end of the list. In the case of derived types and subtypes, the
-- new entity inherits the chain at the point of declaration. This
-- means that it is possible to have multiple instances of the same
-- kind of rep item on the chain, in which case it is the first one
-- that applies to the entity.
-- new entity inherits the chain at the point of declaration. This means
-- that it is possible to have multiple instances of the same kind of rep
-- item on the chain, in which case it is the first one that applies to
-- the entity.
--
-- Note: pragmas that can apply to more than one overloadable entity,
-- (Convention, Interface, Inline, Inline_Always, Import, Export,
@ -1260,8 +1260,8 @@ package Einfo is
-- Linker_Section pragma
-- Weak_External pragma
--
-- If any of these items are present, then the flag Has_Gigi_Rep_Item
-- is set, indicating that Gigi should search the chain.
-- If any of these items are present, then the flag Has_Gigi_Rep_Item is
-- set, indicating that Gigi should search the chain.
--
-- Other representation items are included in the chain so that error
-- messages can easily locate the relevant nodes for posting errors.
@ -1274,10 +1274,10 @@ package Einfo is
-- the floating-point representation to be used.
-- Freeze_Node (Node7)
-- Present in all entities. If there is an associated freeze node for
-- the entity, this field references this freeze node. If no freeze
-- node is associated with the entity, then this field is Empty. See
-- package Freeze for further details.
-- Present in all entities. If there is an associated freeze node for the
-- entity, this field references this freeze node. If no freeze node is
-- associated with the entity, then this field is Empty. See package
-- Freeze for further details.
-- From_With_Type (Flag159)
-- Present in package and type entities. Indicates that the entity
@ -3265,7 +3265,7 @@ package Einfo is
-- Package_Instantiation (Node26)
-- Present in packages and generic packages. When present, this field
-- references an N_Package_Instantiation node associated with an
-- references an N_Generic_Instantiation node associated with an
-- instantiated package. In the case where the referenced node has
-- been rewritten to an N_Package_Specification, the instantiation
-- node is available from the Original_Node field of the package spec

4
gcc/ada/exp_ch11.adb
View File

@ -1666,9 +1666,11 @@ package body Exp_Ch11 is
else
-- Don't expand if back end exception handling active
-- Bypass expansion to a run-time call when back-end exception
-- handling is active, unless the target is a VM or CodePeer.
if VM_Target = No_VM
and then not CodePeer_Mode
and then Exception_Mechanism = Back_End_Exceptions
then
return;

8
gcc/ada/exp_util.adb
View File

@ -628,9 +628,13 @@ package body Exp_Util is
-- d) Finalize_Address
Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
-- Primitive Finalize_Address is never generated in CodePeer mode
-- since it contains an Unchecked_Conversion.
if Needs_Finalization (Desig_Typ) then
if Needs_Finalization (Desig_Typ)
and then not CodePeer_Mode
then
Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
pragma Assert (Present (Fin_Addr_Id));
Append_To (Actuals,

3
gcc/ada/g-comlin.ads
View File

@ -492,11 +492,12 @@ package GNAT.Command_Line is
Invalid_Parameter : exception;
-- Raised when a parameter is missing, or an attempt is made to obtain a
-- parameter for a switch that does not allow a parameter
-- parameter for a switch that does not allow a parameter.
-----------------------------------------
-- Expansion of command line arguments --
-----------------------------------------
-- These subprograms take care of of expanding globbing patterns on the
-- command line. On Unix, such expansion is done by the shell before your
-- application is called. But on Windows you must do this expansion

2
gcc/ada/gnat_ugn.texi
View File

@ -21373,7 +21373,7 @@ information about several specific platforms.
@item @code{@ @ @ @ }Tasking @tab native Win32 threads
@item @code{@ @ @ @ }Exceptions @tab ZCX
@*
@item @code{@ @ }@i{rts-sjlj (default)}
@item @code{@ @ }@i{rts-sjlj}
@item @code{@ @ @ @ }Tasking @tab native Win32 threads
@item @code{@ @ @ @ }Exceptions @tab SJLJ
@*

133
gcc/ada/lib-xref-alfa.adb
View File

@ -165,20 +165,25 @@ package body ALFA is
-- Hash function for hash table
procedure Traverse_Declarations_Or_Statements
(L : List_Id;
Process : Node_Processing);
(L : List_Id;
Process : Node_Processing;
Inside_Stubs : Boolean);
procedure Traverse_Handled_Statement_Sequence
(N : Node_Id;
Process : Node_Processing);
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean);
procedure Traverse_Package_Body
(N : Node_Id;
Process : Node_Processing);
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean);
procedure Traverse_Package_Declaration
(N : Node_Id;
Process : Node_Processing);
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean);
procedure Traverse_Subprogram_Body
(N : Node_Id;
Process : Node_Processing);
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean);
-- Traverse the corresponding constructs, calling Process on all
-- declarations.
@ -201,7 +206,8 @@ package body ALFA is
From := ALFA_Scope_Table.Last + 1;
Traverse_Compilation_Unit (Cunit (U), Detect_And_Add_ALFA_Scope'Access);
Traverse_Compilation_Unit (Cunit (U), Detect_And_Add_ALFA_Scope'Access,
Inside_Stubs => False);
-- Update scope numbers
@ -904,7 +910,7 @@ package body ALFA is
procedure Traverse_All_Compilation_Units (Process : Node_Processing) is
begin
for U in Units.First .. Last_Unit loop
Traverse_Compilation_Unit (Cunit (U), Process);
Traverse_Compilation_Unit (Cunit (U), Process, Inside_Stubs => False);
end loop;
end Traverse_All_Compilation_Units;
@ -913,8 +919,9 @@ package body ALFA is
-------------------------------
procedure Traverse_Compilation_Unit
(CU : Node_Id;
Process : Node_Processing)
(CU : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean)
is
Lu : Node_Id;
@ -938,16 +945,16 @@ package body ALFA is
-- Traverse the unit
if Nkind (Lu) = N_Subprogram_Body then
Traverse_Subprogram_Body (Lu, Process);
Traverse_Subprogram_Body (Lu, Process, Inside_Stubs);
elsif Nkind (Lu) = N_Subprogram_Declaration then
null;
elsif Nkind (Lu) = N_Package_Declaration then
Traverse_Package_Declaration (Lu, Process);
Traverse_Package_Declaration (Lu, Process, Inside_Stubs);
elsif Nkind (Lu) = N_Package_Body then
Traverse_Package_Body (Lu, Process);
Traverse_Package_Body (Lu, Process, Inside_Stubs);
-- ??? TBD
@ -972,8 +979,9 @@ package body ALFA is
-----------------------------------------
procedure Traverse_Declarations_Or_Statements
(L : List_Id;
Process : Node_Processing)
(L : List_Id;
Process : Node_Processing;
Inside_Stubs : Boolean)
is
N : Node_Id;
@ -996,7 +1004,7 @@ package body ALFA is
-- Package declaration
when N_Package_Declaration =>
Traverse_Package_Declaration (N, Process);
Traverse_Package_Declaration (N, Process, Inside_Stubs);
-- Generic package declaration ??? TBD
@ -1007,9 +1015,21 @@ package body ALFA is
when N_Package_Body =>
if Ekind (Defining_Entity (N)) /= E_Generic_Package then
Traverse_Package_Body (N, Process);
Traverse_Package_Body (N, Process, Inside_Stubs);
end if;
when N_Package_Body_Stub =>
declare
Body_N : constant Node_Id := Get_Body_From_Stub (N);
begin
if Inside_Stubs
and then
Ekind (Defining_Entity (Body_N)) /= E_Generic_Package
then
Traverse_Package_Body (Body_N, Process, Inside_Stubs);
end if;
end;
-- Subprogram declaration
when N_Subprogram_Declaration =>
@ -1024,22 +1044,35 @@ package body ALFA is
when N_Subprogram_Body =>
if not Is_Generic_Subprogram (Defining_Entity (N)) then
Traverse_Subprogram_Body (N, Process);
Traverse_Subprogram_Body (N, Process, Inside_Stubs);
end if;
when N_Subprogram_Body_Stub =>
declare
Body_N : constant Node_Id := Get_Body_From_Stub (N);
begin
if Inside_Stubs
and then
not Is_Generic_Subprogram (Defining_Entity (Body_N))
then
Traverse_Subprogram_Body (Body_N, Process, Inside_Stubs);
end if;
end;
-- Block statement
when N_Block_Statement =>
Traverse_Declarations_Or_Statements (Declarations (N), Process);
Traverse_Declarations_Or_Statements
(Declarations (N), Process, Inside_Stubs);
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (N), Process);
(Handled_Statement_Sequence (N), Process, Inside_Stubs);
when N_If_Statement =>
-- Traverse the statements in the THEN part
Traverse_Declarations_Or_Statements
(Then_Statements (N), Process);
(Then_Statements (N), Process, Inside_Stubs);
-- Loop through ELSIF parts if present
@ -1050,7 +1083,7 @@ package body ALFA is
begin
while Present (Elif) loop
Traverse_Declarations_Or_Statements
(Then_Statements (Elif), Process);
(Then_Statements (Elif), Process, Inside_Stubs);
Next (Elif);
end loop;
end;
@ -1059,7 +1092,7 @@ package body ALFA is
-- Finally traverse the ELSE statements if present
Traverse_Declarations_Or_Statements
(Else_Statements (N), Process);
(Else_Statements (N), Process, Inside_Stubs);
-- Case statement
@ -1073,7 +1106,7 @@ package body ALFA is
Alt := First (Alternatives (N));
while Present (Alt) loop
Traverse_Declarations_Or_Statements
(Statements (Alt), Process);
(Statements (Alt), Process, Inside_Stubs);
Next (Alt);
end loop;
end;
@ -1082,12 +1115,13 @@ package body ALFA is
when N_Extended_Return_Statement =>
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (N), Process);
(Handled_Statement_Sequence (N), Process, Inside_Stubs);
-- Loop
when N_Loop_Statement =>
Traverse_Declarations_Or_Statements (Statements (N), Process);
Traverse_Declarations_Or_Statements
(Statements (N), Process, Inside_Stubs);
when others =>
null;
@ -1102,20 +1136,22 @@ package body ALFA is
-----------------------------------------
procedure Traverse_Handled_Statement_Sequence
(N : Node_Id;
Process : Node_Processing)
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean)
is
Handler : Node_Id;
begin
if Present (N) then
Traverse_Declarations_Or_Statements (Statements (N), Process);
Traverse_Declarations_Or_Statements
(Statements (N), Process, Inside_Stubs);
if Present (Exception_Handlers (N)) then
Handler := First (Exception_Handlers (N));
while Present (Handler) loop
Traverse_Declarations_Or_Statements
(Statements (Handler), Process);
(Statements (Handler), Process, Inside_Stubs);
Next (Handler);
end loop;
end if;
@ -1127,12 +1163,14 @@ package body ALFA is
---------------------------
procedure Traverse_Package_Body
(N : Node_Id;
Process : Node_Processing) is
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean) is
begin
Traverse_Declarations_Or_Statements (Declarations (N), Process);
Traverse_Declarations_Or_Statements
(Declarations (N), Process, Inside_Stubs);
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (N), Process);
(Handled_Statement_Sequence (N), Process, Inside_Stubs);
end Traverse_Package_Body;
----------------------------------
@ -1140,15 +1178,16 @@ package body ALFA is
----------------------------------
procedure Traverse_Package_Declaration
(N : Node_Id;
Process : Node_Processing)
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean)
is
Spec : constant Node_Id := Specification (N);
begin
Traverse_Declarations_Or_Statements
(Visible_Declarations (Spec), Process);
(Visible_Declarations (Spec), Process, Inside_Stubs);
Traverse_Declarations_Or_Statements
(Private_Declarations (Spec), Process);
(Private_Declarations (Spec), Process, Inside_Stubs);
end Traverse_Package_Declaration;
------------------------------
@ -1156,12 +1195,14 @@ package body ALFA is
------------------------------
procedure Traverse_Subprogram_Body
(N : Node_Id;
Process : Node_Processing) is
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean) is
begin
Traverse_Declarations_Or_Statements (Declarations (N), Process);
Traverse_Declarations_Or_Statements
(Declarations (N), Process, Inside_Stubs);
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (N), Process);
(Handled_Statement_Sequence (N), Process, Inside_Stubs);
end Traverse_Subprogram_Body;
end ALFA;

5
gcc/ada/lib-xref.ads
View File

@ -593,8 +593,9 @@ package Lib.Xref is
type Node_Processing is access procedure (N : Node_Id);
procedure Traverse_Compilation_Unit
(CU : Node_Id;
Process : Node_Processing);
(CU : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean);
procedure Traverse_All_Compilation_Units (Process : Node_Processing);
-- Call Process on all declarations through all compilation units

64
gcc/ada/prj-conf.adb
View File

@ -722,28 +722,32 @@ package body Prj.Conf is
-- Hash table to keep the languages used in the project tree
IDE : constant Package_Id :=
Value_Of (Name_Ide, Project.Decl.Packages, Shared);
Value_Of (Name_Ide, Project.Decl.Packages, Shared);
Prj_Iter : Project_List;
List : String_List_Id;
Elem : String_Element;
Lang : Name_Id;
Variable : Variable_Value;
Name : Name_Id;
Count : Natural;
Result : Argument_List_Access;
procedure Add_Config_Switches_For_Project
(Project : Project_Id;
Tree : Project_Tree_Ref;
With_State : in out Integer);
-- Add all --config switches for this project. This is also called
-- for aggregate projects.
Check_Default : Boolean;
procedure Add_Config_Switches_For_Project
(Project : Project_Id;
Tree : Project_Tree_Ref;
With_State : in out Integer)
is
pragma Unreferenced (With_State);
Shared : constant Shared_Project_Tree_Data_Access := Tree.Shared;
begin
Prj_Iter := Project_Tree.Projects;
while Prj_Iter /= null loop
if Might_Have_Sources (Prj_Iter.Project) then
Variable : Variable_Value;
Check_Default : Boolean;
Lang : Name_Id;
List : String_List_Id;
Elem : String_Element;
begin
if Might_Have_Sources (Project) then
Variable :=
Value_Of
(Name_Languages,
Prj_Iter.Project.Decl.Attributes,
Shared);
Value_Of (Name_Languages, Project.Decl.Attributes, Shared);
if Variable = Nil_Variable_Value
or else Variable.Default
@ -752,13 +756,13 @@ package body Prj.Conf is
-- project, or if it extends a project with no Languages,
-- check for Default_Language.
Check_Default := Prj_Iter.Project.Extends = No_Project;
Check_Default := Project.Extends = No_Project;
if not Check_Default then
Variable :=
Value_Of
(Name_Languages,
Prj_Iter.Project.Extends.Decl.Attributes,
Project.Extends.Decl.Attributes,
Shared);
Check_Default :=
Variable /= Nil_Variable_Value
@ -769,7 +773,7 @@ package body Prj.Conf is
Variable :=
Value_Of
(Name_Default_Language,
Prj_Iter.Project.Decl.Attributes,
Project.Decl.Attributes,
Shared);
if Variable /= Nil_Variable_Value
@ -805,9 +809,23 @@ package body Prj.Conf is
end loop;
end if;
end if;
end Add_Config_Switches_For_Project;
Prj_Iter := Prj_Iter.Next;
end loop;
procedure For_Every_Imported_Project is new For_Every_Project_Imported
(State => Integer, Action => Add_Config_Switches_For_Project);
Name : Name_Id;
Count : Natural;
Result : Argument_List_Access;
Variable : Variable_Value;
Dummy : Integer := 0;
begin
For_Every_Imported_Project
(By => Project,
Tree => Project_Tree,
With_State => Dummy,
Include_Aggregated => True);
Name := Language_Htable.Get_First;
Count := 0;

36
gcc/ada/s-finmas.adb
View File

@ -128,27 +128,23 @@ package body System.Finalization_Masters is
Curr_Ptr := Master.Objects.Next;
while Curr_Ptr /= Master.Objects'Unchecked_Access loop
-- If primitive Finalize_Address is not set, then the expansion of
-- the designated type or that of the allocator failed. This is a
-- serious error.
if Master.Finalize_Address = null then
raise Program_Error
with "primitive Finalize_Address not available";
end if;
-- Skip the list header in order to offer proper object layout for
-- finalization and call Finalize_Address.
Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
begin
-- If primitive Finalize_Address is not set, then the expansion of
-- the designated type or that of the allocator failed. This is a
-- serious error.
-- Note: The Program_Error must be raised from the same block as
-- the finalization call. If Finalize_Address is not present for
-- a particular object, this should not stop the finalization of
-- the remaining objects.
if Curr_Ptr.Finalize_Address = null then
raise Program_Error
with "primitive Finalize_Address not available";
-- Skip the list header in order to offer proper object layout for
-- finalization and call Finalize_Address.
else
Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
Curr_Ptr.Finalize_Address (Obj_Addr);
end if;
Master.Finalize_Address (Obj_Addr);
exception
when Fin_Occur : others =>

14
gcc/ada/s-finmas.ads
View File

@ -56,9 +56,8 @@ package System.Finalization_Masters is
type FM_Node_Ptr is access all FM_Node;
type FM_Node is record
Prev : FM_Node_Ptr := null;
Next : FM_Node_Ptr := null;
Finalize_Address : Finalize_Address_Ptr := null;
Prev : FM_Node_Ptr := null;
Next : FM_Node_Ptr := null;
end record;
-- A reference to any derivation from Root_Storage_Pool. Since this type
@ -83,6 +82,9 @@ package System.Finalization_Masters is
-- A doubly linked list which contains the headers of all controlled
-- objects allocated in a [sub]pool.
Finalize_Address : Finalize_Address_Ptr := null;
-- A reference to the routine reponsible for object finalization
Finalization_Started : Boolean := False;
pragma Atomic (Finalization_Started);
-- A flag used to detect allocations which occur during the finalization
@ -120,12 +122,12 @@ package System.Finalization_Masters is
-- the list of allocated controlled objects, finalizing each one by calling
-- its specific Finalize_Address. In the end, deallocate the dummy head.
function Header_Size return System.Storage_Elements.Storage_Count;
-- Return the size of type FM_Node as Storage_Count
function Header_Offset return System.Storage_Elements.Storage_Offset;
-- Return the size of type FM_Node as Storage_Offset
function Header_Size return System.Storage_Elements.Storage_Count;
-- Return the size of type FM_Node as Storage_Count
overriding procedure Initialize (Master : in out Finalization_Master);
-- Initialize the dummy head of a finalization master

10
gcc/ada/s-stposu.adb
View File

@ -247,10 +247,12 @@ package body System.Storage_Pools.Subpools is
-- | |
-- +- Header_And_Padding --+
N_Ptr :=
Address_To_FM_Node_Ptr (N_Addr + Header_And_Padding - Header_Size);
N_Ptr := Address_To_FM_Node_Ptr
(N_Addr + Header_And_Padding - Header_Offset);
N_Ptr.Finalize_Address := Fin_Address;
if Master.Finalize_Address = null then
Master.Finalize_Address := Fin_Address;
end if;
-- Prepend the allocated object to the finalization master
@ -334,7 +336,7 @@ package body System.Storage_Pools.Subpools is
-- Convert the bits preceding the object into a list header
N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Size);
N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Offset);
-- Detach the object from the related finalization master. This
-- action does not need to know the prior context used during

2
gcc/ada/sem_ch6.adb
View File

@ -4716,7 +4716,7 @@ package body Sem_Ch6 is
-- Grouping (use of comma in param lists) must be the same
-- This is where we catch a misconformance like:
-- A,B : Integer
-- A, B : Integer
-- A : Integer; B : Integer
-- which are represented identically in the tree except

25
gcc/ada/sem_util.adb
View File

@ -4168,6 +4168,15 @@ package body Sem_Util is
end if;
end Get_Actual_Subtype_If_Available;
------------------------
-- Get_Body_From_Stub --
------------------------
function Get_Body_From_Stub (N : Node_Id) return Node_Id is
begin
return Proper_Body (Unit (Library_Unit (N)));
end Get_Body_From_Stub;
-------------------------------
-- Get_Default_External_Name --
-------------------------------
@ -7939,6 +7948,22 @@ package body Sem_Util is
or else Nkind (N) = N_Procedure_Call_Statement;
end Is_Statement;
--------------------------------------------------
-- Is_Subprogram_Stub_Without_Prior_Declaration --
--------------------------------------------------
function Is_Subprogram_Stub_Without_Prior_Declaration
(N : Node_Id) return Boolean is
begin
-- A subprogram stub without prior declaration serves as declaration for
-- the actual subprogram body. As such, it has an attached defining
-- entity of E_[Generic_]Function or E_[Generic_]Procedure.
return Nkind (N) = N_Subprogram_Body_Stub
and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
end Is_Subprogram_Stub_Without_Prior_Declaration;
---------------------------------
-- Is_Synchronized_Tagged_Type --
---------------------------------

8
gcc/ada/sem_util.ads
View File

@ -479,6 +479,9 @@ package Sem_Util is
-- Actual_Subtype field of the corresponding entity is set, then it is
-- returned. Otherwise the Etype of the node is returned.
function Get_Body_From_Stub (N : Node_Id) return Node_Id;
-- Return the body node for a stub (subprogram or package)
function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id;
-- This is used to construct the string literal node representing a
-- default external name, i.e. one that is constructed from the name of an
@ -884,6 +887,11 @@ package Sem_Util is
-- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo).
-- Note that a label is *not* a statement, and will return False.
function Is_Subprogram_Stub_Without_Prior_Declaration
(N : Node_Id) return Boolean;
-- Return True if N is a subprogram stub with no prior subprogram
-- declaration.
function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean;
-- Returns True if E is a synchronized tagged type (AARM 3.9.4 (6/2))

4
gcc/ada/sem_warn.adb
View File

@ -3340,12 +3340,12 @@ package body Sem_Warn is
if Is_Elementary_Type (Etype (Act1))
and then Ekind (Form2) = E_In_Parameter
then
null; -- no real aliasing.
null; -- No real aliasing
elsif Is_Elementary_Type (Etype (Act2))
and then Ekind (Form2) = E_In_Parameter
then
null; -- ditto
null; -- Ditto
-- If the call was written in prefix notation, and
-- thus its prefix before rewriting was a selected