2011-09-06 Yannick Moy <moy@adacore.com>
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 6 Sep 2011 10:43:17 +0000 (10:43 +0000)
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 6 Sep 2011 10:43:17 +0000 (10:43 +0000)
* sem_ch13.adb (Analyze_Aspect_Specifications): Call
Set_Corresponding_Aspect when creating pragma from aspect.
(Add_Predicates): Use new field Corresponding_Aspect.
* sem_prag.adb (Analyze_Pragma): Make Pname hold source aspect
name when present, for the purpose of issuing error messages;
remove local procedure Error_Pragma_Arg_Alternate_Name.
* sinfo.adb, sinfo.ads (Corresponding_Aspect): New field in
N_Pragma node.
(From_Dynamic_Predicate, From_Static_Predicate): Remove fields from
N_Pragma node.

2011-09-06  Robert Dewar  <dewar@adacore.com>

* checks.adb, s-except.ads, g-socket.adb: Minor reformatting.

2011-09-06  Hristian Kirtchev  <kirtchev@adacore.com>

* exp_ch6.adb (Build_Heap_Allocator): Add new
local variable Desig_Typ. Code and comment reformatting. Add
machinery to ensure that the allocation uses a fat pointer when
the type of the return object is a constrained array and the
function return type is an unconstrained array.

2011-09-06  Vincent Celier  <celier@adacore.com>

* make.adb, prj-part.adb, prj-nmsc.adb: Remove unused formal
parameters in subprograms.

2011-09-06  Arnaud Charlet  <charlet@adacore.com>

* s-taprop-mingw.adb (Finalize_TCB): Fix typo.

2011-09-06  Thomas Quinot  <quinot@adacore.com>

* s-taprop-vxworks.adb, s-tpoaal.adb, s-tpopsp-vxworks.adb
(System.Tasking.Primitive_Operations.Specific.Delete): Remove
subprogram.
(System.Tasking.Primitive_Operations.Specific.Set): If argument
is null, destroy task specific data, to make API consistent with
other platforms, and thus compatible with the shared version
of s-tpoaal.adb.
(System.Tasking.Primitive_Operations.ATCB_Allocation.Free_ATCB):
Document the above assumption.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178583 138bc75d-0d04-0410-961f-82ee72b054a4

15 files changed:
gcc/ada/ChangeLog
gcc/ada/checks.adb
gcc/ada/exp_ch6.adb
gcc/ada/g-socket.adb
gcc/ada/make.adb
gcc/ada/prj-nmsc.adb
gcc/ada/prj-part.adb
gcc/ada/s-taprop-mingw.adb
gcc/ada/s-taprop-vxworks.adb
gcc/ada/s-tpoaal.adb
gcc/ada/s-tpopsp-vxworks.adb
gcc/ada/sem_ch13.adb
gcc/ada/sem_prag.adb
gcc/ada/sinfo.adb
gcc/ada/sinfo.ads

index 0b5216f..f39c314 100644 (file)
@@ -1,3 +1,49 @@
+2011-09-06  Yannick Moy  <moy@adacore.com>
+
+       * sem_ch13.adb (Analyze_Aspect_Specifications): Call
+       Set_Corresponding_Aspect when creating pragma from aspect.
+       (Add_Predicates): Use new field Corresponding_Aspect.
+       * sem_prag.adb (Analyze_Pragma): Make Pname hold source aspect
+       name when present, for the purpose of issuing error messages;
+       remove local procedure Error_Pragma_Arg_Alternate_Name.
+       * sinfo.adb, sinfo.ads (Corresponding_Aspect): New field in
+       N_Pragma node.
+       (From_Dynamic_Predicate, From_Static_Predicate): Remove fields from
+       N_Pragma node.
+
+2011-09-06  Robert Dewar  <dewar@adacore.com>
+
+       * checks.adb, s-except.ads, g-socket.adb: Minor reformatting.
+
+2011-09-06  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * exp_ch6.adb (Build_Heap_Allocator): Add new
+       local variable Desig_Typ. Code and comment reformatting. Add
+       machinery to ensure that the allocation uses a fat pointer when
+       the type of the return object is a constrained array and the
+       function return type is an unconstrained array.
+
+2011-09-06  Vincent Celier  <celier@adacore.com>
+
+       * make.adb, prj-part.adb, prj-nmsc.adb: Remove unused formal
+       parameters in subprograms.
+
+2011-09-06  Arnaud Charlet  <charlet@adacore.com>
+
+       * s-taprop-mingw.adb (Finalize_TCB): Fix typo.
+
+2011-09-06  Thomas Quinot  <quinot@adacore.com>
+
+       * s-taprop-vxworks.adb, s-tpoaal.adb, s-tpopsp-vxworks.adb
+       (System.Tasking.Primitive_Operations.Specific.Delete): Remove
+       subprogram.
+       (System.Tasking.Primitive_Operations.Specific.Set): If argument
+       is null, destroy task specific data, to make API consistent with
+       other platforms, and thus compatible with the shared version
+       of s-tpoaal.adb.
+       (System.Tasking.Primitive_Operations.ATCB_Allocation.Free_ATCB):
+       Document the above assumption.
+
 2011-09-06  Ed Schonberg  <schonberg@adacore.com>
 
        * exp_ch6.adb (Expand_Inlined_Call): Fix use of uninitialized
index 336b144..0d2322a 100644 (file)
@@ -1877,6 +1877,7 @@ package body Checks is
       if Is_Subscr_Ref then
          Arr := Prefix (Parnt);
          Arr_Typ := Get_Actual_Subtype_If_Available (Arr);
+
          if Is_Access_Type (Arr_Typ) then
             Arr_Typ := Directly_Designated_Type (Arr_Typ);
          end if;
index b300389..8955e5d 100644 (file)
@@ -4651,10 +4651,10 @@ package body Exp_Ch6 is
                               Build_In_Place_Formal
                                 (Func_Id, BIP_Finalization_Master);
                Stmts      : constant List_Id := New_List;
-
-               Local_Id : Entity_Id;
-               Pool_Id  : Entity_Id;
-               Ptr_Typ  : Entity_Id;
+               Desig_Typ  : Entity_Id;
+               Local_Id   : Entity_Id;
+               Pool_Id    : Entity_Id;
+               Ptr_Typ    : Entity_Id;
 
             begin
                --  Generate:
@@ -4684,8 +4684,19 @@ package body Exp_Ch6 is
                --  of the temporary. Otherwise the secondary stack allocation
                --  will fail.
 
+               Desig_Typ := Ret_Typ;
+
+               --  Ensure that the build-in-place machinery uses a fat pointer
+               --  when allocating an unconstrained array on the heap. In this
+               --  case the result object type is a constrained array type even
+               --  though the function type is unconstrained.
+
+               if Ekind (Desig_Typ) = E_Array_Subtype then
+                  Desig_Typ := Base_Type (Desig_Typ);
+               end if;
+
                --  Generate:
-               --    type Ptr_Typ is access Ret_Typ;
+               --    type Ptr_Typ is access Desig_Typ;
 
                Ptr_Typ := Make_Temporary (Loc, 'P');
 
@@ -4695,7 +4706,7 @@ package body Exp_Ch6 is
                    Type_Definition     =>
                      Make_Access_To_Object_Definition (Loc,
                        Subtype_Indication =>
-                         New_Reference_To (Ret_Typ, Loc))));
+                         New_Reference_To (Desig_Typ, Loc))));
 
                --  Perform minor decoration in order to set the master and the
                --  storage pool attributes.
index 59e63bd..bf1fe9f 100644 (file)
@@ -474,6 +474,7 @@ package body GNAT.Sockets is
 
    procedure Check_For_Fd_Set (Fd : Socket_Type) is
       use SOSC;
+
    begin
       --  On Windows, fd_set is a FD_SETSIZE array of socket ids:
       --  no check required. Warnings suppressed because condition
index 13777bb..bf6a21a 100644 (file)
@@ -608,8 +608,6 @@ package body Make is
 
    procedure Compute_Switches_For_Main
      (Main_Source_File  : in out File_Name_Type;
-      Main_Index        : Int;
-      Project_Node_Tree : Project_Node_Tree_Ref;
       Root_Environment  : in out Prj.Tree.Environment;
       Compute_Builder   : Boolean;
       Current_Work_Dir  : String);
@@ -744,10 +742,8 @@ package body Make is
    procedure Add_Switches
      (The_Package                      : Package_Id;
       File_Name                        : String;
-      Index                            : Int;
       Program                          : Make_Program_Type;
       Unknown_Switches_To_The_Compiler : Boolean := True;
-      Project_Node_Tree                : Project_Node_Tree_Ref;
       Env                              : in out Prj.Tree.Environment);
    procedure Add_Switch
      (S             : String_Access;
@@ -769,7 +765,6 @@ package body Make is
 
    procedure Check
      (Source_File    : File_Name_Type;
-      Source_Index   : Int;
       Is_Main_Source : Boolean;
       The_Args       : Argument_List;
       Lib_File       : File_Name_Type;
@@ -1276,10 +1271,8 @@ package body Make is
    procedure Add_Switches
      (The_Package                      : Package_Id;
       File_Name                        : String;
-      Index                            : Int;
       Program                          : Make_Program_Type;
       Unknown_Switches_To_The_Compiler : Boolean := True;
-      Project_Node_Tree                : Project_Node_Tree_Ref;
       Env                              : in out Prj.Tree.Environment)
    is
       Switches    : Variable_Value;
@@ -1445,7 +1438,6 @@ package body Make is
 
    procedure Check
      (Source_File    : File_Name_Type;
-      Source_Index   : Int;
       Is_Main_Source : Boolean;
       The_Args       : Argument_List;
       Lib_File       : File_Name_Type;
@@ -3445,7 +3437,6 @@ package body Make is
 
                   if not Force_Compilations then
                      Check (Source_File    => Source.File,
-                            Source_Index   => Source.Index,
                             Is_Main_Source => Source.File = Main_Source,
                             The_Args       => Args,
                             Lib_File       => Lib_File,
@@ -5206,8 +5197,6 @@ package body Make is
 
    procedure Compute_Switches_For_Main
      (Main_Source_File  : in out File_Name_Type;
-      Main_Index        : Int;
-      Project_Node_Tree : Project_Node_Tree_Ref;
       Root_Environment  : in out Prj.Tree.Environment;
       Compute_Builder   : Boolean;
       Current_Work_Dir  : String)
@@ -5349,10 +5338,8 @@ package body Make is
                end if;
 
                Add_Switches
-                 (Project_Node_Tree => Project_Node_Tree,
-                  Env               => Root_Environment,
+                 (Env               => Root_Environment,
                   File_Name         => Main_Unit_File_Name,
-                  Index             => Main_Index,
                   The_Package       => Binder_Package,
                   Program           => Binder);
             end if;
@@ -5367,10 +5354,8 @@ package body Make is
                end if;
 
                Add_Switches
-                 (Project_Node_Tree => Project_Node_Tree,
-                  Env               => Root_Environment,
+                 (Env               => Root_Environment,
                   File_Name         => Main_Unit_File_Name,
-                  Index             => Main_Index,
                   The_Package       => Linker_Package,
                   Program           => Linker);
             end if;
@@ -6029,8 +6014,6 @@ package body Make is
 
          Compute_Switches_For_Main
            (Main_Source_File,
-            Main_Index,
-            Project_Node_Tree,
             Root_Environment,
             Compute_Builder  => Is_First_Main,
             Current_Work_Dir => Current_Work_Dir.all);
index 9ebd300..e7d9c5a 100644 (file)
@@ -426,8 +426,7 @@ package body Prj.Nmsc is
       Naming    : Lang_Naming_Data;
       Kind      : out Source_Kind;
       Unit      : out Name_Id;
-      Project   : Project_Processing_Data;
-      In_Tree   : Project_Tree_Ref);
+      Project   : Project_Processing_Data);
    --  Check whether the file matches the naming scheme. If it does,
    --  compute its unit name. If Unit is set to No_Name on exit, none of the
    --  other out parameters are relevant.
@@ -5627,8 +5626,7 @@ package body Prj.Nmsc is
       Naming    : Lang_Naming_Data;
       Kind      : out Source_Kind;
       Unit      : out Name_Id;
-      Project   : Project_Processing_Data;
-      In_Tree   : Project_Tree_Ref)
+      Project   : Project_Processing_Data)
    is
       Filename : constant String  := Get_Name_String (File_Name);
       Last     : Integer          := Filename'Last;
@@ -6724,8 +6722,7 @@ package body Prj.Nmsc is
                      Naming          => Config.Naming_Data,
                      Kind            => Kind,
                      Unit            => Unit,
-                     Project         => Project,
-                     In_Tree         => In_Tree);
+                     Project         => Project);
 
                   if Unit /= No_Name then
                      Language    := Tmp_Lang;
index 3b07a80..1c18680 100644 (file)
@@ -215,7 +215,6 @@ package body Prj.Part is
       Imported_Projects : in out Project_Node_Id;
       Project_Directory : Path_Name_Type;
       From_Extended     : Extension_Origin;
-      In_Limited        : Boolean;
       Packages_To_Check : String_List_Access;
       Depth             : Natural;
       Current_Dir       : String;
@@ -752,7 +751,6 @@ package body Prj.Part is
       Imported_Projects : in out Project_Node_Id;
       Project_Directory : Path_Name_Type;
       From_Extended     : Extension_Origin;
-      In_Limited        : Boolean;
       Packages_To_Check : String_List_Access;
       Depth             : Natural;
       Current_Dir       : String;
@@ -1503,7 +1501,6 @@ package body Prj.Part is
                Imported_Projects => Imported_Projects,
                Project_Directory => Project_Directory,
                From_Extended     => From_Ext,
-               In_Limited        => In_Limited,
                Packages_To_Check => Packages_To_Check,
                Depth             => Depth + 1,
                Current_Dir       => Current_Dir,
