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

[multiple changes]

Browse Source 
2011-08-31  Yannick Moy  <moy@adacore.com>

	* sem_ch4.adb: Code clean up.

2011-08-31  Yannick Moy  <moy@adacore.com>

	* exp_alfa.adb, exp_alfa.ads: Minor correction of copyright notice.

2011-08-31  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Build_Array_Deep_Procs): Do not generate Deep_Finalize
	and TSS primitive Finalize_Address if finalization is suppressed.
	(Build_Record_Deep_Procs): Do not generate Deep_Finalize and TSS
	primitive Finalize_Address if finalization is suppressed.

2011-08-31  Jose Ruiz  <ruiz@adacore.com>

	* s-mudido-affinity.adb, s-taprop-linux.adb, s-taprop-mingw.adb,
	s-taprop-solaris.adb, s-taprop-vxworks.adb (Set_Task_Affinity): Make
	sure that the underlying task has already been created before trying
	to change its affinity.
	(Set_CPU): Use the term processor instead of CPU, as we do in
	Assign_Task.

2011-08-31  Vincent Celier  <celier@adacore.com>

	* prj-attr.adb: New Compiler attribute Source_File_Switches.
	* prj-nmsc.adb (Process_Compiler): Process attribute
	Source_File_Switches.
	* prj.ads (Language_Config): New name list component
	Name_Source_File_Switches.
	* snames.ads-tmpl (Name_Source_File_Switches): New standard name.

