Commit 70f91180 by Robert Dewar Committed by Arnaud Charlet

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
parent 45fc7ddb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -28,6 +28,8 @@ with Einfo; use Einfo; ...@@ -28,6 +28,8 @@ with Einfo; use Einfo;
with Elists; use Elists; with Elists; use Elists;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Lib; use Lib; with Lib; use Lib;
with Restrict; use Restrict;
with Rident; use Rident;
with Sem_Util; use Sem_Util; with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
...@@ -159,11 +161,16 @@ package body Exp_Tss is ...@@ -159,11 +161,16 @@ package body Exp_Tss is
-- Has_Non_Null_Base_Init_Proc -- -- 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 function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is
BIP : constant Entity_Id := Base_Init_Proc (Typ); BIP : constant Entity_Id := Base_Init_Proc (Typ);
begin 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; end Has_Non_Null_Base_Init_Proc;
--------------- ---------------
...@@ -306,20 +313,31 @@ package body Exp_Tss is ...@@ -306,20 +313,31 @@ package body Exp_Tss is
------------- -------------
procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is
Subprog_Body : constant Node_Id := Unit_Declaration_Node (TSS);
begin 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 -- Skip this for Init_Proc with No_Default_Initialization, since the
Append_Freeze_Action (Typ, Subprog_Body); -- 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;
else -- 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; null;
-- Otherwise make sure body is frozen
else
Append_Freeze_Action (Typ, Unit_Declaration_Node (TSS));
end if; end if;
-- Set TSS entry
Copy_TSS (TSS, Typ); Copy_TSS (TSS, Typ);
end Set_TSS; end Set_TSS;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -56,7 +56,9 @@ package System.Rident is ...@@ -56,7 +56,9 @@ package System.Rident is
type Restriction_Id 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) (Simple_Barriers, -- GNAT (Ravenscar)
No_Abort_Statements, -- (RM D.7(5), H.4(3)) No_Abort_Statements, -- (RM D.7(5), H.4(3))
...@@ -111,7 +113,12 @@ package System.Rident is ...@@ -111,7 +113,12 @@ package System.Rident is
Static_Priorities, -- GNAT Static_Priorities, -- GNAT
Static_Storage_Size, -- 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)) Immediate_Reclamation, -- (RM H.4(10))
No_Implementation_Attributes, -- Ada 2005 AI-257 No_Implementation_Attributes, -- Ada 2005 AI-257
...@@ -123,29 +130,28 @@ package System.Rident is ...@@ -123,29 +130,28 @@ package System.Rident is
-- The following cases require a parameter value -- The following cases require a parameter value
-- The following entries are fully checked at compile/bind time, -- The following entries are fully checked at compile/bind time, which
-- which means that the compiler can in general tell the minimum -- means that the compiler can in general tell the minimum value which
-- value which could be used with a restrictions pragma. The binder -- could be used with a restrictions pragma. The binder can deduce the
-- can deduce the appropriate minimum value for the partition by -- appropriate minimum value for the partition by taking the maximum
-- taking the maximum value required by any unit. -- value required by any unit.
Max_Protected_Entries, -- (RM D.7(14)) Max_Protected_Entries, -- (RM D.7(14))
Max_Select_Alternatives, -- (RM D.7(12)) Max_Select_Alternatives, -- (RM D.7(12))
Max_Task_Entries, -- (RM D.7(13), H.4(3)) Max_Task_Entries, -- (RM D.7(13), H.4(3))
-- The following entries are also fully checked at compile/bind -- The following entries are also fully checked at compile/bind time,
-- time, and the compiler can also at least in some cases tell -- and the compiler can also at least in some cases tell the minimum
-- the minimum value which could be used with a restriction pragma. -- value which could be used with a restriction pragma. The difference
-- The difference is that the contributions are additive, so the -- is that the contributions are additive, so the binder deduces this
-- binder deduces this value by adding the unit contributions. -- value by adding the unit contributions.
Max_Tasks, -- (RM D.7(19), H.4(3)) Max_Tasks, -- (RM D.7(19), H.4(3))
-- The following entries are checked at compile time only for -- The following entries are checked at compile time only for zero/
-- zero/nonzero entries. This means that the compiler can tell -- nonzero entries. This means that the compiler can tell at compile
-- at compile time if a restriction value of zero is (would be) -- time if a restriction value of zero is (would be) violated, but that
-- violated, but that is all. The compiler cannot distinguish -- the compiler cannot distinguish between different non-zero values.
-- between different non-zero values.
Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3)) Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3))
Max_Entry_Queue_Length, -- GNAT Max_Entry_Queue_Length, -- GNAT
...@@ -237,9 +243,9 @@ package System.Rident is ...@@ -237,9 +243,9 @@ package System.Rident is
-- Restriction Status Declarations -- -- Restriction Status Declarations --
------------------------------------- -------------------------------------
-- The following declarations are used to record the current status -- The following declarations are used to record the current status or
-- or restrictions (for the current unit, or related units, at compile -- restrictions (for the current unit, or related units, at compile time,
-- time, and for all units in a partition at bind time or run 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_Flags is array (All_Restrictions) of Boolean;
type Restriction_Values is array (All_Parameter_Restrictions) of Natural; type Restriction_Values is array (All_Parameter_Restrictions) of Natural;
...@@ -247,11 +253,10 @@ package System.Rident is ...@@ -247,11 +253,10 @@ package System.Rident is
type Restrictions_Info is record type Restrictions_Info is record
Set : Restriction_Flags; Set : Restriction_Flags;
-- An entry is True in the Set array if a restrictions pragma has -- An entry is True in the Set array if a restrictions pragma has been
-- been encountered for the given restriction. If the value is -- encountered for the given restriction. If the value is True for a
-- True for a parameter restriction, then the corresponding entry -- parameter restriction, then the corresponding entry in the Value
-- in the Value array gives the minimum value encountered for any -- array gives the minimum value encountered for any such restriction.
-- such restriction.
Value : Restriction_Values; Value : Restriction_Values;
-- If the entry for a parameter restriction in Set is True (i.e. a -- If the entry for a parameter restriction in Set is True (i.e. a
...@@ -261,23 +266,23 @@ package System.Rident is ...@@ -261,23 +266,23 @@ package System.Rident is
-- pragma specifying a value greater than Int'Last is simply ignored. -- pragma specifying a value greater than Int'Last is simply ignored.
Violated : Restriction_Flags; Violated : Restriction_Flags;
-- An entry is True in the violations array if the compiler has -- An entry is True in the violations array if the compiler has detected
-- detected a violation of the restriction. For a parameter -- a violation of the restriction. For a parameter restriction, the
-- restriction, the Count and Unknown arrays have additional -- Count and Unknown arrays have additional information.
-- information.
Count : Restriction_Values; Count : Restriction_Values;
-- If an entry for a parameter restriction is True in Violated, -- If an entry for a parameter restriction is True in Violated, the
-- the corresponding entry in the Count array may record additional -- corresponding entry in the Count array may record additional
-- information. If the actual minimum count is known (by taking -- information. If the actual minimum count is known (by taking
-- maximums, or sums, depending on the restriction), it will be -- maximums, or sums, depending on the restriction), it will be
-- recorded in this array. If not, then the value will remain zero. -- 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; Unknown : Parameter_Flags;
-- If an entry for a parameter restriction is True in Violated, -- If an entry for a parameter restriction is True in Violated, the
-- the corresponding entry in the Unknown array may record additional -- corresponding entry in the Unknown array may record additional
-- information. If the actual count is not known by the compiler (but -- 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, -- This indicates that the value in Count is not known to be exact,
-- and the actual violation count may be higher. -- and the actual violation count may be higher.
......
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