+2011-08-29 Pascal Obry <obry@adacore.com>
+
+ * exp_disp.adb: Minor comment fix.
+ (Make_Disp_Asynchronous_Select_Body): Properly initialize out parameters
+ to avoid warnings when compiling with -Wall.
+ (Make_Disp_Conditional_Select_Body): Likewise.
+ (Make_Disp_Timed_Select_Body): Likewise.
+
+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Analyze_Formal_Subprogram_Declaration): If default is
+ an entity name, generate reference for it.
+
+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch5.adb (Expand_Iterator_Loop): Uniform handling of "X of S"
+ iterator form.
+ * sem_util.adb (Is_Iterator, Is_Reversible_Iterator): Yield True for
+ the class-wide type.
+ * sem_ch5.adb: Move some rewriting to the expander, where it belongs.
+
+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch8.adb (Check_Constrained_Object): Do not create an actual
+ subtype for an object whose type is an unconstrained union.
+
+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * par-ch3.adb (P_Array_Type_Definiation, P_Component_Items): "aliased"
+ is allowed in a component definition, by AI95-406.
+
+2011-08-29 Matthew Heaney <heaney@adacore.com>
+
+ * a-chtgbo.adb (Generic_Iteration): Use correct overloading of Next.
+
+2011-08-29 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * a-except-2005.adb: Alphabetize all routines.
+ (Triggered_By_Abort): New routine.
+ * a-except-2005.ads (Triggered_By_Abort): New routine.
+ * a-except.adb Alphabetize all routines.
+ (Triggered_By_Abort): New routine.
+ * a-except.ads (Triggered_By_Abort): New routine.
+ * exp_ch7.adb: Update all comments involving the detection of aborts in
+ finalization code.
+ (Build_Object_Declarations): Do not generate code to detect the
+ presence of an abort at the start of finalization code, use a runtime
+ routine istead.
+ * rtsfind.ads: Add RE_Triggered_By_Abort to tables RE_Id and
+ RE_Unit_Table.
+ * sem_res.adb (Resolve_Allocator): Emit a warning when attempting to
+ allocate a task on a subpool.
+ * s-stposu.adb: Add library-level flag Finalize_Address_Table_In_Use.
+ The flag disables all actions related to the maintenance of
+ Finalize_Address_Table when subpools are not in use.
+ (Allocate_Any_Controlled): Signal the machinery that subpools are in
+ use.
+ (Deallocate_Any_Controlled): Do not call Delete_Finalize_Address which
+ performs costly task locking when subpools are not in use.
+
2011-08-29 Yannick Moy <moy@adacore.com>
* gnat1drv.adb (Adjust_Global_Switches): Restore expansion of tagged
Node := HT.Buckets (Indx);
while Node /= 0 loop
Process (Node);
- Node := Next (HT, Node);
+ Node := Next (HT.Nodes (Node));
end loop;
end loop;
end Generic_Iteration;
-- in case we do not want any exception tracing support. This is
-- why this package is separated.
+ -----------
+ -- Image --
+ -----------
+
+ function Image (Index : Integer) return String is
+ Result : constant String := Integer'Image (Index);
+ begin
+ if Result (1) = ' ' then
+ return Result (2 .. Result'Last);
+ else
+ return Result;
+ end if;
+ end Image;
+
-----------------------
-- Stream Attributes --
-----------------------
Raise_Current_Excep (E);
end Raise_Exception_Always;
+ ------------------------------
+ -- Raise_Exception_No_Defer --
+ ------------------------------
+
+ procedure Raise_Exception_No_Defer
+ (E : Exception_Id;
+ Message : String := "")
+ is
+ begin
+ Exception_Data.Set_Exception_Msg (E, Message);
+
+ -- Do not call Abort_Defer.all, as specified by the spec
+
+ Raise_Current_Excep (E);
+ end Raise_Exception_No_Defer;
+
-------------------------------------
-- Raise_From_Controlled_Operation --
-------------------------------------
Raise_Current_Excep (E);
end Raise_With_Msg;
- -----------
- -- Image --
- -----------
-
- function Image (Index : Integer) return String is
- Result : constant String := Integer'Image (Index);
- begin
- if Result (1) = ' ' then
- return Result (2 .. Result'Last);
- else
- return Result;
- end if;
- end Image;
-
--------------------------------------
-- Calls to Run-Time Check Routines --
--------------------------------------
return Target;
end Save_Occurrence;
- -------------------------
- -- Transfer_Occurrence --
- -------------------------
-
- procedure Transfer_Occurrence
- (Target : Exception_Occurrence_Access;
- Source : Exception_Occurrence)
- is
- begin
- Save_Occurrence (Target.all, Source);
- end Transfer_Occurrence;
-
-------------------
-- String_To_EId --
-------------------
function String_To_EO (S : String) return Exception_Occurrence
renames Stream_Attributes.String_To_EO;
- ------------------------------
- -- Raise_Exception_No_Defer --
- ------------------------------
-
- procedure Raise_Exception_No_Defer
- (E : Exception_Id;
- Message : String := "")
- is
- begin
- Exception_Data.Set_Exception_Msg (E, Message);
-
- -- Do not call Abort_Defer.all, as specified by the spec
-
- Raise_Current_Excep (E);
- end Raise_Exception_No_Defer;
-
---------------
-- To_Stderr --
---------------
end loop;
end To_Stderr;
+ -------------------------
+ -- Transfer_Occurrence --
+ -------------------------
+
+ procedure Transfer_Occurrence
+ (Target : Exception_Occurrence_Access;
+ Source : Exception_Occurrence)
+ is
+ begin
+ Save_Occurrence (Target.all, Source);
+ end Transfer_Occurrence;
+
+ ------------------------
+ -- Triggered_By_Abort --
+ ------------------------
+
+ function Triggered_By_Abort return Boolean is
+ Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
+
+ begin
+ return Ex /= null
+ and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity;
+ end Triggered_By_Abort;
+
-------------------------
-- Wide_Exception_Name --
-------------------------
-- occurrence. This is used in generated code when it is known that abort
-- is already deferred.
+ function Triggered_By_Abort return Boolean;
+ -- Determine whether the current exception (if exists) is an instance of
+ -- Standard'Abort_Signal.
+
-----------------------
-- Polling Interface --
-----------------------
Raise_Current_Excep (E);
end Raise_Exception_Always;
+ ------------------------------
+ -- Raise_Exception_No_Defer --
+ ------------------------------
+
+ procedure Raise_Exception_No_Defer
+ (E : Exception_Id;
+ Message : String := "")
+ is
+ begin
+ Exception_Data.Set_Exception_Msg (E, Message);
+
+ -- Do not call Abort_Defer.all, as specified by the spec
+
+ Raise_Current_Excep (E);
+ end Raise_Exception_No_Defer;
+
-------------------------------------
-- Raise_From_Controlled_Operation --
-------------------------------------
return Target;
end Save_Occurrence;
- -------------------------
- -- Transfer_Occurrence --
- -------------------------
-
- procedure Transfer_Occurrence
- (Target : Exception_Occurrence_Access;
- Source : Exception_Occurrence)
- is
- begin
- Save_Occurrence (Target.all, Source);
- end Transfer_Occurrence;
-
-------------------
-- String_To_EId --
-------------------
function String_To_EO (S : String) return Exception_Occurrence
renames Stream_Attributes.String_To_EO;
- ------------------------------
- -- Raise_Exception_No_Defer --
- ------------------------------
-
- procedure Raise_Exception_No_Defer
- (E : Exception_Id;
- Message : String := "")
- is
- begin
- Exception_Data.Set_Exception_Msg (E, Message);
-
- -- Do not call Abort_Defer.all, as specified by the spec
-
- Raise_Current_Excep (E);
- end Raise_Exception_No_Defer;
-
---------------
-- To_Stderr --
---------------
end loop;
end To_Stderr;
+ -------------------------
+ -- Transfer_Occurrence --
+ -------------------------
+
+ procedure Transfer_Occurrence
+ (Target : Exception_Occurrence_Access;
+ Source : Exception_Occurrence)
+ is
+ begin
+ Save_Occurrence (Target.all, Source);
+ end Transfer_Occurrence;
+
+ ------------------------
+ -- Triggered_By_Abort --
+ ------------------------
+
+ function Triggered_By_Abort return Boolean is
+ Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
+
+ begin
+ return Ex /= null
+ and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity;
+ end Triggered_By_Abort;
+
end Ada.Exceptions;
-- occurrence. This is used in generated code when it is known that
-- abort is already deferred.
+ function Triggered_By_Abort return Boolean;
+ -- Determine whether the current exception (if exists) is an instance of
+ -- Standard'Abort_Signal.
+
-----------------------
-- Polling Interface --
-----------------------
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
declare
Element_Type : constant Entity_Id := Etype (Id);
+ Iter_Type : Entity_Id;
Pack : Entity_Id;
Decl : Node_Id;
Name_Init : Name_Id;
Name_Step : Name_Id;
begin
+
+ -- The type of the iterator is the return type of the Iterate
+ -- function used. For the "of" form this is the default iterator
+ -- for the type, otherwise it is the type of the explicit
+ -- function used in the loop.
+
+ Iter_Type := Etype (Name (I_Spec));
+
if Is_Entity_Name (Container) then
Pack := Scope (Etype (Container));
end if;
-- The "of" case uses an internally generated cursor whose type
- -- is found in the container package.
+ -- is found in the container package. The domain of iteration
+ -- is expanded into a call to the default Iterator function, but
+ -- this expansion does not take place in a quantifier expressions
+ -- that are analyzed with expansion disabled, and in that case the
+ -- type of the iterator must be obtained from the aspect.
if Of_Present (I_Spec) then
- Cursor := Make_Temporary (Loc, 'I');
-
declare
+ Default_Iter : constant Entity_Id :=
+ Find_Aspect (Etype (Container), Aspect_Default_Iterator);
Ent : Entity_Id;
+
begin
+ Cursor := Make_Temporary (Loc, 'I');
+
+ if Is_Iterator (Iter_Type) then
+ null;
+
+ else
+ Iter_Type :=
+ Etype
+ (Find_Aspect
+ (Etype (Container), Aspect_Default_Iterator));
+
+ -- Rewrite domain of iteration as a call to the default
+ -- iterator for the container type.
+
+ Rewrite (Name (I_Spec),
+ Make_Function_Call (Loc,
+ Name => Default_Iter,
+ Parameter_Associations =>
+ New_List (Relocate_Node (Name (I_Spec)))));
+ Analyze_And_Resolve (Name (I_Spec));
+ end if;
+
+ -- Find cursor type in container package.
+
Ent := First_Entity (Pack);
while Present (Ent) loop
if Chars (Ent) = Name_Cursor then
end if;
Next_Entity (Ent);
end loop;
+
+ -- Generate:
+ -- Id : Element_Type renames Pack.Element (Cursor);
+
+ Decl :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Id,
+ Subtype_Mark =>
+ New_Reference_To (Element_Type, Loc),
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Pack, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Chars => Name_Element)),
+ Expressions =>
+ New_List (New_Occurrence_Of (Cursor, Loc))));
+
+ -- If the container holds controlled objects, wrap the loop
+ -- statements and element renaming declaration with a block.
+ -- This ensures that the result of Element (Iterator) is
+ -- cleaned up after each iteration of the loop.
+
+ if Needs_Finalization (Element_Type) then
+
+ -- Generate:
+ -- declare
+ -- Id : Element_Type := Pack.Element (Iterator);
+ -- begin
+ -- <original loop statements>
+ -- end;
+
+ Stats := New_List (
+ Make_Block_Statement (Loc,
+ Declarations => New_List (Decl),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stats)));
+
+ -- Elements do not need finalization
+
+ else
+ Prepend_To (Stats, Decl);
+ end if;
end;
+ -- X in Iterate (S) : type of iterator is type of explicitly
+ -- given Iterate function.
+
else
Cursor := Id;
end if;
Iterator := Make_Temporary (Loc, 'I');
- if Of_Present (I_Spec) then
-
- -- Generate:
- -- Id : Element_Type renames Pack.Element (Cursor);
-
- Decl :=
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Id,
- Subtype_Mark =>
- New_Reference_To (Element_Type, Loc),
- Name =>
- Make_Indexed_Component (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Reference_To (Pack, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Chars => Name_Element)),
- Expressions => New_List (
- New_Occurrence_Of (Cursor, Loc))));
-
- -- When the container holds controlled objects, wrap the loop
- -- statements and element renaming declaration with a block.
- -- This ensures that the transient result of Element (Iterator)
- -- is cleaned up after each iteration of the loop.
-
- if Needs_Finalization (Element_Type) then
-
- -- Generate:
- -- declare
- -- Id : Element_Type := Pack.Element (Iterator);
- -- begin
- -- <original loop statements>
- -- end;
-
- Stats := New_List (
- Make_Block_Statement (Loc,
- Declarations => New_List (Decl),
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stats)));
- else
- Prepend_To (Stats, Decl);
- end if;
- end if;
-
-- Determine the advancement and initialization steps for the
-- cursor.
declare
Rhs : Node_Id;
+
begin
- if Of_Present (I_Spec) then
- Rhs :=
- Make_Function_Call (Loc,
- Name => Make_Identifier (Loc, Name_Step),
- Parameter_Associations =>
- New_List (New_Reference_To (Cursor, Loc)));
- else
- Rhs :=
- Make_Function_Call (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (Iterator, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Step)),
- Parameter_Associations => New_List (
- New_Reference_To (Cursor, Loc)));
- end if;
+ Rhs :=
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Iterator, Loc),
+ Selector_Name => Make_Identifier (Loc, Name_Step)),
+ Parameter_Associations => New_List (
+ New_Reference_To (Cursor, Loc)));
Append_To (Stats,
Make_Assignment_Statement (Loc,
declare
Decl1 : Node_Id;
Decl2 : Node_Id;
+
begin
Decl1 :=
Make_Object_Declaration (Loc,
Defining_Identifier => Iterator,
- Object_Definition =>
- New_Occurrence_Of (Etype (Name (I_Spec)), Loc),
-
- Expression => Relocate_Node (Name (I_Spec)));
+ Object_Definition => New_Occurrence_Of (Iter_Type, Loc),
+ Expression => Relocate_Node (Name (I_Spec)));
Set_Assignment_OK (Decl1);
Decl2 :=
-- Generate:
-- procedure Fin_Id is
- -- Abort : constant Boolean :=
- -- Exception_Occurrence (Get_Current_Excep.all.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
and then VM_Target = No_VM
and then not For_Package
then
- declare
- Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'E');
-
- begin
- -- Generate:
- -- Temp : constant Exception_Occurrence_Access :=
- -- Get_Current_Excep.all;
+ A_Expr := New_Reference_To (RTE (RE_Triggered_By_Abort), Loc);
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp_Id,
- Constant_Present => True,
- Object_Definition =>
- New_Reference_To (RTE (RE_Exception_Occurrence_Access), Loc),
- Expression =>
- Make_Function_Call (Loc,
- Name =>
- Make_Explicit_Dereference (Loc,
- Prefix =>
- New_Reference_To
- (RTE (RE_Get_Current_Excep), Loc)))));
-
- -- Generate:
- -- Temp /= null
- -- and then Exception_Identity (Temp.all) =
- -- Standard'Abort_Signal'Identity;
-
- A_Expr :=
- Make_And_Then (Loc,
- Left_Opnd =>
- Make_Op_Ne (Loc,
- Left_Opnd => New_Reference_To (Temp_Id, Loc),
- Right_Opnd => Make_Null (Loc)),
-
- Right_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Exception_Identity), Loc),
- Parameter_Associations => New_List (
- Make_Explicit_Dereference (Loc,
- Prefix => New_Reference_To (Temp_Id, Loc)))),
-
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Reference_To (Stand.Abort_Signal, Loc),
- Attribute_Name => Name_Identity)));
- end;
-
- -- No abort or .NET/JVM
+ -- No abort, .NET/JVM or library-level finalizers
else
A_Expr := New_Reference_To (Standard_False, Loc);
Stmt : Node_Id;
begin
- -- Standard run-time, .NET/JVM targets
- -- Call Raise_From_Controlled_Operation (E_Id).
+ -- Standard run-time and .NET/JVM targets use the specialized routine
+ -- Raise_From_Controlled_Operation.
if RTE_Available (RE_Raise_From_Controlled_Operation) then
Stmt :=
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Raise_From_Controlled_Operation),
- Loc),
+ Name =>
+ New_Reference_To
+ (RTE (RE_Raise_From_Controlled_Operation), Loc),
Parameter_Associations =>
New_List (New_Reference_To (E_Id, Loc)));
-- Restricted runtime: exception messages are not supported and hence
- -- Raise_From_Controlled_Operation is not supported.
- -- Simply raise Program_Error.
+ -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
+ -- instead.
else
Stmt :=
Make_Raise_Program_Error (Loc,
Reason => PE_Finalize_Raised_Exception);
-
end if;
-- Generate:
-- if Raised_Id and then not Abort_Id then
-- Raise_From_Controlled_Operation (E_Id);
+ -- <or>
+ -- raise Program_Error; -- restricted runtime
-- end if;
return
-- controlled elements. Generate:
--
-- declare
- -- Temp : constant Exception_Occurrence_Access :=
- -- Get_Current_Excep.all;
- -- Abort : constant Boolean :=
- -- Temp /= null
- -- and then Exception_Identity (Temp_Id.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
--
-- exception
-- when others =>
-- declare
- -- Temp : constant Exception_Occurrence_Access :=
- -- Get_Current_Excep.all;
- -- Abort : constant Boolean :=
- -- Temp /= null
- -- and then Exception_Identity (Temp_Id.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
-- E : Exception_Occurence;
-- the conditional raise:
-- declare
- -- Abort : constant Boolean :=
- -- Exception_Occurrence (Get_Current_Excep.all.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
-- raised flag and the conditional raise.
-- declare
- -- Abort : constant Boolean :=
- -- Exception_Occurrence (Get_Current_Excep.all.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
-- may have discriminants and contain variant parts. Generate:
--
-- declare
- -- Temp : constant Exception_Occurrence_Access :=
- -- Get_Current_Excep.all;
- -- Abort : constant Boolean :=
- -- Temp /= null
- -- and then Exception_Identity (Temp_Id.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
-- E : Exception_Occurence;
-- Generate:
-- declare
- -- Abort : constant Boolean :=
- -- Exception_Occurrence (Get_Current_Excep.all.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
-- Generate:
-- declare
- -- Abort : constant Boolean :=
- -- Exception_Occurrence (Get_Current_Excep.all.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
-- F : out Boolean)
-- is
-- begin
- -- null;
+ -- F := False;
+ -- C := Ada.Tags.POK_Function;
-- end _Disp_Asynchronous_Select;
-- For protected types, generate:
New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- New_List (Make_Null_Statement (Loc))));
+ New_List (Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)))));
end if;
if Is_Concurrent_Record_Type (Typ) then
Expression =>
New_Reference_To (Com_Block, Loc))));
+ -- Generate:
+ -- F := False;
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)));
+
else
pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
else
-- Ensure that the statements list is non-empty
- Append_To (Stmts, Make_Null_Statement (Loc));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)));
end if;
return
-- F : out Boolean)
-- is
-- begin
- -- null;
+ -- F := False;
+ -- C := Ada.Tags.POK_Function;
-- end _Disp_Conditional_Select;
-- For protected types, generate:
No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- New_List (Make_Null_Statement (Loc))));
+ New_List (Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)))));
end if;
if Is_Concurrent_Record_Type (Typ) then
end if;
else
- -- Ensure that the statements list is non-empty
+ -- Initialize out parameters
- Append_To (Stmts, Make_Null_Statement (Loc));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uC),
+ Expression => New_Reference_To (RTE (RE_POK_Function), Loc)));
end if;
return
-- F : out Boolean)
-- is
-- begin
- -- null;
+ -- F := False;
+ -- C := Ada.Tags.POK_Function;
-- end _Disp_Timed_Select;
-- For protected types, generate:
-- P,
-- D,
-- M,
- -- D);
+ -- F);
-- end _Disp_Time_Select;
function Make_Disp_Timed_Select_Body
New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- New_List (Make_Null_Statement (Loc))));
+ New_List (Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)))));
end if;
if Is_Concurrent_Record_Type (Typ) then
end if;
else
- -- Ensure that the statements list is non-empty
+ -- Initialize out parameters
- Append_To (Stmts, Make_Null_Statement (Loc));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uC),
+ Expression => New_Reference_To (RTE (RE_POK_Function), Loc)));
end if;
return
begin
Constr_Node := P_Constraint_Opt;
- if No (Constr_Node) then
+ if No (Constr_Node)
+ or else
+ (Nkind (Constr_Node) = N_Range_Constraint
+ and then Nkind (Range_Expression (Constr_Node)) = N_Error)
+ then
return Subtype_Mark;
else
if Not_Null_Present then
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
- if Aliased_Present then
- Error_Msg_SP ("ALIASED not allowed here");
- end if;
+ -- AI95-406 makes "aliased" legal (and useless) in this context.
+
+ -- if Aliased_Present then
+ -- Error_Msg_SP ("ALIASED not allowed here");
+ -- end if;
Set_Subtype_Indication (CompDef_Node, Empty);
Set_Aliased_Present (CompDef_Node, False);
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
- if Aliased_Present then
- Error_Msg_SP ("ALIASED not allowed here");
- end if;
+ -- AI95-406 makes "aliased" legal (and useless) here.
+
+ -- if Aliased_Present then
+ -- Error_Msg_SP ("ALIASED not allowed here");
+ -- end if;
Set_Subtype_Indication (CompDef_Node, Empty);
Set_Aliased_Present (CompDef_Node, False);
RE_Reraise_Occurrence_Always, -- Ada.Exceptions
RE_Reraise_Occurrence_No_Defer, -- Ada.Exceptions
RE_Save_Occurrence, -- Ada.Exceptions
+ RE_Triggered_By_Abort, -- Ada.Exceptions
RE_Interrupt_ID, -- Ada.Interrupts
RE_Is_Reserved, -- Ada.Interrupts
RE_Reraise_Occurrence_Always => Ada_Exceptions,
RE_Reraise_Occurrence_No_Defer => Ada_Exceptions,
RE_Save_Occurrence => Ada_Exceptions,
+ RE_Triggered_By_Abort => Ada_Exceptions,
RE_Interrupt_ID => Ada_Interrupts,
RE_Is_Reserved => Ada_Interrupts,
package body System.Storage_Pools.Subpools is
+ Finalize_Address_Table_In_Use : Boolean := False;
+ -- This flag should be set only when a successfull allocation on a subpool
+ -- has been performed and the associated Finalize_Address has been added to
+ -- the hash table in System.Finalization_Masters.
+
procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr);
-- Attach a subpool node to a pool
pragma Assert (not Master.Is_Homogeneous);
Set_Finalize_Address (Addr, Fin_Address);
+ Finalize_Address_Table_In_Use := True;
-- Normal allocations chain objects on homogeneous collections
if Is_Controlled then
-- Destroy the relation pair object - Finalize_Address since it is no
- -- longer needed. If the object was chained on a homogeneous master,
- -- this call does nothing. This is unconditional destruction since we
- -- do not want to drag in additional data to determine the master
- -- kind.
+ -- longer needed.
- Delete_Finalize_Address (Addr);
+ if Finalize_Address_Table_In_Use then
+ Delete_Finalize_Address (Addr);
+ end if;
-- Account for possible padding space before the header due to a
-- larger alignment.
end;
if Subp /= Any_Id then
+
+ -- Subprogram found, generate reference to it.
+
Set_Entity (Def, Subp);
+ Generate_Reference (Subp, Def);
if Subp = Nam then
Error_Msg_N ("premature usage of formal subprogram", Def);
Set_Ekind (Def_Id, E_Loop_Parameter);
if Of_Present (N) then
- -- If the container has already been rewritten as a
- -- call to the default iterator, nothing to do. This
- -- is the case with the expansion of a quantified
- -- expression.
- if Nkind (Name (N)) = N_Function_Call
- and then not Comes_From_Source (Name (N))
- then
- null;
-
- elsif Expander_Active then
-
- -- Find the Iterator_Element and the default_iterator
- -- of the container type.
-
- Set_Etype (Def_Id,
- Entity (
- Find_Aspect (Typ, Aspect_Iterator_Element)));
+ -- The type of the loop variable is the Iterator_Element
+ -- aspect of the container type.
- declare
- Default_Iter : constant Entity_Id :=
- Find_Aspect (Typ, Aspect_Default_Iterator);
- begin
- Rewrite (Name (N),
- Make_Function_Call (Loc,
- Name => Default_Iter,
- Parameter_Associations =>
- New_List (Relocate_Node (Iter_Name))));
- Analyze_And_Resolve (Name (N));
- end;
- end if;
+ Set_Etype (Def_Id,
+ Entity (Find_Aspect (Typ, Aspect_Iterator_Element)));
else
- -- result type of Iterate function is the classwide
- -- type of the interface parent. We need the specific
- -- Cursor type defined in the package.
+ -- The result type of Iterate function is the classwide type
+ -- of the interface parent. We need the specific Cursor type
+ -- defined in the container package.
Ent := First_Entity (Scope (Typ));
while Present (Ent) loop
then
null;
+ -- A renaming of an unchecked union does not have an
+ -- actual subtype.
+
+ elsif Is_Unchecked_Union (Etype (Nam)) then
+ null;
+
else
Subt := Make_Temporary (Loc, 'T');
Remove_Side_Effects (Nam);
end if;
-- Report a simple error: if the designated object is a local task,
- -- its body has not been seen yet, and its activation will fail
- -- an elaboration check.
+ -- its body has not been seen yet, and its activation will fail an
+ -- elaboration check.
if Is_Task_Type (Desig_T)
and then Scope (Base_Type (Desig_T)) = Current_Scope
and then Ekind (Current_Scope) = E_Package
and then not In_Package_Body (Current_Scope)
then
- Error_Msg_N
- ("cannot activate task before body seen?", N);
+ Error_Msg_N ("cannot activate task before body seen?", N);
Error_Msg_N ("\Program_Error will be raised at run time?", N);
end if;
+
+ -- Ada 2012 (AI05-0111-3): Issue a warning whenever allocating a task
+ -- or a type containing tasks on a subpool since the deallocation of
+ -- the subpool may lead to undefined task behavior.
+
+ if Ada_Version >= Ada_2012
+ and then Present (Subpool_Handle_Name (N))
+ and then Has_Task (Desig_T)
+ then
+ Error_Msg_N ("?allocation of task on subpool may lead to " &
+ "undefined behavior", N);
+ end if;
end Resolve_Allocator;
---------------------------
Iface : Entity_Id;
begin
- if not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
+ if Is_Class_Wide_Type (Typ)
+ and then
+ (Chars (Etype (Typ)) = Name_Forward_Iterator
+ or else Chars (Etype (Typ)) = Name_Reversible_Iterator)
+ and then
+ Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
+ then
+ return True;
+
+ elsif not Is_Tagged_Type (Typ)
+ or else not Is_Derived_Type (Typ)
+ then
return False;
else
return False;
end if;
end Is_Iterator;
+
+ ----------------------------
+ -- Is_Reversible_Iterator --
+ ----------------------------
+
+ function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
+ Ifaces_List : Elist_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface : Entity_Id;
+
+ begin
+ if Is_Class_Wide_Type (Typ)
+ and then Chars (Etype (Typ)) = Name_Reversible_Iterator
+ and then
+ Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
+ then
+ return True;
+
+ elsif not Is_Tagged_Type (Typ)
+ or else not Is_Derived_Type (Typ)
+ then
+ return False;
+ else
+
+ Collect_Interfaces (Typ, Ifaces_List);
+
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+ if Chars (Iface) = Name_Reversible_Iterator
+ and then
+ Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Iface)))
+ then
+ return True;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+
+ end if;
+ return False;
+ end Is_Reversible_Iterator;
+
------------
-- Is_LHS --
------------
return False;
end Is_Renamed_Entry;
- ----------------------------
- -- Is_Reversible_Iterator --
- ----------------------------
-
- function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
- Ifaces_List : Elist_Id;
- Iface_Elmt : Elmt_Id;
- Iface : Entity_Id;
-
- begin
- if not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
- return False;
-
- else
- Collect_Interfaces (Typ, Ifaces_List);
-
- Iface_Elmt := First_Elmt (Ifaces_List);
- while Present (Iface_Elmt) loop
- Iface := Node (Iface_Elmt);
- if Chars (Iface) = Name_Reversible_Iterator
- and then
- Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Iface)))
- then
- return True;
- end if;
-
- Next_Elmt (Iface_Elmt);
- end loop;
- end if;
-
- return False;
- end Is_Reversible_Iterator;
-
----------------------
-- Is_Selector_Name --
----------------------
projects / thirdparty / gcc.git / commitdiff