@@ -1863,7 +1860,6 @@ package body Prj.Part is
             Imported_Projects => Imported_Projects,
             Project_Directory => Project_Directory,
             From_Extended     => From_Ext,
-            In_Limited        => In_Limited,
             Packages_To_Check => Packages_To_Check,
             Depth             => Depth + 1,
             Current_Dir       => Current_Dir,
index d26568f..7fc505e 100644 (file)
@@ -997,7 +997,7 @@ package body System.Task_Primitives.Operations is
          Known_Tasks (T.Known_Tasks_Index) := null;
       end if;
 
-      if Self_ID.Common.LL.Thread /= 0 then
+      if T.Common.LL.Thread /= 0 then
 
          --  This task has been activated. Wait for the thread to terminate
          --  then close it. This is needed to release system resources.
index 6b3c35e..be76162 100644 (file)
@@ -124,11 +124,8 @@ package body System.Task_Primitives.Operations is
 
       procedure Set (Self_Id : Task_Id);
       pragma Inline (Set);
-      --  Set the self id for the current task
-
-      procedure Delete;
-      pragma Inline (Delete);
-      --  Delete the task specific data associated with the current task
+      --  Set the self id for the current task, unless Self_Id is null, in
+      --  which case the task specific data is deleted.
 
       function Self return Task_Id;
       pragma Inline (Self);
index 0e79f45..1d25fb8 100644 (file)
@@ -59,6 +59,10 @@ package body ATCB_Allocation is
 
             Specific.Set (Local_ATCB'Unchecked_Access);
             Free (Tmp);
+
+            --  Note: it is assumed here that for all platforms, Specific.Set
+            --  deletes the task specific information if passed a null value.
+
             Specific.Set (null);
          end;
 
index 64bf10c..09c03ef 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---         Copyright (C) 1992-2009, Free Software Foundation, Inc.          --
+--         Copyright (C) 1992-2011, Free Software Foundation, Inc.          --
 --                                                                          --
 -- GNARL 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- --
@@ -44,17 +44,6 @@ package body Specific is
    --  implementation. This mechanism is used to minimize impact on other
    --  targets.
 
-   ------------
-   -- Delete --
-   ------------
-
-   procedure Delete is
-      Result : STATUS;
-   begin
-      Result := taskVarDelete (taskIdSelf, ATCB_Key'Access);
-      pragma Assert (Result /= ERROR);
-   end Delete;
-
    ----------------
    -- Initialize --
    ----------------
@@ -81,6 +70,14 @@ package body Specific is
       Result : STATUS;
 
    begin
+      --  If Self_Id is null, delete task specific data
+
+      if Self_Id = null then
+         Result := taskVarDelete (taskIdSelf, ATCB_Key'Access);
+         pragma Assert (Result /= ERROR);
+         return;
+      end if;
+
       if taskVarGet (0, ATCB_Key'Access) = ERROR then
          Result := taskVarAdd (0, ATCB_Key'Access);
          pragma Assert (Result = OK);
index 2655b25..f5b52d0 100644 (file)
@@ -1146,6 +1146,7 @@ package body Sem_Ch13 is
                         New_List (Ent, Relocate_Node (Expr)));
 
                   Set_From_Aspect_Specification (Aitem, True);
+                  Set_Corresponding_Aspect (Aitem, Aspect);
 
                   pragma Assert (not Delay_Required);
 
@@ -1181,6 +1182,7 @@ package body Sem_Ch13 is
                                    Expression => Relocate_Node (Expr))));
 
                      Set_From_Aspect_Specification (Aitem, True);
+                     Set_Corresponding_Aspect (Aitem, Aspect);
 
                      pragma Assert (not Delay_Required);
                   end;
@@ -1259,6 +1261,7 @@ package body Sem_Ch13 is
                   end if;
 
                   Set_From_Aspect_Specification (Aitem, True);
+                  Set_Corresponding_Aspect (Aitem, Aspect);
                   Set_Is_Delayed_Aspect (Aspect);
 
                   --  For Pre/Post cases, insert immediately after the entity
@@ -1316,6 +1319,7 @@ package body Sem_Ch13 is
                   end if;
 
                   Set_From_Aspect_Specification (Aitem, True);
+                  Set_Corresponding_Aspect (Aitem, Aspect);
                   Set_Is_Delayed_Aspect (Aspect);
 
                   --  For Invariant case, insert immediately after the entity
@@ -1345,14 +1349,7 @@ package body Sem_Ch13 is
                         Make_Identifier (Sloc (Id), Name_Predicate));
 
                   Set_From_Aspect_Specification (Aitem, True);
