[multiple changes]
authorArnaud Charlet <charlet@gcc.gnu.org>
Wed, 31 Aug 2011 08:52:34 +0000 (10:52 +0200)
committerArnaud Charlet <charlet@gcc.gnu.org>
Wed, 31 Aug 2011 08:52:34 +0000 (10:52 +0200)
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

17 files changed:
gcc/ada/ChangeLog
gcc/ada/exp_alfa.adb
gcc/ada/exp_alfa.ads
gcc/ada/exp_ch7.adb
gcc/ada/lib-xref-alfa.adb
gcc/ada/prj-attr.adb
gcc/ada/prj-nmsc.adb
gcc/ada/prj.ads
gcc/ada/s-mudido-affinity.adb
gcc/ada/s-taprop-linux.adb
gcc/ada/s-taprop-mingw.adb
gcc/ada/s-taprop-solaris.adb
gcc/ada/s-taprop-vxworks.adb
gcc/ada/sem_attr.adb
gcc/ada/sem_ch12.adb
gcc/ada/sem_ch4.adb
gcc/ada/snames.ads-tmpl

index ff67fffa5f84df3aa9b6d23d050846c43d15807b..53aed0db311fdf6c96a1495f45b51c52da6503b9 100644 (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
index f0bdc805cbd58bb679c57f3eba0038326b513a88..56092c1da84c65b5642a54df86c878c274099652 100644 (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- --
index a5c07864be1ea34fca30c8b23b13c92500924567..0e882bef98d808d61f075020d320ca254f97e3f4 100644 (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- --
index 6318c42508e5663039a906ecf372b234199b63a0..74de4b00ac57261db97060a189868bc47c93723d 100644 (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;
 
index 9cb28fde9c7814ffcb89eb8a9affbbd2de05523c..6f1f393d7dabe93d2314b7a1997da6891ba4cb85 100644 (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);
index 0f8608b359ce2daef3412eb11d40f18c26477612..f8084619d89059e2870d06a97d91ad4d66b5dff7 100644 (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#" &
index 0f1699a579ddae80e13c253cf41e9e48dcd2d91c..28c93265dc5c503a206f47bc4a26b6c5f3a90283 100644 (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
index 6cd46d323ac275d97c5bca9d8632498ff25d0306..5cb84fb50dddf0b72156cce41c6c795f40224d0b 100644 (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,
index aa92773b009eca63547b0ba876223f1978f8dd98..c72dc39d6d77b0c78b03fc504be87a6004775b6f 100644 (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);
index b33b50cf5241e09ebfea33e62da38fac8cb30886..a47e4b1a0a0b513fc90f2b664d935fa7ed435cfc 100644 (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;
 
index 4d31ca1aa2f815e08c590013508a3f54adc52b7f..a56b8e7bf4233f06a5adc27495edf3691410e92a 100644 (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.
index 278b32c1101aa4566f4daf6f5315973632dfb485..6461c9f9e164310f2e0d9370bbd246ebd372e2c5 100644 (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
index 068e5eb649c81375d8db1612ce6358a933592892..a9f89f58ee456030bb683e6601fb18e76adffe87 100644 (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.
index 36a2efa44fdb1c8081083727434527f339ee7733..cf93ec763017a1b5fe3a8b5d912a9519a2e733b1 100644 (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 --
       ------------
index a88dfaf8fc0d4d945b2dc42ac225ff153b43ecbb..ad6d482e7651438de6920d56f661742f5eec792f 100644 (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
-         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;
 
index 12c2b7a756202a837adfc580ccfa20f6d8d9fb17..34df78348c67255730f1a7e853e8f80237b0ce72 100644 (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;
index 3c54e8a05fb292b58d48fcc87459c25557b33d77..36b11d520c804c8309095bbe90467f9ba77bfef7 100644 (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 + $;