2011-08-31  Ed Schonberg  <schonberg@adacore.com>

	* sem_attr.adb (Analyze_Attribute, case 'Old): If prefix may be a
	discriminated component of an actual, expand at once to prevent
	ouf-of-order references with generated subtypes.

2011-08-31  Yannick Moy  <moy@adacore.com>

	* lib-xref-alfa.adb (Add_Alfa_Xrefs): Do not take into account read
	reference to operator in Alfa xrefs.

2011-08-31  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch12.adb (Freeze_Subprogram_Body): Add code to handle the case
	where the parent instance was frozen before the current instance due to
	the presence of a source body. Update calls to Insert_After_Last_Decl.
	(Insert_After_Last_Decl): Renamed to Insert_Freeze_Node_For_Instance.
	Update the comment which illustrates the purpose of the routine.
	Package instances are now frozen by source bodies which appear after
	the instance. This ensures that entities coming from within the
	instance are available for use in the said bodies.
	(Install_Body): Add code to handle the case where the parent instance
	was frozen before the current instance due to the presence of a source
	body. Update calls to Insert_After_Last_Decl.

From-SVN: r178360
This commit is contained in:
Arnaud Charlet 2011-08-31 10:52:34 +02:00
parent 16c3301a61
commit d2b4b3da0d
17 changed files with 363 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
gcc/ada/ChangeLog
View File

@ -1,3 +1,61 @@
2011-08-31 Yannick Moy <moy@adacore.com>
* sem_ch4.adb: Code clean up.
2011-08-31 Yannick Moy <moy@adacore.com>
* exp_alfa.adb, exp_alfa.ads: Minor correction of copyright notice.
2011-08-31 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Build_Array_Deep_Procs): Do not generate Deep_Finalize
and TSS primitive Finalize_Address if finalization is suppressed.
(Build_Record_Deep_Procs): Do not generate Deep_Finalize and TSS
primitive Finalize_Address if finalization is suppressed.
2011-08-31 Jose Ruiz <ruiz@adacore.com>
* s-mudido-affinity.adb, s-taprop-linux.adb, s-taprop-mingw.adb,
s-taprop-solaris.adb, s-taprop-vxworks.adb (Set_Task_Affinity): Make
sure that the underlying task has already been created before trying
to change its affinity.
(Set_CPU): Use the term processor instead of CPU, as we do in
Assign_Task.
2011-08-31 Vincent Celier <celier@adacore.com>
* prj-attr.adb: New Compiler attribute Source_File_Switches.
* prj-nmsc.adb (Process_Compiler): Process attribute
Source_File_Switches.
* prj.ads (Language_Config): New name list component
Name_Source_File_Switches.
* snames.ads-tmpl (Name_Source_File_Switches): New standard name.
2011-08-31 Ed Schonberg <schonberg@adacore.com>
* sem_attr.adb (Analyze_Attribute, case 'Old): If prefix may be a
discriminated component of an actual, expand at once to prevent
ouf-of-order references with generated subtypes.
2011-08-31 Yannick Moy <moy@adacore.com>
* lib-xref-alfa.adb (Add_Alfa_Xrefs): Do not take into account read
reference to operator in Alfa xrefs.
2011-08-31 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch12.adb (Freeze_Subprogram_Body): Add code to handle the case
where the parent instance was frozen before the current instance due to
the presence of a source body. Update calls to Insert_After_Last_Decl.
(Insert_After_Last_Decl): Renamed to Insert_Freeze_Node_For_Instance.
Update the comment which illustrates the purpose of the routine.
Package instances are now frozen by source bodies which appear after
the instance. This ensures that entities coming from within the
instance are available for use in the said bodies.
(Install_Body): Add code to handle the case where the parent instance
was frozen before the current instance due to the presence of a source
body. Update calls to Insert_After_Last_Decl.
2011-08-31 Jose Ruiz <ruiz@adacore.com>
* s-taprop-linux.adb (Set_Task_Affinity): Avoid the use of anonymous

2
gcc/ada/exp_alfa.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --

2
gcc/ada/exp_alfa.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --

54
gcc/ada/exp_ch7.adb
View File

@ -434,21 +434,26 @@ package body Exp_Ch7 is
Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
end if;
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Finalize_Case,
Typ => Typ,
Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
-- Do not generate Deep_Finalize and Finalize_Address if finalization is
-- suppressed since these routine will not be used.
-- Create TSS primitive Finalize_Address for non-VM targets. JVM and
-- .NET do not support address arithmetic and unchecked conversions.
if VM_Target = No_VM then
if not Restriction_Active (No_Finalization) then
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Address_Case,
(Prim => Finalize_Case,
Typ => Typ,
Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
-- Create TSS primitive Finalize_Address for non-VM targets. JVM and
-- .NET do not support address arithmetic and unchecked conversions.
if VM_Target = No_VM then
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Address_Case,
Typ => Typ,
Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
end if;
end if;
end Build_Array_Deep_Procs;
@ -3090,21 +3095,26 @@ package body Exp_Ch7 is
Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
end if;
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Finalize_Case,
Typ => Typ,
Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
-- Do not generate Deep_Finalize and Finalize_Address if finalization is
-- suppressed since these routine will not be used.
-- Create TSS primitive Finalize_Address for non-VM targets. JVM and
-- .NET do not support address arithmetic and unchecked conversions.
if VM_Target = No_VM then
if not Restriction_Active (No_Finalization) then
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Address_Case,
(Prim => Finalize_Case,
Typ => Typ,
Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
-- Create TSS primitive Finalize_Address for non-VM targets. JVM and
-- .NET do not support address arithmetic and unchecked conversions.
if VM_Target = No_VM then
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Address_Case,
Typ => Typ,
Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
end if;
end if;
end Build_Record_Deep_Procs;

26
gcc/ada/lib-xref-alfa.adb
View File

@ -576,6 +576,11 @@ package body Alfa is
Eliminate_Before_Sort : declare
NR : Nat;
function Is_Alfa_Reference
(E : Entity_Id;
Typ : Character) return Boolean;
-- Return whether the reference is adequate for this entity
function Is_Alfa_Scope (E : Entity_Id) return Boolean;
-- Return whether the entity or reference scope is adequate
@ -583,6 +588,25 @@ package body Alfa is
-- Return True if E is a global constant for which we should ignore
-- reads in Alfa.
-----------------------
-- Is_Alfa_Reference --
-----------------------
function Is_Alfa_Reference
(E : Entity_Id;
Typ : Character) return Boolean is
begin
-- The only references of interest on callable entities are calls.
-- On non-callable entities, the only references of interest are
-- reads and writes.
if Ekind (E) in Overloadable_Kind then
return Typ = 's';
else
return Typ = 'r' or else Typ = 'm';
end if;
end Is_Alfa_Reference;
-------------------
-- Is_Alfa_Scope --
-------------------
@ -617,6 +641,8 @@ package body Alfa is
and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Ent_Scope)
and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Ref_Scope)
and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Ent)
and then Is_Alfa_Reference (Xrefs.Table (Rnums (J)).Ent,
Xrefs.Table (Rnums (J)).Typ)
then
Nrefs := Nrefs + 1;
Rnums (Nrefs) := Rnums (J);

