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

s-rident.ads: Add No_Default_Initialization restriction 

2008-04-08  Robert Dewar  <dewar@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* s-rident.ads: Add No_Default_Initialization restriction

	* exp_tss.adb: 
	(Has_Non_Null_Base_Init_Proc): Handle No_Default_Initialization case
	(Set_TSS): Handle No_Default_Initialization case

	* exp_ch6.adb (Expand_N_Subprogram_Body): Handle restriction
	No_Default_Initialization
	(Expand_N_Subprogram_Body): Remove redundant initialization of out
	parameters when Normalize_Scalars is active.
	(Add_Final_List_Actual_To_Build_In_Place_Call): Add formal Sel_Comp
	Fix casing error in formal parameter name in call
	(Register_Predefined_DT_Entry): Replace occurrences of RE_Address by
	(Expand_Call, Propagate_Tag): Call Kill_Current_Values when processing a
	dispatching call on VM targets.

From-SVN: r134028
This commit is contained in:
Robert Dewar 2008-04-08 08:50:21 +02:00 committed by Arnaud Charlet
parent 45fc7ddb49
commit 70f9118087
3 changed files with 142 additions and 165 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

194
gcc/ada/exp_ch6.adb
View File

@ -1,4 +1,4 @@
------------------------------------------------------------------------------
-----------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
@ -110,13 +110,16 @@ package body Exp_Ch6 is
procedure Add_Final_List_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
Acc_Type : Entity_Id);
Acc_Type : Entity_Id;
Sel_Comp : Node_Id := Empty);
-- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has
-- controlled parts, add an actual parameter that is a pointer to
-- appropriate finalization list. The finalization list is that of the
-- current scope, except for "new Acc'(F(...))" in which case it's the
-- finalization list of the access type returned by the allocator. Acc_Type
-- is that type in the allocator case; Empty otherwise.
-- is that type in the allocator case; Empty otherwise. If Sel_Comp is
-- not Empty, then it denotes a selected component and the finalization
-- list is obtained from the _controller list of the prefix object.
procedure Add_Task_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
@ -379,12 +382,16 @@ package body Exp_Ch6 is
procedure Add_Final_List_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
Acc_Type : Entity_Id)
Acc_Type : Entity_Id;
Sel_Comp : Node_Id := Empty)
is
Loc : constant Source_Ptr := Sloc (Function_Call);
Final_List : Node_Id;
Final_List_Actual : Node_Id;
Final_List_Formal : Node_Id;
Is_Ctrl_Result : constant Boolean :=
Controlled_Type
(Underlying_Type (Etype (Function_Id)));
begin
-- No such extra parameter is needed if there are no controlled parts.
@ -395,7 +402,7 @@ package body Exp_Ch6 is
-- must be treated the same as a call to class-wide functions. Both of
-- these situations require that a finalization list be passed.
if not Controlled_Type (Underlying_Type (Etype (Function_Id)))
if not Is_Ctrl_Result
and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id)))
then
return;
@ -416,6 +423,14 @@ package body Exp_Ch6 is
Present (Associated_Final_Chain (Base_Type (Acc_Type))))
then
Final_List := Find_Final_List (Acc_Type);
-- If Sel_Comp is present and the function result is controlled, then
-- the finalization list will be obtained from the _controller list of
-- the selected component's prefix object.
elsif Present (Sel_Comp) and then Is_Ctrl_Result then
Final_List := Find_Final_List (Current_Scope, Sel_Comp);
else
Final_List := Find_Final_List (Current_Scope);
end if;
@ -1016,7 +1031,7 @@ package body Exp_Ch6 is
Low_Bound =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Var, Loc),
Attribute_name => Name_First),
Attribute_Name => Name_First),
High_Bound =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Var, Loc),
@ -1541,8 +1556,7 @@ package body Exp_Ch6 is
-- formal subtype are not the same, requiring a check.
-- It is necessary to exclude tagged types because of "downward
-- conversion" errors and a strange assertion error in namet
-- from gnatf in bug 1215-001 ???
-- conversion" errors.
elsif Is_Access_Type (E_Formal)
and then not Same_Type (E_Formal, Etype (Actual))
@ -1662,9 +1676,9 @@ package body Exp_Ch6 is
-- This procedure handles expansion of function calls and procedure call
-- statements (i.e. it serves as the body for Expand_N_Function_Call and
-- Expand_N_Procedure_Call_Statement. Processing for calls includes:
-- Expand_N_Procedure_Call_Statement). Processing for calls includes:
-- Replace call to Raise_Exception by Raise_Exception always if possible
-- Replace call to Raise_Exception by Raise_Exception_Always if possible
-- Provide values of actuals for all formals in Extra_Formals list
-- Replace "call" to enumeration literal function by literal itself
-- Rewrite call to predefined operator as operator
@ -1694,12 +1708,12 @@ package body Exp_Ch6 is
function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
-- Within an instance, a type derived from a non-tagged formal derived
-- type inherits from the original parent, not from the actual. This is
-- tested in 4723-003. The current derivation mechanism has the derived
-- type inherit from the actual, which is only correct outside of the
-- instance. If the subprogram is inherited, we test for this particular
-- case through a convoluted tree traversal before setting the proper
-- subprogram to be called.
-- type inherits from the original parent, not from the actual. The
-- current derivation mechanism has the derived type inherit from the
-- actual, which is only correct outside of the instance. If the
-- subprogram is inherited, we test for this particular case through a
-- convoluted tree traversal before setting the proper subprogram to be
-- called.
--------------------------
-- Add_Actual_Parameter --
@ -1919,11 +1933,11 @@ package body Exp_Ch6 is
-- Replace call to Raise_Exception by call to Raise_Exception_Always
-- if we can tell that the first parameter cannot possibly be null.
-- This helps optimization and also generation of warnings.
-- This improves efficiency by avoiding a run-time test.
-- We do not do this if Raise_Exception_Always does not exist, which
-- can happen in configurable run time profiles which provide only a
-- Raise_Exception, which is in fact an unconditional raise anyway.
-- Raise_Exception.
if Is_RTE (Subp, RE_Raise_Exception)
and then RTE_Available (RE_Raise_Exception_Always)
@ -2547,21 +2561,31 @@ package body Exp_Ch6 is
if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
and then Present (Controlling_Argument (N))
and then VM_Target = No_VM
then
Expand_Dispatching_Call (N);
if VM_Target = No_VM then
Expand_Dispatching_Call (N);
-- The following return is worrisome. Is it really OK to
-- skip all remaining processing in this procedure ???
-- The following return is worrisome. Is it really OK to
-- skip all remaining processing in this procedure ???
return;
return;
-- Expansion of a dispatching call results in an indirect call, which
-- in turn causes current values to be killed (see Resolve_Call), so
-- on VM targets we do the call here to ensure consistent warnings
-- between VM and non-VM targets.
else
Kill_Current_Values;
end if;
end if;
-- Similarly, expand calls to RCI subprograms on which pragma
-- All_Calls_Remote applies. The rewriting will be reanalyzed
-- later. Do this only when the call comes from source since we do
-- not want such a rewriting to occur in expanded code.
elsif Is_All_Remote_Call (N) then
if Is_All_Remote_Call (N) then
Expand_All_Calls_Remote_Subprogram_Call (N);
-- Similarly, do not add extra actuals for an entry call whose entity
@ -3110,34 +3134,6 @@ package body Exp_Ch6 is
end if;
end;
end if;
-- Special processing for Ada 2005 AI-329, which requires a call to
-- Raise_Exception to raise Constraint_Error if the Exception_Id is
-- null. Note that we never need to do this in GNAT mode, or if the
-- parameter to Raise_Exception is a use of Identity, since in these
-- cases we know that the parameter is never null.
-- Note: We must check that the node has not been inlined. This is
-- required because under zfp the Raise_Exception subprogram has the
-- pragma inline_always (and hence the call has been expanded above
-- into a block containing the code of the subprogram).
if Ada_Version >= Ada_05
and then not GNAT_Mode
and then Is_RTE (Subp, RE_Raise_Exception)
and then Nkind (N) = N_Procedure_Call_Statement
and then (Nkind (First_Actual (N)) /= N_Attribute_Reference
or else Attribute_Name (First_Actual (N)) /= Name_Identity)
then
declare
RCE : constant Node_Id :=
Make_Raise_Constraint_Error (Loc,
Reason => CE_Null_Exception_Id);
begin
Insert_After (N, RCE);
Analyze (RCE);
end;
end if;
end Expand_Call;
--------------------------
@ -3978,12 +3974,9 @@ package body Exp_Ch6 is
Loc : constant Source_Ptr := Sloc (N);
H : constant Node_Id := Handled_Statement_Sequence (N);
Body_Id : Entity_Id;
Spec_Id : Entity_Id;
Except_H : Node_Id;
Scop : Entity_Id;
Dec : Node_Id;
Next_Op : Node_Id;
L : List_Id;
Spec_Id : Entity_Id;
procedure Add_Return (S : List_Id);
-- Append a return statement to the statement sequence S if the last
@ -4165,6 +4158,8 @@ package body Exp_Ch6 is
if Is_Scalar_Type (Etype (F))
and then Ekind (F) = E_Out_Parameter
then
Check_Restriction (No_Default_Initialization, F);
-- Insert the initialization. We turn off validity checks
-- for this assignment, since we do not want any check on
-- the initial value itself (which may well be invalid).
@ -4172,7 +4167,7 @@ package body Exp_Ch6 is
Insert_Before_And_Analyze (First (L),
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (F, Loc),
Expression => Get_Simple_Init_Val (Etype (F), Loc)),
Expression => Get_Simple_Init_Val (Etype (F), N)),
Suppress => Validity_Check);
end if;
@ -4181,34 +4176,6 @@ package body Exp_Ch6 is
end;
end if;
Scop := Scope (Spec_Id);
-- Add discriminal renamings to protected subprograms. Install new
-- discriminals for expansion of the next subprogram of this protected
-- type, if any.
if Is_List_Member (N)
and then Present (Parent (List_Containing (N)))
and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
then
Add_Discriminal_Declarations
(Declarations (N), Scop, Name_uObject, Loc);
Add_Private_Declarations
(Declarations (N), Scop, Name_uObject, Loc);
-- Associate privals and discriminals with the next protected
-- operation body to be expanded. These are used to expand references
-- to private data objects and discriminants, respectively.
Next_Op := Next_Protected_Operation (N);
if Present (Next_Op) then
Dec := Parent (Base_Type (Scop));
Set_Privals (Dec, Next_Op, Loc);
Set_Discriminals (Dec);
end if;
end if;
-- Clear out statement list for stubbed procedure
if Present (Corresponding_Spec (N)) then
@ -4226,6 +4193,16 @@ package body Exp_Ch6 is
end if;
end if;
-- Create a set of discriminals for the next protected subprogram body
if Is_List_Member (N)
and then Present (Parent (List_Containing (N)))
and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
and then Present (Next_Protected_Operation (N))
then
Set_Discriminals (Parent (Base_Type (Scope (Spec_Id))));
end if;
-- Returns_By_Ref flag is normally set when the subprogram is frozen
-- but subprograms with no specs are not frozen.
@ -4324,37 +4301,6 @@ package body Exp_Ch6 is
Detect_Infinite_Recursion (N, Spec_Id);
end if;
-- Finally, if we are in Normalize_Scalars mode, then any scalar out
-- parameters must be initialized to the appropriate default value.
if Ekind (Spec_Id) = E_Procedure and then Normalize_Scalars then
declare
Floc : Source_Ptr;
Formal : Entity_Id;
Stm : Node_Id;
begin
Formal := First_Formal (Spec_Id);
while Present (Formal) loop
Floc := Sloc (Formal);
if Ekind (Formal) = E_Out_Parameter
and then Is_Scalar_Type (Etype (Formal))
then
Stm :=
Make_Assignment_Statement (Floc,
Name => New_Occurrence_Of (Formal, Floc),
Expression =>
Get_Simple_Init_Val (Etype (Formal), Floc));
Prepend (Stm, Declarations (N));
Analyze (Stm);
end if;
Next_Formal (Formal);
end loop;
end;
end if;
-- Set to encode entity names in package body before gigi is called
Qualify_Entity_Names (N);
@ -4780,7 +4726,7 @@ package body Exp_Ch6 is
New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
Position => DT_Position (Prim),
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))),
@ -4792,7 +4738,7 @@ package body Exp_Ch6 is
Loc),
Position => DT_Position (Prim),
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access)))));
@ -5250,8 +5196,16 @@ package body Exp_Ch6 is
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
Add_Final_List_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Acc_Type => Empty);
-- If Lhs is a selected component, then pass it along so that its prefix
-- object will be used as the source of the finalization list.
if Nkind (Lhs) = N_Selected_Component then
Add_Final_List_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Acc_Type => Empty, Sel_Comp => Lhs);
else
Add_Final_List_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Acc_Type => Empty);
end if;
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));

