+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
-- --
-- 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- --
-- --
-- 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- --
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;
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;
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
-- 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 --
-------------------
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);
"Latrailing_required_switches#" &
"Lapic_option#" &
"Sapath_syntax#" &
+ "Sasource_file_switches#" &
"Saobject_file_suffix#" &
"Laobject_file_switches#" &
"Lamulti_unit_switches#" &
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
-- 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
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,
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);
-- 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;
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 --
--------------------
-- 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 --
-------------------
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,
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;
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 --
------------------------------------
-- 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);
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.
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 --
----------------------
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 :=
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);
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
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 --
--------------------
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;
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;
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);
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;
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;
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);
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;
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;
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.
-- 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
Aname /= Name_UET_Address
and then
Aname /= Name_Enabled
+ and then
+ Aname /= Name_Old
then
Analyze (P);
P_Type := Etype (P);
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
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 --
------------
-- 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;
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,
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
- if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then
+ -- The parent was a premature instantiation. Insert freeze node at
+ -- the end the current declarative part.
- -- The parent was a premature instantiation. Insert freeze node at
- -- the end the current declarative part.
-
- Insert_After_Last_Decl (Inst_Node, F_Node);
+ if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then
+ Insert_Freeze_Node_For_Instance (Inst_Node, 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.
+
+ 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);
-- 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)
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;
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;
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;
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
+ Decls := Private_Declarations (Par_N);
+ Decl := First (Decls);
+ end if;
+
+ -- 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
- L := Private_Declarations (P);
+ 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;
- Insert_After (Last (L), F_Node);
+ -- 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 --
-- 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.
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
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;
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;
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 + $;
OSDN Git Service