1
gcc/ada/prj-attr.adb
View File

@ -190,6 +190,7 @@ package body Prj.Attr is
"Latrailing_required_switches#" &
"Lapic_option#" &
"Sapath_syntax#" &
"Sasource_file_switches#" &
"Saobject_file_suffix#" &
"Laobject_file_switches#" &
"Lamulti_unit_switches#" &

6
gcc/ada/prj-nmsc.adb
View File

@ -1470,6 +1470,12 @@ package body Prj.Nmsc is
Element.Value.Location, Project);
end;
when Name_Source_File_Switches =>
Put (Into_List =>
Lang_Index.Config.Source_File_Switches,
From_List => Element.Value.Values,
In_Tree => Data.Tree);
when Name_Object_File_Suffix =>
if Get_Name_String (Element.Value.Value) = "" then
Error_Msg

6
gcc/ada/prj.ads
View File

@ -447,6 +447,11 @@ package Prj is
-- Value may be Canonical (Unix style) or Host (host syntax, for example
-- on VMS for DEC C).
Source_File_Switches : Name_List_Index := No_Name_List;
-- Optional switches to be put before the source file. The source file
-- path name is appended to the last switch in the list.
-- Example: ("-i", "");
Object_File_Suffix : Name_Id := No_Name;
-- Optional alternate object file suffix
@ -580,6 +585,7 @@ package Prj is
Multi_Unit_Switches => No_Name_List,
Multi_Unit_Object_Separator => ' ',
Path_Syntax => Canonical,
Source_File_Switches => No_Name_List,
Object_File_Suffix => No_Name,
Object_File_Switches => No_Name_List,
Compilation_PIC_Option => No_Name_List,

2
gcc/ada/s-mudido-affinity.adb
View File

@ -337,7 +337,7 @@ package body System.Multiprocessors.Dispatching_Domains is
not Target.Common.Domain (CPU))
then
raise Dispatching_Domain_Error with
"CPU does not belong to the task's dispatching domain";
"processor does not belong to the task's dispatching domain";
end if;
Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target);

21
gcc/ada/s-taprop-linux.adb
View File

