git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

2010-10-11  Arnaud Charlet  <charlet@adacore.com>

        * sem_prag.adb (Check_Interrupt_Or_Attach_Handler): Do not emit error
        for AI05-0033 in CodePeer mode.

2010-10-11  Robert Dewar  <dewar@adacore.com>

        * atree.h, atree.ads, atree.adb (Flag3): New flag (replaces Unused_1)
        * csinfo.adb: Aspect_Specifications is a new special field
        * einfo.adb (Flag3): New unused flag
        * exp_util.adb (Insert_Actions): Add processing for
        N_Aspect_Specification.
        * sem.adb: Add entry for N_Aspect_Specification.
        * sinfo.ads, sinfo.adb (N_Aspect_Specification): New node
        (Has_Aspect_Specifications): New flag
        (Permits_Aspect_Specifications): New function
        (Aspect_Specifications): New function
        (Set_Aspect_Specifications): New procedure
        * sprint.adb (Sprint_Node): Put N_At_Clause in proper alpha order
        (Sprint_Node): Add dummy entry for N_Aspect_Specification
        * treepr.adb (Flag3): New flag to be listed

2010-10-11  Vincent Celier  <celier@adacore.com>

        * adaint.c: Minor reformatting.

From-SVN: r165279
This commit is contained in:
Arnaud Charlet 2010-10-11 10:44:15 +02:00
parent 7b53cb49e2
commit 313d6f2c34
13 changed files with 427 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
gcc/ada/adaint.c
View File

