diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 58 | ||||
| -rw-r--r-- | gcc/ada/exp_alfa.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_alfa.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 54 | ||||
| -rw-r--r-- | gcc/ada/lib-xref-alfa.adb | 26 | ||||
| -rw-r--r-- | gcc/ada/prj-attr.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/prj-nmsc.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/prj.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/s-mudido-affinity.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-linux.adb | 21 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-mingw.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-solaris.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-vxworks.adb | 29 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 177 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 8 | ||||
| -rw-r--r-- | 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 <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 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 + $; |