@ -38,7 +38,6 @@ pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during tasking
-- operations. It causes infinite loops and other problems.
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Interfaces.C;
@ -113,6 +112,10 @@ package body System.Task_Primitives.Operations is
Abort_Handler_Installed : Boolean := False;
-- True if a handler for the abort signal is installed
Null_Thread_Id : constant pthread_t := pthread_t'Last;
-- Constant to indicate that the thread identifier has not yet been
-- initialized.
--------------------
-- Local Packages --
--------------------
@ -154,13 +157,8 @@ package body System.Task_Primitives.Operations is
-- Local Subprograms --
-----------------------
subtype unsigned_long is Interfaces.C.unsigned_long;
procedure Abort_Handler (signo : Signal);
function To_pthread_t is new Ada.Unchecked_Conversion
(unsigned_long, System.OS_Interface.pthread_t);
-------------------
-- Abort_Handler --
-------------------
@ -773,7 +771,7 @@ package body System.Task_Primitives.Operations is
Next_Serial_Number := Next_Serial_Number + 1;
pragma Assert (Next_Serial_Number /= 0);
Self_ID.Common.LL.Thread := To_pthread_t (-1);
Self_ID.Common.LL.Thread := Null_Thread_Id;
if not Single_Lock then
Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
@ -1363,7 +1361,14 @@ package body System.Task_Primitives.Operations is
use type System.Multiprocessors.CPU_Range;
begin
if pthread_setaffinity_np'Address /= System.Null_Address then
-- Do nothing if there is no support for setting affinities or the
-- underlying thread has not yet been created. If the thread has not
-- yet been created then the proper affinity will be set during its
-- creation.
if pthread_setaffinity_np'Address /= System.Null_Address
and then T.Common.LL.Thread /= Null_Thread_Id
then
declare
type cpu_set_t_ptr is access all cpu_set_t;

15
gcc/ada/s-taprop-mingw.adb
View File