@ -2372,17 +2372,17 @@ __gnat_number_of_cpus (void)
{ {
int cores = 1; int cores = 1;
#if defined (linux) || defined (sun) || defined (AIX) || \ #if defined (linux) || defined (sun) || defined (AIX) \
(defined (__alpha__) && defined (_osf_)) || defined (__APPLE__) || (defined (__alpha__) && defined (_osf_)) || defined (__APPLE__)
cores = (int)sysconf(_SC_NPROCESSORS_ONLN); cores = (int) sysconf (_SC_NPROCESSORS_ONLN);
#elif (defined (__mips) && defined (__sgi)) #elif (defined (__mips) && defined (__sgi))
cores = (int)sysconf(_SC_NPROC_ONLN); cores = (int) sysconf (_SC_NPROC_ONLN);
#elif defined (__hpux__) #elif defined (__hpux__)
struct pst_dynamic psd; struct pst_dynamic psd;
if (pstat_getdynamic(&psd, sizeof(psd), 1, 0) != -1) if (pstat_getdynamic (&psd, sizeof (psd), 1, 0) != -1)
cores = (int)psd.psd_proc_cnt; cores = (int) psd.psd_proc_cnt;
#endif #endif

28
gcc/ada/atree.adb
View File

@ -2704,6 +2704,12 @@ package body Atree is
return From_Union (Nodes.Table (N + 3).Field8); return From_Union (Nodes.Table (N + 3).Field8);
end Ureal21; end Ureal21;
function Flag3 (N : Node_Id) return Boolean is
begin
pragma Assert (N <= Nodes.Last);
return Nodes.Table (N).Flag3;
end Flag3;
function Flag4 (N : Node_Id) return Boolean is function Flag4 (N : Node_Id) return Boolean is
begin begin
pragma Assert (N <= Nodes.Last); pragma Assert (N <= Nodes.Last);
@ -2803,7 +2809,7 @@ package body Atree is
function Flag20 (N : Node_Id) return Boolean is function Flag20 (N : Node_Id) return Boolean is
begin begin
pragma Assert (Nkind (N) in N_Entity); pragma Assert (Nkind (N) in N_Entity);
return Nodes.Table (N + 1).Unused_1; return Nodes.Table (N + 1).Flag3;
end Flag20; end Flag20;
function Flag21 (N : Node_Id) return Boolean is function Flag21 (N : Node_Id) return Boolean is
@ -2929,7 +2935,7 @@ package body Atree is
function Flag41 (N : Node_Id) return Boolean is function Flag41 (N : Node_Id) return Boolean is
begin begin
pragma Assert (Nkind (N) in N_Entity); pragma Assert (Nkind (N) in N_Entity);
return Nodes.Table (N + 2).Unused_1; return Nodes.Table (N + 2).Flag3;
end Flag41; end Flag41;
function Flag42 (N : Node_Id) return Boolean is function Flag42 (N : Node_Id) return Boolean is
@ -3463,7 +3469,7 @@ package body Atree is
function Flag130 (N : Node_Id) return Boolean is function Flag130 (N : Node_Id) return Boolean is
begin begin
pragma Assert (Nkind (N) in N_Entity); pragma Assert (Nkind (N) in N_Entity);
return Nodes.Table (N + 3).Unused_1; return Nodes.Table (N + 3).Flag3;
end Flag130; end Flag130;
function Flag131 (N : Node_Id) return Boolean is function Flag131 (N : Node_Id) return Boolean is
@ -3985,7 +3991,7 @@ package body Atree is
function Flag217 (N : Node_Id) return Boolean is function Flag217 (N : Node_Id) return Boolean is
begin begin
pragma Assert (Nkind (N) in N_Entity); pragma Assert (Nkind (N) in N_Entity);
return Nodes.Table (N + 4).Unused_1; return Nodes.Table (N + 4).Flag3;
end Flag217; end Flag217;
function Flag218 (N : Node_Id) return Boolean is function Flag218 (N : Node_Id) return Boolean is
@ -4806,6 +4812,12 @@ package body Atree is
Nodes.Table (N + 3).Field8 := To_Union (Val); Nodes.Table (N + 3).Field8 := To_Union (Val);
end Set_Ureal21; end Set_Ureal21;
procedure Set_Flag3 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag3 := Val;
end Set_Flag3;
procedure Set_Flag4 (N : Node_Id; Val : Boolean) is procedure Set_Flag4 (N : Node_Id; Val : Boolean) is
begin begin
pragma Assert (N <= Nodes.Last); pragma Assert (N <= Nodes.Last);
@ -4905,7 +4917,7 @@ package body Atree is
procedure Set_Flag20 (N : Node_Id; Val : Boolean) is procedure Set_Flag20 (N : Node_Id; Val : Boolean) is
begin begin
pragma Assert (Nkind (N) in N_Entity); pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Unused_1 := Val; Nodes.Table (N + 1).Flag3 := Val;
end Set_Flag20; end Set_Flag20;
procedure Set_Flag21 (N : Node_Id; Val : Boolean) is procedure Set_Flag21 (N : Node_Id; Val : Boolean) is
@ -5031,7 +5043,7 @@ package body Atree is
procedure Set_Flag41 (N : Node_Id; Val : Boolean) is procedure Set_Flag41 (N : Node_Id; Val : Boolean) is
begin begin
pragma Assert (Nkind (N) in N_Entity); pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Unused_1 := Val; Nodes.Table (N + 2).Flag3 := Val;
end Set_Flag41; end Set_Flag41;
procedure Set_Flag42 (N : Node_Id; Val : Boolean) is procedure Set_Flag42 (N : Node_Id; Val : Boolean) is
@ -5693,7 +5705,7 @@ package body Atree is
procedure Set_Flag130 (N : Node_Id; Val : Boolean) is procedure Set_Flag130 (N : Node_Id; Val : Boolean) is
begin begin
pragma Assert (Nkind (N) in N_Entity); pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Unused_1 := Val; Nodes.Table (N + 3).Flag3 := Val;
end Set_Flag130; end Set_Flag130;
procedure Set_Flag131 (N : Node_Id; Val : Boolean) is procedure Set_Flag131 (N : Node_Id; Val : Boolean) is
@ -6343,7 +6355,7 @@ package body Atree is
procedure Set_Flag217 (N : Node_Id; Val : Boolean) is procedure Set_Flag217 (N : Node_Id; Val : Boolean) is
begin begin
pragma Assert (Nkind (N) in N_Entity); pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Unused_1 := Val; Nodes.Table (N + 4).Flag3 := Val;
end Set_Flag217; end Set_Flag217;
procedure Set_Flag218 (N : Node_Id; Val : Boolean) is procedure Set_Flag218 (N : Node_Id; Val : Boolean) is

36
gcc/ada/atree.ads
View File

@ -85,10 +85,6 @@ package Atree is
-- In_List A flag used to indicate if the node is a member -- In_List A flag used to indicate if the node is a member
-- of a node list. -- of a node list.
-- Rewrite_Sub A flag set if the node has been rewritten using
-- the Rewrite procedure. The original value of the
-- node is retrievable with Original_Node.
-- Rewrite_Ins A flag set if a node is marked as a rewrite inserted -- Rewrite_Ins A flag set if a node is marked as a rewrite inserted
-- node as a result of a call to Mark_Rewrite_Insertion. -- node as a result of a call to Mark_Rewrite_Insertion.
@ -155,17 +151,18 @@ package Atree is
-- it is useful to be able to do untyped traversals, and an internal -- it is useful to be able to do untyped traversals, and an internal
-- package in Atree allows for direct untyped accesses in such cases. -- package in Atree allows for direct untyped accesses in such cases.
-- Flag4 Fifteen Boolean flags (use depends on Nkind and -- Flag3
-- Flag4 Sixteen Boolean flags (use depends on Nkind and
-- Flag5 Ekind, as described for FieldN). Again the access -- Flag5 Ekind, as described for FieldN). Again the access
-- Flag6 is usually via subprograms in Sinfo and Einfo which -- Flag6 is usually via subprograms in Sinfo and Einfo which
-- Flag7 provide high-level synonyms for these flags, and -- Flag7 provide high-level synonyms for these flags, and
-- Flag8 contain debugging code that checks that the values -- Flag8 contain debugging code that checks that the values
-- Flag9 in Nkind and Ekind are appropriate for the access. -- Flag9 in Nkind and Ekind are appropriate for the access.
-- Flag10 -- Flag10
-- Flag11 Note that Flag1-3 are missing from this list. The -- Flag11 Note that Flag1-2 are missing from this list. For
-- Flag12 first three flag positions are reserved for the -- Flag12 historical reasons, these flag names are unused.
-- Flag13 standard flags (Comes_From_Source, Error_Posted, -- Flag13
-- Flag14 and Analyzed) -- Flag14
-- Flag15 -- Flag15
-- Flag16 -- Flag16
-- Flag17 -- Flag17
@ -184,9 +181,9 @@ package Atree is
-- entity, it is of type Entity_Kind which is defined -- entity, it is of type Entity_Kind which is defined
-- in package Einfo. -- in package Einfo.
-- Flag19 229 additional flags -- Flag19 235 additional flags
-- ... -- ...
-- Flag247 -- Flag254
-- Convention Entity convention (Convention_Id value) -- Convention Entity convention (Convention_Id value)
@ -296,7 +293,7 @@ package Atree is
------------------------------------- -------------------------------------
-- A subpackage Atree.Unchecked_Access provides routines for reading and -- A subpackage Atree.Unchecked_Access provides routines for reading and
-- writing the fields defined above (Field1-27, Node1-27, Flag1-247 etc). -- writing the fields defined above (Field1-27, Node1-27, Flag3-254 etc).
-- These unchecked access routines can be used for untyped traversals. -- These unchecked access routines can be used for untyped traversals.
-- In addition they are used in the implementations of the Sinfo and -- In addition they are used in the implementations of the Sinfo and
-- Einfo packages. These packages both provide logical synonyms for -- Einfo packages. These packages both provide logical synonyms for
@ -1199,6 +1196,9 @@ package Atree is
function Ureal21 (N : Node_Id) return Ureal; function Ureal21 (N : Node_Id) return Ureal;
pragma Inline (Ureal21); pragma Inline (Ureal21);
function Flag3 (N : Node_Id) return Boolean;
pragma Inline (Flag3);
function Flag4 (N : Node_Id) return Boolean; function Flag4 (N : Node_Id) return Boolean;
pragma Inline (Flag4); pragma Inline (Flag4);
@ -2254,6 +2254,9 @@ package Atree is
procedure Set_Ureal21 (N : Node_Id; Val : Ureal); procedure Set_Ureal21 (N : Node_Id; Val : Ureal);
pragma Inline (Set_Ureal21); pragma Inline (Set_Ureal21);
procedure Set_Flag3 (N : Node_Id; Val : Boolean);
pragma Inline (Set_Flag3);
procedure Set_Flag4 (N : Node_Id; Val : Boolean); procedure Set_Flag4 (N : Node_Id; Val : Boolean);
pragma Inline (Set_Flag4); pragma Inline (Set_Flag4);
@ -3088,8 +3091,7 @@ package Atree is
-- Flag used to indicate if node is a member of a list. -- Flag used to indicate if node is a member of a list.
-- This field is considered private to the Atree package. -- This field is considered private to the Atree package.
Unused_1 : Boolean; Flag3 : Boolean;
-- Currently unused flag
Rewrite_Ins : Boolean; Rewrite_Ins : Boolean;
-- Flag set by Mark_Rewrite_Insertion procedure. -- Flag set by Mark_Rewrite_Insertion procedure.
@ -3128,7 +3130,7 @@ package Atree is
-- used in component 5 (where we still have lots of room!) -- used in component 5 (where we still have lots of room!)
-- In_List used as Flag19, Flag40, Flag129, Flag216 -- In_List used as Flag19, Flag40, Flag129, Flag216
-- Unused_1 used as Flag20, Flag41, Flag130, Flag217 -- Flag3 used as Flag20, Flag41, Flag130, Flag217
-- Rewrite_Ins used as Flag21, Flag42, Flag131, Flag218 -- Rewrite_Ins used as Flag21, Flag42, Flag131, Flag218
-- Analyzed used as Flag22, Flag43, Flag132, Flag219 -- Analyzed used as Flag22, Flag43, Flag132, Flag219
-- Comes_From_Source used as Flag23, Flag44, Flag133, Flag220 -- Comes_From_Source used as Flag23, Flag44, Flag133, Flag220
@ -3243,7 +3245,7 @@ package Atree is
Pflag1 => False, Pflag1 => False,
Pflag2 => False, Pflag2 => False,
In_List => False, In_List => False,
Unused_1 => False, Flag3 => False,
Rewrite_Ins => False, Rewrite_Ins => False,
Analyzed => False, Analyzed => False,
Comes_From_Source => False, Comes_From_Source => False,
@ -3288,7 +3290,7 @@ package Atree is
Pflag1 => False, Pflag1 => False,
Pflag2 => False, Pflag2 => False,
In_List => False, In_List => False,
Unused_1 => False, Flag3 => False,
Rewrite_Ins => False, Rewrite_Ins => False,
Analyzed => False, Analyzed => False,
Comes_From_Source => False, Comes_From_Source => False,

45
gcc/ada/atree.h
View File

@ -36,16 +36,16 @@
struct NFK struct NFK
{ {
Boolean is_extension : 1; Boolean is_extension : 1;
Boolean pflag1 : 1; Boolean pflag1 : 1;
Boolean pflag2 : 1; Boolean pflag2 : 1;
Boolean in_list : 1; Boolean in_list : 1;
Boolean rewrite_sub : 1; Boolean flag3 : 1;
Boolean rewrite_ins : 1; Boolean rewrite_ins : 1;
Boolean analyzed : 1; Boolean analyzed : 1;
Boolean c_f_s : 1; Boolean c_f_s : 1;
Boolean error_posted : 1; Boolean error_posted : 1;
Boolean flag4 : 1; Boolean flag4 : 1;
Boolean flag5 : 1; Boolean flag5 : 1;
Boolean flag6 : 1; Boolean flag6 : 1;
@ -71,16 +71,16 @@ struct NFK
struct NFNK struct NFNK
{ {
Boolean is_extension : 1; Boolean is_extension : 1;
Boolean pflag1 : 1; Boolean pflag1 : 1;
Boolean pflag2 : 1; Boolean pflag2 : 1;
Boolean in_list : 1; Boolean in_list : 1;
Boolean rewrite_sub : 1; Boolean flag3 : 1;
Boolean rewrite_ins : 1; Boolean rewrite_ins : 1;
Boolean analyzed : 1; Boolean analyzed : 1;
Boolean c_f_s : 1; Boolean c_f_s : 1;
Boolean error_posted : 1; Boolean error_posted : 1;
Boolean flag4 : 1; Boolean flag4 : 1;
Boolean flag5 : 1; Boolean flag5 : 1;
Boolean flag6 : 1; Boolean flag6 : 1;
@ -469,6 +469,7 @@ extern Node_Id Current_Error_Node;
#define Convention(N) \ #define Convention(N) \
(Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.convention) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.convention)
#define Flag3(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag3)
#define Flag4(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag4) #define Flag4(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag4)
#define Flag5(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag5) #define Flag5(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag5)
#define Flag6(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag6) #define Flag6(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag6)
@ -486,7 +487,7 @@ extern Node_Id Current_Error_Node;
#define Flag18(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag18) #define Flag18(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag18)
#define Flag19(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.in_list) #define Flag19(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.in_list)
#define Flag20(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.rewrite_sub) #define Flag20(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag3)
#define Flag21(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.rewrite_ins) #define Flag21(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.rewrite_ins)
#define Flag22(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.analyzed) #define Flag22(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.analyzed)
#define Flag23(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.c_f_s) #define Flag23(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.c_f_s)
@ -508,7 +509,7 @@ extern Node_Id Current_Error_Node;
#define Flag39(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag18) #define Flag39(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag18)
#define Flag40(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.in_list) #define Flag40(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.in_list)
#define Flag41(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.rewrite_sub) #define Flag41(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag3)
#define Flag42(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.rewrite_ins) #define Flag42(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.rewrite_ins)
#define Flag43(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.analyzed) #define Flag43(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.analyzed)
#define Flag44(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.c_f_s) #define Flag44(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.c_f_s)
@ -600,7 +601,7 @@ extern Node_Id Current_Error_Node;
#define Flag128(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag128) #define Flag128(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag128)
#define Flag129(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.in_list) #define Flag129(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.in_list)
#define Flag130(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.rewrite_sub) #define Flag130(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag3)
#define Flag131(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.rewrite_ins) #define Flag131(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.rewrite_ins)
#define Flag132(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.analyzed) #define Flag132(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.analyzed)
#define Flag133(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.c_f_s) #define Flag133(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.c_f_s)
@ -690,7 +691,7 @@ extern Node_Id Current_Error_Node;
#define Flag215(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag215) #define Flag215(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag215)
#define Flag216(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.in_list) #define Flag216(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.in_list)
#define Flag217(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.rewrite_sub) #define Flag217(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag3)
#define Flag218(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.rewrite_ins) #define Flag218(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.rewrite_ins)
#define Flag219(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.analyzed) #define Flag219(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.analyzed)
#define Flag220(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.c_f_s) #define Flag220(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.c_f_s)

3
gcc/ada/csinfo.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -210,6 +210,7 @@ begin
Set (Special, "Etype", True); Set (Special, "Etype", True);
Set (Special, "Evaluate_Once", True); Set (Special, "Evaluate_Once", True);
Set (Special, "First_Itype", True); Set (Special, "First_Itype", True);
Set (Special, "Has_Aspect_Specifications", True);
Set (Special, "Has_Dynamic_Itype", True); Set (Special, "Has_Dynamic_Itype", True);
Set (Special, "Has_Dynamic_Range_Check", True); Set (Special, "Has_Dynamic_Range_Check", True);
Set (Special, "Has_Dynamic_Length_Check", True); Set (Special, "Has_Dynamic_Length_Check", True);

5
gcc/ada/einfo.adb
View File

@ -241,9 +241,7 @@ package body Einfo is
-- sense for them to be set true for certain subsets of entity kinds. See -- sense for them to be set true for certain subsets of entity kinds. See
-- the spec of Einfo for further details. -- the spec of Einfo for further details.
-- Note: Flag1-Flag3 are absent from this list, since these flag positions -- Note: Flag1-Flag2 are absent from this list, for historical reasons
-- are used for the flags Analyzed, Comes_From_Source, and Error_Posted,
-- which are common to all nodes, including entity nodes.
-- Is_Frozen Flag4 -- Is_Frozen Flag4
-- Has_Discriminants Flag5 -- Has_Discriminants Flag5
@ -512,6 +510,7 @@ package body Einfo is
-- Is_Underlying_Record_View Flag246 -- Is_Underlying_Record_View Flag246
-- OK_To_Rename Flag247 -- OK_To_Rename Flag247
-- (unused) Flag3
-- (unused) Flag200 -- (unused) Flag200
-- (unused) Flag232 -- (unused) Flag232

1
gcc/ada/exp_util.adb
View File

@ -2774,6 +2774,7 @@ package body Exp_Util is
N_Access_To_Object_Definition | N_Access_To_Object_Definition |
N_Aggregate | N_Aggregate |
N_Allocator | N_Allocator |
N_Aspect_Specification |
N_Case_Expression | N_Case_Expression |
N_Case_Statement_Alternative | N_Case_Statement_Alternative |
N_Character_Literal | N_Character_Literal |

1
gcc/ada/sem.adb
View File

@ -636,6 +636,7 @@ package body Sem is
N_Access_Function_Definition | N_Access_Function_Definition |
N_Access_Procedure_Definition | N_Access_Procedure_Definition |
N_Access_To_Object_Definition | N_Access_To_Object_Definition |
N_Aspect_Specification |
N_Case_Expression_Alternative | N_Case_Expression_Alternative |
N_Case_Statement_Alternative | N_Case_Statement_Alternative |
N_Compilation_Unit_Aux | N_Compilation_Unit_Aux |

8
gcc/ada/sem_prag.adb
View File

@ -1338,13 +1338,17 @@ package body Sem_Prag is
("argument for pragma% must be library level entity", Arg1); ("argument for pragma% must be library level entity", Arg1);
end if; end if;
-- AI05-0033 : pragma cannot appear within a generic body, because -- AI05-0033: A pragma cannot appear within a generic body, because
-- instance can be in a nested scope. The check that protected type -- instance can be in a nested scope. The check that protected type
-- is itself a library-level declaration is done elsewhere. -- is itself a library-level declaration is done elsewhere.
-- Note: we omit this check in Codepeer mode to properly handle code
-- prior to AI-0033 (pragmas don't matter to codepeer in any case).
if Inside_A_Generic then if Inside_A_Generic then
if Ekind (Scope (Current_Scope)) = E_Generic_Package if Ekind (Scope (Current_Scope)) = E_Generic_Package
and then In_Package_Body (Scope (Current_Scope)) and then In_Package_Body (Scope (Current_Scope))
and then not CodePeer_Mode
then then
Error_Pragma ("pragma% cannot be used inside a generic"); Error_Pragma ("pragma% cannot be used inside a generic");
end if; end if;

157
gcc/ada/sinfo.adb
View File

@ -32,7 +32,10 @@
pragma Style_Checks (All_Checks); pragma Style_Checks (All_Checks);
-- No subprogram ordering check, due to logical grouping -- No subprogram ordering check, due to logical grouping
with Atree; use Atree; with Atree; use Atree;
with Nlists; use Nlists;
with System.HTable;
package body Sinfo is package body Sinfo is
@ -53,6 +56,30 @@ package body Sinfo is
NT : Nodes.Table_Ptr renames Nodes.Table; NT : Nodes.Table_Ptr renames Nodes.Table;
-- A short hand abbreviation, useful for the debugging checks -- A short hand abbreviation, useful for the debugging checks
------------------------------------------
-- Hash Table for Aspect Specifications --
------------------------------------------
type Hash_Range is range 0 .. 510;
-- Size of hash table headers
function AS_Hash (F : Node_Id) return Hash_Range;
-- Hash function for hash table
function AS_Hash (F : Node_Id) return Hash_Range is
begin
return Hash_Range (F mod 511);
end AS_Hash;
package Aspect_Specifications_Hash_Table is new
System.HTable.Simple_HTable
(Header_Num => Hash_Range,
Element => List_Id,
No_Element => No_List,
Key => Node_Id,
Hash => AS_Hash,
Equal => "=");
---------------------------- ----------------------------
-- Field Access Functions -- -- Field Access Functions --
---------------------------- ----------------------------
@ -392,6 +419,14 @@ package body Sinfo is
return List1 (N); return List1 (N);
end Choices; end Choices;
function Class_Present
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Aspect_Specification);
return Flag6 (N);
end Class_Present;
function Coextensions function Coextensions
(N : Node_Id) return Elist_Id is (N : Node_Id) return Elist_Id is
begin begin
@ -1171,6 +1206,7 @@ package body Sinfo is
begin begin
pragma Assert (False pragma Assert (False
or else NT (N).Nkind = N_Allocator or else NT (N).Nkind = N_Allocator
or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_Assignment_Statement
or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_At_Clause
or else NT (N).Nkind = N_Attribute_Definition_Clause or else NT (N).Nkind = N_Attribute_Definition_Clause
@ -1215,6 +1251,14 @@ package body Sinfo is
return List1 (N); return List1 (N);
end Expressions; end Expressions;
function First_Aspect
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Aspect_Specification);
return Flag4 (N);
end First_Aspect;
function First_Bit function First_Bit
(N : Node_Id) return Node_Id is (N : Node_Id) return Node_Id is
begin begin
@ -1373,6 +1417,13 @@ package body Sinfo is
return Node2 (N); return Node2 (N);
end Handler_List_Entry; end Handler_List_Entry;
function Has_Aspect_Specifications
(N : Node_Id) return Boolean is
begin
pragma Assert (Permits_Aspect_Specifications (N));
return Flag3 (N);
end Has_Aspect_Specifications;
function Has_Created_Identifier function Has_Created_Identifier
(N : Node_Id) return Boolean is (N : Node_Id) return Boolean is
begin begin
@ -1387,7 +1438,6 @@ package body Sinfo is
begin begin
return Flag10 (N); return Flag10 (N);
end Has_Dynamic_Length_Check; end Has_Dynamic_Length_Check;
function Has_Dynamic_Range_Check function Has_Dynamic_Range_Check
(N : Node_Id) return Boolean is (N : Node_Id) return Boolean is
begin begin
@ -1521,6 +1571,7 @@ package body Sinfo is
(N : Node_Id) return Node_Id is (N : Node_Id) return Node_Id is
begin begin
pragma Assert (False pragma Assert (False
or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_At_Clause
or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Block_Statement
or else NT (N).Nkind = N_Designator or else NT (N).Nkind = N_Designator
@ -1818,6 +1869,14 @@ package body Sinfo is
return Node2 (N); return Node2 (N);
end Label_Construct; end Label_Construct;
function Last_Aspect
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Aspect_Specification);
return Flag5 (N);
end Last_Aspect;
function Last_Bit function Last_Bit
(N : Node_Id) return Node_Id is (N : Node_Id) return Node_Id is
begin begin
@ -3307,6 +3366,14 @@ package body Sinfo is
Set_List1_With_Parent (N, Val); Set_List1_With_Parent (N, Val);
end Set_Choices; end Set_Choices;
procedure Set_Class_Present
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Aspect_Specification);
Set_Flag6 (N, Val);
end Set_Class_Present;
procedure Set_Coextensions procedure Set_Coextensions
(N : Node_Id; Val : Elist_Id) is (N : Node_Id; Val : Elist_Id) is
begin begin
@ -4077,6 +4144,7 @@ package body Sinfo is
begin begin
pragma Assert (False pragma Assert (False
or else NT (N).Nkind = N_Allocator or else NT (N).Nkind = N_Allocator
or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_Assignment_Statement
or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_At_Clause
or else NT (N).Nkind = N_Attribute_Definition_Clause or else NT (N).Nkind = N_Attribute_Definition_Clause
@ -4121,6 +4189,14 @@ package body Sinfo is
Set_List1_With_Parent (N, Val); Set_List1_With_Parent (N, Val);
end Set_Expressions; end Set_Expressions;
procedure Set_First_Aspect
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Aspect_Specification);
Set_Flag4 (N, Val);
end Set_First_Aspect;
procedure Set_First_Bit procedure Set_First_Bit
(N : Node_Id; Val : Node_Id) is (N : Node_Id; Val : Node_Id) is
begin begin
@ -4279,6 +4355,13 @@ package body Sinfo is
Set_Node2 (N, Val); Set_Node2 (N, Val);
end Set_Handler_List_Entry; end Set_Handler_List_Entry;
procedure Set_Has_Aspect_Specifications
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (Permits_Aspect_Specifications (N));
Set_Flag3 (N, Val);
end Set_Has_Aspect_Specifications;
procedure Set_Has_Created_Identifier procedure Set_Has_Created_Identifier
(N : Node_Id; Val : Boolean := True) is (N : Node_Id; Val : Boolean := True) is
begin begin
@ -4427,6 +4510,7 @@ package body Sinfo is
(N : Node_Id; Val : Node_Id) is (N : Node_Id; Val : Node_Id) is
begin begin
pragma Assert (False pragma Assert (False
or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_At_Clause
or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Block_Statement
or else NT (N).Nkind = N_Designator or else NT (N).Nkind = N_Designator
@ -4732,6 +4816,14 @@ package body Sinfo is
Set_Node4_With_Parent (N, Val); Set_Node4_With_Parent (N, Val);
end Set_Last_Bit; end Set_Last_Bit;
procedure Set_Last_Aspect
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Aspect_Specification);
Set_Flag5 (N, Val);
end Set_Last_Aspect;
procedure Set_Last_Name procedure Set_Last_Name
(N : Node_Id; Val : Boolean := True) is (N : Node_Id; Val : Boolean := True) is
begin begin
@ -6071,4 +6163,65 @@ package body Sinfo is
return Chars (Pragma_Identifier (N)); return Chars (Pragma_Identifier (N));
end Pragma_Name; end Pragma_Name;
-----------------------------------
-- Permits_Aspect_Specifications --
-----------------------------------
Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean :=
(N_Abstract_Subprogram_Declaration => True,
N_Component_Declaration => True,
N_Entry_Declaration => True,
N_Exception_Declaration => True,
N_Formal_Abstract_Subprogram_Declaration => True,
N_Formal_Concrete_Subprogram_Declaration => True,
N_Formal_Object_Declaration => True,
N_Formal_Package_Declaration => True,
N_Formal_Type_Declaration => True,
N_Full_Type_Declaration => True,
N_Function_Instantiation => True,
N_Generic_Package_Declaration => True,
N_Generic_Subprogram_Declaration => True,
N_Object_Declaration => True,
N_Package_Declaration => True,
N_Package_Instantiation => True,
N_Private_Extension_Declaration => True,
N_Private_Type_Declaration => True,
N_Procedure_Instantiation => True,
N_Protected_Type_Declaration => True,
N_Single_Protected_Declaration => True,
N_Single_Task_Declaration => True,
N_Subprogram_Declaration => True,
N_Subtype_Declaration => True,
N_Task_Type_Declaration => True,
others => False);
function Permits_Aspect_Specifications (N : Node_Id) return Boolean is
begin
return Has_Aspect_Specifications_Flag (Nkind (N));
end Permits_Aspect_Specifications;
---------------------------
-- Aspect_Specifications --
---------------------------
function Aspect_Specifications (N : Node_Id) return List_Id is
begin
return Aspect_Specifications_Hash_Table.Get (N);
end Aspect_Specifications;
-------------------------------
-- Set_Aspect_Specifications --
-------------------------------
procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is
begin
pragma Assert (Permits_Aspect_Specifications (N));
pragma Assert (not Has_Aspect_Specifications (N));
pragma Assert (L /= No_List);
Set_Has_Aspect_Specifications (N);
Set_Parent (L, N);
Aspect_Specifications_Hash_Table.Set (N, L);
end Set_Aspect_Specifications;
end Sinfo; end Sinfo;

185
gcc/ada/sinfo.ads
View File

@ -2102,6 +2102,9 @@ package Sinfo is
-- Discriminant_Specifications (List4) (set to No_List if none) -- Discriminant_Specifications (List4) (set to No_List if none)
-- Type_Definition (Node3) -- Type_Definition (Node3)
-- Discr_Check_Funcs_Built (Flag11-Sem) -- Discr_Check_Funcs_Built (Flag11-Sem)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
---------------------------- ----------------------------
-- 3.2.1 Type Definition -- -- 3.2.1 Type Definition --
@ -2130,6 +2133,9 @@ package Sinfo is
-- Subtype_Indication (Node5) -- Subtype_Indication (Node5)
-- Generic_Parent_Type (Node4-Sem) (set for an actual derived type). -- Generic_Parent_Type (Node4-Sem) (set for an actual derived type).
-- Exception_Junk (Flag8-Sem) -- Exception_Junk (Flag8-Sem)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
------------------------------- -------------------------------
-- 3.2.2 Subtype Indication -- -- 3.2.2 Subtype Indication --
@ -2260,6 +2266,9 @@ package Sinfo is
-- Exception_Junk (Flag8-Sem) -- Exception_Junk (Flag8-Sem)
-- Is_Subprogram_Descriptor (Flag16-Sem) -- Is_Subprogram_Descriptor (Flag16-Sem)
-- Has_Init_Expression (Flag14) -- Has_Init_Expression (Flag14)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
------------------------------------- -------------------------------------
-- 3.3.1 Defining Identifier List -- -- 3.3.1 Defining Identifier List --
@ -2832,6 +2841,9 @@ package Sinfo is
-- Expression (Node3) (set to Empty if no default expression) -- Expression (Node3) (set to Empty if no default expression)
-- More_Ids (Flag5) (set to False if no more identifiers in list) -- More_Ids (Flag5) (set to False if no more identifiers in list)
-- Prev_Ids (Flag6) (set to False if no previous identifiers in list) -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
------------------------- -------------------------
-- 3.8.1 Variant Part -- -- 3.8.1 Variant Part --
@ -4185,6 +4197,9 @@ package Sinfo is
-- Body_To_Inline (Node3-Sem) -- Body_To_Inline (Node3-Sem)
-- Corresponding_Body (Node5-Sem) -- Corresponding_Body (Node5-Sem)
-- Parent_Spec (Node4-Sem) -- Parent_Spec (Node4-Sem)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
------------------------------------------ ------------------------------------------
-- 6.1 Abstract Subprogram Declaration -- -- 6.1 Abstract Subprogram Declaration --
@ -4196,6 +4211,9 @@ package Sinfo is
-- N_Abstract_Subprogram_Declaration -- N_Abstract_Subprogram_Declaration
-- Sloc points to ABSTRACT -- Sloc points to ABSTRACT
-- Specification (Node1) -- Specification (Node1)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
----------------------------------- -----------------------------------
-- 6.1 Subprogram Specification -- -- 6.1 Subprogram Specification --
@ -4586,9 +4604,12 @@ package Sinfo is
-- By_Ref (Flag5-Sem) -- By_Ref (Flag5-Sem)
-- Note: Return_Statement_Entity points to an E_Return_Statement. -- Note: Return_Statement_Entity points to an E_Return_Statement.
-- Note that Return_Object_Declarations is a list containing the -- Note that Return_Object_Declarations is a list containing the
-- N_Object_Declaration -- see comment on this field above. -- N_Object_Declaration -- see comment on this field above.
-- The declared object will have Is_Return_Object = True. -- The declared object will have Is_Return_Object = True.
-- There is no such syntactic category as return_object_declaration -- There is no such syntactic category as return_object_declaration
-- in the RM. Return_Object_Declarations represents this portion of -- in the RM. Return_Object_Declarations represents this portion of
-- the syntax for EXTENDED_RETURN_STATEMENT: -- the syntax for EXTENDED_RETURN_STATEMENT:
@ -4616,6 +4637,9 @@ package Sinfo is
-- Corresponding_Body (Node5-Sem) -- Corresponding_Body (Node5-Sem)
-- Parent_Spec (Node4-Sem) -- Parent_Spec (Node4-Sem)
-- Activation_Chain_Entity (Node3-Sem) -- Activation_Chain_Entity (Node3-Sem)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
-------------------------------- --------------------------------
-- 7.1 Package Specification -- -- 7.1 Package Specification --
@ -4682,6 +4706,9 @@ package Sinfo is
-- Abstract_Present (Flag4) -- Abstract_Present (Flag4)
-- Tagged_Present (Flag15) -- Tagged_Present (Flag15)
-- Limited_Present (Flag17) -- Limited_Present (Flag17)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
---------------------------------------- ----------------------------------------
-- 7.4 Private Extension Declaration -- -- 7.4 Private Extension Declaration --
@ -4707,6 +4734,9 @@ package Sinfo is
-- Synchronized_Present (Flag7) -- Synchronized_Present (Flag7)
-- Subtype_Indication (Node5) -- Subtype_Indication (Node5)
-- Interface_List (List2) (set to No_List if none) -- Interface_List (List2) (set to No_List if none)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
--------------------- ---------------------
-- 8.4 Use Clause -- -- 8.4 Use Clause --
@ -4864,6 +4894,9 @@ package Sinfo is
-- Interface_List (List2) (set to No_List if none) -- Interface_List (List2) (set to No_List if none)
-- Task_Definition (Node3) (set to Empty if not present) -- Task_Definition (Node3) (set to Empty if not present)
-- Corresponding_Body (Node5-Sem) -- Corresponding_Body (Node5-Sem)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
---------------------------------- ----------------------------------
-- 9.1 Single Task Declaration -- -- 9.1 Single Task Declaration --
@ -4878,6 +4911,9 @@ package Sinfo is
-- Defining_Identifier (Node1) -- Defining_Identifier (Node1)
-- Interface_List (List2) (set to No_List if none) -- Interface_List (List2) (set to No_List if none)
-- Task_Definition (Node3) (set to Empty if not present) -- Task_Definition (Node3) (set to Empty if not present)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
-------------------------- --------------------------
-- 9.1 Task Definition -- -- 9.1 Task Definition --
@ -4950,6 +4986,9 @@ package Sinfo is
-- Interface_List (List2) (set to No_List if none) -- Interface_List (List2) (set to No_List if none)
-- Protected_Definition (Node3) -- Protected_Definition (Node3)
-- Corresponding_Body (Node5-Sem) -- Corresponding_Body (Node5-Sem)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
--------------------------------------- ---------------------------------------
-- 9.4 Single Protected Declaration -- -- 9.4 Single Protected Declaration --
@ -4966,6 +5005,9 @@ package Sinfo is
-- Defining_Identifier (Node1) -- Defining_Identifier (Node1)
-- Interface_List (List2) (set to No_List if none) -- Interface_List (List2) (set to No_List if none)
-- Protected_Definition (Node3) -- Protected_Definition (Node3)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
------------------------------- -------------------------------
-- 9.4 Protected Definition -- -- 9.4 Protected Definition --
@ -5048,8 +5090,10 @@ package Sinfo is
-- Corresponding_Body (Node5-Sem) -- Corresponding_Body (Node5-Sem)
-- Must_Override (Flag14) set if overriding indicator present -- Must_Override (Flag14) set if overriding indicator present
-- Must_Not_Override (Flag15) set if not_overriding indicator present -- Must_Not_Override (Flag15) set if not_overriding indicator present
-- Has_Aspect_Specifications (Flag3)
-- Note: overriding indicator is an Ada 2005 feature -- Note: overriding indicator is an Ada 2005 feature
-- Note: Aspect_Specification is an Ada 2012 feature
----------------------------- -----------------------------
-- 9.5.2 Accept statement -- -- 9.5.2 Accept statement --
@ -5713,6 +5757,9 @@ package Sinfo is
-- Renaming_Exception (Node2-Sem) -- Renaming_Exception (Node2-Sem)
-- More_Ids (Flag5) (set to False if no more identifiers in list) -- More_Ids (Flag5) (set to False if no more identifiers in list)
-- Prev_Ids (Flag6) (set to False if no previous identifiers in list) -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
------------------------------------------ ------------------------------------------
-- 11.2 Handled Sequence Of Statements -- -- 11.2 Handled Sequence Of Statements --
@ -5861,6 +5908,9 @@ package Sinfo is
-- Corresponding_Body (Node5-Sem) -- Corresponding_Body (Node5-Sem)
-- Generic_Formal_Declarations (List2) from generic formal part -- Generic_Formal_Declarations (List2) from generic formal part
-- Parent_Spec (Node4-Sem) -- Parent_Spec (Node4-Sem)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
--------------------------------------- ---------------------------------------
-- 12.1 Generic Package Declaration -- -- 12.1 Generic Package Declaration --
@ -5882,6 +5932,9 @@ package Sinfo is
-- Generic_Formal_Declarations (List2) from generic formal part -- Generic_Formal_Declarations (List2) from generic formal part
-- Parent_Spec (Node4-Sem) -- Parent_Spec (Node4-Sem)
-- Activation_Chain_Entity (Node3-Sem) -- Activation_Chain_Entity (Node3-Sem)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
------------------------------- -------------------------------
-- 12.1 Generic Formal Part -- -- 12.1 Generic Formal Part --
@ -5923,6 +5976,7 @@ package Sinfo is
-- Parent_Spec (Node4-Sem) -- Parent_Spec (Node4-Sem)
-- Instance_Spec (Node5-Sem) -- Instance_Spec (Node5-Sem)
-- ABE_Is_Certain (Flag18-Sem) -- ABE_Is_Certain (Flag18-Sem)
-- Has_Aspect_Specifications (Flag3)
-- N_Procedure_Instantiation -- N_Procedure_Instantiation
-- Sloc points to PROCEDURE -- Sloc points to PROCEDURE
@ -5935,6 +5989,7 @@ package Sinfo is
-- Must_Override (Flag14) set if overriding indicator present -- Must_Override (Flag14) set if overriding indicator present
-- Must_Not_Override (Flag15) set if not_overriding indicator present -- Must_Not_Override (Flag15) set if not_overriding indicator present
-- ABE_Is_Certain (Flag18-Sem) -- ABE_Is_Certain (Flag18-Sem)
-- Has_Aspect_Specifications (Flag3)
-- N_Function_Instantiation -- N_Function_Instantiation
-- Sloc points to FUNCTION -- Sloc points to FUNCTION
@ -5947,8 +6002,10 @@ package Sinfo is
-- Must_Override (Flag14) set if overriding indicator present -- Must_Override (Flag14) set if overriding indicator present
-- Must_Not_Override (Flag15) set if not_overriding indicator present -- Must_Not_Override (Flag15) set if not_overriding indicator present
-- ABE_Is_Certain (Flag18-Sem) -- ABE_Is_Certain (Flag18-Sem)
-- Has_Aspect_Specifications (Flag3)
-- Note: overriding indicator is an Ada 2005 feature -- Note: overriding indicator is an Ada 2005 feature
-- Note: Aspect_Specification is an Ada 2012 feature
------------------------------- -------------------------------
-- 12.3 Generic Actual Part -- -- 12.3 Generic Actual Part --
@ -6019,6 +6076,9 @@ package Sinfo is
-- Default_Expression (Node5) (set to Empty if no default expression) -- Default_Expression (Node5) (set to Empty if no default expression)
-- More_Ids (Flag5) (set to False if no more identifiers in list) -- More_Ids (Flag5) (set to False if no more identifiers in list)
-- Prev_Ids (Flag6) (set to False if no previous identifiers in list) -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
----------------------------------- -----------------------------------
-- 12.5 Formal Type Declaration -- -- 12.5 Formal Type Declaration --
@ -6035,6 +6095,9 @@ package Sinfo is
-- Discriminant_Specifications (List4) (set to No_List if no -- Discriminant_Specifications (List4) (set to No_List if no
-- discriminant part) -- discriminant part)
-- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
---------------------------------- ----------------------------------
-- 12.5 Formal type definition -- -- 12.5 Formal type definition --
@ -6180,10 +6243,13 @@ package Sinfo is
-- Specification (Node1) -- Specification (Node1)
-- Default_Name (Node2) (set to Empty if no subprogram default) -- Default_Name (Node2) (set to Empty if no subprogram default)
-- Box_Present (Flag15) -- Box_Present (Flag15)
-- Has_Aspect_Specifications (Flag3)
-- Note: if no subprogram default is present, then Name is set -- Note: if no subprogram default is present, then Name is set
-- to Empty, and Box_Present is False. -- to Empty, and Box_Present is False.
-- Note: Aspect_Specification is an Ada 2012 feature
-------------------------------------------------- --------------------------------------------------
-- 12.6 Formal Abstract Subprogram Declaration -- -- 12.6 Formal Abstract Subprogram Declaration --
-------------------------------------------------- --------------------------------------------------
@ -6196,10 +6262,13 @@ package Sinfo is
-- Specification (Node1) -- Specification (Node1)
-- Default_Name (Node2) (set to Empty if no subprogram default) -- Default_Name (Node2) (set to Empty if no subprogram default)
-- Box_Present (Flag15) -- Box_Present (Flag15)
-- Has_Aspect_Specifications (Flag3)
-- Note: if no subprogram default is present, then Name is set -- Note: if no subprogram default is present, then Name is set
-- to Empty, and Box_Present is False. -- to Empty, and Box_Present is False.
-- Note: Aspect_Specification is an Ada 2012 feature
------------------------------ ------------------------------
-- 12.6 Subprogram Default -- -- 12.6 Subprogram Default --
------------------------------ ------------------------------
@ -6236,6 +6305,9 @@ package Sinfo is
-- Box_Present (Flag15) -- Box_Present (Flag15)
-- Instance_Spec (Node5-Sem) -- Instance_Spec (Node5-Sem)
-- ABE_Is_Certain (Flag18-Sem) -- ABE_Is_Certain (Flag18-Sem)
-- Has_Aspect_Specifications (Flag3)
-- Note: Aspect_Specification is an Ada 2012 feature
-------------------------------------- --------------------------------------
-- 12.7 Formal Package Actual Part -- -- 12.7 Formal Package Actual Part --
@ -6325,6 +6397,32 @@ package Sinfo is
-- Check_Address_Alignment (Flag11-Sem) -- Check_Address_Alignment (Flag11-Sem)
-- Address_Warning_Posted (Flag18-Sem) -- Address_Warning_Posted (Flag18-Sem)
----------------------------------
-- 13.3.1 Aspect Specification --
----------------------------------
-- ASPECT_SPECIFICATION ::=
-- with ASPECT_MARK [=> ASPECT_DEFINITION] {.
-- ASPECT_MARK [=> ASPECT_DEFINITION] }
-- ASPECT_MARK ::= aspect_IDENTIFIER['Class]
-- ASPECT_DEFINITION ::= NAME | EXPRESSION
-- See separate section "Handling of Aspect Specifications" for details
-- on the incorporation of these nodes into the tree, and association
-- with the related declaration node.
-- N_Aspect_Specification
-- Sloc points to aspect identifier
-- Identifier (Node1) aspect identifier
-- Expression (Node3) Aspect_Definition (set to Empty if none)
-- First_Aspect (Flag4) Set for first aspect for a declaration
-- Last_Aspect (Flag5) Set for last aspect for a declaration
-- Class_Present (Flag6) Set if 'Class present
-- Note: Aspect_Specification is an Ada 2012 feature
--------------------------------------------- ---------------------------------------------
-- 13.4 Enumeration representation clause -- -- 13.4 Enumeration representation clause --
--------------------------------------------- ---------------------------------------------
@ -7180,6 +7278,7 @@ package Sinfo is
N_Enumeration_Representation_Clause, N_Enumeration_Representation_Clause,
N_Mod_Clause, N_Mod_Clause,
N_Record_Representation_Clause, N_Record_Representation_Clause,
N_Aspect_Specification,
-- N_Representation_Clause, N_Has_Chars -- N_Representation_Clause, N_Has_Chars
@ -7849,6 +7948,9 @@ package Sinfo is
function Choices function Choices
(N : Node_Id) return List_Id; -- List1 (N : Node_Id) return List_Id; -- List1
function Class_Present
(N : Node_Id) return Boolean; -- Flag6
function Coextensions function Coextensions
(N : Node_Id) return Elist_Id; -- Elist4 (N : Node_Id) return Elist_Id; -- Elist4
@ -8095,6 +8197,9 @@ package Sinfo is
function Expressions function Expressions
(N : Node_Id) return List_Id; -- List1 (N : Node_Id) return List_Id; -- List1
function First_Aspect
(N : Node_Id) return Boolean; -- Flag4
function First_Bit function First_Bit
(N : Node_Id) return Node_Id; -- Node3 (N : Node_Id) return Node_Id; -- Node3
@ -8149,6 +8254,9 @@ package Sinfo is
function Handler_List_Entry function Handler_List_Entry
(N : Node_Id) return Node_Id; -- Node2 (N : Node_Id) return Node_Id; -- Node2
function Has_Aspect_Specifications
(N : Node_Id) return Boolean; -- Flag3
function Has_Created_Identifier function Has_Created_Identifier
(N : Node_Id) return Boolean; -- Flag15 (N : Node_Id) return Boolean; -- Flag15
@ -8308,6 +8416,9 @@ package Sinfo is
function Left_Opnd function Left_Opnd
(N : Node_Id) return Node_Id; -- Node2 (N : Node_Id) return Node_Id; -- Node2
function Last_Aspect
(N : Node_Id) return Boolean; -- Flag5
function Last_Bit function Last_Bit
(N : Node_Id) return Node_Id; -- Node4 (N : Node_Id) return Node_Id; -- Node4
@ -8731,6 +8842,9 @@ package Sinfo is
procedure Set_Array_Aggregate procedure Set_Array_Aggregate
(N : Node_Id; Val : Node_Id); -- Node3 (N : Node_Id; Val : Node_Id); -- Node3
procedure Set_Has_Aspect_Specifications
(N : Node_Id; Val : Boolean := True); -- Flag3
procedure Set_Assignment_OK procedure Set_Assignment_OK
(N : Node_Id; Val : Boolean := True); -- Flag15 (N : Node_Id; Val : Boolean := True); -- Flag15
@ -8776,12 +8890,15 @@ package Sinfo is
procedure Set_Choice_Parameter procedure Set_Choice_Parameter
(N : Node_Id; Val : Node_Id); -- Node2 (N : Node_Id; Val : Node_Id); -- Node2
procedure Set_Coextensions
(N : Node_Id; Val : Elist_Id); -- Elist4
procedure Set_Choices procedure Set_Choices
(N : Node_Id; Val : List_Id); -- List1 (N : Node_Id; Val : List_Id); -- List1
procedure Set_Class_Present
(N : Node_Id; Val : Boolean := True); -- Flag6
procedure Set_Coextensions
(N : Node_Id; Val : Elist_Id); -- Elist4
procedure Set_Comes_From_Extended_Return_Statement procedure Set_Comes_From_Extended_Return_Statement
(N : Node_Id; Val : Boolean := True); -- Flag18 (N : Node_Id; Val : Boolean := True); -- Flag18
@ -9022,6 +9139,9 @@ package Sinfo is
procedure Set_Expressions procedure Set_Expressions
(N : Node_Id; Val : List_Id); -- List1 (N : Node_Id; Val : List_Id); -- List1
procedure Set_First_Aspect
(N : Node_Id; Val : Boolean := True); -- Flag4
procedure Set_First_Bit procedure Set_First_Bit
(N : Node_Id; Val : Node_Id); -- Node3 (N : Node_Id; Val : Node_Id); -- Node3
@ -9229,6 +9349,9 @@ package Sinfo is
procedure Set_Kill_Range_Check procedure Set_Kill_Range_Check
(N : Node_Id; Val : Boolean := True); -- Flag11 (N : Node_Id; Val : Boolean := True); -- Flag11
procedure Set_Last_Aspect
(N : Node_Id; Val : Boolean := True); -- Flag5
procedure Set_Last_Bit procedure Set_Last_Bit
(N : Node_Id; Val : Node_Id); -- Node4 (N : Node_Id; Val : Node_Id); -- Node4
@ -11001,6 +11124,13 @@ package Sinfo is
4 => False, -- unused 4 => False, -- unused
5 => False), -- Next_Rep_Item (Node5-Sem) 5 => False), -- Next_Rep_Item (Node5-Sem)
N_Aspect_Specification =>
(1 => True, -- Identifier (Node1)
2 => False, -- unused
3 => True, -- Expression (Node3)
4 => False, -- unused
5 => False), -- unused
N_Enumeration_Representation_Clause => N_Enumeration_Representation_Clause =>
(1 => True, -- Identifier (Node1) (1 => True, -- Identifier (Node1)
2 => False, -- unused 2 => False, -- unused
@ -11232,8 +11362,6 @@ package Sinfo is
4 => False, -- unused 4 => False, -- unused
5 => False), -- unused 5 => False), -- unused
-- End of inserted output from makeisf program
-- Entries for SCIL nodes -- Entries for SCIL nodes
N_SCIL_Dispatch_Table_Tag_Init => N_SCIL_Dispatch_Table_Tag_Init =>
@ -11289,6 +11417,45 @@ package Sinfo is
4 => False, -- unused 4 => False, -- unused
5 => False)); -- unused 5 => False)); -- unused
---------------------------------------
-- Handling of Aspect Specifications --
---------------------------------------
-- Several kinds of declaration node permit aspect specifications in Ada
-- 2012 mode. If there was room in all these declaration nodes, we could
-- just have a field Aspect_Specifications pointing to a list of nodes
-- for the aspects (N_Aspect_Specification nodes). But there isn't room,
-- so we adopt a different approach.
-- The following subprograms provide access to a specialized interface
-- implemented internally with a hash table in the body, that provides
-- access to aspect specifications.
function Permits_Aspect_Specifications (N : Node_Id) return Boolean;
-- Returns True if the node N is a declaration node that permits aspect
-- specifications. All such nodes have the Has_Aspect_Specifications
-- flag defined. Returns False for all other nodes.
function Aspect_Specifications (N : Node_Id) return List_Id;
-- Given a node N, returns the list of N_Aspect_Specification nodes that
-- are attached to this declaration node. If the node is in the class of
-- declaration nodes that permit aspect specifications, as defined by the
-- predicate above, and if their Has_Aspect_Specifications flag is set to
-- True, then this will always be a non-empty list. If this flag is set to
-- False, or the node is not in the declaration class permitting aspect
-- specifications, then No_List is returned.
procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id);
-- The node N must be in the class of declaration nodes that permit aspect
-- specifications and the Has_Aspect_Specifications flag must be False on
-- entry. L must be a non-empty list of N_Aspect_Specification nodes. This
-- procedure sets the Has_Aspect_Specifications flag to True, and makes an
-- entry that can be retrieved by a subsequent Aspect_Specifications call.
-- The parent of list L is set to reference the declaration node N. It is
-- an error to call this procedure with a node that does not permit aspect
-- specifications, or a node that has its Has_Aspect_Specifications flag
-- set True on entry, or with L being an empty list or No_List.
-------------------- --------------------
-- Inline Pragmas -- -- Inline Pragmas --
-------------------- --------------------
@ -11330,6 +11497,7 @@ package Sinfo is
pragma Inline (Check_Address_Alignment); pragma Inline (Check_Address_Alignment);
pragma Inline (Choice_Parameter); pragma Inline (Choice_Parameter);
pragma Inline (Choices); pragma Inline (Choices);
pragma Inline (Class_Present);
pragma Inline (Coextensions); pragma Inline (Coextensions);
pragma Inline (Comes_From_Extended_Return_Statement); pragma Inline (Comes_From_Extended_Return_Statement);
pragma Inline (Compile_Time_Known_Aggregate); pragma Inline (Compile_Time_Known_Aggregate);
@ -11412,6 +11580,7 @@ package Sinfo is
pragma Inline (Explicit_Generic_Actual_Parameter); pragma Inline (Explicit_Generic_Actual_Parameter);
pragma Inline (Expression); pragma Inline (Expression);
pragma Inline (Expressions); pragma Inline (Expressions);
pragma Inline (First_Aspect);
pragma Inline (First_Bit); pragma Inline (First_Bit);
pragma Inline (First_Inlined_Subprogram); pragma Inline (First_Inlined_Subprogram);
pragma Inline (First_Name); pragma Inline (First_Name);
@ -11430,6 +11599,7 @@ package Sinfo is
pragma Inline (Generic_Parent_Type); pragma Inline (Generic_Parent_Type);
pragma Inline (Handled_Statement_Sequence); pragma Inline (Handled_Statement_Sequence);
pragma Inline (Handler_List_Entry); pragma Inline (Handler_List_Entry);
pragma Inline (Has_Aspect_Specifications);
pragma Inline (Has_Created_Identifier); pragma Inline (Has_Created_Identifier);
pragma Inline (Has_Dynamic_Length_Check); pragma Inline (Has_Dynamic_Length_Check);
pragma Inline (Has_Dynamic_Range_Check); pragma Inline (Has_Dynamic_Range_Check);
@ -11481,6 +11651,7 @@ package Sinfo is
pragma Inline (Iteration_Scheme); pragma Inline (Iteration_Scheme);
pragma Inline (Itype); pragma Inline (Itype);
pragma Inline (Kill_Range_Check); pragma Inline (Kill_Range_Check);
pragma Inline (Last_Aspect);
pragma Inline (Last_Bit); pragma Inline (Last_Bit);
pragma Inline (Last_Name); pragma Inline (Last_Name);
pragma Inline (Library_Unit); pragma Inline (Library_Unit);
@ -11637,6 +11808,7 @@ package Sinfo is
pragma Inline (Set_Check_Address_Alignment); pragma Inline (Set_Check_Address_Alignment);
pragma Inline (Set_Choice_Parameter); pragma Inline (Set_Choice_Parameter);
pragma Inline (Set_Choices); pragma Inline (Set_Choices);
pragma Inline (Set_Class_Present);
pragma Inline (Set_Coextensions); pragma Inline (Set_Coextensions);
pragma Inline (Set_Comes_From_Extended_Return_Statement); pragma Inline (Set_Comes_From_Extended_Return_Statement);
pragma Inline (Set_Compile_Time_Known_Aggregate); pragma Inline (Set_Compile_Time_Known_Aggregate);
@ -11718,6 +11890,7 @@ package Sinfo is
pragma Inline (Set_Explicit_Generic_Actual_Parameter); pragma Inline (Set_Explicit_Generic_Actual_Parameter);
pragma Inline (Set_Expression); pragma Inline (Set_Expression);
pragma Inline (Set_Expressions); pragma Inline (Set_Expressions);
pragma Inline (Set_First_Aspect);
pragma Inline (Set_First_Bit); pragma Inline (Set_First_Bit);
pragma Inline (Set_First_Inlined_Subprogram); pragma Inline (Set_First_Inlined_Subprogram);
pragma Inline (Set_First_Name); pragma Inline (Set_First_Name);
@ -11736,6 +11909,7 @@ package Sinfo is
pragma Inline (Set_Generic_Parent_Type); pragma Inline (Set_Generic_Parent_Type);
pragma Inline (Set_Handled_Statement_Sequence); pragma Inline (Set_Handled_Statement_Sequence);
pragma Inline (Set_Handler_List_Entry); pragma Inline (Set_Handler_List_Entry);
pragma Inline (Set_Has_Aspect_Specifications);
pragma Inline (Set_Has_Created_Identifier); pragma Inline (Set_Has_Created_Identifier);
pragma Inline (Set_Has_Dynamic_Length_Check); pragma Inline (Set_Has_Dynamic_Length_Check);
pragma Inline (Set_Has_Init_Expression); pragma Inline (Set_Has_Init_Expression);
@ -11787,6 +11961,7 @@ package Sinfo is
pragma Inline (Set_Iteration_Scheme); pragma Inline (Set_Iteration_Scheme);
pragma Inline (Set_Itype); pragma Inline (Set_Itype);
pragma Inline (Set_Kill_Range_Check); pragma Inline (Set_Kill_Range_Check);
pragma Inline (Set_Last_Aspect);
pragma Inline (Set_Last_Bit); pragma Inline (Set_Last_Bit);
pragma Inline (Set_Last_Name); pragma Inline (Set_Last_Name);
pragma Inline (Set_Library_Unit); pragma Inline (Set_Library_Unit);

15
gcc/ada/sprint.adb
View File

@ -999,12 +999,8 @@ package body Sprint is
Write_Str_Sloc (" and then "); Write_Str_Sloc (" and then ");
Sprint_Right_Opnd (Node); Sprint_Right_Opnd (Node);
when N_At_Clause => when N_Aspect_Specification =>
Write_Indent_Str_Sloc ("for "); raise Program_Error;
Write_Id (Identifier (Node));
Write_Str_With_Col_Check (" use at ");
Sprint_Node (Expression (Node));
Write_Char (';');
when N_Assignment_Statement => when N_Assignment_Statement =>
Write_Indent; Write_Indent;
@ -1026,6 +1022,13 @@ package body Sprint is
Sprint_Node (Abortable_Part (Node)); Sprint_Node (Abortable_Part (Node));
Write_Indent_Str ("end select;"); Write_Indent_Str ("end select;");
when N_At_Clause =>
Write_Indent_Str_Sloc ("for ");
Write_Id (Identifier (Node));
Write_Str_With_Col_Check (" use at ");
Sprint_Node (Expression (Node));
Write_Char (';');
when N_Attribute_Definition_Clause => when N_Attribute_Definition_Clause =>
Write_Indent_Str_Sloc ("for "); Write_Indent_Str_Sloc ("for ");
Sprint_Node (Name (Node)); Sprint_Node (Name (Node));

5
gcc/ada/treepr.adb
View File

@ -1099,6 +1099,7 @@ package body Treepr is
when F_Field5 => when F_Field5 =>
Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty); Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty);
when F_Flag3 => Field_To_Be_Printed := Flag3 (N);
when F_Flag4 => Field_To_Be_Printed := Flag4 (N); when F_Flag4 => Field_To_Be_Printed := Flag4 (N);
when F_Flag5 => Field_To_Be_Printed := Flag5 (N); when F_Flag5 => Field_To_Be_Printed := Flag5 (N);
when F_Flag6 => Field_To_Be_Printed := Flag6 (N); when F_Flag6 => Field_To_Be_Printed := Flag6 (N);
@ -1115,12 +1116,10 @@ package body Treepr is
when F_Flag17 => Field_To_Be_Printed := Flag17 (N); when F_Flag17 => Field_To_Be_Printed := Flag17 (N);
when F_Flag18 => Field_To_Be_Printed := Flag18 (N); when F_Flag18 => Field_To_Be_Printed := Flag18 (N);
-- Flag1,2,3 are no longer used -- Flag1,2 are no longer used
when F_Flag1 => raise Program_Error; when F_Flag1 => raise Program_Error;
when F_Flag2 => raise Program_Error; when F_Flag2 => raise Program_Error;
when F_Flag3 => raise Program_Error;
end case; end case;
-- Print field if it is to be printed -- Print field if it is to be printed