Skip to content

R
riscv-gcc-1
Commit ca5af305 by Arnaud Charlet
Options

[multiple changes] 

2011-08-29  Robert Dewar  <dewar@adacore.com>

	* a-exexpr-gcc.adb, a-synbar.adb, sem_ch13.adb: Minor reformatting.

2011-08-29  Bob Duff  <duff@adacore.com>

	* sem_aggr.adb (Resolve_Aggr_Expr): Call this routine even in the case
	of <>, because this is the routine that checks for dimensionality
	errors (for example, for a two-dimensional array, (others => <>) should
	be (others => (others => <>)).

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

	* impunit.adb: Add new run-time units.
	* freeze.adb, exp_ch7.ads, exp_ch7.adb, exp_util.ads, exp_util.adb,
	s-stposu.ads, s-stposu.adb: Code clean up.
	Handle protected class-wide or task class-wide types
	Handle C/C++/CIL/Java types.
	* s-spsufi.adb, s-spsufi.ads: New files.

From-SVN: r178205
parent 5accd7b6
Showing with 401 additions and 124 deletions
gcc/ada/ChangeLog
2011-08-29 Robert Dewar <dewar@adacore.com>
* a-exexpr-gcc.adb, a-synbar.adb, sem_ch13.adb: Minor reformatting.
2011-08-29 Bob Duff <duff@adacore.com>
* sem_aggr.adb (Resolve_Aggr_Expr): Call this routine even in the case
of <>, because this is the routine that checks for dimensionality
errors (for example, for a two-dimensional array, (others => <>) should
be (others => (others => <>)).
2011-08-29 Hristian Kirtchev <kirtchev@adacore.com>
* impunit.adb: Add new run-time units.
* freeze.adb, exp_ch7.ads, exp_ch7.adb, exp_util.ads, exp_util.adb,
s-stposu.ads, s-stposu.adb: Code clean up.
Handle protected class-wide or task class-wide types
Handle C/C++/CIL/Java types.
* s-spsufi.adb, s-spsufi.ads: New files.
2011-08-29 Yannick Moy <moy@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): Reject test-case on
......
gcc/ada/Makefile.rtl
......@@ -155,7 +155,6 @@ GNATRTL_NONTASKING_OBJS= \
a-envvar$(objext) \
a-except$(objext) \
a-exctra$(objext) \
a-fihema$(objext) \
a-finali$(objext) \
a-flteio$(objext) \
a-fwteio$(objext) \
......@@ -291,6 +290,7 @@ GNATRTL_NONTASKING_OBJS= \
a-tiunio$(objext) \
a-unccon$(objext) \
a-uncdea$(objext) \
a-undesu$(objext) \
a-wichha$(objext) \
a-wichun$(objext) \
a-widcha$(objext) \
......@@ -496,6 +496,7 @@ GNATRTL_NONTASKING_OBJS= \
s-ficobl$(objext) \
s-fileio$(objext) \
s-filofl$(objext) \
s-finmas$(objext) \
s-finroo$(objext) \
s-fishfl$(objext) \
s-flocon$(objext) \
......@@ -606,12 +607,14 @@ GNATRTL_NONTASKING_OBJS= \
s-sequio$(objext) \
s-shasto$(objext) \
s-soflin$(objext) \
s-spsufi$(objext) \
s-stache$(objext) \
s-stalib$(objext) \
s-stausa$(objext) \
s-stchop$(objext) \
s-stoele$(objext) \
s-stopoo$(objext) \
s-stposu$(objext) \
s-stratt$(objext) \
s-strhas$(objext) \
s-string$(objext) \
......
gcc/ada/a-exexpr-gcc.adb
......@@ -277,13 +277,15 @@ package body Exception_Propagation is
procedure GNAT_GCC_Exception_Cleanup
(Reason : Unwind_Reason_Code;
Excep : not null GNAT_GCC_Exception_Access) is
Excep : not null GNAT_GCC_Exception_Access)
is
pragma Unreferenced (Reason);
procedure Free is new Unchecked_Deallocation
(GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
Copy : GNAT_GCC_Exception_Access := Excep;
begin
-- Simply free the memory
......@@ -303,6 +305,7 @@ package body Exception_Propagation is
UW_Argument : System.Address) return Unwind_Reason_Code
is
pragma Unreferenced (UW_Version, UW_Eclass, UW_Context, UW_Argument);
begin
-- Terminate when the end of the stack is reached
......@@ -332,6 +335,7 @@ package body Exception_Propagation is
Reraised : Boolean := False)
is
pragma Unreferenced (Excep, Current, Reraised);
begin
-- In the GNAT-SJLJ case this "stack" only exists implicitly, by way of
-- local occurrence declarations together with save/restore operations
......@@ -345,8 +349,10 @@ package body Exception_Propagation is
-------------------------
procedure Setup_Current_Excep
(GCC_Exception : not null GCC_Exception_Access) is
(GCC_Exception : not null GCC_Exception_Access)
is
Excep : constant EOA := Get_Current_Excep.all;
begin
-- Setup the exception occurrence
......@@ -356,7 +362,7 @@ package body Exception_Propagation is
declare
GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
To_GNAT_GCC_Exception (GCC_Exception);
To_GNAT_GCC_Exception (GCC_Exception);
begin
Excep.all := GNAT_Occurrence.Occurrence;
end;
......@@ -404,7 +410,8 @@ package body Exception_Propagation is
-----------------------------
procedure Reraise_GCC_Exception
(GCC_Exception : not null GCC_Exception_Access) is
(GCC_Exception : not null GCC_Exception_Access)
is
begin
-- Simply propagate it
Propagate_GCC_Exception (GCC_Exception);
......@@ -418,7 +425,8 @@ package body Exception_Propagation is
-- the two phase scheme it implements.
procedure Propagate_GCC_Exception
(GCC_Exception : not null GCC_Exception_Access) is
(GCC_Exception : not null GCC_Exception_Access)
is
begin
-- Perform a standard raise first. If a regular handler is found, it
-- will be entered after all the intermediate cleanups have run. If
......@@ -436,15 +444,15 @@ package body Exception_Propagation is
-- Now, un a forced unwind to trigger cleanups. Control should not
-- resume there, if there are cleanups and in any cases as the
-- unwinding hook calls Unhandled_Exception_Terminate when end of stack
-- is reached.
-- unwinding hook calls Unhandled_Exception_Terminate when end of
-- stack is reached.
Unwind_ForcedUnwind (GCC_Exception,
CleanupUnwind_Handler'Address,
System.Null_Address);
-- We get here in case of error.
-- The debugger has been notified before the second step above.
-- We get here in case of error. The debugger has been notified before
-- the second step above.
Setup_Current_Excep (GCC_Exception);
Unhandled_Exception_Terminate;
......@@ -455,8 +463,8 @@ package body Exception_Propagation is
-------------------------
-- Build an object suitable for the libgcc processing and call
-- Unwind_RaiseException to actually throw, taking care of handling
-- the two phase scheme it implements.
-- Unwind_RaiseException to actually do the raise, taking care of
-- handling the two phase scheme it implements.
procedure Propagate_Exception
(E : Exception_Id;
......@@ -494,14 +502,16 @@ package body Exception_Propagation is
-- Allocate the GCC exception
GCC_Exception := new GNAT_GCC_Exception'
(Header => (Class => GNAT_Exception_Class,
Cleanup => GNAT_GCC_Exception_Cleanup'Address,
Private1 => 0,
Private2 => 0),
Occurrence => Excep.all);
GCC_Exception :=
new GNAT_GCC_Exception'
(Header => (Class => GNAT_Exception_Class,
Cleanup => GNAT_GCC_Exception_Cleanup'Address,
Private1 => 0,
Private2 => 0),
Occurrence => Excep.all);
-- Propagate it
-- Propagate it.
Propagate_GCC_Exception (To_GCC_Exception (GCC_Exception));
end Propagate_Exception;
......
gcc/ada/a-synbar.adb
......@@ -61,7 +61,6 @@ package body Ada.Synchronous_Barriers is
Notified := Wait'Count = 0;
end Wait;
end Synchronous_Barrier;
----------------------
......
gcc/ada/a-undesu.adb
......@@ -17,20 +17,15 @@
-- ??? What is the header version here, see a-uncdea.adb. No GPL?
with System.Storage_Pools.Subpools; use System.Storage_Pools.Subpools;
with System.Storage_Pools.Subpools,
System.Storage_Pools.Subpools.Finalization;
use System.Storage_Pools.Subpools,
System.Storage_Pools.Subpools.Finalization;
procedure Ada.Unchecked_Deallocate_Subpool
(Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle)
is
begin
-- Finalize all controlled objects allocated on the input subpool
-- ??? It is awkward to create a child of Storage_Pools.Subpools for the
-- sole purpose of exporting Finalize_Subpool.
-- Finalize_Subpool (Subpool);
-- Dispatch to the user-defined implementation of Deallocate_Subpool
Deallocate_Subpool (Pool_Of_Subpool (Subpool).all, Subpool);
Finalize_And_Deallocate (Subpool);
end Ada.Unchecked_Deallocate_Subpool;
gcc/ada/exp_ch3.adb
......@@ -6626,35 +6626,31 @@ package body Exp_Ch3 is
-- finalization support if not needed.
if not Comes_From_Source (Def_Id)
and then not Has_Private_Declaration (Def_Id)
and then not Has_Private_Declaration (Def_Id)
then
null;
elsif (Needs_Finalization (Desig_Type)
and then Convention (Desig_Type) /= Convention_Java
and then Convention (Desig_Type) /= Convention_CIL)
or else
(Is_Incomplete_Or_Private_Type (Desig_Type)
and then No (Full_View (Desig_Type))
-- An exception is made for types defined in the run-time
-- because Ada.Tags.Tag itself is such a type and cannot
-- afford this unnecessary overhead that would generates a
-- loop in the expansion scheme...
and then not In_Runtime (Def_Id)
-- Another exception is if Restrictions (No_Finalization)
-- is active, since then we know nothing is controlled.
-- An exception is made for types defined in the run-time because
-- Ada.Tags.Tag itself is such a type and cannot afford this
-- unnecessary overhead that would generates a loop in the
-- expansion scheme. Another exception is if Restrictions
-- (No_Finalization) is active, since then we know nothing is
-- controlled.
and then not Restriction_Active (No_Finalization))
elsif Restriction_Active (No_Finalization)
or else In_Runtime (Def_Id)
then
null;
-- If the designated type is not frozen yet, its controlled
-- status must be retrieved explicitly.
-- The machinery assumes that incomplete or private types are
-- always completed by a controlled full vies.
elsif Needs_Finalization (Desig_Type)
or else
(Is_Incomplete_Or_Private_Type (Desig_Type)
and then No (Full_View (Desig_Type)))
or else
(Is_Array_Type (Desig_Type)
and then not Is_Frozen (Desig_Type)
and then Needs_Finalization (Component_Type (Desig_Type)))
then
Build_Finalization_Master (Def_Id);
......
gcc/ada/exp_ch7.ads
......@@ -84,8 +84,8 @@ package Exp_Ch7 is
-- Subsidiary to routines Build_Finalizer, Make_Deep_Array_Body and Make_
-- Deep_Record_Body. Generate the following conditional raise statement:
--
-- if Raised_Id then
-- Raise_From_Controlled_Operation (E_Id, Abort_Id);
-- if Raised_Id and then not Abort_Id then
-- Raise_From_Controlled_Operation (E_Id);
-- end if;
--
-- Abort_Id is a local boolean flag which is set when the finalization was
......
gcc/ada/exp_util.adb
......@@ -327,10 +327,11 @@ package body Exp_Util is
(N : Node_Id;
Is_Allocate : Boolean)
is
Expr : constant Node_Id := Expression (N);
Ptr_Typ : constant Entity_Id := Etype (Expr);
Desig_Typ : constant Entity_Id :=
Available_View (Designated_Type (Ptr_Typ));
Desig_Typ : Entity_Id;
Expr : Node_Id;
Pool_Id : Entity_Id;
Proc_To_Call : Node_Id := Empty;
Ptr_Typ : Entity_Id;
function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id;
-- Locate TSS primitive Finalize_Address in type Typ
......@@ -351,13 +352,33 @@ package body Exp_Util is
Utyp : Entity_Id := Typ;
begin
-- Handle protected class-wide or task class-wide types
if Is_Class_Wide_Type (Utyp) then
if Is_Concurrent_Type (Root_Type (Utyp)) then
Utyp := Root_Type (Utyp);
elsif Is_Private_Type (Root_Type (Utyp))
and then Present (Full_View (Root_Type (Utyp)))
and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
then
Utyp := Full_View (Root_Type (Utyp));
end if;
end if;
-- Handle private types
if Is_Private_Type (Utyp)
and then Present (Full_View (Utyp))
then
Utyp := Full_View (Utyp);
end if;
if Is_Concurrent_Type (Utyp) then
-- Handle protected and task types
if Is_Concurrent_Type (Utyp)
and then Present (Corresponding_Record_Type (Utyp))
then
Utyp := Corresponding_Record_Type (Utyp);
end if;
......@@ -459,18 +480,91 @@ package body Exp_Util is
-- Start of processing for Build_Allocate_Deallocate_Proc
begin
-- The allocation / deallocation of a non-controlled object does not
-- need the machinery created by this routine.
-- Obtain the attributes of the allocation / deallocation
if Nkind (N) = N_Free_Statement then
Expr := Expression (N);
Ptr_Typ := Base_Type (Etype (Expr));
Proc_To_Call := Procedure_To_Call (N);
else
if Nkind (N) = N_Object_Declaration then
Expr := Expression (N);
else
Expr := N;
end if;
Ptr_Typ := Base_Type (Etype (Expr));
-- The allocator may have been rewritten into something else
if Nkind (Expr) = N_Allocator then
Proc_To_Call := Procedure_To_Call (Expr);
end if;
end if;
Pool_Id := Associated_Storage_Pool (Ptr_Typ);
Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
if not Needs_Finalization (Desig_Typ) then
-- Handle concurrent types
if Is_Concurrent_Type (Desig_Typ)
and then Present (Corresponding_Record_Type (Desig_Typ))
then
Desig_Typ := Corresponding_Record_Type (Desig_Typ);
end if;
-- Do not process allocations / deallocations without a pool
if No (Pool_Id) then
return;
-- The allocator or free statement has already been expanded and already
-- has a custom Allocate / Deallocate routine.
-- Do not process allocations on / deallocations from the secondary
-- stack.
elsif Is_RTE (Pool_Id, RE_SS_Pool) then
return;
-- Do not replicate the machinery if the allocator / free has already
-- been expanded and has a custom Allocate / Deallocate.
elsif Present (Proc_To_Call)
and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
then
return;
end if;
if Needs_Finalization (Desig_Typ) then
-- Certain run-time configurations and targets do not provide support
-- for controlled types.
if Restriction_Active (No_Finalization) then
return;
-- Do nothing if the access type may never allocate / deallocate
-- objects.
elsif No_Pool_Assigned (Ptr_Typ) then
return;
-- Access-to-controlled types are not supported on .NET/JVM since
-- these targets cannot support pools and address arithmetic.
elsif VM_Target /= No_VM then
return;
end if;
-- The allocation / deallocation of a controlled object must be
-- chained on / detached from a finalization master.
pragma Assert (Present (Finalization_Master (Ptr_Typ)));
-- The only other kind of allocation / deallocation supported by this
-- routine is on / from a subpool.
elsif Nkind (Expr) = N_Allocator
and then Present (Procedure_To_Call (Expr))
and then Is_Allocate_Deallocate_Proc (Procedure_To_Call (Expr))
and then No (Subpool_Handle_Name (Expr))
then
return;
end if;
......@@ -486,36 +580,27 @@ package body Exp_Util is
Fin_Addr_Id : Entity_Id;
Fin_Mas_Act : Node_Id;
Fin_Mas_Id : Entity_Id;
Fin_Mas_Typ : Entity_Id;
Proc_To_Call : Entity_Id;
Subpool : Node_Id := Empty;
begin
-- When dealing with an access subtype, always use the base type
-- since it carries all the attributes.
if Ekind (Ptr_Typ) = E_Access_Subtype then
Fin_Mas_Typ := Base_Type (Ptr_Typ);
else
Fin_Mas_Typ := Ptr_Typ;
end if;
Actuals := New_List;
-- Step 1: Construct all the actuals for the call to library routine
-- Allocate_Any_Controlled / Deallocate_Any_Controlled.
-- a) Storage pool
Append_To (Actuals,
New_Reference_To (Associated_Storage_Pool (Fin_Mas_Typ), Loc));
Actuals := New_List (New_Reference_To (Pool_Id, Loc));
if Is_Allocate then
-- b) Subpool
if Present (Subpool_Handle_Name (Expr)) then
Append_To (Actuals,
New_Reference_To (Entity (Subpool_Handle_Name (Expr)), Loc));
if Nkind (Expr) = N_Allocator then
Subpool := Subpool_Handle_Name (Expr);
end if;
if Present (Subpool) then
Append_To (Actuals, New_Reference_To (Entity (Subpool), Loc));
else
Append_To (Actuals, Make_Null (Loc));
end if;
......@@ -523,7 +608,7 @@ package body Exp_Util is
-- c) Finalization master
if Needs_Finalization (Desig_Typ) then
Fin_Mas_Id := Finalization_Master (Fin_Mas_Typ);
Fin_Mas_Id := Finalization_Master (Ptr_Typ);
Fin_Mas_Act := New_Reference_To (Fin_Mas_Id, Loc);
-- Handle the case where the master is actually a pointer to a
......@@ -545,7 +630,9 @@ package body Exp_Util is
Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
if Present (Fin_Addr_Id) then
if Needs_Finalization (Desig_Typ) then
pragma Assert (Present (Fin_Addr_Id));
Append_To (Actuals,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Fin_Addr_Id, Loc),
......@@ -654,11 +741,23 @@ package body Exp_Util is
Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
end;
-- The object is statically known to be controlled
else
Append_To (Actuals, New_Reference_To (Standard_True, Loc));
end if;
else
Append_To (Actuals, New_Reference_To (Standard_False, Loc));
end if;
-- i) On_Subpool
if Is_Allocate then
Append_To (Actuals,
New_Reference_To (Boolean_Literals (Present (Subpool)), Loc));
end if;
-- Step 2: Build a wrapper Allocate / Deallocate which internally
-- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
......@@ -5296,6 +5395,16 @@ package body Exp_Util is
if Restriction_Active (No_Finalization) then
return False;
-- C, C++, CIL and Java types are not considered controlled. It is
-- assumed that the non-Ada side will handle their clean up.
elsif Convention (T) = Convention_C
or else Convention (T) = Convention_CIL
or else Convention (T) = Convention_CPP
or else Convention (T) = Convention_Java
then
return False;
else
-- Class-wide types are treated as controlled because derivations
-- from the root type can introduce controlled components.
......
gcc/ada/exp_util.ads
......@@ -198,8 +198,13 @@ package Exp_Util is
(N : Node_Id;
Is_Allocate : Boolean);
-- Create a custom Allocate/Deallocate to be associated with an allocation
-- or deallocation of a controlled or class-wide object. In the case of
-- allocation, N is the declaration of the temporary variable which
-- or deallocation:
--
-- 1) controlled objects
-- 2) class-wide objects
-- 3) any kind of object on a subpool
--
-- N must be an allocator or the declaration of a temporary variable which
-- represents the expression of the original allocator node, otherwise N
-- must be a free statement. If flag Is_Allocate is set, the generated
-- routine is allocate, deallocate otherwise.
......
gcc/ada/freeze.adb
......@@ -1439,27 +1439,24 @@ package body Freeze is
end loop;
end;
-- We add finalization collections to access types whose designated
-- types require finalization. This is normally done when freezing
-- the type, but this misses recursive type definitions where the
-- later members of the recursion introduce controlled components
-- (such as can happen when incomplete types are involved), as well
-- cases where a component type is private and the controlled full
-- type occurs after the access type is frozen. Cases that don't
-- need a finalization collection are generic formal types (the
-- actual type will have it) and types with Java and CIL conventions,
-- since those are used for API bindings. (Are there any other cases
-- that should be excluded here???)
-- We add finalization masters to access types whose designated types
-- require finalization. This is normally done when freezing the
-- type, but this misses recursive type definitions where the later
-- members of the recursion introduce controlled components (such as
-- can happen when incomplete types are involved), as well cases
-- where a component type is private and the controlled full type
-- occurs after the access type is frozen. Cases that don't need a
-- finalization master are generic formal types (the actual type will
-- have it) and types with Java and CIL conventions, since those are
-- used for API bindings. (Are there any other cases that should be
-- excluded here???)
elsif Is_Access_Type (E)
and then Comes_From_Source (E)
and then not Is_Generic_Type (E)
and then Needs_Finalization (Designated_Type (E))
and then No (Associated_Collection (E))
and then Convention (Designated_Type (E)) /= Convention_Java
and then Convention (Designated_Type (E)) /= Convention_CIL
then
Build_Finalization_Collection (E);
Build_Finalization_Master (E);
end if;
Next_Entity (E);
......
gcc/ada/impunit.adb
......@@ -346,6 +346,7 @@ package body Impunit is
"s-addima", -- System.Address_Image
"s-assert", -- System.Assertions
"s-finmas", -- System.Finalization_Masters
"s-memory", -- System.Memory
"s-parint", -- System.Partition_Interface
"s-pooglo", -- System.Pool_Global
......@@ -508,6 +509,7 @@ package body Impunit is
Non_Imp_File_Names_12 : constant File_List := (
"s-multip", -- System.Multiprocessors
"s-mudido", -- System.Multiprocessors.Dispatching_Domains
"s-stposu", -- System.Storage_Pools.Subpools
"a-cobove", -- Ada.Containers.Bounded_Vectors
"a-cbdlli", -- Ada.Containers.Bounded_Doubly_Linked_Lists
"a-cborse", -- Ada.Containers.Bounded_Ordered_Sets
......@@ -521,11 +523,13 @@ package body Impunit is
"a-extiin", -- Ada.Execution_Time.Interrupts
"a-iteint", -- Ada.Iterator_Interfaces
"a-synbar", -- Ada.Synchronous_Barriers
"a-undesu", -- Ada.Unchecked_Deallocate_Subpool
-----------------------------------------
-- GNAT Defined Additions to Ada 20012 --
-----------------------------------------
"s-spsufi", -- System.Storage_Pools.Subpools.Finalization
"a-cofove", -- Ada.Containers.Formal_Vectors
"a-cfdlli", -- Ada.Containers.Formal_Doubly_Linked_Lists
"a-cforse", -- Ada.Containers.Formal_Ordered_Sets
......
gcc/ada/s-finmas.ads
......@@ -35,6 +35,8 @@ with Ada.Unchecked_Conversion;
with System.Storage_Elements;
with System.Storage_Pools;
pragma Compiler_Unit;
package System.Finalization_Masters is
pragma Preelaborate (System.Finalization_Masters);
......
gcc/ada/s-spsufi.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S . --
-- F I N A L I Z A T I O N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package body System.Storage_Pools.Subpools.Finalization is
-----------------------------
-- Finalize_And_Deallocate --
-----------------------------
procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle) is
begin
-- Do nothing if the subpool was never created or never used. The latter
-- case may arise with an array of subpool implementations.
if Subpool = null
or else Subpool.Owner = null
or else Subpool.Node = null
then
return;
end if;
-- Clean up all controlled objects allocated through the subpool
Finalize_Subpool (Subpool);
-- Dispatch to the user-defined implementation of Deallocate_Subpool
Deallocate_Subpool (Pool_Of_Subpool (Subpool).all, Subpool);
Subpool := null;
end Finalize_And_Deallocate;
end System.Storage_Pools.Subpools.Finalization;
gcc/ada/s-spsufi.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S . --
-- F I N A L I Z A T I O N --
-- --
-- S p e c --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
pragma Compiler_Unit;
package System.Storage_Pools.Subpools.Finalization is
procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle);
-- This routine performs the following actions:
-- 1) Finalize all objects chained on the subpool's master
-- 2) Remove the the subpool from the owner's list of subpools
-- 3) Deallocate the doubly linked list node associated with the subpool
-- 4) Call Deallocate_Subpool
end System.Storage_Pools.Subpools.Finalization;
gcc/ada/sem_aggr.adb
......@@ -1309,6 +1309,10 @@ package body Sem_Aggr is
-- for discrete choices such as "L .. H => Expr" or the OTHERS choice).
-- In this event we do not resolve Expr unless expansion is disabled.
-- To know why, see the DELAYED COMPONENT RESOLUTION note above.
--
-- NOTE: In the case of "... => <>", we pass the in the
-- N_Component_Association node as Expr, since there is no Expression in
-- that case, and we need a Sloc for the error message.
---------
-- Add --
......@@ -1635,6 +1639,13 @@ package body Sem_Aggr is
end if;
end if;
-- If it's "... => <>", nothing to resolve
if Nkind (Expr) = N_Component_Association then
pragma Assert (Box_Present (Expr));
return Success;
end if;
-- Ada 2005 (AI-231): Propagate the type to the nested aggregate.
-- Required to check the null-exclusion attribute (if present).
-- This value may be overridden later on.
......@@ -1644,19 +1655,29 @@ package body Sem_Aggr is
Resolution_OK := Resolve_Array_Aggregate
(Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed);
-- Do not resolve the expressions of discrete or others choices
-- unless the expression covers a single component, or the expander
-- is inactive.
else
-- If it's "... => <>", nothing to resolve
elsif Single_Elmt
or else not Expander_Active
or else In_Spec_Expression
then
Analyze_And_Resolve (Expr, Component_Typ);
Check_Expr_OK_In_Limited_Aggregate (Expr);
Check_Non_Static_Context (Expr);
Aggregate_Constraint_Checks (Expr, Component_Typ);
Check_Unset_Reference (Expr);
if Nkind (Expr) = N_Component_Association then
pragma Assert (Box_Present (Expr));
return Success;
end if;
-- Do not resolve the expressions of discrete or others choices
-- unless the expression covers a single component, or the
-- expander is inactive.
if Single_Elmt
or else not Expander_Active
or else In_Spec_Expression
then
Analyze_And_Resolve (Expr, Component_Typ);
Check_Expr_OK_In_Limited_Aggregate (Expr);
Check_Non_Static_Context (Expr);
Aggregate_Constraint_Checks (Expr, Component_Typ);
Check_Unset_Reference (Expr);
end if;
end if;
if Raises_Constraint_Error (Expr)
......@@ -1988,9 +2009,15 @@ package body Sem_Aggr is
-- Ada 2005 (AI-287): In case of default initialization of a
-- component the expander will generate calls to the
-- corresponding initialization subprogram.
-- corresponding initialization subprogram. We need to call
-- Resolve_Aggr_Expr to check the rules about
-- dimensionality.
null;
if not Resolve_Aggr_Expr (Assoc,
Single_Elmt => Single_Choice)
then
return Failure;
end if;
elsif not Resolve_Aggr_Expr (Expression (Assoc),
Single_Elmt => Single_Choice)
......@@ -2321,9 +2348,13 @@ package body Sem_Aggr is
-- Ada 2005 (AI-287): In case of default initialization of a
-- component the expander will generate calls to the
-- corresponding initialization subprogram.
-- corresponding initialization subprogram. We need to call
-- Resolve_Aggr_Expr to check the rules about
-- dimensionality.
null;
if not Resolve_Aggr_Expr (Assoc, Single_Elmt => False) then
return Failure;
end if;
elsif not Resolve_Aggr_Expr (Expression (Assoc),
Single_Elmt => False)
......
gcc/ada/sem_ch13.adb
......@@ -1471,6 +1471,7 @@ package body Sem_Ch13 is
else
case A_Id is
-- For Pre/Post cases, insert immediately after the
-- entity declaration, since that is the required pragma
-- placement.
......
gcc/ada/sem_ch6.adb
......@@ -2348,7 +2348,7 @@ package body Sem_Ch6 is
-- the proper back-annotations.
if not Is_Frozen (Spec_Id)
and then (Expander_Active or ASIS_Mode)
and then (Expander_Active or else ASIS_Mode)
then
-- Force the generation of its freezing node to ensure proper
-- management of access types in the backend.
......@@ -6081,14 +6081,13 @@ package body Sem_Ch6 is
end if;
-- In the case of functions whose result type needs finalization,
-- add an extra formal of type Ada.Finalization.Heap_Management.
-- Finalization_Collection_Ptr.
-- add an extra formal which represents the finalization master.
if Needs_BIP_Collection (E) then
if Needs_BIP_Finalization_Master (E) then
Discard :=
Add_Extra_Formal
(E, RTE (RE_Finalization_Collection_Ptr),
E, BIP_Formal_Suffix (BIP_Collection));
(E, RTE (RE_Finalization_Master_Ptr),
E, BIP_Formal_Suffix (BIP_Finalization_Master));
end if;
-- If the result type contains tasks, we have two extra formals:
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment