Skip to content

R
riscv-gcc-1
Commit 6eab5a95 by Arnaud Charlet
Options

[multiple changes] 

2009-07-15  Robert Dewar  <dewar@adacore.com>

	* sem_ch10.adb: Minor reformatting throughout
	Minor code reorganization (put nested subprograms in alpha order)

2009-07-15  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch6.adb (Expand_Call): Prevent double attachment of the result
	when compiling a call to a protected function that returns a controlled
	object.

2009-07-15  Hristian Kirtchev  <kirtchev@adacore.com>

	* sysdep.c (__gnat_localtime_tzoff): Consolidate the Lynx cases into
	one. Add task locking and unlocking around the critical region which
	mentions localtime_r and global variable timezone for various targets.
	Comment reformatting.

From-SVN: r149686
parent 3eb532e6
Showing with 374 additions and 335 deletions
gcc/ada/ChangeLog
2009-07-15 Robert Dewar <dewar@adacore.com> 2009-07-15 Robert Dewar <dewar@adacore.com>
* sem_ch10.adb: Minor reformatting throughout
Minor code reorganization (put nested subprograms in alpha order)
2009-07-15 Ed Schonberg <schonberg@adacore.com>
* exp_ch6.adb (Expand_Call): Prevent double attachment of the result
when compiling a call to a protected function that returns a controlled
object.
2009-07-15 Hristian Kirtchev <kirtchev@adacore.com>
* sysdep.c (__gnat_localtime_tzoff): Consolidate the Lynx cases into
one. Add task locking and unlocking around the critical region which
mentions localtime_r and global variable timezone for various targets.
Comment reformatting.
2009-07-15 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Document s-ststop.ads * gnat_rm.texi: Document s-ststop.ads
* impunit.ad: (Map_Array): New table of alternative names * impunit.ad: (Map_Array): New table of alternative names
......
gcc/ada/exp_ch6.adb
...@@ -3097,10 +3097,17 @@ package body Exp_Ch6 is ...@@ -3097,10 +3097,17 @@ package body Exp_Ch6 is
-- Functions returning controlled objects need special attention: -- Functions returning controlled objects need special attention:
-- if the return type is limited, the context is an initialization -- if the return type is limited, the context is an initialization
-- and different processing applies. -- and different processing applies. If the call is to a protected
-- function, the expansion above will call Expand_Call recusively.
-- To prevent a double attachment, check that the current call is
-- not a rewriting of a protected function call.
if Needs_Finalization (Etype (Subp)) if Needs_Finalization (Etype (Subp))
and then not Is_Inherently_Limited_Type (Etype (Subp)) and then not Is_Inherently_Limited_Type (Etype (Subp))
and then
(No (First_Formal (Subp))
or else
not Is_Concurrent_Record_Type (Etype (First_Formal (Subp))))
then then
Expand_Ctrl_Function_Call (N); Expand_Ctrl_Function_Call (N);
end if; end if;
......
gcc/ada/sem_ch10.adb
...@@ -77,13 +77,13 @@ package body Sem_Ch10 is ...@@ -77,13 +77,13 @@ package body Sem_Ch10 is
procedure Build_Limited_Views (N : Node_Id); procedure Build_Limited_Views (N : Node_Id);
-- Build and decorate the list of shadow entities for a package mentioned -- Build and decorate the list of shadow entities for a package mentioned
-- in a limited_with clause. If the package was not previously analyzed -- in a limited_with clause. If the package was not previously analyzed
-- then it also performs a basic decoration of the real entities; this -- then it also performs a basic decoration of the real entities. This is
-- is required to do not pass non-decorated entities to the back-end. -- required to do not pass non-decorated entities to the back-end.
-- Implements Ada 2005 (AI-50217). -- Implements Ada 2005 (AI-50217).
procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id); procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
-- Check whether the source for the body of a compilation unit must -- Check whether the source for the body of a compilation unit must be
-- be included in a standalone library. -- included in a standalone library.
procedure Check_Private_Child_Unit (N : Node_Id); procedure Check_Private_Child_Unit (N : Node_Id);
-- If a with_clause mentions a private child unit, the compilation -- If a with_clause mentions a private child unit, the compilation
...@@ -130,8 +130,8 @@ package body Sem_Ch10 is ...@@ -130,8 +130,8 @@ package body Sem_Ch10 is
-- and use_clauses for current unit and its library unit if any. -- and use_clauses for current unit and its library unit if any.
procedure Install_Limited_Context_Clauses (N : Node_Id); procedure Install_Limited_Context_Clauses (N : Node_Id);
-- Subsidiary to Install_Context. Process only limited with_clauses -- Subsidiary to Install_Context. Process only limited with_clauses for
-- for current unit. Implements Ada 2005 (AI-50217). -- current unit. Implements Ada 2005 (AI-50217).
procedure Install_Limited_Withed_Unit (N : Node_Id); procedure Install_Limited_Withed_Unit (N : Node_Id);
-- Place shadow entities for a limited_with package in the visibility -- Place shadow entities for a limited_with package in the visibility
...@@ -140,11 +140,11 @@ package body Sem_Ch10 is ...@@ -140,11 +140,11 @@ package body Sem_Ch10 is
procedure Install_Withed_Unit procedure Install_Withed_Unit
(With_Clause : Node_Id; (With_Clause : Node_Id;
Private_With_OK : Boolean := False); Private_With_OK : Boolean := False);
-- If the unit is not a child unit, make unit immediately visible. -- If the unit is not a child unit, make unit immediately visible. The
-- The caller ensures that the unit is not already currently installed. -- caller ensures that the unit is not already currently installed. The
-- The flag Private_With_OK is set true in Install_Private_With_Clauses, -- flag Private_With_OK is set true in Install_Private_With_Clauses, which
-- which is called when compiling the private part of a package, or -- is called when compiling the private part of a package, or installing
-- installing the private declarations of a parent unit. -- the private declarations of a parent unit.
procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean); procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean);
-- This procedure establishes the context for the compilation of a child -- This procedure establishes the context for the compilation of a child
...@@ -170,8 +170,8 @@ package body Sem_Ch10 is ...@@ -170,8 +170,8 @@ package body Sem_Ch10 is
-- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
-- compilation unit for the parent spec. -- compilation unit for the parent spec.
-- --
-- Lib_Unit can also be a subprogram body that acts as its own spec. If -- Lib_Unit can also be a subprogram body that acts as its own spec. If the
-- the Parent_Spec is non-empty, this is also a child unit. -- Parent_Spec is non-empty, this is also a child unit.
procedure Remove_Context_Clauses (N : Node_Id); procedure Remove_Context_Clauses (N : Node_Id);
-- Subsidiary of previous one. Remove use_ and with_clauses -- Subsidiary of previous one. Remove use_ and with_clauses
...@@ -664,13 +664,13 @@ package body Sem_Ch10 is ...@@ -664,13 +664,13 @@ package body Sem_Ch10 is
Analyze_Context (N); Analyze_Context (N);
-- If the unit is a package body, the spec is already loaded and must -- If the unit is a package body, the spec is already loaded and must be
-- be analyzed first, before we analyze the body. -- analyzed first, before we analyze the body.
if Nkind (Unit_Node) = N_Package_Body then if Nkind (Unit_Node) = N_Package_Body then
-- If no Lib_Unit, then there was a serious previous error, so -- If no Lib_Unit, then there was a serious previous error, so just
-- just ignore the entire analysis effort -- ignore the entire analysis effort
if No (Lib_Unit) then if No (Lib_Unit) then
return; return;
...@@ -688,8 +688,8 @@ package body Sem_Ch10 is ...@@ -688,8 +688,8 @@ package body Sem_Ch10 is
("no legal package declaration for package body", N); ("no legal package declaration for package body", N);
return; return;
-- Otherwise, the entity in the declaration is visible. Update -- Otherwise, the entity in the declaration is visible. Update the
-- the version to reflect dependence of this body on the spec. -- version to reflect dependence of this body on the spec.
else else
Spec_Id := Defining_Entity (Unit (Lib_Unit)); Spec_Id := Defining_Entity (Unit (Lib_Unit));
...@@ -1108,29 +1108,29 @@ package body Sem_Ch10 is ...@@ -1108,29 +1108,29 @@ package body Sem_Ch10 is
-- Case of units which do not require elaboration checks -- Case of units which do not require elaboration checks
if if
-- Pure units do not need checks -- Pure units do not need checks
Is_Pure (Spec_Id) Is_Pure (Spec_Id)
-- Preelaborated units do not need checks -- Preelaborated units do not need checks
or else Is_Preelaborated (Spec_Id) or else Is_Preelaborated (Spec_Id)
-- No checks needed if pragma Elaborate_Body present -- No checks needed if pragma Elaborate_Body present
or else Has_Pragma_Elaborate_Body (Spec_Id) or else Has_Pragma_Elaborate_Body (Spec_Id)
-- No checks needed if unit does not require a body -- No checks needed if unit does not require a body
or else not Unit_Requires_Body (Spec_Id) or else not Unit_Requires_Body (Spec_Id)
-- No checks needed for predefined files -- No checks needed for predefined files
or else Is_Predefined_File_Name (Unit_File_Name (Unum)) or else Is_Predefined_File_Name (Unit_File_Name (Unum))
-- No checks required if no separate spec -- No checks required if no separate spec
or else Acts_As_Spec (N) or else Acts_As_Spec (N)
then then
-- This is a case where we only need the entity for -- This is a case where we only need the entity for
-- checking to prevent multiple elaboration checks. -- checking to prevent multiple elaboration checks.
...@@ -1283,15 +1283,15 @@ package body Sem_Ch10 is ...@@ -1283,15 +1283,15 @@ package body Sem_Ch10 is
while Present (Item) loop while Present (Item) loop
-- For with clause, analyze the with clause, and then update -- For with clause, analyze the with clause, and then update the
-- the version, since we are dependent on a unit that we with. -- version, since we are dependent on a unit that we with.
if Nkind (Item) = N_With_Clause if Nkind (Item) = N_With_Clause
and then not Limited_Present (Item) and then not Limited_Present (Item)
then then
-- Skip analyzing with clause if no unit, nothing to do (this -- Skip analyzing with clause if no unit, nothing to do (this
-- happens for a with that references a non-existent unit) -- happens for a with that references a non-existent unit). Skip
-- Skip as well if this is a with_clause for the main unit, which -- as well if this is a with_clause for the main unit, which
-- happens if a subunit has a useless with_clause on its parent. -- happens if a subunit has a useless with_clause on its parent.
if Present (Library_Unit (Item)) then if Present (Library_Unit (Item)) then
...@@ -1338,8 +1338,8 @@ package body Sem_Ch10 is ...@@ -1338,8 +1338,8 @@ package body Sem_Ch10 is
if not Implicit_With (Item) then if not Implicit_With (Item) then
-- Verify that the illegal contexts given in 10.1.2 (18/2) -- Verify that the illegal contexts given in 10.1.2 (18/2) are
-- are properly rejected, including renaming declarations. -- properly rejected, including renaming declarations.
if not Nkind_In (Ukind, N_Package_Declaration, if not Nkind_In (Ukind, N_Package_Declaration,
N_Subprogram_Declaration) N_Subprogram_Declaration)
...@@ -1400,8 +1400,8 @@ package body Sem_Ch10 is ...@@ -1400,8 +1400,8 @@ package body Sem_Ch10 is
and then not Limited_Present (It) and then not Limited_Present (It)
and then and then
Nkind_In (Unit (Library_Unit (It)), Nkind_In (Unit (Library_Unit (It)),
N_Package_Declaration, N_Package_Declaration,
N_Package_Renaming_Declaration) N_Package_Renaming_Declaration)
then then
if Nkind (Unit (Library_Unit (It))) = if Nkind (Unit (Library_Unit (It))) =
N_Package_Declaration N_Package_Declaration
...@@ -1512,8 +1512,8 @@ package body Sem_Ch10 is ...@@ -1512,8 +1512,8 @@ package body Sem_Ch10 is
------------------------- -------------------------
procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is
Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N); Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
Unum : Unit_Number_Type; Unum : Unit_Number_Type;
procedure Optional_Subunit; procedure Optional_Subunit;
-- This procedure is called when the main unit is a stub, or when we -- This procedure is called when the main unit is a stub, or when we
...@@ -1556,8 +1556,8 @@ package body Sem_Ch10 is ...@@ -1556,8 +1556,8 @@ package body Sem_Ch10 is
then then
Comp_Unit := Cunit (Unum); Comp_Unit := Cunit (Unum);
-- If the file was empty or seriously mangled, the unit -- If the file was empty or seriously mangled, the unit itself may
-- itself may be missing. -- be missing.
if No (Unit (Comp_Unit)) then if No (Unit (Comp_Unit)) then
Error_Msg_N Error_Msg_N
...@@ -1588,16 +1588,16 @@ package body Sem_Ch10 is ...@@ -1588,16 +1588,16 @@ package body Sem_Ch10 is
-- Start of processing for Analyze_Proper_Body -- Start of processing for Analyze_Proper_Body
begin begin
-- If the subunit is already loaded, it means that the main unit -- If the subunit is already loaded, it means that the main unit is a
-- is a subunit, and that the current unit is one of its parents -- subunit, and that the current unit is one of its parents which was
-- which was being analyzed to provide the needed context for the -- being analyzed to provide the needed context for the analysis of the
-- analysis of the subunit. In this case we analyze the subunit and -- subunit. In this case we analyze the subunit and continue with the
-- continue with the parent, without looking a subsequent subunits. -- parent, without looking a subsequent subunits.
if Is_Loaded (Subunit_Name) then if Is_Loaded (Subunit_Name) then
-- If the proper body is already linked to the stub node, -- If the proper body is already linked to the stub node, the stub is
-- the stub is in a generic unit and just needs analyzing. -- in a generic unit and just needs analyzing.
if Present (Library_Unit (N)) then if Present (Library_Unit (N)) then
Set_Corresponding_Stub (Unit (Library_Unit (N)), N); Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
...@@ -1606,9 +1606,9 @@ package body Sem_Ch10 is ...@@ -1606,9 +1606,9 @@ package body Sem_Ch10 is
-- Otherwise we must load the subunit and link to it -- Otherwise we must load the subunit and link to it
else else
-- Load the subunit, this must work, since we originally -- Load the subunit, this must work, since we originally loaded
-- loaded the subunit earlier on. So this will not really -- the subunit earlier on. So this will not really load it, just
-- load it, just give access to it. -- give access to it.
Unum := Unum :=
Load_Unit Load_Unit
...@@ -1814,13 +1814,12 @@ package body Sem_Ch10 is ...@@ -1814,13 +1814,12 @@ package body Sem_Ch10 is
-- Analyze_Subprogram_Body_Stub -- -- Analyze_Subprogram_Body_Stub --
---------------------------------- ----------------------------------
-- A subprogram body stub can appear with or without a previous -- A subprogram body stub can appear with or without a previous spec. If
-- specification. If there is one, the analysis of the body will -- there is one, then the analysis of the body will find it and verify
-- find it and verify conformance. The formals appearing in the -- conformance. The formals appearing in the specification of the stub play
-- specification of the stub play no role, except for requiring an -- no role, except for requiring an additional conformance check. If there
-- additional conformance check. If there is no previous subprogram -- is no previous subprogram declaration, the stub acts as a spec, and
-- declaration, the stub acts as a spec, and provides the defining -- provides the defining entity for the subprogram.
-- entity for the subprogram.
procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is
Decl : Node_Id; Decl : Node_Id;
...@@ -1861,21 +1860,19 @@ package body Sem_Ch10 is ...@@ -1861,21 +1860,19 @@ package body Sem_Ch10 is
-- Analyze_Subunit -- -- Analyze_Subunit --
--------------------- ---------------------
-- A subunit is compiled either by itself (for semantic checking) -- A subunit is compiled either by itself (for semantic checking) or as
-- or as part of compiling the parent (for code generation). In -- part of compiling the parent (for code generation). In either case, by
-- either case, by the time we actually process the subunit, the -- the time we actually process the subunit, the parent has already been
-- parent has already been installed and analyzed. The node N is -- installed and analyzed. The node N is a compilation unit, whose context
-- a compilation unit, whose context needs to be treated here, -- needs to be treated here, because we come directly here from the parent
-- because we come directly here from the parent without calling -- without calling Analyze_Compilation_Unit.
-- Analyze_Compilation_Unit.
-- The compilation context includes the explicit context of the subunit,
-- The compilation context includes the explicit context of the -- and the context of the parent, together with the parent itself. In order
-- subunit, and the context of the parent, together with the parent -- to compile the current context, we remove the one inherited from the
-- itself. In order to compile the current context, we remove the -- parent, in order to have a clean visibility table. We restore the parent
-- one inherited from the parent, in order to have a clean visibility -- context before analyzing the proper body itself. On exit, we remove only
-- table. We restore the parent context before analyzing the proper -- the explicit context of the subunit.
-- body itself. On exit, we remove only the explicit context of the
-- subunit.
procedure Analyze_Subunit (N : Node_Id) is procedure Analyze_Subunit (N : Node_Id) is
Lib_Unit : constant Node_Id := Library_Unit (N); Lib_Unit : constant Node_Id := Library_Unit (N);
...@@ -1888,29 +1885,29 @@ package body Sem_Ch10 is ...@@ -1888,29 +1885,29 @@ package body Sem_Ch10 is
Svg : constant Suppress_Array := Scope_Suppress; Svg : constant Suppress_Array := Scope_Suppress;
procedure Analyze_Subunit_Context; procedure Analyze_Subunit_Context;
-- Capture names in use clauses of the subunit. This must be done -- Capture names in use clauses of the subunit. This must be done before
-- before re-installing parent declarations, because items in the -- re-installing parent declarations, because items in the context must
-- context must not be hidden by declarations local to the parent. -- not be hidden by declarations local to the parent.
procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id); procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id);
-- Recursive procedure to restore scope of all ancestors of subunit, -- Recursive procedure to restore scope of all ancestors of subunit,
-- from outermost in. If parent is not a subunit, the call to install -- from outermost in. If parent is not a subunit, the call to install
-- context installs context of spec and (if parent is a child unit) -- context installs context of spec and (if parent is a child unit) the
-- the context of its parents as well. It is confusing that parents -- context of its parents as well. It is confusing that parents should
-- should be treated differently in both cases, but the semantics are -- be treated differently in both cases, but the semantics are just not
-- just not identical. -- identical.
procedure Re_Install_Use_Clauses; procedure Re_Install_Use_Clauses;
-- As part of the removal of the parent scope, the use clauses are -- As part of the removal of the parent scope, the use clauses are
-- removed, to be reinstalled when the context of the subunit has -- removed, to be reinstalled when the context of the subunit has been
-- been analyzed. Use clauses may also have been affected by the -- analyzed. Use clauses may also have been affected by the analysis of
-- analysis of the context of the subunit, so they have to be applied -- the context of the subunit, so they have to be applied again, to
-- again, to insure that the compilation environment of the rest of -- insure that the compilation environment of the rest of the parent
-- the parent unit is identical. -- unit is identical.
procedure Remove_Scope; procedure Remove_Scope;
-- Remove current scope from scope stack, and preserve the list -- Remove current scope from scope stack, and preserve the list of use
-- of use clauses in it, to be reinstalled after context is analyzed. -- clauses in it, to be reinstalled after context is analyzed.
----------------------------- -----------------------------
-- Analyze_Subunit_Context -- -- Analyze_Subunit_Context --
...@@ -1969,8 +1966,8 @@ package body Sem_Ch10 is ...@@ -1969,8 +1966,8 @@ package body Sem_Ch10 is
Next (Item); Next (Item);
end loop; end loop;
-- Reset visibility of withed units. They will be made visible -- Reset visibility of withed units. They will be made visible again
-- again when we install the subunit context. -- when we install the subunit context.
Item := First (Context_Items (N)); Item := First (Context_Items (N));
while Present (Item) loop while Present (Item) loop
...@@ -2038,9 +2035,9 @@ package body Sem_Ch10 is ...@@ -2038,9 +2035,9 @@ package body Sem_Ch10 is
Next_Entity (E); Next_Entity (E);
end loop; end loop;
-- A subunit appears within a body, and for a nested subunits -- A subunit appears within a body, and for a nested subunits all the
-- all the parents are bodies. Restore full visibility of their -- parents are bodies. Restore full visibility of their private
-- private entities. -- entities.
if Is_Package_Or_Generic_Package (Scop) then if Is_Package_Or_Generic_Package (Scop) then
Set_In_Package_Body (Scop); Set_In_Package_Body (Scop);
...@@ -2097,8 +2094,8 @@ package body Sem_Ch10 is ...@@ -2097,8 +2094,8 @@ package body Sem_Ch10 is
Remove_Scope; Remove_Scope;
Remove_Context (Lib_Unit); Remove_Context (Lib_Unit);
-- Now remove parents and their context, including enclosing -- Now remove parents and their context, including enclosing subunits
-- subunits and the outer parent body which is not a subunit. -- and the outer parent body which is not a subunit.
if Present (Lib_Spec) then if Present (Lib_Spec) then
Remove_Context (Lib_Spec); Remove_Context (Lib_Spec);
...@@ -2125,12 +2122,12 @@ package body Sem_Ch10 is ...@@ -2125,12 +2122,12 @@ package body Sem_Ch10 is
Re_Install_Parents (Lib_Unit, Par_Unit); Re_Install_Parents (Lib_Unit, Par_Unit);
Set_Is_Immediately_Visible (Par_Unit); Set_Is_Immediately_Visible (Par_Unit);
-- If the context includes a child unit of the parent of the -- If the context includes a child unit of the parent of the subunit,
-- subunit, the parent will have been removed from visibility, -- the parent will have been removed from visibility, after compiling
-- after compiling that cousin in the context. The visibility -- that cousin in the context. The visibility of the parent must be
-- of the parent must be restored now. This also applies if the -- restored now. This also applies if the context includes another
-- context includes another subunit of the same parent which in -- subunit of the same parent which in turn includes a child unit in
-- turn includes a child unit in its context. -- its context.
if Is_Package_Or_Generic_Package (Par_Unit) then if Is_Package_Or_Generic_Package (Par_Unit) then
if not Is_Immediately_Visible (Par_Unit) if not Is_Immediately_Visible (Par_Unit)
...@@ -2151,9 +2148,9 @@ package body Sem_Ch10 is ...@@ -2151,9 +2148,9 @@ package body Sem_Ch10 is
Scope_Suppress := Svg; Scope_Suppress := Svg;
-- If the subunit is within a child unit, then siblings of any -- If the subunit is within a child unit, then siblings of any parent
-- parent unit that appear in the context clause of the subunit -- unit that appear in the context clause of the subunit must also be
-- must also be made immediately visible. -- made immediately visible.
if Present (Enclosing_Child) then if Present (Enclosing_Child) then
Install_Siblings (Enclosing_Child, N); Install_Siblings (Enclosing_Child, N);
...@@ -2164,10 +2161,10 @@ package body Sem_Ch10 is ...@@ -2164,10 +2161,10 @@ package body Sem_Ch10 is
Analyze (Proper_Body (Unit (N))); Analyze (Proper_Body (Unit (N)));
Remove_Context (N); Remove_Context (N);
-- The subunit may contain a with_clause on a sibling of some -- The subunit may contain a with_clause on a sibling of some ancestor.
-- ancestor. Removing the context will remove from visibility those -- Removing the context will remove from visibility those ancestor child
-- ancestor child units, which must be restored to the visibility -- units, which must be restored to the visibility they have in the
-- they have in the enclosing body. -- enclosing body.
if Present (Enclosing_Child) then if Present (Enclosing_Child) then
declare declare
...@@ -2202,9 +2199,7 @@ package body Sem_Ch10 is ...@@ -2202,9 +2199,7 @@ package body Sem_Ch10 is
Nam := Full_View (Nam); Nam := Full_View (Nam);
end if; end if;
if No (Nam) if No (Nam) or else not Is_Task_Type (Etype (Nam)) then
or else not Is_Task_Type (Etype (Nam))
then
Error_Msg_N ("missing specification for task body", N); Error_Msg_N ("missing specification for task body", N);
else else
Set_Scope (Defining_Entity (N), Current_Scope); Set_Scope (Defining_Entity (N), Current_Scope);
...@@ -2212,11 +2207,11 @@ package body Sem_Ch10 is ...@@ -2212,11 +2207,11 @@ package body Sem_Ch10 is
Set_Has_Completion (Etype (Nam)); Set_Has_Completion (Etype (Nam));
Analyze_Proper_Body (N, Etype (Nam)); Analyze_Proper_Body (N, Etype (Nam));
-- Set elaboration flag to indicate that entity is callable. -- Set elaboration flag to indicate that entity is callable. This
-- This cannot be done in the expansion of the body itself, -- cannot be done in the expansion of the body itself, because the
-- because the proper body is not in a declarative part. This -- proper body is not in a declarative part. This is only done if
-- is only done if expansion is active, because the context -- expansion is active, because the context may be generic and the
-- may be generic and the flag not defined yet. -- flag not defined yet.
if Expander_Active then if Expander_Active then
Insert_After (N, Insert_After (N,
...@@ -2226,7 +2221,6 @@ package body Sem_Ch10 is ...@@ -2226,7 +2221,6 @@ package body Sem_Ch10 is
New_External_Name (Chars (Etype (Nam)), 'E')), New_External_Name (Chars (Etype (Nam)), 'E')),
Expression => New_Reference_To (Standard_True, Loc))); Expression => New_Reference_To (Standard_True, Loc)));
end if; end if;
end if; end if;
end Analyze_Task_Body_Stub; end Analyze_Task_Body_Stub;
...@@ -2234,16 +2228,16 @@ package body Sem_Ch10 is ...@@ -2234,16 +2228,16 @@ package body Sem_Ch10 is
-- Analyze_With_Clause -- -- Analyze_With_Clause --
------------------------- -------------------------
-- Analyze the declaration of a unit in a with clause. At end, -- Analyze the declaration of a unit in a with clause. At end, label the
-- label the with clause with the defining entity for the unit. -- with clause with the defining entity for the unit.
procedure Analyze_With_Clause (N : Node_Id) is procedure Analyze_With_Clause (N : Node_Id) is
-- Retrieve the original kind of the unit node, before analysis. -- Retrieve the original kind of the unit node, before analysis. If it
-- If it is a subprogram instantiation, its analysis below will -- is a subprogram instantiation, its analysis below will rewrite the
-- rewrite as the declaration of the wrapper package. If the same -- node as the declaration of the wrapper package. If the same
-- instantiation appears indirectly elsewhere in the context, it -- instantiation appears indirectly elsewhere in the context, it will
-- will have been analyzed already. -- have been analyzed already.
Unit_Kind : constant Node_Kind := Unit_Kind : constant Node_Kind :=
Nkind (Original_Node (Unit (Library_Unit (N)))); Nkind (Original_Node (Unit (Library_Unit (N))));
...@@ -2533,6 +2527,10 @@ package body Sem_Ch10 is ...@@ -2533,6 +2527,10 @@ package body Sem_Ch10 is
-- Returns true if and only if the library unit is declared with -- Returns true if and only if the library unit is declared with
-- an explicit designation of private. -- an explicit designation of private.
-----------------------------
-- Is_Private_Library_Unit --
-----------------------------
function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is
Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit)); Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit));
...@@ -2792,8 +2790,7 @@ package body Sem_Ch10 is ...@@ -2792,8 +2790,7 @@ package body Sem_Ch10 is
Set_Implicit_With (Withn, True); Set_Implicit_With (Withn, True);
-- If the unit is a package declaration, a private_with_clause on a -- If the unit is a package declaration, a private_with_clause on a
-- child unit implies that the implicit with on the parent is also -- child unit implies the implicit with on the parent is also private.
-- private.
if Nkind (Unit (N)) = N_Package_Declaration then if Nkind (Unit (N)) = N_Package_Declaration then
Set_Private_Present (Withn, Private_Present (Item)); Set_Private_Present (Withn, Private_Present (Item));
...@@ -2930,9 +2927,11 @@ package body Sem_Ch10 is ...@@ -2930,9 +2927,11 @@ package body Sem_Ch10 is
function Build_Unit_Name return Node_Id is function Build_Unit_Name return Node_Id is
Result : Node_Id; Result : Node_Id;
begin begin
if No (Parent_Spec (P_Unit)) then if No (Parent_Spec (P_Unit)) then
return New_Reference_To (P_Name, Loc); return New_Reference_To (P_Name, Loc);
else else
Result := Result :=
Make_Expanded_Name (Loc, Make_Expanded_Name (Loc,
...@@ -3120,13 +3119,10 @@ package body Sem_Ch10 is ...@@ -3120,13 +3119,10 @@ package body Sem_Ch10 is
if Sloc (Library_Unit (Item)) /= No_Location then if Sloc (Library_Unit (Item)) /= No_Location then
License_Check : declare License_Check : declare
Withu : constant Unit_Number_Type := Withu : constant Unit_Number_Type :=
Get_Source_Unit (Library_Unit (Item)); Get_Source_Unit (Library_Unit (Item));
Withl : constant License_Type := Withl : constant License_Type :=
License (Source_Index (Withu)); License (Source_Index (Withu));
Unitl : constant License_Type := Unitl : constant License_Type :=
License (Source_Index (Current_Sem_Unit)); License (Source_Index (Current_Sem_Unit));
...@@ -3306,13 +3302,13 @@ package body Sem_Ch10 is ...@@ -3306,13 +3302,13 @@ package body Sem_Ch10 is
procedure Check_Private_Limited_Withed_Unit (Item : Node_Id); procedure Check_Private_Limited_Withed_Unit (Item : Node_Id);
-- Check that if a limited_with clause of a given compilation_unit -- Check that if a limited_with clause of a given compilation_unit
-- mentions a descendant of a private child of some library unit, -- mentions a descendant of a private child of some library unit, then
-- then the given compilation_unit shall be the declaration of a -- the given compilation_unit shall be the declaration of a private
-- private descendant of that library unit, or a public descendant -- descendant of that library unit, or a public descendant of such. The
-- of such. The code is analogous to that of Check_Private_Child_Unit -- code is analogous to that of Check_Private_Child_Unit but we cannot
-- but we cannot use entities on the limited with_clauses because -- use entities on the limited with_clauses because their units have not
-- their units have not been analyzed, so we have to climb the tree -- been analyzed, so we have to climb the tree of ancestors looking for
-- of ancestors looking for private keywords. -- private keywords.
procedure Expand_Limited_With_Clause procedure Expand_Limited_With_Clause
(Comp_Unit : Node_Id; (Comp_Unit : Node_Id;
...@@ -3431,7 +3427,7 @@ package body Sem_Ch10 is ...@@ -3431,7 +3427,7 @@ package body Sem_Ch10 is
Child_Parent := Library_Unit (Item); Child_Parent := Library_Unit (Item);
-- If the child unit is a public child, then locate its nearest -- If the child unit is a public child, then locate its nearest
-- private ancestor, if any; Child_Parent will then be set to -- private ancestor, if any, then Child_Parent will then be set to
-- the parent of that ancestor. -- the parent of that ancestor.
if not Private_Present (Library_Unit (Item)) then if not Private_Present (Library_Unit (Item)) then
...@@ -3448,8 +3444,8 @@ package body Sem_Ch10 is ...@@ -3448,8 +3444,8 @@ package body Sem_Ch10 is
Child_Parent := Parent_Spec (Unit (Child_Parent)); Child_Parent := Parent_Spec (Unit (Child_Parent));
-- Traverse all the ancestors of the current compilation -- Traverse all the ancestors of the current compilation unit to
-- unit to check if it is a descendant of named library unit. -- check if it is a descendant of named library unit.
Curr_Parent := Parent (Item); Curr_Parent := Parent (Item);
Curr_Private := Private_Present (Curr_Parent); Curr_Private := Private_Present (Curr_Parent);
...@@ -3472,8 +3468,8 @@ package body Sem_Ch10 is ...@@ -3472,8 +3468,8 @@ package body Sem_Ch10 is
or else Curr_Private or else Curr_Private
or else Private_Present (Item) or else Private_Present (Item)
or else Nkind_In (Unit (Parent (Item)), N_Package_Body, or else Nkind_In (Unit (Parent (Item)), N_Package_Body,
N_Subprogram_Body, N_Subprogram_Body,
N_Subunit) N_Subunit)
then then
-- Current unit is private, of descendant of a private unit -- Current unit is private, of descendant of a private unit
...@@ -3646,8 +3642,8 @@ package body Sem_Ch10 is ...@@ -3646,8 +3642,8 @@ package body Sem_Ch10 is
end loop; end loop;
-- Ada 2005 (AI-412): Examine the visible declarations of a package -- Ada 2005 (AI-412): Examine the visible declarations of a package
-- spec, looking for incomplete subtype declarations of incomplete -- spec, looking for incomplete subtype declarations of incomplete types
-- types visible through a limited with clause. -- visible through a limited with clause.
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then Analyzed (N) and then Analyzed (N)
...@@ -3872,10 +3868,10 @@ package body Sem_Ch10 is ...@@ -3872,10 +3868,10 @@ package body Sem_Ch10 is
Item := First (Context_Items (N)); Item := First (Context_Items (N));
while Present (Item) loop while Present (Item) loop
-- Do not install private_with_clauses declaration, unless -- Do not install private_with_clauses declaration, unless unit
-- unit is itself a private child unit, or is a body. -- is itself a private child unit, or is a body. Note that for a
-- Note that for a subprogram body the private_with_clause does -- subprogram body the private_with_clause does not take effect until
-- not take effect until after the specification. -- after the specification.
if Nkind (Item) /= N_With_Clause if Nkind (Item) /= N_With_Clause
or else Implicit_With (Item) or else Implicit_With (Item)
...@@ -3894,8 +3890,8 @@ package body Sem_Ch10 is ...@@ -3894,8 +3890,8 @@ package body Sem_Ch10 is
then then
Set_Is_Immediately_Visible (Id); Set_Is_Immediately_Visible (Id);
-- Check for the presence of another unit in the context, -- Check for the presence of another unit in the context that
-- that may be inadvertently hidden by the child. -- may be inadvertently hidden by the child.
Prev := Current_Entity (Id); Prev := Current_Entity (Id);
...@@ -4119,7 +4115,8 @@ package body Sem_Ch10 is ...@@ -4119,7 +4115,8 @@ package body Sem_Ch10 is
Next (Decl); Next (Decl);
end loop; end loop;
-- Look for declarations that require the presence of a body -- Look for declarations that require the presence of a body. We
-- have already skipped pragmas at the start of the list.
while Present (Decl) loop while Present (Decl) loop
...@@ -4395,7 +4392,7 @@ package body Sem_Ch10 is ...@@ -4395,7 +4392,7 @@ package body Sem_Ch10 is
Next (Item); Next (Item);
end loop; end loop;
-- If it's a body not acting as spec, follow pointer to -- If it is a body not acting as spec, follow pointer to the
-- corresponding spec, otherwise follow pointer to parent spec. -- corresponding spec, otherwise follow pointer to parent spec.
if Present (Library_Unit (Aux_Unit)) if Present (Library_Unit (Aux_Unit))
...@@ -4506,7 +4503,7 @@ package body Sem_Ch10 is ...@@ -4506,7 +4503,7 @@ package body Sem_Ch10 is
-- One of the ancestors has a limited with clause -- One of the ancestors has a limited with clause
and then Nkind (Parent (Parent (Main_Unit_Entity))) = and then Nkind (Parent (Parent (Main_Unit_Entity))) =
N_Package_Specification N_Package_Specification
and then Has_Limited_With_Clause (Scope (Main_Unit_Entity), P) and then Has_Limited_With_Clause (Scope (Main_Unit_Entity), P)
then then
return; return;
...@@ -4532,8 +4529,7 @@ package body Sem_Ch10 is ...@@ -4532,8 +4529,7 @@ package body Sem_Ch10 is
if Analyzed (P_Unit) if Analyzed (P_Unit)
and then and then
(Is_Immediately_Visible (P) (Is_Immediately_Visible (P)
or else or else (Is_Child_Package and then Is_Visible_Child_Unit (P)))
(Is_Child_Package and then Is_Visible_Child_Unit (P)))
then then
return; return;
end if; end if;
...@@ -4775,9 +4771,9 @@ package body Sem_Ch10 is ...@@ -4775,9 +4771,9 @@ package body Sem_Ch10 is
Write_Eol; Write_Eol;
end if; end if;
-- We do not apply the restrictions to an internal unit unless -- We do not apply the restrictions to an internal unit unless we are
-- we are compiling the internal unit as a main unit. This check -- compiling the internal unit as a main unit. This check is also
-- is also skipped for dummy units (for missing packages). -- skipped for dummy units (for missing packages).
if Sloc (Uname) /= No_Location if Sloc (Uname) /= No_Location
and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)) and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
...@@ -4949,8 +4945,9 @@ package body Sem_Ch10 is ...@@ -4949,8 +4945,9 @@ package body Sem_Ch10 is
C_Unit : constant Node_Id := Cunit (Current_Sem_Unit); C_Unit : constant Node_Id := Cunit (Current_Sem_Unit);
begin begin
return Nkind (Unit (C_Unit)) = N_Package_Body return Nkind (Unit (C_Unit)) = N_Package_Body
and then Has_With_Clause (C_Unit, and then
Cunit_Entity (Get_Source_Unit (Non_Limited_View (T)))); Has_With_Clause
(C_Unit, Cunit_Entity (Get_Source_Unit (Non_Limited_View (T))));
end Is_Legal_Shadow_Entity_In_Body; end Is_Legal_Shadow_Entity_In_Body;
----------------------- -----------------------
...@@ -5024,9 +5021,7 @@ package body Sem_Ch10 is ...@@ -5024,9 +5021,7 @@ package body Sem_Ch10 is
Last_Lim_E : Entity_Id := Empty; -- Last limited entity built Last_Lim_E : Entity_Id := Empty; -- Last limited entity built
Last_Pub_Lim_E : Entity_Id; -- To set the first private entity Last_Pub_Lim_E : Entity_Id; -- To set the first private entity
procedure Decorate_Incomplete_Type procedure Decorate_Incomplete_Type (E : Entity_Id; Scop : Entity_Id);
(E : Entity_Id;
Scop : Entity_Id);
-- Add attributes of an incomplete type to a shadow entity. The same -- Add attributes of an incomplete type to a shadow entity. The same
-- attributes are placed on the real entity, so that gigi receives -- attributes are placed on the real entity, so that gigi receives
-- a consistent view. -- a consistent view.
...@@ -5042,9 +5037,7 @@ package body Sem_Ch10 is ...@@ -5042,9 +5037,7 @@ package body Sem_Ch10 is
-- Set basic attributes of tagged type T, including its class_wide type. -- Set basic attributes of tagged type T, including its class_wide type.
-- The parameters Loc, Scope are used to decorate the class_wide type. -- The parameters Loc, Scope are used to decorate the class_wide type.
procedure Build_Chain procedure Build_Chain (Scope : Entity_Id; First_Decl : Node_Id);
(Scope : Entity_Id;
First_Decl : Node_Id);
-- Construct list of shadow entities and attach it to entity of -- Construct list of shadow entities and attach it to entity of
-- package that is mentioned in a limited_with clause. -- package that is mentioned in a limited_with clause.
...@@ -5055,122 +5048,11 @@ package body Sem_Ch10 is ...@@ -5055,122 +5048,11 @@ package body Sem_Ch10 is
-- Build a new internal entity and append it to the list of shadow -- Build a new internal entity and append it to the list of shadow
-- entities available through the limited-header -- entities available through the limited-header
------------------------------
-- Decorate_Incomplete_Type --
------------------------------
procedure Decorate_Incomplete_Type
(E : Entity_Id;
Scop : Entity_Id)
is
begin
Set_Ekind (E, E_Incomplete_Type);
Set_Scope (E, Scop);
Set_Etype (E, E);
Set_Is_First_Subtype (E, True);
Set_Stored_Constraint (E, No_Elist);
Set_Full_View (E, Empty);
Init_Size_Align (E);
end Decorate_Incomplete_Type;
--------------------------
-- Decorate_Tagged_Type --
--------------------------
procedure Decorate_Tagged_Type
(Loc : Source_Ptr;
T : Entity_Id;
Scop : Entity_Id)
is
CW : Entity_Id;
begin
Decorate_Incomplete_Type (T, Scop);
Set_Is_Tagged_Type (T);
-- Build corresponding class_wide type, if not previously done
-- Note: The class-wide entity is shared by the limited-view
-- and the full-view.
if No (Class_Wide_Type (T)) then
CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
-- Set parent to be the same as the parent of the tagged type.
-- We need a parent field set, and it is supposed to point to
-- the declaration of the type. The tagged type declaration
-- essentially declares two separate types, the tagged type
-- itself and the corresponding class-wide type, so it is
-- reasonable for the parent fields to point to the declaration
-- in both cases.
Set_Parent (CW, Parent (T));
-- Set remaining fields of classwide type
Set_Ekind (CW, E_Class_Wide_Type);
Set_Etype (CW, T);
Set_Scope (CW, Scop);
Set_Is_Tagged_Type (CW);
Set_Is_First_Subtype (CW, True);
Init_Size_Align (CW);
Set_Has_Unknown_Discriminants (CW, True);
Set_Class_Wide_Type (CW, CW);
Set_Equivalent_Type (CW, Empty);
Set_From_With_Type (CW, From_With_Type (T));
-- Link type to its class-wide type
Set_Class_Wide_Type (T, CW);
end if;
end Decorate_Tagged_Type;
------------------------------------
-- Decorate_Package_Specification --
------------------------------------
procedure Decorate_Package_Specification (P : Entity_Id) is
begin
-- Place only the most basic attributes
Set_Ekind (P, E_Package);
Set_Etype (P, Standard_Void_Type);
end Decorate_Package_Specification;
--------------------------------
-- New_Internal_Shadow_Entity --
--------------------------------
function New_Internal_Shadow_Entity
(Kind : Entity_Kind;
Sloc_Value : Source_Ptr;
Id_Char : Character) return Entity_Id
is
E : constant Entity_Id :=
Make_Defining_Identifier (Sloc_Value,
Chars => New_Internal_Name (Id_Char));
begin
Set_Ekind (E, Kind);
Set_Is_Internal (E, True);
if Kind in Type_Kind then
Init_Size_Align (E);
end if;
Append_Entity (E, Lim_Header);
Last_Lim_E := E;
return E;
end New_Internal_Shadow_Entity;
----------------- -----------------
-- Build_Chain -- -- Build_Chain --
----------------- -----------------
procedure Build_Chain procedure Build_Chain (Scope : Entity_Id; First_Decl : Node_Id) is
(Scope : Entity_Id;
First_Decl : Node_Id)
is
Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum)); Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum));
Is_Tagged : Boolean; Is_Tagged : Boolean;
Decl : Node_Id; Decl : Node_Id;
...@@ -5219,10 +5101,11 @@ package body Sem_Ch10 is ...@@ -5219,10 +5101,11 @@ package body Sem_Ch10 is
-- Create shadow entity for type -- Create shadow entity for type
Lim_Typ := New_Internal_Shadow_Entity Lim_Typ :=
(Kind => Ekind (Comp_Typ), New_Internal_Shadow_Entity
Sloc_Value => Sloc (Comp_Typ), (Kind => Ekind (Comp_Typ),
Id_Char => 'Z'); Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
Set_Chars (Lim_Typ, Chars (Comp_Typ)); Set_Chars (Lim_Typ, Chars (Comp_Typ));
Set_Parent (Lim_Typ, Parent (Comp_Typ)); Set_Parent (Lim_Typ, Parent (Comp_Typ));
...@@ -5256,10 +5139,11 @@ package body Sem_Ch10 is ...@@ -5256,10 +5139,11 @@ package body Sem_Ch10 is
end if; end if;
end if; end if;
Lim_Typ := New_Internal_Shadow_Entity Lim_Typ :=
(Kind => Ekind (Comp_Typ), New_Internal_Shadow_Entity
Sloc_Value => Sloc (Comp_Typ), (Kind => Ekind (Comp_Typ),
Id_Char => 'Z'); Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
Set_Chars (Lim_Typ, Chars (Comp_Typ)); Set_Chars (Lim_Typ, Chars (Comp_Typ));
Set_Parent (Lim_Typ, Parent (Comp_Typ)); Set_Parent (Lim_Typ, Parent (Comp_Typ));
...@@ -5282,10 +5166,11 @@ package body Sem_Ch10 is ...@@ -5282,10 +5166,11 @@ package body Sem_Ch10 is
-- Create shadow entity for type -- Create shadow entity for type
Lim_Typ := New_Internal_Shadow_Entity Lim_Typ :=
(Kind => Ekind (Comp_Typ), New_Internal_Shadow_Entity
Sloc_Value => Sloc (Comp_Typ), (Kind => Ekind (Comp_Typ),
Id_Char => 'Z'); Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
Set_Chars (Lim_Typ, Chars (Comp_Typ)); Set_Chars (Lim_Typ, Chars (Comp_Typ));
Set_Parent (Lim_Typ, Parent (Comp_Typ)); Set_Parent (Lim_Typ, Parent (Comp_Typ));
...@@ -5309,10 +5194,11 @@ package body Sem_Ch10 is ...@@ -5309,10 +5194,11 @@ package body Sem_Ch10 is
Set_Scope (Comp_Typ, Scope); Set_Scope (Comp_Typ, Scope);
end if; end if;
Lim_Typ := New_Internal_Shadow_Entity Lim_Typ :=
(Kind => Ekind (Comp_Typ), New_Internal_Shadow_Entity
Sloc_Value => Sloc (Comp_Typ), (Kind => Ekind (Comp_Typ),
Id_Char => 'Z'); Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
Decorate_Package_Specification (Lim_Typ); Decorate_Package_Specification (Lim_Typ);
Set_Scope (Lim_Typ, Scope); Set_Scope (Lim_Typ, Scope);
...@@ -5334,6 +5220,111 @@ package body Sem_Ch10 is ...@@ -5334,6 +5220,111 @@ package body Sem_Ch10 is
end loop; end loop;
end Build_Chain; end Build_Chain;
------------------------------
-- Decorate_Incomplete_Type --
------------------------------
procedure Decorate_Incomplete_Type (E : Entity_Id; Scop : Entity_Id) is
begin
Set_Ekind (E, E_Incomplete_Type);
Set_Scope (E, Scop);
Set_Etype (E, E);
Set_Is_First_Subtype (E, True);
Set_Stored_Constraint (E, No_Elist);
Set_Full_View (E, Empty);
Init_Size_Align (E);
end Decorate_Incomplete_Type;
--------------------------
-- Decorate_Tagged_Type --
--------------------------
procedure Decorate_Tagged_Type
(Loc : Source_Ptr;
T : Entity_Id;
Scop : Entity_Id)
is
CW : Entity_Id;
begin
Decorate_Incomplete_Type (T, Scop);
Set_Is_Tagged_Type (T);
-- Build corresponding class_wide type, if not previously done
-- Note: The class-wide entity is shared by the limited-view
-- and the full-view.
if No (Class_Wide_Type (T)) then
CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
-- Set parent to be the same as the parent of the tagged type.
-- We need a parent field set, and it is supposed to point to
-- the declaration of the type. The tagged type declaration
-- essentially declares two separate types, the tagged type
-- itself and the corresponding class-wide type, so it is
-- reasonable for the parent fields to point to the declaration
-- in both cases.
Set_Parent (CW, Parent (T));
-- Set remaining fields of classwide type
Set_Ekind (CW, E_Class_Wide_Type);
Set_Etype (CW, T);
Set_Scope (CW, Scop);
Set_Is_Tagged_Type (CW);
Set_Is_First_Subtype (CW, True);
Init_Size_Align (CW);
Set_Has_Unknown_Discriminants (CW, True);
Set_Class_Wide_Type (CW, CW);
Set_Equivalent_Type (CW, Empty);
Set_From_With_Type (CW, From_With_Type (T));
-- Link type to its class-wide type
Set_Class_Wide_Type (T, CW);
end if;
end Decorate_Tagged_Type;
------------------------------------
-- Decorate_Package_Specification --
------------------------------------
procedure Decorate_Package_Specification (P : Entity_Id) is
begin
-- Place only the most basic attributes
Set_Ekind (P, E_Package);
Set_Etype (P, Standard_Void_Type);
end Decorate_Package_Specification;
--------------------------------
-- New_Internal_Shadow_Entity --
--------------------------------
function New_Internal_Shadow_Entity
(Kind : Entity_Kind;
Sloc_Value : Source_Ptr;
Id_Char : Character) return Entity_Id
is
E : constant Entity_Id :=
Make_Defining_Identifier (Sloc_Value,
Chars => New_Internal_Name (Id_Char));
begin
Set_Ekind (E, Kind);
Set_Is_Internal (E, True);
if Kind in Type_Kind then
Init_Size_Align (E);
end if;
Append_Entity (E, Lim_Header);
Last_Lim_E := E;
return E;
end New_Internal_Shadow_Entity;
-- Start of processing for Build_Limited_Views -- Start of processing for Build_Limited_Views
begin begin
...@@ -5420,11 +5411,11 @@ package body Sem_Ch10 is ...@@ -5420,11 +5411,11 @@ package body Sem_Ch10 is
First_Decl => First (Private_Declarations (Spec))); First_Decl => First (Private_Declarations (Spec)));
if Last_Pub_Lim_E /= Empty then if Last_Pub_Lim_E /= Empty then
Set_First_Private_Entity (Lim_Header, Set_First_Private_Entity
Next_Entity (Last_Pub_Lim_E)); (Lim_Header, Next_Entity (Last_Pub_Lim_E));
else else
Set_First_Private_Entity (Lim_Header, Set_First_Private_Entity
First_Entity (P)); (Lim_Header, First_Entity (P));
end if; end if;
Set_Limited_View_Installed (Spec); Set_Limited_View_Installed (Spec);
...@@ -5467,8 +5458,7 @@ package body Sem_Ch10 is ...@@ -5467,8 +5458,7 @@ package body Sem_Ch10 is
return True; return True;
elsif Ekind (E) = E_Package elsif Ekind (E) = E_Package
and then and then Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration
Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration
and then Present (Corresponding_Body (Unit_Declaration_Node (E))) and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
then then
Ent := First_Entity (E); Ent := First_Entity (E);
...@@ -5491,8 +5481,7 @@ package body Sem_Ch10 is ...@@ -5491,8 +5481,7 @@ package body Sem_Ch10 is
begin begin
if Ekind (Unit_Name) = E_Generic_Package if Ekind (Unit_Name) = E_Generic_Package
and then and then Nkind (Unit_Declaration_Node (Unit_Name)) =
Nkind (Unit_Declaration_Node (Unit_Name)) =
N_Generic_Package_Declaration N_Generic_Package_Declaration
and then and then
Present (Corresponding_Body (Unit_Declaration_Node (Unit_Name))) Present (Corresponding_Body (Unit_Declaration_Node (Unit_Name)))
...@@ -5500,7 +5489,8 @@ package body Sem_Ch10 is ...@@ -5500,7 +5489,8 @@ package body Sem_Ch10 is
Set_Body_Needed_For_SAL (Unit_Name); Set_Body_Needed_For_SAL (Unit_Name);
elsif Ekind (Unit_Name) = E_Generic_Procedure elsif Ekind (Unit_Name) = E_Generic_Procedure
or else Ekind (Unit_Name) = E_Generic_Function or else
Ekind (Unit_Name) = E_Generic_Function
then then
Set_Body_Needed_For_SAL (Unit_Name); Set_Body_Needed_For_SAL (Unit_Name);
...@@ -5696,15 +5686,13 @@ package body Sem_Ch10 is ...@@ -5696,15 +5686,13 @@ package body Sem_Ch10 is
if Ekind (Lim_Typ) /= E_Package if Ekind (Lim_Typ) /= E_Package
and then not Is_Child_Unit (Non_Limited_View (Lim_Typ)) and then not Is_Child_Unit (Non_Limited_View (Lim_Typ))
then then
-- If the package has incomplete types, the limited view of the
-- If the package has incomplete types, the limited view -- incomplete type is in fact never visible (AI05-129) but we
-- of the incomplete type is in fact never visible (AI05-129) -- have created a shadow entity E1 for it, that points to E2,
-- but we have created a shadow entity E1 for it, that points -- a non-limited incomplete type. This in turn has a full view
-- to E2, a non-limited incomplete type. This in turn has a -- E3 that is the full declaration. There is a corresponding
-- full view E3 that is the full declaration. There is a -- shadow entity E4. When reinstalling the non-limited view,
-- corresponding shadow entity E4. When reinstalling the -- E2 must become the current entity and E3 must be ignored.
-- non-limited view, E2 must become the current entity and
-- E3 must be ignored.
E := Non_Limited_View (Lim_Typ); E := Non_Limited_View (Lim_Typ);
...@@ -5714,8 +5702,8 @@ package body Sem_Ch10 is ...@@ -5714,8 +5702,8 @@ package body Sem_Ch10 is
then then
-- Lim_Typ is the limited view of a full type declaration -- Lim_Typ is the limited view of a full type declaration
-- that has a previous incomplete declaration, i.e. E3 -- that has a previous incomplete declaration, i.e. E3 from
-- from the previous description. Nothing to insert. -- the previous description. Nothing to insert.
null; null;
...@@ -5778,7 +5766,6 @@ package body Sem_Ch10 is ...@@ -5778,7 +5766,6 @@ package body Sem_Ch10 is
end if; end if;
if Present (P_Spec) then if Present (P_Spec) then
P := Unit (P_Spec); P := Unit (P_Spec);
P_Name := Get_Parent_Entity (P); P_Name := Get_Parent_Entity (P);
Remove_Context_Clauses (P_Spec); Remove_Context_Clauses (P_Spec);
...@@ -5799,9 +5786,9 @@ package body Sem_Ch10 is ...@@ -5799,9 +5786,9 @@ package body Sem_Ch10 is
Set_In_Package_Body (P_Name, False); Set_In_Package_Body (P_Name, False);
-- This is the recursive call to remove the context of any -- This is the recursive call to remove the context of any higher
-- higher level parent. This recursion ensures that all parents -- level parent. This recursion ensures that all parents are removed
-- are removed in the reverse order of their installation. -- in the reverse order of their installation.
Remove_Parents (P); Remove_Parents (P);
end if; end if;
...@@ -5815,9 +5802,9 @@ package body Sem_Ch10 is ...@@ -5815,9 +5802,9 @@ package body Sem_Ch10 is
Item : Node_Id; Item : Node_Id;
function In_Regular_With_Clause (E : Entity_Id) return Boolean; function In_Regular_With_Clause (E : Entity_Id) return Boolean;
-- Check whether a given unit appears in a regular with_clause. -- Check whether a given unit appears in a regular with_clause. Used to
-- Used to determine whether a private_with_clause, implicit or -- determine whether a private_with_clause, implicit or explicit, should
-- explicit, should be ignored. -- be ignored.
---------------------------- ----------------------------
-- In_Regular_With_Clause -- -- In_Regular_With_Clause --
......
gcc/ada/sysdep.c
...@@ -814,7 +814,10 @@ __gnat_localtime_tzoff (const time_t *timer, long *off) ...@@ -814,7 +814,10 @@ __gnat_localtime_tzoff (const time_t *timer, long *off)
} }
#else #else
#if defined (__Lynx__) && defined (___THREADS_POSIX4ad4__)
/* On Lynx, all time values are treated in GMT */
#if defined (__Lynx__)
/* As of LynxOS 3.1.0a patch level 040, LynuxWorks changes the /* As of LynxOS 3.1.0a patch level 040, LynuxWorks changes the
prototype to the C library function localtime_r from the POSIX.4 prototype to the C library function localtime_r from the POSIX.4
...@@ -828,18 +831,24 @@ __gnat_localtime_tzoff (const time_t *, long *); ...@@ -828,18 +831,24 @@ __gnat_localtime_tzoff (const time_t *, long *);
void void
__gnat_localtime_tzoff (const time_t *timer, long *off) __gnat_localtime_tzoff (const time_t *timer, long *off)
{ {
/* Treat all time values in GMT */
*off = 0; *off = 0;
} }
#else #else
/* VMS does not need __gnat_locatime_tzoff */
#if defined (VMS) #if defined (VMS)
/* __gnat_localtime_tzoff is not needed on VMS */ /* Other targets except Lynx, VMS and Windows provide a standard locatime_r */
#else #else
/* All other targets provide a standard localtime_r */ #define Lock_Task system__soft_links__lock_task
extern void (*Lock_Task) (void);
#define Unlock_Task system__soft_links__unlock_task
extern void (*Unlock_Task) (void);
extern void extern void
__gnat_localtime_tzoff (const time_t *, long *); __gnat_localtime_tzoff (const time_t *, long *);
...@@ -847,25 +856,33 @@ __gnat_localtime_tzoff (const time_t *, long *); ...@@ -847,25 +856,33 @@ __gnat_localtime_tzoff (const time_t *, long *);
void void
__gnat_localtime_tzoff (const time_t *timer, long *off) __gnat_localtime_tzoff (const time_t *timer, long *off)
{ {
struct tm tp; struct tm tp;
localtime_r (timer, &tp);
/* AIX, HPUX, SGI Irix, Sun Solaris */ /* AIX, HPUX, SGI Irix, Sun Solaris */
#if defined (_AIX) || defined (__hpux__) || defined (sgi) || defined (sun) #if defined (_AIX) || defined (__hpux__) || defined (sgi) || defined (sun)
*off = (long) -timezone; {
if (tp.tm_isdst > 0) (*Lock_Task) ();
*off = *off + 3600;
/* Lynx - Treat all time values in GMT */ localtime_r (timer, &tp);
#elif defined (__Lynx__) *off = (long) -timezone;
*off = 0;
(*Unlock_Task) ();
if (tp.tm_isdst > 0)
*off = *off + 3600;
}
/* VxWorks */ /* VxWorks */
#elif defined (__vxworks) #elif defined (__vxworks)
#include <stdlib.h> #include <stdlib.h>
{ {
(*Lock_Task) ();
localtime_r (timer, &tp);
/* Try to read the environment variable TIMEZONE. The variable may not have /* Try to read the environment variable TIMEZONE. The variable may not have
been initialize, in that case return an offset of zero (0) for UTC. */ been initialize, in that case return an offset of zero (0) for UTC. */
char *tz_str = getenv ("TIMEZONE"); char *tz_str = getenv ("TIMEZONE");
if ((tz_str == NULL) || (*tz_str == '\0')) if ((tz_str == NULL) || (*tz_str == '\0'))
...@@ -880,24 +897,34 @@ __gnat_localtime_tzoff (const time_t *timer, long *off) ...@@ -880,24 +897,34 @@ __gnat_localtime_tzoff (const time_t *timer, long *off)
the value of U involves setting two pointers, one at the beginning and the value of U involves setting two pointers, one at the beginning and
one at the end of the value. The end pointer is then set to null in one at the end of the value. The end pointer is then set to null in
order to delimit a string slice for atol to process. */ order to delimit a string slice for atol to process. */
tz_start = index (tz_str, ':') + 2; tz_start = index (tz_str, ':') + 2;
tz_end = index (tz_start, ':'); tz_end = index (tz_start, ':');
tz_end = '\0'; tz_end = '\0';
/* The Ada layer expects an offset in seconds */ /* The Ada layer expects an offset in seconds */
*off = atol (tz_start) * 60; *off = atol (tz_start) * 60;
} }
(*Unlock_Task) ();
} }
/* Darwin, Free BSD, Linux, Tru64, where component tm_gmtoff is present in /* Darwin, Free BSD, Linux, Tru64, where component tm_gmtoff is present in
struct tm */ struct tm */
#elif defined (__APPLE__) || defined (__FreeBSD__) || defined (linux) ||\ #elif defined (__APPLE__) || defined (__FreeBSD__) || defined (linux) ||\
(defined (__alpha__) && defined (__osf__)) || defined (__GLIBC__) (defined (__alpha__) && defined (__osf__)) || defined (__GLIBC__)
{
localtime_r (timer, &tp);
*off = tp.tm_gmtoff; *off = tp.tm_gmtoff;
}
/* Default: treat all time values in GMT */
/* All other platforms: Treat all time values in GMT */
#else #else
*off = 0; *off = 0;
#endif #endif
} }
......
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