-
-                  --  Set special flags for dynamic/static cases
-
-                  if A_Id = Aspect_Dynamic_Predicate then
-                     Set_From_Dynamic_Predicate (Aitem);
-                  elsif A_Id = Aspect_Static_Predicate then
-                     Set_From_Static_Predicate (Aitem);
-                  end if;
+                  Set_Corresponding_Aspect (Aitem, Aspect);
 
                   --  Make sure we have a freeze node (it might otherwise be
                   --  missing in cases like subtype X is Y, and we would not
@@ -1426,6 +1423,7 @@ package body Sem_Ch13 is
                         Args);
 
                   Set_From_Aspect_Specification (Aitem, True);
+                  Set_Corresponding_Aspect (Aitem, Aspect);
                   Set_Is_Delayed_Aspect (Aspect);
 
                   --  Insert immediately after the entity declaration
@@ -1444,6 +1442,11 @@ package body Sem_Ch13 is
             if Delay_Required then
                if Present (Aitem) then
                   Set_From_Aspect_Specification (Aitem, True);
+
+                  if Nkind (Aitem) = N_Pragma then
+                     Set_Corresponding_Aspect (Aitem, Aspect);
+                  end if;
+
                   Set_Is_Delayed_Aspect (Aitem);
                   Set_Aspect_Rep_Item (Aspect, Aitem);
                end if;
@@ -1457,6 +1460,10 @@ package body Sem_Ch13 is
             else
                Set_From_Aspect_Specification (Aitem, True);
 
+               if Nkind (Aitem) = N_Pragma then
+                  Set_Corresponding_Aspect (Aitem, Aspect);
+               end if;
+
                --  If this is a compilation unit, we will put the pragma in
                --  the Pragmas_After list of the N_Compilation_Unit_Aux node.
 
@@ -4734,10 +4741,15 @@ package body Sem_Ch13 is
             if Nkind (Ritem) = N_Pragma
               and then Pragma_Name (Ritem) = Name_Predicate
             then
-               if From_Dynamic_Predicate (Ritem) then
-                  Dynamic_Predicate_Present := True;
-               elsif From_Static_Predicate (Ritem) then
-                  Static_Predicate_Present := Ritem;
+               if Present (Corresponding_Aspect (Ritem)) then
+                  case Chars (Identifier (Corresponding_Aspect (Ritem))) is
+                     when Name_Dynamic_Predicate =>
+                        Dynamic_Predicate_Present := True;
+                     when Name_Static_Predicate =>
+                        Static_Predicate_Present := Ritem;
+                     when others =>
+                        null;
+                  end case;
                end if;
 
                --  Acquire arguments
index 2ca9417..e3db807 100644 (file)
 --  to complete the syntax checks. Certain pragmas are handled partially or
 --  completely by the parser (see Par.Prag for further details).
 
-with System.Case_Util;
-
-with Atree;            use Atree;
-with Casing;           use Casing;
-with Checks;           use Checks;
-with Csets;            use Csets;
-with Debug;            use Debug;
-with Einfo;            use Einfo;
-with Elists;           use Elists;
-with Errout;           use Errout;
-with Exp_Dist;         use Exp_Dist;
-with Exp_Util;         use Exp_Util;
-with Freeze;           use Freeze;
-with Lib;              use Lib;
-with Lib.Writ;         use Lib.Writ;
-with Lib.Xref;         use Lib.Xref;
-with Namet.Sp;         use Namet.Sp;
-with Nlists;           use Nlists;
-with Nmake;            use Nmake;
-with Opt;              use Opt;
-with Output;           use Output;
-with Par_SCO;          use Par_SCO;
-with Restrict;         use Restrict;
-with Rident;           use Rident;
-with Rtsfind;          use Rtsfind;
-with Sem;              use Sem;
-with Sem_Aux;          use Sem_Aux;
-with Sem_Ch3;          use Sem_Ch3;
-with Sem_Ch6;          use Sem_Ch6;
-with Sem_Ch8;          use Sem_Ch8;
-with Sem_Ch12;         use Sem_Ch12;
-with Sem_Ch13;         use Sem_Ch13;
-with Sem_Disp;         use Sem_Disp;
-with Sem_Dist;         use Sem_Dist;
-with Sem_Elim;         use Sem_Elim;
-with Sem_Eval;         use Sem_Eval;
-with Sem_Intr;         use Sem_Intr;
-with Sem_Mech;         use Sem_Mech;
-with Sem_Res;          use Sem_Res;
-with Sem_Type;         use Sem_Type;
-with Sem_Util;         use Sem_Util;
-with Sem_VFpt;         use Sem_VFpt;
-with Sem_Warn;         use Sem_Warn;
-with Stand;            use Stand;
-with Sinfo;            use Sinfo;
-with Sinfo.CN;         use Sinfo.CN;
-with Sinput;           use Sinput;
-with Snames;           use Snames;
-with Stringt;          use Stringt;
-with Stylesw;          use Stylesw;
+with Atree;    use Atree;
+with Casing;   use Casing;
+with Checks;   use Checks;
+with Csets;    use Csets;
+with Debug;    use Debug;
+with Einfo;    use Einfo;
+with Elists;   use Elists;
+with Errout;   use Errout;
+with Exp_Dist; use Exp_Dist;
+with Exp_Util; use Exp_Util;
+with Freeze;   use Freeze;
+with Lib;      use Lib;
+with Lib.Writ; use Lib.Writ;
+with Lib.Xref; use Lib.Xref;
+with Namet.Sp; use Namet.Sp;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Output;   use Output;
+with Par_SCO;  use Par_SCO;
+with Restrict; use Restrict;
+with Rident;   use Rident;
+with Rtsfind;  use Rtsfind;
+with Sem;      use Sem;
+with Sem_Aux;  use Sem_Aux;
+with Sem_Ch3;  use Sem_Ch3;
+with Sem_Ch6;  use Sem_Ch6;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Intr; use Sem_Intr;
+with Sem_Mech; use Sem_Mech;
+with Sem_Res;  use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_VFpt; use Sem_VFpt;
+with Sem_Warn; use Sem_Warn;
+with Stand;    use Stand;
+with Sinfo;    use Sinfo;
+with Sinfo.CN; use Sinfo.CN;
+with Sinput;   use Sinput;
+with Snames;   use Snames;
+with Stringt;  use Stringt;
+with Stylesw;  use Stylesw;
 with Table;