@ -131,6 +131,10 @@ package body System.Task_Primitives.Operations is
Annex_D : Boolean := False;
-- Set to True if running with Annex-D semantics
Null_Thread_Id : constant Thread_Id := 0;
-- Constant to indicate that the thread identifier has not yet been
-- initialized.
------------------------------------
-- The thread local storage index --
------------------------------------
@ -853,7 +857,7 @@ package body System.Task_Primitives.Operations is
-- Initialize thread ID to 0, this is needed to detect threads that
-- are not yet activated.
Self_ID.Common.LL.Thread := 0;
Self_ID.Common.LL.Thread := Null_Thread_Id;
Initialize_Cond (Self_ID.Common.LL.CV'Access);
@ -1362,9 +1366,16 @@ package body System.Task_Primitives.Operations is
use type System.Multiprocessors.CPU_Range;
begin
-- Do nothing if the underlying thread has not yet been created. If the
-- thread has not yet been created then the proper affinity will be set
-- during its creation.
if T.Common.LL.Thread = Null_Thread_Id then
null;
-- pragma CPU
if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then
elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
-- The CPU numbering in pragma CPU starts at 1 while the subprogram
-- to set the affinity starts at 0, therefore we must substract 1.

17
gcc/ada/s-taprop-solaris.adb
View File

@ -101,6 +101,10 @@ package body System.Task_Primitives.Operations is
Abort_Handler_Installed : Boolean := False;
-- True if a handler for the abort signal is installed
Null_Thread_Id : constant Thread_Id := Thread_Id'Last;
-- Constant to indicate that the thread identifier has not yet been
-- initialized.
----------------------
-- Priority Support --
----------------------
@ -917,7 +921,7 @@ package body System.Task_Primitives.Operations is
Next_Serial_Number := Next_Serial_Number + 1;
pragma Assert (Next_Serial_Number /= 0);
Self_ID.Common.LL.Thread := To_thread_t (-1);
Self_ID.Common.LL.Thread := Null_Thread_Id;
if not Single_Lock then
Result :=
@ -1021,7 +1025,7 @@ package body System.Task_Primitives.Operations is
Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
T.Common.LL.Thread := To_thread_t (0);
T.Common.LL.Thread := Null_Thread_Id;
if not Single_Lock then
Result := mutex_destroy (T.Common.LL.L.L'Access);
@ -1944,9 +1948,16 @@ package body System.Task_Primitives.Operations is
use type System.Multiprocessors.CPU_Range;
begin
-- Do nothing if the underlying thread has not yet been created. If the
-- thread has not yet been created then the proper affinity will be set
-- during its creation.
if T.Common.LL.Thread = Null_Thread_Id then
null;
-- pragma CPU
if T.Common.Base_CPU /=
elsif T.Common.Base_CPU /=
System.Multiprocessors.Not_A_Specific_CPU
then
-- The CPU numbering in pragma CPU starts at 1 while the subprogram

29
gcc/ada/s-taprop-vxworks.adb
View File

@ -105,6 +105,10 @@ package body System.Task_Primitives.Operations is
Time_Slice_Val : Integer;
pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
Null_Thread_Id : constant Thread_Id := 0;
-- Constant to indicate that the thread identifier has not yet been
-- initialized.
--------------------
-- Local Packages --
--------------------
@ -859,7 +863,7 @@ package body System.Task_Primitives.Operations is
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
begin
Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY);
Self_ID.Common.LL.Thread := 0;
Self_ID.Common.LL.Thread := Null_Thread_Id;
if Self_ID.Common.LL.CV = 0 then
Succeeded := False;
@ -952,7 +956,7 @@ package body System.Task_Primitives.Operations is
Set_Task_Affinity (T);
if T.Common.LL.Thread <= 0 then
if T.Common.LL.Thread <= Null_Thread_Id then
Succeeded := False;
else
Succeeded := True;
@ -979,7 +983,7 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end if;
T.Common.LL.Thread := 0;
T.Common.LL.Thread := Null_Thread_Id;
Result := semDelete (T.Common.LL.CV);
pragma Assert (Result = 0);
@ -1254,7 +1258,7 @@ package body System.Task_Primitives.Operations is
Thread_Self : Thread_Id) return Boolean
is
begin
if T.Common.LL.Thread /= 0
if T.Common.LL.Thread /= Null_Thread_Id
and then T.Common.LL.Thread /= Thread_Self
then
return taskSuspend (T.Common.LL.Thread) = 0;
@ -1272,7 +1276,7 @@ package body System.Task_Primitives.Operations is
Thread_Self : Thread_Id) return Boolean
is
begin
if T.Common.LL.Thread /= 0
if T.Common.LL.Thread /= Null_Thread_Id
and then T.Common.LL.Thread /= Thread_Self
then
return taskResume (T.Common.LL.Thread) = 0;
@ -1298,7 +1302,7 @@ package body System.Task_Primitives.Operations is
C := All_Tasks_List;
while C /= null loop
if C.Common.LL.Thread /= 0
if C.Common.LL.Thread /= Null_Thread_Id
and then C.Common.LL.Thread /= Thread_Self
then
Dummy := Task_Stop (C.Common.LL.Thread);
@ -1316,7 +1320,7 @@ package body System.Task_Primitives.Operations is
function Stop_Task (T : ST.Task_Id) return Boolean is
begin
if T.Common.LL.Thread /= 0 then
if T.Common.LL.Thread /= Null_Thread_Id then
return Task_Stop (T.Common.LL.Thread) = 0;
else
return True;
@ -1330,7 +1334,7 @@ package body System.Task_Primitives.Operations is
function Continue_Task (T : ST.Task_Id) return Boolean
is
begin
if T.Common.LL.Thread /= 0 then
if T.Common.LL.Thread /= Null_Thread_Id then
return Task_Cont (T.Common.LL.Thread) = 0;
else
return True;
@ -1408,9 +1412,16 @@ package body System.Task_Primitives.Operations is
use type System.Multiprocessors.CPU_Range;
begin
-- Do nothing if the underlying thread has not yet been created. If the
-- thread has not yet been created then the proper affinity will be set
-- during its creation.
if T.Common.LL.Thread = Null_Thread_Id then
null;
-- pragma CPU
if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then
elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
-- Ada 2012 pragma CPU uses CPU numbers starting from 1, while on
-- VxWorks the first CPU is identified by a 0, so we need to adjust.

28
gcc/ada/sem_attr.adb
View File

