summaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2011-09-06 10:43:17 +0000
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2011-09-06 10:43:17 +0000
commitcce84b09e105d119e21714d124766a8b3a8bfd8f (patch)
tree1157a2d869f2276dd64328c487465347fc91ac7c /gcc
parenta3a76ccc41dd9d4d6e05bdcc53a81cc9c98d6ccc (diff)
downloadgcc-cce84b09e105d119e21714d124766a8b3a8bfd8f.tar.gz
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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178583 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
-rw-r--r--gcc/ada/ChangeLog46
-rw-r--r--gcc/ada/checks.adb1
-rw-r--r--gcc/ada/exp_ch6.adb23
-rw-r--r--gcc/ada/g-socket.adb1
-rw-r--r--gcc/ada/make.adb21
-rw-r--r--gcc/ada/prj-nmsc.adb9
-rw-r--r--gcc/ada/prj-part.adb4
-rw-r--r--gcc/ada/s-taprop-mingw.adb2
-rw-r--r--gcc/ada/s-taprop-vxworks.adb7
-rw-r--r--gcc/ada/s-tpoaal.adb4
-rw-r--r--gcc/ada/s-tpopsp-vxworks.adb21
-rw-r--r--gcc/ada/sem_ch13.adb36
-rw-r--r--gcc/ada/sem_prag.adb173
-rw-r--r--gcc/ada/sinfo.adb48
-rw-r--r--gcc/ada/sinfo.ads39
15 files changed, 209 insertions, 226 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 0b5216f1e0c..f39c314bec0 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -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
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 336b14462c2..0d2322afa6f 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -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;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index b3003893eef..8955e5d9174 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -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.
diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb
index 59e63bde246..bf1fe9fdde0 100644
--- a/gcc/ada/g-socket.adb
+++ b/gcc/ada/g-socket.adb
@@ -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
diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb
index 13777bbf0c5..bf6a21a0dad 100644
--- a/gcc/ada/make.adb
+++ b/gcc/ada/make.adb
@@ -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);
diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb
index 9ebd3003aa3..e7d9c5af859 100644
--- a/gcc/ada/prj-nmsc.adb
+++ b/gcc/ada/prj-nmsc.adb
@@ -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;
diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb
index 3b07a804648..1c18680fbe8 100644
--- a/gcc/ada/prj-part.adb
+++ b/gcc/ada/prj-part.adb
@@ -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,
diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb
index d26568f4522..7fc505e30bc 100644
--- a/gcc/ada/s-taprop-mingw.adb
+++ b/gcc/ada/s-taprop-mingw.adb
@@ -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.
diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb
index 6b3c35eafe3..be76162b284 100644
--- a/gcc/ada/s-taprop-vxworks.adb
+++ b/gcc/ada/s-taprop-vxworks.adb
@@ -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);
diff --git a/gcc/ada/s-tpoaal.adb b/gcc/ada/s-tpoaal.adb
index 0e79f457068..1d25fb84b62 100644
--- a/gcc/ada/s-tpoaal.adb
+++ b/gcc/ada/s-tpoaal.adb
@@ -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;
diff --git a/gcc/ada/s-tpopsp-vxworks.adb b/gcc/ada/s-tpopsp-vxworks.adb
index 64bf10c4d94..09c03efe061 100644
--- a/gcc/ada/s-tpopsp-vxworks.adb
+++ b/gcc/ada/s-tpopsp-vxworks.adb
@@ -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);
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 2655b25eddf..f5b52d04e0d 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -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
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 2ca94177c44..e3db8077f68 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -29,65 +29,63 @@
-- 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
diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb
index 32d993880b7..75433470b71 100644
--- a/gcc/ada/sinfo.adb
+++ b/gcc/ada/sinfo.adb
@@ -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
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 203d18643b4..4e239b8203b 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -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);