-with Targparm;         use Targparm;
-with Tbuild;           use Tbuild;
+with Targparm; use Targparm;
+with Tbuild;   use Tbuild;
 with Ttypes;
-with Uintp;            use Uintp;
-with Uname;            use Uname;
-with Urealp;           use Urealp;
-with Validsw;          use Validsw;
-with Warnsw;           use Warnsw;
+with Uintp;    use Uintp;
+with Uname;    use Uname;
+with Urealp;   use Urealp;
+with Validsw;  use Validsw;
+with Warnsw;   use Warnsw;
 
 package body Sem_Prag is
 
@@ -374,9 +372,13 @@ package body Sem_Prag is
 
    procedure Analyze_Pragma (N : Node_Id) is
       Loc     : constant Source_Ptr := Sloc (N);
-      Pname   : constant Name_Id    := Pragma_Name (N);
       Prag_Id : Pragma_Id;
 
+      Pname : Name_Id;
+      --  Name of the source pragma, or name of the corresponding aspect for
+      --  pragmas which originate in a source aspect. In the latter case, the
+      --  name may be different from the pragma name.
+
       Pragma_Exit : exception;
       --  This exception is used to exit pragma processing completely. It is
       --  used when an error is detected, and no further processing is
@@ -648,17 +650,6 @@ package body Sem_Prag is
       --  Similar to above form of Error_Pragma_Arg except that two messages
       --  are provided, the second is a continuation comment starting with \.
 
-      procedure Error_Pragma_Arg_Alternate_Name
-        (Msg      : String;
-         Arg      : Node_Id;
-         Alt_Name : Name_Id);
-      pragma No_Return (Error_Pragma_Arg_Alternate_Name);
-      --  Outputs error message for current pragma, similar to
-      --  Error_Pragma_Arg, except the source name of the aspect/pragma to use
-      --  in warnings may be equal to Alt_Name (which should be equivalent to
-      --  the name used in pragma). The location for the source name should be
-      --  pointed to by Arg.
-
       procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
       pragma No_Return (Error_Pragma_Arg_Ident);
       --  Outputs error message for current pragma. The message may contain
@@ -2440,34 +2431,6 @@ package body Sem_Prag is
          Error_Pragma_Arg (Msg2, Arg);
       end Error_Pragma_Arg;
 
-      -------------------------------------
-      -- Error_Pragma_Arg_Alternate_Name --
-      -------------------------------------
-
-      procedure Error_Pragma_Arg_Alternate_Name
-        (Msg      : String;
-         Arg      : Node_Id;
-         Alt_Name : Name_Id)
-      is
-         MsgF        : String := Msg;
-         Source_Name : String := Exact_Source_Name (Sloc (Arg));
-         Alter_Name  : String := Get_Name_String (Alt_Name);
-
-      begin
-         System.Case_Util.To_Lower (Source_Name);
-         System.Case_Util.To_Lower (Alter_Name);
-
-         if Source_Name = Alter_Name then
-            Error_Msg_Name_1 := Alt_Name;
-         else
-            Error_Msg_Name_1 := Pname;
-         end if;
-
-         Fix_Error (MsgF);
-         Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
-         raise Pragma_Exit;
-      end Error_Pragma_Arg_Alternate_Name;
-
       ----------------------------
       -- Error_Pragma_Arg_Ident --
       ----------------------------