@ -1939,7 +1939,7 @@ package body Sem_Attr is
-- Analyze prefix and exit if error in analysis. If the prefix is an
-- incomplete type, use full view if available. Note that there are
-- some attributes for which we do not analyze the prefix, since the
-- prefix is not a normal name.
-- prefix is not a normal name, or else needs special handling.
if Aname /= Name_Elab_Body
and then
@ -1950,6 +1950,8 @@ package body Sem_Attr is
Aname /= Name_UET_Address
and then
Aname /= Name_Enabled
and then
Aname /= Name_Old
then
Analyze (P);
P_Type := Etype (P);
@ -3772,6 +3774,12 @@ package body Sem_Attr is
end if;
Check_E0;
-- Prefix has not been analyzed yet, and its full analysis will take
-- place during expansion (see below).
Preanalyze_And_Resolve (P);
P_Type := Etype (P);
Set_Etype (N, P_Type);
if No (Current_Subprogram) then
@ -3852,6 +3860,24 @@ package body Sem_Attr is
end if;
end Check_Local;
-- The attribute ppears within a pre/postcondition, but refers to
-- an entity in the enclosing subprogram. If it is a component of a
-- formal its expansion might generate actual subtypes that may be
-- referenced in an inner context, and which must be elaborated
-- within the subprogram itself. As a result we create a declaration
-- for it and insert it at the start of the enclosing subprogram
-- This is properly an expansion activity but it has to be performed
-- now to prevent out-of-order issues.
if Nkind (P) = N_Selected_Component
and then Has_Discriminants (Etype (Prefix (P)))
then
P_Type := Base_Type (P_Type);
Set_Etype (N, P_Type);
Set_Etype (P, P_Type);
Expand (N);
end if;
------------
-- Output --
------------

173
gcc/ada/sem_ch12.adb
View File

