From d2b4b3da0d21bea1af905d255971a4869b5617cc Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 31 Aug 2011 10:52:34 +0200 Subject: [PATCH] [multiple changes] 2011-08-31 Yannick Moy * sem_ch4.adb: Code clean up. 2011-08-31 Yannick Moy * exp_alfa.adb, exp_alfa.ads: Minor correction of copyright notice. 2011-08-31 Hristian Kirtchev * 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 * 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 * 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 * 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 * lib-xref-alfa.adb (Add_Alfa_Xrefs): Do not take into account read reference to operator in Alfa xrefs. 2011-08-31 Hristian Kirtchev * 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 --- gcc/ada/ChangeLog | 58 +++++++++++ gcc/ada/exp_alfa.adb | 2 +- gcc/ada/exp_alfa.ads | 2 +- gcc/ada/exp_ch7.adb | 54 ++++++----- gcc/ada/lib-xref-alfa.adb | 26 +++++ gcc/ada/prj-attr.adb | 1 + gcc/ada/prj-nmsc.adb | 6 ++ gcc/ada/prj.ads | 6 ++ gcc/ada/s-mudido-affinity.adb | 2 +- gcc/ada/s-taprop-linux.adb | 21 ++-- gcc/ada/s-taprop-mingw.adb | 15 ++- gcc/ada/s-taprop-solaris.adb | 17 +++- gcc/ada/s-taprop-vxworks.adb | 29 ++++-- gcc/ada/sem_attr.adb | 28 +++++- gcc/ada/sem_ch12.adb | 177 +++++++++++++++++++++++++++------- gcc/ada/sem_ch4.adb | 8 +- gcc/ada/snames.ads-tmpl | 1 + 17 files changed, 365 insertions(+), 88 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ff67fffa5f8..53aed0db311 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,61 @@ +2011-08-31 Yannick Moy + + * sem_ch4.adb: Code clean up. + +2011-08-31 Yannick Moy + + * exp_alfa.adb, exp_alfa.ads: Minor correction of copyright notice. + +2011-08-31 Hristian Kirtchev + + * 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 + + * 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 + + * 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 + + * 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 + + * lib-xref-alfa.adb (Add_Alfa_Xrefs): Do not take into account read + reference to operator in Alfa xrefs. + +2011-08-31 Hristian Kirtchev + + * 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 * s-taprop-linux.adb (Set_Task_Affinity): Avoid the use of anonymous diff --git a/gcc/ada/exp_alfa.adb b/gcc/ada/exp_alfa.adb index f0bdc805cbd..56092c1da84 100644 --- a/gcc/ada/exp_alfa.adb +++ b/gcc/ada/exp_alfa.adb @@ -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- -- diff --git a/gcc/ada/exp_alfa.ads b/gcc/ada/exp_alfa.ads index a5c07864be1..0e882bef98d 100644 --- a/gcc/ada/exp_alfa.ads +++ b/gcc/ada/exp_alfa.ads @@ -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- -- diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 6318c42508e..74de4b00ac5 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -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; diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb index 9cb28fde9c7..6f1f393d7da 100644 --- a/gcc/ada/lib-xref-alfa.adb +++ b/gcc/ada/lib-xref-alfa.adb @@ -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); diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index 0f8608b359c..f8084619d89 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -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#" & diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 0f1699a579d..28c93265dc5 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -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 diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 6cd46d323ac..5cb84fb50dd 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -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, diff --git a/gcc/ada/s-mudido-affinity.adb b/gcc/ada/s-mudido-affinity.adb index aa92773b009..c72dc39d6d7 100644 --- a/gcc/ada/s-mudido-affinity.adb +++ b/gcc/ada/s-mudido-affinity.adb @@ -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); diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index b33b50cf524..a47e4b1a0a0 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -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; diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index 4d31ca1aa2f..a56b8e7bf42 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -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. diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index 278b32c1101..6461c9f9e16 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -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 diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 068e5eb649c..a9f89f58ee4 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -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. diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 36a2efa44fd..cf93ec76301 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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 -- ------------ diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index a88dfaf8fc0..ad6d482e765 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -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 - 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); @@ -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 + 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 -- @@ -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; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 12c2b7a7562..34df78348c6 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -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; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 3c54e8a05fb..36b11d520c8 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -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 + $; -- 2.30.2