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