@@ -6212,6 +6175,8 @@ package body Sem_Prag is
 
       --  Deal with unrecognized pragma
 
+      Pname := Pragma_Name (N);
+
       if not Is_Pragma_Name (Pname) then
          if Warn_On_Unrecognized_Pragma then
             Error_Msg_Name_1 := Pname;
@@ -6234,6 +6199,10 @@ package body Sem_Prag is
 
       Prag_Id := Get_Pragma_Id (Pname);
 
+      if Present (Corresponding_Aspect (N)) then
+         Pname := Chars (Identifier (Corresponding_Aspect (N)));
+      end if;
+
       --  Preset arguments
 
       Arg_Count := 0;
@@ -10182,15 +10151,13 @@ package body Sem_Prag is
                null;
 
             elsif In_Private_Part (Current_Scope) then
-               Error_Pragma_Arg_Alternate_Name
+               Error_Pragma_Arg
                  ("pragma% only allowed for private type " &
-                  "declared in visible part", Arg1,
-                  Alt_Name => Name_Type_Invariant);
+                  "declared in visible part", Arg1);
 
             else
-               Error_Pragma_Arg_Alternate_Name
-                 ("pragma% only allowed for private type", Arg1,
-                  Alt_Name => Name_Type_Invariant);
+               Error_Pragma_Arg
+                 ("pragma% only allowed for private type", Arg1);
             end if;
 
             --  Note that the type has at least one invariant, and also that
index 32d9938..7543347 100644 (file)
@@ -590,6 +590,14 @@ package body Sinfo is
       return Flag14 (N);
    end Conversion_OK;
 
+   function Corresponding_Aspect
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Pragma);
+      return Node3 (N);
+   end Corresponding_Aspect;
+
    function Corresponding_Body
       (N : Node_Id) return Node_Id is
    begin
@@ -1337,22 +1345,6 @@ package body Sinfo is
       return Flag6 (N);
    end From_Default;
 
-   function From_Dynamic_Predicate
-      (N : Node_Id) return Boolean is
-   begin
-      pragma Assert (False
-        or else NT (N).Nkind = N_Pragma);
-      return Flag7 (N);
-   end From_Dynamic_Predicate;
-
-   function From_Static_Predicate
-      (N : Node_Id) return Boolean is
-   begin
-      pragma Assert (False
-        or else NT (N).Nkind = N_Pragma);
-      return Flag8 (N);
-   end From_Static_Predicate;
-
    function Generic_Associations
       (N : Node_Id) return List_Id is
    begin
@@ -3658,6 +3650,14 @@ package body Sinfo is
       Set_Flag14 (N, Val);
    end Set_Conversion_OK;
 
+   procedure Set_Corresponding_Aspect
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Pragma);
+      Set_Node3 (N, Val);
+   end Set_Corresponding_Aspect;
+
    procedure Set_Corresponding_Body
       (N : Node_Id; Val : Node_Id) is
    begin
@@ -4396,22 +4396,6 @@ package body Sinfo is
       Set_Flag6 (N, Val);
    end Set_From_Default;
 
-   procedure Set_From_Dynamic_Predicate
-      (N : Node_Id; Val : Boolean := True) is
-   begin
-      pragma Assert (False
-        or else NT (N).Nkind = N_Pragma);
-      Set_Flag7 (N, Val);
-   end Set_From_Dynamic_Predicate;
-
-   procedure Set_From_Static_Predicate
-      (N : Node_Id; Val : Boolean := True) is
-   begin
-      pragma Assert (False
-        or else NT (N).Nkind = N_Pragma);
-      Set_Flag8 (N, Val);
-   end Set_From_Static_Predicate;
-
    procedure Set_Generic_Associations
       (N : Node_Id; Val : List_Id) is
    begin
index 203d186..4e239b8 100644 (file)
@@ -717,6 +717,10 @@ package Sinfo is
    --    direct conversion of the underlying integer result, with no regard to
    --    the small operand.
 
+   --  Corresponding_Aspect (Node3-Sem)
+   --    Present in N_Pragma node. Used to point back to the source aspect from
+   --    the corresponding pragma. This field is Empty for source pragmas.
+
    --  Corresponding_Body (Node5-Sem)
    --    This field is set in subprogram declarations, package declarations,
    --    entry declarations of protected types, and in generic units. It points
@@ -1076,14 +1080,6 @@ package Sinfo is
    --    declaration is treated as an implicit reference to the formal in the
    --    ali file.
 
-   --  From_Dynamic_Predicate (Flag7-Sem)
-   --    Set for generated pragma Predicate node if this is generated by a
-   --    Dynamic_Predicate aspect.
-
-   --  From_Static_Predicate (Flag8-Sem)
-   --    Set for generated pragma Predicate node if this is generated by a
-   --    Static_Predicate aspect.
-
    --  Generic_Parent (Node5-Sem)
    --    Generic_Parent is defined on declaration nodes that are instances. The
    --    value of Generic_Parent is the generic entity from which the instance
