+2011-08-03 Javier Miranda <miranda@adacore.com>
+
+ * sem_prag.adb (Process_Interface_Name): Allow duplicated export names
+ in Java since they are always enclosed in a namespace that
+ differentiates them, and overloaded entities are supported by the VM.
+
+2011-08-03 Ed Schonberg <schonberg@adacore.com>
+
+ * checks.adb (Determine_Range): If a computed bound of an operation is
+ outside the range of the base type of the expression, and overflow
+ checks are enabled, the result is unknown and cannot be used for any
+ subsequent constant folding.
+ * sem_eval.adb (Compile_Time_Compare): if the bounds of one operand are
+ unknown, so is the result of the comparison.
+
+2011-08-03 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * a-except-2005.adb (Raise_From_Controlled_Operation): Add new formal
+ From_Abort. When finalization was triggered by an abort, propagate
+ Standard'Abort_Signal rather than Program_Error.
+ * a-except-2005.ads (Raise_From_Controlled_Operation): Add new formal
+ From_Abort.
+ * a-except.adb (Raise_From_Controlled_Operation): Add new formal
+ From_Abort. When finalization was triggered by an abort, propagate
+ Standard'Abort_Signal rather than Program_Error.
+ * a-except.ads:(Raise_From_Controlled_Operation): Add new formal
+ From_Abort.
+ * exp_ch7.adb:(Build_Adjust_Or_Finalize_Statements): New local variable
+ Abort_Id. Update the calls to Build_Object_Declarations and
+ Build_Raise_Statement to include Abort_Id.
+ (Build_Adjust_Statements): New local variable Abort_Id. Update the
+ calls to Build_Object_Declarations and Build_Raise_Statement to include
+ Abort_Id.
+ (Build_Finalize_Statements): New local variable Abort_Id. Update the
+ calls to Build_Object_Declarations and Build_Raise_Statement to include
+ Abort_Id.
+ (Build_Components): Create an entity for Abort_Id when exceptions are
+ allowed on the target.
+ (Build_Finalizer): New local variable Abort_Id.
+ (Build_Initialize_Statements): New local variable Abort_Id. Update the
+ calls to Build_Object_Declarations and Build_Raise_Statement to include
+ Abort_Id.
+ (Build_Object_Declarations): Add new formal Abort_Id. Create the
+ declaration of flag Abort_Id to preserve the original abort status
+ before finalization code is executed.
+ (Build_Raise_Statement): Add new formal Abort_Id. Pass Abort_Id to
+ runtime routine Raise_From_Controlled_Operation.
+ (Create_Finalizer): Update the call to Build_Raise_Statement to include
+ Abort_Id. Update the call to Build_Object_Declarations to include
+ Abort_Id. Update the layout of the finalizer body.
+ (Make_Handler_For_Ctrl_Operation): Add an actual for From_Abort.
+ (Process_Transient_Objects): New local variable Abort_Id. Remove the
+ clunky code to create all flags and objects related to
+ exception propagation and replace it with a call to
+ Build_Object_Declarations. Update the call to Build_Raise_Statement to
+ include Abort_Id.
+ * exp_ch7.ads (Build_Object_Declarations): Moved from body to spec.
+ Add new formal Abort_Id and associated comment on its use.
+ (Build_Raise_Statement): Add new formal Abort_Id and associated comment
+ on its use.
+ * exp_intr.adb (Expand_Unc_Deallocation): New local variable Abort_Id.
+ Remove the clunky code to create all flags and objects related to
+ exception propagation and replace it with a call to
+ Build_Object_Declarations. Update the call to Build_Raise_Statement.
+
+2011-08-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * s-tassta.adb: Fix minor typos.
+
+2011-08-03 Robert Dewar <dewar@adacore.com>
+
+ * rtsfind.ads, makeutl.ads, prj.ads, prj.adb, make.adb,
+ lib-writ.adb, makeutl.adb, s-soflin.ads, clean.adb: Minor reformatting.
+
2011-08-03 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Create_Finalizer): Treat freeze nodes in similar fashion
-------------------------------------
procedure Raise_From_Controlled_Operation
- (X : Ada.Exceptions.Exception_Occurrence)
+ (X : Ada.Exceptions.Exception_Occurrence;
+ From_Abort : Boolean)
is
- Prev_Exc : constant EOA := Get_Current_Excep.all;
-
begin
- -- We're raising an exception during finalization. If the finalization
- -- was triggered by an abort, as indicated by Not_Handled_By_Others,
- -- then we don't want to raise Program_Error; we want to continue with
- -- the Abort_Signal exception. Note that the original exception
- -- occurrence that triggered the finalization is saved before calling
- -- the Finalize procedures, and then restored afterward, so in the case
- -- of abort, the original Abort_Signal will be the current one.
+ -- When finalization was triggered by an abort, keep propagating the
+ -- abort signal rather than raising Program_Error.
- if Prev_Exc.Id /= null and then Prev_Exc.Id.Not_Handled_By_Others then
- Raise_Current_Excep (Prev_Exc.Id);
+ if From_Abort then
+ raise Standard'Abort_Signal;
-- Otherwise, raise Program_Error
-- system to return here rather than to the original location.
procedure Raise_From_Controlled_Operation
- (X : Ada.Exceptions.Exception_Occurrence);
+ (X : Ada.Exceptions.Exception_Occurrence;
+ From_Abort : Boolean);
pragma No_Return (Raise_From_Controlled_Operation);
pragma Export
(Ada, Raise_From_Controlled_Operation,
-------------------------------------
procedure Raise_From_Controlled_Operation
- (X : Ada.Exceptions.Exception_Occurrence)
+ (X : Ada.Exceptions.Exception_Occurrence;
+ From_Abort : Boolean)
is
- Prev_Exc : constant EOA := Get_Current_Excep.all;
-
begin
- -- We're raising an exception during finalization. If the finalization
- -- was triggered by an abort, as indicated by Not_Handled_By_Others,
- -- then we don't want to raise Program_Error; we want to continue with
- -- the Abort_Signal exception. Note that the original exception
- -- occurrence that triggered the finalization is saved before calling
- -- the Finalize procedures, and then restored afterward, so in the case
- -- of abort, the original Abort_Signal will be the current one.
+ -- When finalization was triggered by an abort, keep propagating the
+ -- abort signal rather than raising Program_Error.
- if Prev_Exc.Id /= null and then Prev_Exc.Id.Not_Handled_By_Others then
- Raise_Current_Excep (Prev_Exc.Id);
+ if From_Abort then
+ raise Standard'Abort_Signal;
-- Otherwise, raise Program_Error
Prefix : constant String := "adjust/finalize raised ";
Orig_Msg : constant String := Exception_Message (X);
Orig_Prefix_Length : constant Natural :=
- Integer'Min (Prefix'Length, Orig_Msg'Length);
+ Integer'Min
+ (Prefix'Length, Orig_Msg'Length);
Orig_Prefix : String renames Orig_Msg
- (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1);
+ (Orig_Msg'First ..
+ Orig_Msg'First + Orig_Prefix_Length - 1);
begin
-- Message already has proper prefix, just re-reraise
-- system to return here rather than to the original location.
procedure Raise_From_Controlled_Operation
- (X : Ada.Exceptions.Exception_Occurrence);
+ (X : Ada.Exceptions.Exception_Occurrence;
+ From_Abort : Boolean);
pragma No_Return (Raise_From_Controlled_Operation);
pragma Export
(Ada, Raise_From_Controlled_Operation,
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- the computed expression is in the range Lor .. Hir. We can use this
-- to restrict the possible range of results.
+ -- If one of the computed bounds is outside the range of the base type,
+ -- the expression may raise an exception and we better indicate that
+ -- the evaluation has failed, at least if checks are enabled.
+
+ if Enable_Overflow_Checks
+ and then not Is_Entity_Name (N)
+ and then (Lor < Lo or else Hir > Hi)
+ then
+ OK := False;
+ return;
+ end if;
+
if OK1 then
-- If the refined value of the low bound is greater than the type
Text : Text_Buffer_Ptr;
The_ALI : ALI_Id;
-
- Found : Boolean;
- Source : Queue.Source_Info;
+ Found : Boolean;
+ Source : Queue.Source_Info;
begin
Queue.Initialize (Queue_Per_Obj_Dir => False);
for N_File in 1 .. Osint.Number_Of_Files loop
Main_Source_File := Next_Main_Source;
- Main_Lib_File := Osint.Lib_File_Name
- (Main_Source_File, Current_File_Index);
+ Main_Lib_File :=
+ Osint.Lib_File_Name (Main_Source_File, Current_File_Index);
if Main_Lib_File /= No_File then
Queue.Insert
-- an exception handler, the statements will be wrapped in a block to avoid
-- unwanted interaction with the new At_End handler.
- function Build_Object_Declarations
- (Loc : Source_Ptr;
- E_Id : Entity_Id;
- Raised_Id : Entity_Id) return List_Id;
- -- Subsidiary to Make_Deep_Array_Body and Make_Deep_Record_Body. Return a
- -- list containing the object declarations of the exception occurrence E_Id
- -- and boolean flag Raised_Id.
- --
- -- E_Id : Exception_Occurrence;
- -- Raised_Id : Boolean := False;
-
procedure Build_Record_Deep_Procs (Typ : Entity_Id);
-- Build the deep Initialize/Adjust/Finalize for a record Typ with
-- Has_Component_Component set and store them using the TSS mechanism.
-- structures right from the start. Entities and lists are created once
-- it has been established that N has at least one controlled object.
+ Abort_Id : Entity_Id := Empty;
+ -- Entity of local flag. The flag is set when finalization is triggered
+ -- by an abort.
+
Components_Built : Boolean := False;
-- A flag used to avoid double initialization of entities and lists. If
-- the flag is set then the following variables have been initialized:
--
+ -- Abort_Id
-- Counter_Id
-- E_Id
-- Finalizer_Decls
Counter_Typ := Make_Temporary (Loc, 'T');
if Exceptions_OK then
+ Abort_Id := Make_Temporary (Loc, 'A');
E_Id := Make_Temporary (Loc, 'E');
Raised_Id := Make_Temporary (Loc, 'R');
end if;
procedure Create_Finalizer is
Conv_Name : Name_Id;
- E_Decl : Node_Id;
Fin_Body : Node_Id;
Fin_Spec : Node_Id;
Jump_Block : Node_Id;
-- level finalizers. Generate:
--
-- if Raised then
- -- Raise_From_Controlled_Operation (E);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
if not For_Package
and then Exceptions_OK
then
Append_To (Finalizer_Stmts,
- Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
end if;
-- Create the jump block which controls the finalization flow
-- Generate:
-- procedure Fin_Id is
+ -- Abort : constant Boolean :=
+ -- Exception_Occurrence (Get_Current_Excep.all.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
+
-- E : Exception_Occurrence; -- All added if flag
-- Raised : Boolean := False; -- Has_Ctrl_Objs is set
-- L0 : label;
-- ...
-- Lnn : label;
+
-- begin
-- Abort_Defer; -- Added if abort is allowed
-- <call to Prev_At_End> -- Added if exists
if Has_Ctrl_Objs
and then Exceptions_OK
then
- -- Generate:
- -- Raised : Boolean := False;
-
- Prepend_To (Finalizer_Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Raised_Id,
- Object_Definition =>
- New_Reference_To (Standard_Boolean, Loc),
- Expression =>
- New_Reference_To (Standard_False, Loc)));
-
- -- Generate:
- -- E : Exception_Occurrence;
-
- E_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => E_Id,
- Object_Definition =>
- New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
- Set_No_Initialization (E_Decl);
-
- Prepend_To (Finalizer_Decls, E_Decl);
+ Prepend_List_To (Finalizer_Decls,
+ Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id));
end if;
-- Create the body of the finalizer
function Build_Object_Declarations
(Loc : Source_Ptr;
+ Abort_Id : Entity_Id;
E_Id : Entity_Id;
Raised_Id : Entity_Id) return List_Id
is
+ A_Expr : Node_Id;
E_Decl : Node_Id;
begin
return Empty_List;
end if;
+ pragma Assert (Present (Abort_Id));
pragma Assert (Present (E_Id));
pragma Assert (Present (Raised_Id));
+ -- Generate:
+ -- Exception_Identity (Get_Current_Excep.all.all) =
+ -- Standard'Abort_Signal'Identity;
+
+ if Abort_Allowed then
+ A_Expr :=
+ 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 =>
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ New_Reference_To
+ (RTE (RE_Get_Current_Excep), Loc)))))),
+
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (Stand.Abort_Signal, Loc),
+ Attribute_Name => Name_Identity));
+ else
+ A_Expr := New_Reference_To (Standard_False, Loc);
+ end if;
+
+ -- Generate:
+ -- E_Id : Exception_Occurrence;
+
E_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => E_Id,
New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
Set_No_Initialization (E_Decl);
- return New_List (E_Decl,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Raised_Id,
- Object_Definition =>
- New_Reference_To (Standard_Boolean, Loc),
- Expression =>
- New_Reference_To (Standard_False, Loc)));
+ return
+ New_List (
+
+ -- Abort_Id
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Abort_Id,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Expression => A_Expr),
+
+ -- E_Id
+
+ E_Decl,
+
+ -- Raised_Id
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Raised_Id,
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Expression =>
+ New_Reference_To (Standard_False, Loc)));
end Build_Object_Declarations;
---------------------------
---------------------------
function Build_Raise_Statement
- (Loc : Source_Ptr;
- E_Id : Entity_Id;
- R_Id : Entity_Id) return Node_Id
+ (Loc : Source_Ptr;
+ Abort_Id : Entity_Id;
+ E_Id : Entity_Id;
+ Raised_Id : Entity_Id) return Node_Id
is
- Raise_Id : Entity_Id;
+ Params : List_Id;
+ Proc_Id : Entity_Id;
begin
+ -- The default parameter is the local exception occurrence
+
+ Params := New_List (New_Reference_To (E_Id, Loc));
+
+ -- .NET/JVM
+
if VM_Target /= No_VM then
- Raise_Id := RTE (RE_Reraise_Occurrence);
+ Proc_Id := RTE (RE_Reraise_Occurrence);
- -- Standard run-time library
+ -- Standard run-time library, this case handles finalization exceptions
+ -- raised during an abort.
elsif RTE_Available (RE_Raise_From_Controlled_Operation) then
- Raise_Id := RTE (RE_Raise_From_Controlled_Operation);
+ Proc_Id := RTE (RE_Raise_From_Controlled_Operation);
+ Append_To (Params, New_Reference_To (Abort_Id, Loc));
-- Restricted runtime: exception messages are not supported and hence
-- Raise_From_Controlled_Operation is not supported.
else
- Raise_Id := RTE (RE_Reraise_Occurrence);
+ Proc_Id := RTE (RE_Reraise_Occurrence);
end if;
-- Generate:
- -- if R_Id then
- -- <Raise_Id> (E_Id);
+ -- if Raised_Id then
+ -- <Proc_Id> (<Params>);
-- end if;
return
Make_If_Statement (Loc,
Condition =>
- New_Reference_To (R_Id, Loc),
+ New_Reference_To (Raised_Id, Loc),
Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Reference_To (Raise_Id, Loc),
- Parameter_Associations => New_List (
- New_Reference_To (E_Id, Loc)))));
+ New_Reference_To (Proc_Id, Loc),
+ Parameter_Associations => Params)));
end Build_Raise_Statement;
-----------------------------
Last_Object : Node_Id;
Related_Node : Node_Id)
is
+ Abort_Id : Entity_Id;
Built : Boolean := False;
Desig : Entity_Id;
- E_Decl : Node_Id;
E_Id : Entity_Id;
Fin_Block : Node_Id;
Last_Fin : Node_Id := Empty;
-- time around.
if not Built then
-
- -- Generate:
- -- Enn : Exception_Occurrence;
-
- E_Id := Make_Temporary (Loc, 'E');
-
- E_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => E_Id,
- Object_Definition =>
- New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
- Set_No_Initialization (E_Decl);
- Insert_Before_And_Analyze (First_Object, E_Decl);
-
- -- Generate:
- -- Rnn : Boolean := False;
-
+ Abort_Id := Make_Temporary (Loc, 'A');
+ E_Id := Make_Temporary (Loc, 'E');
Raised_Id := Make_Temporary (Loc, 'R');
- Insert_Before_And_Analyze (First_Object,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Raised_Id,
- Object_Definition =>
- New_Reference_To (Standard_Boolean, Loc),
- Expression =>
- New_Reference_To (Standard_False, Loc)));
+ Insert_List_Before_And_Analyze (First_Object,
+ Build_Object_Declarations
+ (Loc, Abort_Id, E_Id, Raised_Id));
Built := True;
end if;
-- Generate:
-- if Rnn then
- -- Raise_From_Controlled_Operation (Enn);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
if Built
and then Present (Last_Fin)
then
Insert_After_And_Analyze (Last_Fin,
- Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
end if;
end Process_Transient_Objects;
-- controlled elements. Generate:
-- declare
+ -- Abort : constant Boolean :=
+ -- Exception_Identity (Get_Current_Excep.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
+
-- E : Exception_Occurrence;
-- Raised : Boolean := False;
-- end loop;
-- if Raised then
- -- Raise_From_Controlled_Operation (E);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
-- end;
-- exception
-- when others =>
-- declare
+ -- Abort : constant Boolean :=
+ -- Exception_Identity (Get_Current_Excep.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
-- E : Exception_Occurence;
-- Raised : Boolean := False;
-- end;
-- if Raised then
- -- Raise_From_Controlled_Operation (E);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
-- raise;
Index_List : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (Typ);
Num_Dims : constant Int := Number_Dimensions (Typ);
+ Abort_Id : Entity_Id := Empty;
Call : Node_Id;
Comp_Ref : Node_Id;
Core_Loop : Node_Id;
Build_Indices;
if Exceptions_OK then
+ Abort_Id := Make_Temporary (Loc, 'A');
E_Id := Make_Temporary (Loc, 'E');
Raised_Id := Make_Temporary (Loc, 'R');
end if;
end loop;
-- Generate the block which contains the core loop, the declarations
- -- of the flag and exception occurrence and the conditional raise:
+ -- of the abort flag, the exception occurrence, the raised flag and
+ -- the conditional raise:
-- declare
+ -- Abort : constant Boolean :=
+ -- Exception_Occurrence (Get_Current_Excep.all.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
+
-- E : Exception_Occurrence;
-- Raised : Boolean := False;
-- <core loop>
-- if Raised then -- Expection handlers allowed
- -- Raise_From_Controlled_Operation (E);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
-- end;
Stmts := New_List (Core_Loop);
if Exceptions_OK then
- Append_To (Stmts, Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ Append_To (Stmts,
+ Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
end if;
return
New_List (
Make_Block_Statement (Loc,
Declarations =>
- Build_Object_Declarations (Loc, E_Id, Raised_Id),
+ Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts)));
Index_List : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (Typ);
Num_Dims : constant Int := Number_Dimensions (Typ);
+ Abort_Id : Entity_Id;
Counter_Id : Entity_Id;
Dim : Int;
E_Id : Entity_Id := Empty;
Counter_Id := Make_Temporary (Loc, 'C');
if Exceptions_OK then
+ Abort_Id := Make_Temporary (Loc, 'A');
E_Id := Make_Temporary (Loc, 'E');
Raised_Id := Make_Temporary (Loc, 'R');
end if;
Dim := Dim - 1;
end loop;
- -- Generate the block which houses the finalization failure flag,
- -- all the finalization loops and the exception raise.
+ -- Generate the block which contains the finalization loops, the
+ -- declarations of the abort flag, the exception occurrence, the
+ -- raised flag and the conditional raise.
-- declare
+ -- Abort : constant Boolean :=
+ -- Exception_Occurrence (Get_Current_Excep.all.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
+
-- E : Exception_Occurrence;
-- Raised : Boolean := False;
-- <final loop>
-- if Raised then -- Exception handlers allowed
- -- Raise_From_Controlled_Operation (E);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
-- raise; -- Exception handlers allowed
Stmts := New_List (Build_Counter_Assignment, Final_Loop);
if Exceptions_OK then
- Append_To (Stmts, Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ Append_To (Stmts,
+ Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
Append_To (Stmts, Make_Raise_Statement (Loc));
end if;
Final_Block :=
Make_Block_Statement (Loc,
Declarations =>
- Build_Object_Declarations (Loc, E_Id, Raised_Id),
+ Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
-- end if;
-- if Raised then
- -- Raise_From_Controlled_Object (E);
+ -- Raise_From_Controlled_Object (E, Abort);
-- end if;
-- end;
-- may have discriminants and contain variant parts. Generate:
-- declare
+ -- Abort : constant Boolean :=
+ -- Exception_Identity (Get_Current_Excep.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
-- E : Exception_Occurence;
-- Raised : Boolean := False;
-- Root_Controlled (V).Finalized := True;
-- if Raised then
- -- Raise_From_Controlled_Object (E);
+ -- Raise_From_Controlled_Object (E, Abort);
-- end if;
-- end;
function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
+ Abort_Id : Entity_Id := Empty;
Bod_Stmts : List_Id;
E_Id : Entity_Id := Empty;
Raised_Id : Entity_Id := Empty;
begin
if Exceptions_OK then
+ Abort_Id := Make_Temporary (Loc, 'A');
E_Id := Make_Temporary (Loc, 'E');
Raised_Id := Make_Temporary (Loc, 'R');
end if;
-- Generate:
-- declare
+ -- Abort : constant Boolean :=
+ -- Exception_Occurrence (Get_Current_Excep.all.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
+
-- E : Exception_Occurence;
-- Raised : Boolean := False;
-- <adjust statements>
-- if Raised then
- -- Raise_From_Controlled_Operation (E);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
-- end;
else
if Exceptions_OK then
Append_To (Bod_Stmts,
- Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
end if;
return
New_List (
Make_Block_Statement (Loc,
Declarations =>
- Build_Object_Declarations (Loc, E_Id, Raised_Id),
+ Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
+ Abort_Id : Entity_Id := Empty;
Bod_Stmts : List_Id;
Counter : Int := 0;
E_Id : Entity_Id := Empty;
begin
if Exceptions_OK then
+ Abort_Id := Make_Temporary (Loc, 'A');
E_Id := Make_Temporary (Loc, 'E');
Raised_Id := Make_Temporary (Loc, 'R');
end if;
-- Generate:
-- declare
+ -- Abort : constant Boolean :=
+ -- Exception_Occurrence (Get_Current_Excep.all.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
+
-- E : Exception_Occurence;
-- Raised : Boolean := False;
-- V.Finalized := True;
-- if Raised then
- -- Raise_From_Controlled_Operation (E);
+ -- Raise_From_Controlled_Operation (E, Abort);
-- end if;
-- end;
else
if Exceptions_OK then
Append_To (Bod_Stmts,
- Build_Raise_Statement (Loc, E_Id, Raised_Id));
+ Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
end if;
return
New_List (
Make_Block_Statement (Loc,
Declarations =>
- Build_Object_Declarations (Loc, E_Id, Raised_Id),
+ Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
-- Generate:
-- when E : others =>
- -- Raise_From_Controlled_Operation (X => E);
+ -- Raise_From_Controlled_Operation (E, False);
-- or:
Raise_Node :=
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Reference_To (
- RTE (RE_Raise_From_Controlled_Operation), Loc),
+ New_Reference_To
+ (RTE (RE_Raise_From_Controlled_Operation), Loc),
Parameter_Associations => New_List (
- New_Reference_To (E_Occ, Loc)));
+ New_Reference_To (E_Occ, Loc),
+ New_Reference_To (Standard_False, Loc)));
-- Restricted runtime: exception messages are not supported
-- Build one controlling procedure when a late body overrides one of
-- the controlling operations.
+ function Build_Object_Declarations
+ (Loc : Source_Ptr;
+ Abort_Id : Entity_Id;
+ E_Id : Entity_Id;
+ Raised_Id : Entity_Id) return List_Id;
+ -- Subsidiary to Make_Deep_Array_Body and Make_Deep_Record_Body. Return a
+ -- list containing the object declarations of boolean flag Abort_Id, the
+ -- exception occurrence E_Id and boolean flag Raised_Id.
+ --
+ -- Abort_Id : constant Boolean :=
+ -- Exception_Identity (Get_Current_Excep.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort_Id : constant Boolean := False; -- no abort
+ --
+ -- E_Id : Exception_Occurrence;
+ -- Raised_Id : Boolean := False;
+
function Build_Raise_Statement
- (Loc : Source_Ptr;
- E_Id : Entity_Id;
- R_Id : Entity_Id) return Node_Id;
+ (Loc : Source_Ptr;
+ Abort_Id : Entity_Id;
+ E_Id : Entity_Id;
+ Raised_Id : Entity_Id) return Node_Id;
-- Subsidiary to routines Build_Finalizer, Make_Deep_Array_Body and Make_
-- Deep_Record_Body. Generate the following conditional raise statement:
--
- -- if R_Id then
- -- Raise_From_Controlled_Operation (E_Id);
+ -- if Raised_Id then
+ -- Raise_From_Controlled_Operation (E_Id, Abort_Id);
-- end if;
--
- -- E_Id denotes the defining identifier of a local exception occurrence,
- -- R_Id is the entity of a local boolean flag.
+ -- Abort_Id is a local boolean flag which is set when the finalization was
+ -- triggered by an abort, E_Id denotes the defining identifier of a local
+ -- exception occurrence, Raised_Id is the entity of a local boolean flag.
function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean;
-- True if T is a class-wide type, or if it has controlled parts ("part"
Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp);
Stmts : constant List_Id := New_List;
- Blk : Node_Id := Empty;
- Deref : Node_Id;
- Exc_Occ_Decl : Node_Id;
- Exc_Occ_Id : Entity_Id := Empty;
- Final_Code : List_Id;
- Free_Arg : Node_Id;
- Free_Node : Node_Id;
- Gen_Code : Node_Id;
- Raised_Decl : Node_Id;
- Raised_Id : Entity_Id := Empty;
+ Abort_Id : Entity_Id := Empty;
+ Blk : Node_Id := Empty;
+ Deref : Node_Id;
+ E_Id : Entity_Id := Empty;
+ Final_Code : List_Id;
+ Free_Arg : Node_Id;
+ Free_Node : Node_Id;
+ Gen_Code : Node_Id;
+ Raised_Id : Entity_Id := Empty;
Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N);
-- This captures whether we know the argument to be non-null so that
-- the later raise.
--
-- Generate:
- -- Raised : Boolean := False;
- -- Exc_Occ : Exception_Occurrence;
+ -- Abort : constant Boolean :=
+ -- Exception_Occurrence (Get_Current_Excep.all.all) =
+ -- Standard'Abort_Signal'Identity;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
+
+ -- E : Exception_Occurrence;
+ -- Raised : Boolean := False;
--
-- begin
-- [Deep_]Finalize (Obj);
-- exception
-- when others =>
-- Raised := True;
- -- Save_Occurrence (Exc_Occ, Get_Current_Excep.all.all);
+ -- Save_Occurrence (E, Get_Current_Excep.all.all);
-- end;
- Exc_Occ_Id := Make_Temporary (Loc, 'E');
- Raised_Id := Make_Temporary (Loc, 'R');
+ Abort_Id := Make_Temporary (Loc, 'A');
+ E_Id := Make_Temporary (Loc, 'E');
+ Raised_Id := Make_Temporary (Loc, 'R');
- Raised_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Raised_Id,
- Object_Definition =>
- New_Reference_To (Standard_Boolean, Loc),
- Expression =>
- New_Reference_To (Standard_False, Loc));
-
- Append_To (Stmts, Raised_Decl);
-
- Exc_Occ_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Exc_Occ_Id,
- Object_Definition =>
- New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
- Set_No_Initialization (Exc_Occ_Decl);
-
- Append_To (Stmts, Exc_Occ_Decl);
+ Append_List_To (Stmts,
+ Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id));
Final_Code := New_List (
Make_Block_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Save_Occurrence), Loc),
Parameter_Associations => New_List (
- New_Reference_To (Exc_Occ_Id, Loc),
+ New_Reference_To (E_Id, Loc),
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Function_Call (Loc,
--
-- Generate:
-- if Raised then
- -- Reraise_Occurrence (Exc_Occ); -- for .NET and
- -- -- restricted RTS
+ -- Reraise_Occurrence (E); -- for .NET and
+ -- -- restricted RTS
-- <or>
- -- Raise_From_Controlled_Operation (Exc_Occ); -- all other cases
+ -- Raise_From_Controlled_Operation (E, Abort); -- all other cases
-- end if;
if Present (Raised_Id) then
- Append_To (Stmts, Build_Raise_Statement (Loc, Exc_Occ_Id, Raised_Id));
+ Append_To (Stmts,
+ Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
end if;
-- If we know the argument is non-null, then make a block statement
Write_Info_Str (" O");
Write_Info_Char (OA_Setting (Unit_Num));
- if (Ekind (Uent) = E_Package
- or else Ekind (Uent) = E_Package_Body)
+ if Ekind_In (Uent, E_Package, E_Package_Body)
and then Present (Finalizer (Uent))
then
Write_Info_Str (" PF");
new String'(Name_Buffer (1 .. Name_Len));
Test_If_Relative_Path
(New_Args (Last_New),
- Do_Fail => Make_Failed'Access,
- Parent => Dir_Path,
+ Do_Fail => Make_Failed'Access,
+ Parent => Dir_Path,
Including_Non_Switch => False);
end if;
end loop;
Add_Arguments
- (Configuration_Pragmas_Switch
- (Arguments_Project) &
- New_Args (1 .. Last_New) &
- The_Saved_Gcc_Switches.all);
+ (Configuration_Pragmas_Switch (Arguments_Project)
+ & New_Args (1 .. Last_New)
+ & The_Saved_Gcc_Switches.all);
end;
end;
(Name_Buffer (1 .. Name_Len)));
Dir_Path : constant String :=
Get_Name_String
- (Arguments_Project.
- Directory.Display_Name);
+ (Arguments_Project.
+ Directory.Display_Name);
begin
Test_If_Relative_Path
if Add_It then
if not Queue.Insert
- ((Format => Format_Gnatmake,
- File => Sfile,
- Unit => No_Unit_Name,
- Project => No_Project,
- Index => 0))
+ ((Format => Format_Gnatmake,
+ File => Sfile,
+ Unit => No_Unit_Name,
+ Project => No_Project,
+ Index => 0))
then
if Is_In_Obsoleted (Sfile) then
Executable_Obsolete := True;
-- except those of library projects.
Prj.Env.Set_Ada_Paths
- (Project => Main_Project,
- In_Tree => Project_Tree,
+ (Project => Main_Project,
+ In_Tree => Project_Tree,
Including_Libraries => False,
- Include_Path => Use_Include_Path_File);
+ Include_Path => Use_Include_Path_File);
-- If switch -C was specified, create a binder mapping file
Linker_Switches.Increment_Last;
Linker_Switches.Table (Linker_Switches.Last) :=
new String'("-l" &
- Get_Name_String
- (Library_Projs.Table (Index).
- Library_Name));
+ Get_Name_String
+ (Library_Projs.Table (Index).
+ Library_Name));
end if;
end if;
end loop;
Test_If_Relative_Path
(Binder_Switches.Table (J),
Do_Fail => Make_Failed'Access,
- Parent => Dir_Path, Including_L_Switch => False);
+ Parent => Dir_Path, Including_L_Switch => False);
end loop;
for
J in Last_Linker_Switch + 1 .. Linker_Switches.Last
loop
Test_If_Relative_Path
- (Linker_Switches.Table (J), Parent => Dir_Path,
+ (Linker_Switches.Table (J),
+ Parent => Dir_Path,
Do_Fail => Make_Failed'Access);
end loop;
end;
-- We now put in the Binder_Switches and Linker_Switches
-- tables, the binder and linker switches of the command
- -- line that have been put in the Saved_ tables.
- -- These switches will follow the project file switches.
+ -- line that have been put in the Saved_ tables. These
+ -- switches will follow the project file switches.
for J in 1 .. Saved_Binder_Switches.Last loop
Add_Switch
if Do_Codepeer_Globalize_Step then
declare
Success : Boolean := False;
+
begin
Globalize (Success);
-- Test for trailing -D switch
elsif Object_Directory_Present
- and then not Object_Directory_Seen then
+ and then not Object_Directory_Seen
+ then
Make_Failed ("object directory missing after -D");
end if;
for Next_Arg in 1 .. Argument_Count loop
declare
Argv : constant String := Argument (Next_Arg);
+
begin
if Argv'Length > 2
and then Argv (1) = '-'
elsif Program_Args /= None then
- -- Check to see if we are reading -I switches in order
- -- to take into account in the src & lib search directories.
+ -- Check to see if we are reading -I switches in order to take into
+ -- account in the src & lib search directories.
if Argv'Length > 2 and then Argv (1 .. 2) = "-I" then
if Argv (3 .. Argv'Last) = "-" then
------------------------------
function Check_Source_Info_In_ALI
- (The_ALI : ALI_Id;
- Tree : Project_Tree_Ref) return Boolean
+ (The_ALI : ALI_Id;
+ Tree : Project_Tree_Ref) return Boolean
is
Unit_Name : Name_Id;
-- paths must be converted to absolute paths.
Test_If_Relative_Path
- (Switch => Linker_Options_Buffer (Last_Linker_Option),
- Parent => Dir_Path,
+ (Switch => Linker_Options_Buffer (Last_Linker_Option),
+ Parent => Dir_Path,
Do_Fail => Do_Fail,
Including_L_Switch => True);
end if;
procedure Extract
(Found : out Boolean;
- Source : out Source_Info) is
+ Source : out Source_Info)
+ is
begin
Found := False;
procedure Initialize
(Queue_Per_Obj_Dir : Boolean;
- Force : Boolean := False) is
+ Force : Boolean := False)
+ is
begin
if Force or else not Q_Initialized then
Q_Initialized := True;
------------
procedure Insert (Source : Source_Info) is
- Tmp : Boolean;
- pragma Unreferenced (Tmp);
+ Discard : Boolean;
+ pragma Unreferenced (Discard);
begin
- Tmp := Insert (Source);
+ Discard := Insert (Source);
end Insert;
--------------
-- queue management.
with ALI;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Namet; use Namet;
+with Namet; use Namet;
with Opt;
-with Prj; use Prj;
+with Prj; use Prj;
with Prj.Tree;
-with Types; use Types;
+with Types; use Types;
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
package Makeutl is
Including_L_Switch : Boolean := True;
Including_Non_Switch : Boolean := True;
Including_RTS : Boolean := False);
- -- Test if Switch is a relative search path switch. If it is, fail if
- -- Parent is the empty string, otherwise prepend the path with Parent.
- -- This subprogram is only called when using project files. For gnatbind
- -- switches, Including_L_Switch is False, because the argument of the -L
- -- switch is not a path. If Including_RTS is True, process also switches
- -- --RTS=.
- -- Do_Fail is called in case of error. Using Osing.Fail might be
+ -- Test if Switch is a relative search path switch. If so, fail if Parent
+ -- is the empty string, otherwise prepend the path with Parent. This
+ -- subprogram is only used when using project files. For gnatbind switches,
+ -- Including_L_Switch is False, because the argument of the -L switch is
+ -- not a path. If Including_RTS is True, process also switches --RTS=.
+ -- Do_Fail is called in case of error. Using Osint.Fail might be
-- appropriate.
function Path_Or_File_Name (Path : Path_Name_Type) return String;
begin
if Tree /= null then
if Tree.Is_Root_Tree then
- Name_List_Table.Free (Tree.Shared.Name_Lists);
- Number_List_Table.Free (Tree.Shared.Number_Lists);
- String_Element_Table.Free (Tree.Shared.String_Elements);
+ Name_List_Table.Free (Tree.Shared.Name_Lists);
+ Number_List_Table.Free (Tree.Shared.Number_Lists);
+ String_Element_Table.Free (Tree.Shared.String_Elements);
Variable_Element_Table.Free (Tree.Shared.Variable_Elements);
- Array_Element_Table.Free (Tree.Shared.Array_Elements);
- Array_Table.Free (Tree.Shared.Arrays);
- Package_Table.Free (Tree.Shared.Packages);
-
- Temp_Files_Table.Free (Tree.Shared.Private_Part.Temp_Files);
+ Array_Element_Table.Free (Tree.Shared.Array_Elements);
+ Array_Table.Free (Tree.Shared.Arrays);
+ Package_Table.Free (Tree.Shared.Packages);
+ Temp_Files_Table.Free (Tree.Shared.Private_Part.Temp_Files);
end if;
Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
Array_Elements : Array_Element_Table.Instance;
Arrays : Array_Table.Instance;
Packages : Package_Table.Instance;
-
Private_Part : Private_Project_Tree_Data;
end record;
type Shared_Project_Tree_Data_Access is access all Shared_Project_Tree_Data;
-- package see declarations in the runtime entity table below.
RTU_Null,
- -- Used as a null entry. Will cause an error if referenced.
+ -- Used as a null entry (will cause an error if referenced)
-- Children of Ada
pragma Suppress_Initialization (No_Param_Proc);
-- Some uninitialized objects of that type are initialized by the Binder
-- so it is important that such objects are not reset to null during
- -- elaboration
+ -- elaboration.
type Addr_Param_Proc is access procedure (Addr : Address);
pragma Favor_Top_Level (Addr_Param_Proc);
Finalize_Library_Objects : No_Param_Proc;
pragma Export (C, Finalize_Library_Objects,
"__gnat_finalize_library_objects");
- -- will be initialized by the binder
+ -- Will be initialized by the binder
Adafinal : No_Param_Proc := Adafinal_NT'Access;
-- Performs the finalization of the Ada Runtime
-- Package elaboration code
begin
- -- Establish the Adafinal oftlink
+ -- Establish the Adafinal softlink
-- This is not done inside the central RTS initialization routine
- -- to avoid with-ing this package from System.Tasking.Initialization.
+ -- to avoid with'ing this package from System.Tasking.Initialization.
SSL.Adafinal := Finalize_Global_Tasks'Access;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
return Unknown;
end if;
end if;
+ else
+
+ -- If the range of either operand cannot be determined,
+ -- nothing further can be inferred.
+
+ return Unknown;
end if;
end;
(Get_Base_Subprogram (Subprogram_Def), Link_Nam);
end if;
- -- We allow duplicated export names in CIL, as they are always
+ -- We allow duplicated export names in CIL/Java, as they are always
-- enclosed in a namespace that differentiates them, and overloaded
-- entities are supported by the VM.
- if Convention (Subprogram_Def) /= Convention_CIL then
+ if Convention (Subprogram_Def) /= Convention_CIL
+ and then Convention (Subprogram_Def) /= Convention_Java
+ then
Check_Duplicated_Export_Name (Link_Nam);
end if;
end Process_Interface_Name;
projects / gcc.git / commitdiff