@ -516,11 +516,22 @@ package body Sem_Ch12 is
-- of packages that are early instantiations are delayed, and their freeze
-- node appears after the generic body.
procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id);
-- Insert freeze node at the end of the declarative part that includes the
-- instance node N. If N is in the visible part of an enclosing package
-- declaration, the freeze node has to be inserted at the end of the
-- private declarations, if any.
procedure Insert_Freeze_Node_For_Instance
(N : Node_Id;
F_Node : Node_Id);
-- N is an instance and F_Node is its corresponding freeze node. Insert
-- F_Node depending on the enclosing context and placement of N in the
-- following manner:
--
-- 1) N is a package instance - Attempt to insert the freeze node before
-- a source package or subprogram body which follows immediately after N.
-- If no such body is found, perform the actions in 2).
--
-- 2) N is a subprogram instance or a package instance not followed by
-- a source body - Insert the freeze node at the end of the declarations
-- list which contains N. If N is in the visible part of an enclosing
-- package declaration, the freeze node is inserted at the end of the
-- private declarations.
procedure Freeze_Subprogram_Body
(Inst_Node : Node_Id;
@ -6698,12 +6709,12 @@ package body Sem_Ch12 is
Gen_Body : Node_Id;
Pack_Id : Entity_Id)
is
F_Node : Node_Id;
Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
Par : constant Entity_Id := Scope (Gen_Unit);
E_G_Id : Entity_Id;
Enc_G : Entity_Id;
Enc_I : Node_Id;
E_G_Id : Entity_Id;
F_Node : Node_Id;
function Earlier (N1, N2 : Node_Id) return Boolean;
-- Yields True if N1 and N2 appear in the same compilation unit,
@ -6881,15 +6892,37 @@ package body Sem_Ch12 is
if Is_Generic_Instance (Par)
and then Present (Freeze_Node (Par))
and then
In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node)
and then In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node)
then
-- The parent was a premature instantiation. Insert freeze node at
-- the end the current declarative part.
if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then
Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
-- The parent was a premature instantiation. Insert freeze node at
-- the end the current declarative part.
-- Handle the following case:
--
-- package Parent_Inst is new ...
-- Parent_Inst []
--
-- procedure P ... -- this body freezes Parent_Inst
--
-- package Inst is new ...
--
-- In this particular scenario, the freeze node for Inst must be
-- inserted in the same manner as that of Parent_Inst - before the
-- next source body or at the end of the declarative list (body not
-- available). If body P did not exist and Parent_Inst was frozen
-- after Inst, either by a body following Inst or at the end of the
-- declarative region, the freeze node for Inst must be inserted
-- after that of Parent_Inst. This relation is established by
-- comparing the Slocs of Parent_Inst freeze node and Inst.
Insert_After_Last_Decl (Inst_Node, F_Node);
elsif List_Containing (Get_Package_Instantiation_Node (Par)) =
List_Containing (Inst_Node)
and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node)
then
Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
else
Insert_After (Freeze_Node (Par), F_Node);
@ -6917,11 +6950,11 @@ package body Sem_Ch12 is
-- node, we place it at the end of the declarative part of the
-- parent of the generic.
Insert_After_Last_Decl
Insert_Freeze_Node_For_Instance
(Freeze_Node (Par), Package_Freeze_Node (Enc_I));
end if;
Insert_After_Last_Decl (Inst_Node, F_Node);
Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
elsif Present (Enc_G)
and then Present (Enc_I)
@ -6955,7 +6988,8 @@ package body Sem_Ch12 is
end if;
if Parent (List_Containing (Enc_G)) /= Enclosing_Body then
Insert_After_Last_Decl (Enc_G, Package_Freeze_Node (Enc_I));
Insert_Freeze_Node_For_Instance
(Enc_G, Package_Freeze_Node (Enc_I));
end if;
end;
@ -6967,13 +7001,13 @@ package body Sem_Ch12 is
Insert_After (Enc_G, Freeze_Node (E_G_Id));
end if;
Insert_After_Last_Decl (Inst_Node, F_Node);
Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
else
-- If none of the above, insert freeze node at the end of the current
-- declarative part.
Insert_After_Last_Decl (Inst_Node, F_Node);
Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
end if;
end Freeze_Subprogram_Body;
@ -7197,7 +7231,7 @@ package body Sem_Ch12 is
return False;
elsif Nkind (Nod) = N_Subunit then
Nod := Corresponding_Stub (Nod);
Nod := Corresponding_Stub (Nod);
elsif Nkind (Nod) = N_Compilation_Unit then
return False;
@ -7319,27 +7353,69 @@ package body Sem_Ch12 is
Hidden_Entities := No_Elist;
end Initialize;
----------------------------
-- Insert_After_Last_Decl --
----------------------------
-------------------------------------
-- Insert_Freeze_Node_For_Instance --
-------------------------------------
procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id) is
L : List_Id := List_Containing (N);
P : constant Node_Id := Parent (L);
procedure Insert_Freeze_Node_For_Instance
(N : Node_Id;
F_Node : Node_Id)
is
Inst : constant Entity_Id := Entity (F_Node);
Decl : Node_Id;
Decls : List_Id;
Par_N : Node_Id;
begin
if not Is_List_Member (F_Node) then
if Nkind (P) = N_Package_Specification
and then L = Visible_Declarations (P)
and then Present (Private_Declarations (P))
and then not Is_Empty_List (Private_Declarations (P))
Decls := List_Containing (N);
Par_N := Parent (Decls);
Decl := N;
-- When the instantiation occurs in a package declaration, append the
-- freeze node to the private declarations (if any).
if Nkind (Par_N) = N_Package_Specification
and then Decls = Visible_Declarations (Par_N)
and then Present (Private_Declarations (Par_N))
and then not Is_Empty_List (Private_Declarations (Par_N))
then
L := Private_Declarations (P);
Decls := Private_Declarations (Par_N);
Decl := First (Decls);
end if;
Insert_After (Last (L), F_Node);
-- Determine the proper freeze point of a package instantiation. We
-- adhere to the general rule of a package or subprogram body causing
-- freezing of anything before it in the same declarative region. In
-- this case, the proper freeze point of a package instantiation is
-- before the first source body which follows. This ensures that
-- entities coming from the instance are already frozen and usable
-- in source bodies.
if Nkind (Par_N) /= N_Package_Declaration
and then Ekind (Inst) = E_Package
and then Is_Generic_Instance (Inst)
and then
not In_Same_Source_Unit (Generic_Parent (Parent (Inst)), Inst)
then
while Present (Decl) loop
if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body)
and then Comes_From_Source (Decl)
then
Insert_Before (Decl, F_Node);
return;
end if;
Next (Decl);
end loop;
end if;
-- In a package declaration, or if no previous body, insert at end
-- of list.
Insert_After (Last (Decls), F_Node);
end if;
end Insert_After_Last_Decl;
end Insert_Freeze_Node_For_Instance;
------------------
-- Install_Body --
@ -7475,7 +7551,34 @@ package body Sem_Ch12 is
-- generic.
if In_Same_Declarative_Part (Freeze_Node (Par), N) then
Insert_After (Freeze_Node (Par), F_Node);
-- Handle the following case:
--
-- package Parent_Inst is new ...
-- Parent_Inst []
--
-- procedure P ... -- this body freezes Parent_Inst
--
-- package Inst is new ...
--
-- In this particular scenario, the freeze node for Inst must
-- be inserted in the same manner as that of Parent_Inst -
-- before the next source body or at the end of the declarative
-- list (body not available). If body P did not exist and
-- Parent_Inst was frozen after Inst, either by a body
-- following Inst or at the end of the declarative region, the
-- freeze node for Inst must be inserted after that of
-- Parent_Inst. This relation is established by comparing the
-- Slocs of Parent_Inst freeze node and Inst.
if List_Containing (Get_Package_Instantiation_Node (Par)) =
List_Containing (N)
and then Sloc (Freeze_Node (Par)) < Sloc (N)
then
Insert_Freeze_Node_For_Instance (N, F_Node);
else
Insert_After (Freeze_Node (Par), F_Node);
end if;
-- Freeze package enclosing instance of inner generic after
-- instance of enclosing generic.
@ -7489,7 +7592,7 @@ package body Sem_Ch12 is
Corresponding_Spec (Parent (N));
begin
Insert_After_Last_Decl (N, F_Node);
Insert_Freeze_Node_For_Instance (N, F_Node);
Ensure_Freeze_Node (Enclosing);
if not Is_List_Member (Freeze_Node (Enclosing)) then
@ -7498,11 +7601,11 @@ package body Sem_Ch12 is
end;
else
Insert_After_Last_Decl (N, F_Node);
Insert_Freeze_Node_For_Instance (N, F_Node);
end if;
else
Insert_After_Last_Decl (N, F_Node);
Insert_Freeze_Node_For_Instance (N, F_Node);
end if;
end if;

8
gcc/ada/sem_ch4.adb
View File

@ -3357,10 +3357,12 @@ package body Sem_Ch4 is
Check_SPARK_Restriction ("quantified expression is not allowed", N);
-- If expansion is enabled, the condition is analyzed after rewritten
-- as a loop. Otherwise we only need to set the type.
-- If expansion is enabled (and not in Alfa mode), the condition is
-- analyzed after rewritten as a loop. So we only need to set the type.
if Operating_Mode /= Check_Semantics then
if Operating_Mode /= Check_Semantics
and then not Alfa_Mode
then
Set_Etype (N, Standard_Boolean);
return;
end if;

1
gcc/ada/snames.ads-tmpl
View File

@ -1193,6 +1193,7 @@ package Snames is
Name_Shared_Library_Suffix : constant Name_Id := N + $;
Name_Separate_Suffix : constant Name_Id := N + $;
Name_Source_Dirs : constant Name_Id := N + $;
Name_Source_File_Switches : constant Name_Id := N + $;
Name_Source_Files : constant Name_Id := N + $;
Name_Source_List_File : constant Name_Id := N + $;
Name_Spec : constant Name_Id := N + $;