@@ -2063,6 +2059,7 @@ package Sinfo is
       --  Sloc points to PRAGMA
       --  Next_Pragma (Node1-Sem)
       --  Pragma_Argument_Associations (List2) (set to No_List if none)
+      --  Corresponding_Aspect (Node3-Sem) (set to Empty if not present)
       --  Pragma_Identifier (Node4)
       --  Next_Rep_Item (Node5-Sem)
       --  From_Aspect_Specification (Flag13-Sem)
@@ -2070,8 +2067,6 @@ package Sinfo is
       --  Import_Interface_Present (Flag16-Sem)
       --  Split_PPC (Flag17) set if corresponding aspect had Split_PPC set
       --  Class_Present (Flag6) set if from Aspect with 'Class
-      --  From_Dynamic_Predicate (Flag7-Sem) Set if Dynamic_Predicate aspect
-      --  From_Static_Predicate (Flag8-Sem) Set if Static_Predicate aspect
 
       --  Note: we should have a section on what pragmas are passed on to
       --  the back end to be processed. This section should note that pragma
@@ -8242,6 +8237,9 @@ package Sinfo is
    function Conversion_OK
      (N : Node_Id) return Boolean;    -- Flag14
 
+   function Corresponding_Aspect
+     (N : Node_Id) return Node_Id;    -- Node3
+
    function Corresponding_Body
      (N : Node_Id) return Node_Id;    -- Node5
 
@@ -8464,12 +8462,6 @@ package Sinfo is
    function From_Default
      (N : Node_Id) return Boolean;    -- Flag6
 
-   function From_Dynamic_Predicate
-     (N : Node_Id) return Boolean;    -- Flag7
-
-   function From_Static_Predicate
-     (N : Node_Id) return Boolean;    -- Flag8
-
    function Generic_Associations
      (N : Node_Id) return List_Id;    -- List3
 
@@ -9220,6 +9212,9 @@ package Sinfo is
    procedure Set_Conversion_OK
      (N : Node_Id; Val : Boolean := True);    -- Flag14
 
+   procedure Set_Corresponding_Aspect
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
    procedure Set_Corresponding_Body
      (N : Node_Id; Val : Node_Id);            -- Node5
 
@@ -9439,12 +9434,6 @@ package Sinfo is
    procedure Set_From_Default
      (N : Node_Id; Val : Boolean := True);    -- Flag6
 
-   procedure Set_From_Dynamic_Predicate
-     (N : Node_Id; Val : Boolean := True);    -- Flag7
-
-   procedure Set_From_Static_Predicate
-     (N : Node_Id; Val : Boolean := True);    -- Flag8
-
    procedure Set_Generic_Associations
      (N : Node_Id; Val : List_Id);            -- List3
 
@@ -11813,6 +11802,7 @@ package Sinfo is
    pragma Inline (Context_Pending);
    pragma Inline (Controlling_Argument);
    pragma Inline (Conversion_OK);
+   pragma Inline (Corresponding_Aspect);
    pragma Inline (Corresponding_Body);
    pragma Inline (Corresponding_Formal_Spec);
    pragma Inline (Corresponding_Generic_Association);
@@ -11887,8 +11877,6 @@ package Sinfo is
    pragma Inline (From_At_End);
    pragma Inline (From_At_Mod);
    pragma Inline (From_Default);
-   pragma Inline (From_Dynamic_Predicate);
-   pragma Inline (From_Static_Predicate);
    pragma Inline (Generic_Associations);
    pragma Inline (Generic_Formal_Declarations);
    pragma Inline (Generic_Parent);
@@ -12136,6 +12124,7 @@ package Sinfo is
    pragma Inline (Set_Context_Pending);
    pragma Inline (Set_Controlling_Argument);
    pragma Inline (Set_Conversion_OK);
+   pragma Inline (Set_Corresponding_Aspect);
    pragma Inline (Set_Corresponding_Body);
    pragma Inline (Set_Corresponding_Formal_Spec);
    pragma Inline (Set_Corresponding_Generic_Association);
@@ -12209,8 +12198,6 @@ package Sinfo is
    pragma Inline (Set_From_At_End);
    pragma Inline (Set_From_At_Mod);
    pragma Inline (Set_From_Default);
-   pragma Inline (Set_From_Dynamic_Predicate);
-   pragma Inline (Set_From_Static_Predicate);
    pragma Inline (Set_Generic_Associations);
    pragma Inline (Set_Generic_Formal_Declarations);
    pragma Inline (Set_Generic_Parent);