38
gcc/ada/exp_tss.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -28,6 +28,8 @@ with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Util; use Exp_Util;
with Lib; use Lib;
with Restrict; use Restrict;
with Rident; use Rident;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
@ -159,11 +161,16 @@ package body Exp_Tss is
-- Has_Non_Null_Base_Init_Proc --
---------------------------------
-- Note: if a base Init_Proc is present, and No_Default_Initialization is
-- present, then we must avoid testing for a null init proc, since there
-- is no init proc present in this case.
function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is
BIP : constant Entity_Id := Base_Init_Proc (Typ);
begin
return Present (BIP) and then not Is_Null_Init_Proc (BIP);
return Present (BIP)
and then (Restriction_Active (No_Default_Initialization)
or else not Is_Null_Init_Proc (BIP));
end Has_Non_Null_Base_Init_Proc;
---------------
@ -306,20 +313,31 @@ package body Exp_Tss is
-------------
procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is
Subprog_Body : constant Node_Id := Unit_Declaration_Node (TSS);
begin
-- Case of insertion location is in unit defining the type
-- Make sure body of subprogram is frozen
if In_Same_Code_Unit (Typ, TSS) then
Append_Freeze_Action (Typ, Subprog_Body);
-- Skip this for Init_Proc with No_Default_Initialization, since the
-- Init proc is a dummy void entity in this case to be ignored.
-- Otherwise, we are using an already existing TSS in another unit
if Is_Init_Proc (TSS)
and then Restriction_Active (No_Default_Initialization)
then
null;
-- Skip this if not in the same code unit (since it means we are using
-- an already existing TSS in another unit)
elsif not In_Same_Code_Unit (Typ, TSS) then
null;
-- Otherwise make sure body is frozen
else
null;
Append_Freeze_Action (Typ, Unit_Declaration_Node (TSS));
end if;
-- Set TSS entry
Copy_TSS (TSS, Typ);
end Set_TSS;

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

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, 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- --
@ -56,7 +56,9 @@ package System.Rident is
type Restriction_Id is
-- The following cases are checked for consistency in the binder
-- The following cases are checked for consistency in the binder. The
-- binder will check that every unit either has the restriction set, or
-- does not violate the restriction.
(Simple_Barriers, -- GNAT (Ravenscar)
No_Abort_Statements, -- (RM D.7(5), H.4(3))
@ -111,7 +113,12 @@ package System.Rident is
Static_Priorities, -- GNAT
Static_Storage_Size, -- GNAT
-- The following cases do not require partition-wide checks
-- The following require consistency checking with special rules. See
-- individual routines in unit Bcheck for details of what is required.
No_Default_Initialization, -- GNAT
-- The following cases do not require consistency checking
Immediate_Reclamation, -- (RM H.4(10))
No_Implementation_Attributes, -- Ada 2005 AI-257
@ -123,29 +130,28 @@ package System.Rident is
-- The following cases require a parameter value
-- The following entries are fully checked at compile/bind time,
-- which means that the compiler can in general tell the minimum
-- value which could be used with a restrictions pragma. The binder
-- can deduce the appropriate minimum value for the partition by
-- taking the maximum value required by any unit.
-- The following entries are fully checked at compile/bind time, which
-- means that the compiler can in general tell the minimum value which
-- could be used with a restrictions pragma. The binder can deduce the
-- appropriate minimum value for the partition by taking the maximum
-- value required by any unit.
Max_Protected_Entries, -- (RM D.7(14))
Max_Select_Alternatives, -- (RM D.7(12))
Max_Task_Entries, -- (RM D.7(13), H.4(3))
-- The following entries are also fully checked at compile/bind
-- time, and the compiler can also at least in some cases tell
-- the minimum value which could be used with a restriction pragma.
-- The difference is that the contributions are additive, so the
-- binder deduces this value by adding the unit contributions.
-- The following entries are also fully checked at compile/bind time,
-- and the compiler can also at least in some cases tell the minimum
-- value which could be used with a restriction pragma. The difference
-- is that the contributions are additive, so the binder deduces this
-- value by adding the unit contributions.
Max_Tasks, -- (RM D.7(19), H.4(3))
-- The following entries are checked at compile time only for
-- zero/nonzero entries. This means that the compiler can tell
-- at compile time if a restriction value of zero is (would be)
-- violated, but that is all. The compiler cannot distinguish
-- between different non-zero values.
-- The following entries are checked at compile time only for zero/
-- nonzero entries. This means that the compiler can tell at compile
-- time if a restriction value of zero is (would be) violated, but that
-- the compiler cannot distinguish between different non-zero values.
Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3))
Max_Entry_Queue_Length, -- GNAT
@ -237,9 +243,9 @@ package System.Rident is
-- Restriction Status Declarations --
-------------------------------------
-- The following declarations are used to record the current status
-- or restrictions (for the current unit, or related units, at compile
-- time, and for all units in a partition at bind time or run time).
-- The following declarations are used to record the current status or
-- restrictions (for the current unit, or related units, at compile time,
-- and for all units in a partition at bind time or run time).
type Restriction_Flags is array (All_Restrictions) of Boolean;
type Restriction_Values is array (All_Parameter_Restrictions) of Natural;
@ -247,11 +253,10 @@ package System.Rident is
type Restrictions_Info is record
Set : Restriction_Flags;
-- An entry is True in the Set array if a restrictions pragma has
-- been encountered for the given restriction. If the value is
-- True for a parameter restriction, then the corresponding entry
-- in the Value array gives the minimum value encountered for any
-- such restriction.
-- An entry is True in the Set array if a restrictions pragma has been
-- encountered for the given restriction. If the value is True for a
-- parameter restriction, then the corresponding entry in the Value
-- array gives the minimum value encountered for any such restriction.
Value : Restriction_Values;
-- If the entry for a parameter restriction in Set is True (i.e. a
@ -261,23 +266,23 @@ package System.Rident is
-- pragma specifying a value greater than Int'Last is simply ignored.
Violated : Restriction_Flags;
-- An entry is True in the violations array if the compiler has
-- detected a violation of the restriction. For a parameter
-- restriction, the Count and Unknown arrays have additional
-- information.
-- An entry is True in the violations array if the compiler has detected
-- a violation of the restriction. For a parameter restriction, the
-- Count and Unknown arrays have additional information.
Count : Restriction_Values;
-- If an entry for a parameter restriction is True in Violated,
-- the corresponding entry in the Count array may record additional
-- If an entry for a parameter restriction is True in Violated, the
-- corresponding entry in the Count array may record additional
-- information. If the actual minimum count is known (by taking
-- maximums, or sums, depending on the restriction), it will be
-- recorded in this array. If not, then the value will remain zero.
-- The value is also zero for a non-violated restriction.
Unknown : Parameter_Flags;
-- If an entry for a parameter restriction is True in Violated,
-- the corresponding entry in the Unknown array may record additional
-- If an entry for a parameter restriction is True in Violated, the
-- corresponding entry in the Unknown array may record additional
-- information. If the actual count is not known by the compiler (but
-- is known to be non-zero), then the entry in Unknown will be True.
-- is nown to be non-zero), then the entry in Unknown will be True.
-- This indicates that the value in Count is not known to be exact,
-- and the actual violation count may be higher.