[multiple changes]
2010-10-11 Robert Dewar <dewar@adacore.com> * aspects.ads, aspects.adb: Major revision of this package for 2nd stage of aspects implementation. * gcc-interface/Make-lang.in: Add entry for aspects.o * gcc-interface/Makefile.in: Add aspects.o to GNATMAKE_OBJS * par-ch13.adb (Aspect_Specifications_Present): New function (P_Aspect_Specifications): New procedure * par-ch3.adb (P_Type_Declaration): Handle aspect specifications (P_Derived_Type_Def_Or_Private_Ext_Decl): Handle aspect specifications (P_Identifier_Declarations): Handle aspect specifications (P_Component_Items): Handle aspect specifications (P_Subtype_Declaration): Handle aspect specifications * par-ch6.adb (P_Subprogram): Handle aspect specifications * par-ch9.adb (P_Entry_Declaration): Handle aspect specifications * par.adb (Aspect_Specifications_Present): New function (P_Aspect_Specifications): New procedure * sem.adb (Analyze_Full_Type_Declaration): New name for Analyze_Type_Declaration. (Analyze_Formal_Package_Declaration): New name (add _Declaration) (Analyze_Formal_Subprogram_Declaration): New name (add _Declaration) (Analyze_Protected_Type_Declaration): New name (add _Declaration) (Analyze_Single_Protected_Declaration): New name (add _Declaration) (Analyze_Single_Task_Declaration): New name (add _Declaration) (Analyze_Task_Type_Declaration): New name (add _Declaration) * sem_cat.adb (Analyze_Full_Type_Declaration): New name for Analyze_Type_Declaration. * sem_ch11.adb (Analyze_Exception_Declaration): Analyze aspect specifications. * sem_ch12.adb (Analyze_Formal_Object_Declaration): Handle aspect specifications. (Analyze_Formal_Package_Declaration): New name (add _Declaration) (Analyze_Formal_Package_Declaration): Handle aspect specifications (Analyze_Formal_Subprogram_Declaration): New name (add _Declaration) (Analyze_Formal_Subprogram_Declaration): Handle aspect specifications (Analyze_Formal_Type_Declaration): Handle aspect specifications (Analyze_Generic_Package_Declaration): Handle aspect specifications (Analyze_Generic_Subprogram_Declaration): Handle aspect specifications (Analyze_Package_Instantiation): Handle aspect specifications (Analyze_Subprogram_Instantiation): Handle aspect specifications * sem_ch12.ads (Analyze_Formal_Package_Declaration): New name (add _Declaration). (Analyze_Formal_Subprogram_Declaration): New name (add _Declaration) * sem_ch13.adb (Analyze_Aspect_Specifications): New procedure (Duplicate_Clause): New function, calls to this function are added to processing for all aspects. * sem_ch13.ads (Analyze_Aspect_Specifications): New procedure * sem_ch3.adb (Analyze_Full_Type_Declaration): New name for Analyze_Type_Declaration. * sem_ch3.ads (Analyze_Full_Type_Declaration): New name for Analyze_Type_Declaration. * sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): Analyze aspect specifications. (Analyze_Subprogram_Declaration): Analyze aspect specifications * sem_ch7.adb (Analyze_Package_Declaration): Analyze aspect specifications. (Analyze_Private_Type_Declaration): Analyze aspect specifications * sem_ch9.adb (Analyze_Protected_Type_Declaration): Analyze aspect specifications. (Analyze_Protected_Type_Declaration): New name (add _Declaration) (Analyze_Single_Protected_Declaration): Analyze aspect specifications (Analyze_Single_Protected_Declaration): New name (add _Declaration) (Analyze_Single_Task_Declaration): Analyze aspect specifications (Analyze_Single_Task_Declaration): New name (add _Declaration) (Analyze_Task_Type_Declaration): Analyze aspect specifications (Analyze_Task_Type_Declaration): New name (add _Declaration) * sem_ch9.ads (Analyze_Protected_Type_Declaration): New name (add _Declaration). (Analyze_Single_Protected_Declaration): New name (add _Declaration) (Analyze_Single_Task_Declaration): New name (add _Declaration) (Analyze_Task_Type_Declaration): New name (add _Declaration) * sem_prag.adb: Use Get_Pragma_Arg systematically so that we do not have to generate unnecessary pragma argument associations (this matches the doc). Throughout do changes to accomodate aspect specifications, including specializing messages, handling the case of not going through all homonyms, and allowing for cancellation. * sinfo.ads, sinfo.adb: Clean up obsolete documentation for Flag1,2,3 (Aspect_Cancel): New flag (From_Aspect_Specification): New flag (First_Aspect): Removed flag (Last_Aspect): Removed flag * sprint.adb (Sprint_Aspect_Specifications): New procedure (Sprint_Node_Actual): Add calls to Sprint_Aspect_Specifications 2010-10-11 Bob Duff <duff@adacore.com> * sem_res.adb (Resolve_Actuals): Minor change to warning messages so they match in Ada 95, 2005, and 2012 modes, in the case where the language didn't change. Same thing for the run-time exception message. 2010-10-11 Javier Miranda <miranda@adacore.com> * debug.adb Document that switch -gnatd.p enables the CIL verifier. 2010-10-11 Robert Dewar <dewar@adacore.com> * s-htable.adb: Minor reformatting. From-SVN: r165299
This commit is contained in:
parent
1237d6ef3c
commit
0f1a6a0b83
|
@ -1,3 +1,102 @@
|
|||
2010-10-11 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* aspects.ads, aspects.adb: Major revision of this package for 2nd
|
||||
stage of aspects implementation.
|
||||
* gcc-interface/Make-lang.in: Add entry for aspects.o
|
||||
* gcc-interface/Makefile.in: Add aspects.o to GNATMAKE_OBJS
|
||||
* par-ch13.adb (Aspect_Specifications_Present): New function
|
||||
(P_Aspect_Specifications): New procedure
|
||||
* par-ch3.adb (P_Type_Declaration): Handle aspect specifications
|
||||
(P_Derived_Type_Def_Or_Private_Ext_Decl): Handle aspect specifications
|
||||
(P_Identifier_Declarations): Handle aspect specifications
|
||||
(P_Component_Items): Handle aspect specifications
|
||||
(P_Subtype_Declaration): Handle aspect specifications
|
||||
* par-ch6.adb (P_Subprogram): Handle aspect specifications
|
||||
* par-ch9.adb (P_Entry_Declaration): Handle aspect specifications
|
||||
* par.adb (Aspect_Specifications_Present): New function
|
||||
(P_Aspect_Specifications): New procedure
|
||||
* sem.adb (Analyze_Full_Type_Declaration): New name for
|
||||
Analyze_Type_Declaration.
|
||||
(Analyze_Formal_Package_Declaration): New name (add _Declaration)
|
||||
(Analyze_Formal_Subprogram_Declaration): New name (add _Declaration)
|
||||
(Analyze_Protected_Type_Declaration): New name (add _Declaration)
|
||||
(Analyze_Single_Protected_Declaration): New name (add _Declaration)
|
||||
(Analyze_Single_Task_Declaration): New name (add _Declaration)
|
||||
(Analyze_Task_Type_Declaration): New name (add _Declaration)
|
||||
* sem_cat.adb (Analyze_Full_Type_Declaration): New name for
|
||||
Analyze_Type_Declaration.
|
||||
* sem_ch11.adb (Analyze_Exception_Declaration): Analyze aspect
|
||||
specifications.
|
||||
* sem_ch12.adb (Analyze_Formal_Object_Declaration): Handle aspect
|
||||
specifications.
|
||||
(Analyze_Formal_Package_Declaration): New name (add _Declaration)
|
||||
(Analyze_Formal_Package_Declaration): Handle aspect specifications
|
||||
(Analyze_Formal_Subprogram_Declaration): New name (add _Declaration)
|
||||
(Analyze_Formal_Subprogram_Declaration): Handle aspect specifications
|
||||
(Analyze_Formal_Type_Declaration): Handle aspect specifications
|
||||
(Analyze_Generic_Package_Declaration): Handle aspect specifications
|
||||
(Analyze_Generic_Subprogram_Declaration): Handle aspect specifications
|
||||
(Analyze_Package_Instantiation): Handle aspect specifications
|
||||
(Analyze_Subprogram_Instantiation): Handle aspect specifications
|
||||
* sem_ch12.ads (Analyze_Formal_Package_Declaration): New name (add
|
||||
_Declaration).
|
||||
(Analyze_Formal_Subprogram_Declaration): New name (add _Declaration)
|
||||
* sem_ch13.adb (Analyze_Aspect_Specifications): New procedure
|
||||
(Duplicate_Clause): New function, calls to this function are added to
|
||||
processing for all aspects.
|
||||
* sem_ch13.ads (Analyze_Aspect_Specifications): New procedure
|
||||
* sem_ch3.adb (Analyze_Full_Type_Declaration): New name for
|
||||
Analyze_Type_Declaration.
|
||||
* sem_ch3.ads (Analyze_Full_Type_Declaration): New name for
|
||||
Analyze_Type_Declaration.
|
||||
* sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): Analyze aspect
|
||||
specifications.
|
||||
(Analyze_Subprogram_Declaration): Analyze aspect specifications
|
||||
* sem_ch7.adb (Analyze_Package_Declaration): Analyze aspect
|
||||
specifications.
|
||||
(Analyze_Private_Type_Declaration): Analyze aspect specifications
|
||||
* sem_ch9.adb (Analyze_Protected_Type_Declaration): Analyze aspect
|
||||
specifications.
|
||||
(Analyze_Protected_Type_Declaration): New name (add _Declaration)
|
||||
(Analyze_Single_Protected_Declaration): Analyze aspect specifications
|
||||
(Analyze_Single_Protected_Declaration): New name (add _Declaration)
|
||||
(Analyze_Single_Task_Declaration): Analyze aspect specifications
|
||||
(Analyze_Single_Task_Declaration): New name (add _Declaration)
|
||||
(Analyze_Task_Type_Declaration): Analyze aspect specifications
|
||||
(Analyze_Task_Type_Declaration): New name (add _Declaration)
|
||||
* sem_ch9.ads (Analyze_Protected_Type_Declaration): New name (add
|
||||
_Declaration).
|
||||
(Analyze_Single_Protected_Declaration): New name (add _Declaration)
|
||||
(Analyze_Single_Task_Declaration): New name (add _Declaration)
|
||||
(Analyze_Task_Type_Declaration): New name (add _Declaration)
|
||||
* sem_prag.adb: Use Get_Pragma_Arg systematically so that we do not
|
||||
have to generate unnecessary pragma argument associations (this matches
|
||||
the doc).
|
||||
Throughout do changes to accomodate aspect specifications, including
|
||||
specializing messages, handling the case of not going through all
|
||||
homonyms, and allowing for cancellation.
|
||||
* sinfo.ads, sinfo.adb: Clean up obsolete documentation for Flag1,2,3
|
||||
(Aspect_Cancel): New flag
|
||||
(From_Aspect_Specification): New flag
|
||||
(First_Aspect): Removed flag
|
||||
(Last_Aspect): Removed flag
|
||||
* sprint.adb (Sprint_Aspect_Specifications): New procedure
|
||||
(Sprint_Node_Actual): Add calls to Sprint_Aspect_Specifications
|
||||
|
||||
2010-10-11 Bob Duff <duff@adacore.com>
|
||||
|
||||
* sem_res.adb (Resolve_Actuals): Minor change to warning messages so
|
||||
they match in Ada 95, 2005, and 2012 modes, in the case where the
|
||||
language didn't change. Same thing for the run-time exception message.
|
||||
|
||||
2010-10-11 Javier Miranda <miranda@adacore.com>
|
||||
|
||||
* debug.adb Document that switch -gnatd.p enables the CIL verifier.
|
||||
|
||||
2010-10-11 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* s-htable.adb: Minor reformatting.
|
||||
|
||||
2010-10-11 Javier Miranda <miranda@adacore.com>
|
||||
|
||||
* debug.adb: Update comment.
|
||||
|
|
|
@ -29,10 +29,43 @@
|
|||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree; use Atree;
|
||||
with Nlists; use Nlists;
|
||||
with Sinfo; use Sinfo;
|
||||
with Snames; use Snames;
|
||||
|
||||
with GNAT.HTable; use GNAT.HTable;
|
||||
|
||||
package body Aspects is
|
||||
|
||||
------------------------------------------
|
||||
-- Hash Table for Aspect Specifications --
|
||||
------------------------------------------
|
||||
|
||||
type AS_Hash_Range is range 0 .. 510;
|
||||
-- Size of hash table headers
|
||||
|
||||
function AS_Hash (F : Node_Id) return AS_Hash_Range;
|
||||
-- Hash function for hash table
|
||||
|
||||
function AS_Hash (F : Node_Id) return AS_Hash_Range is
|
||||
begin
|
||||
return AS_Hash_Range (F mod 511);
|
||||
end AS_Hash;
|
||||
|
||||
package Aspect_Specifications_Hash_Table is new
|
||||
GNAT.HTable.Simple_HTable
|
||||
(Header_Num => AS_Hash_Range,
|
||||
Element => List_Id,
|
||||
No_Element => No_List,
|
||||
Key => Node_Id,
|
||||
Hash => AS_Hash,
|
||||
Equal => "=");
|
||||
|
||||
-----------------------------------------
|
||||
-- Table Linking Names and Aspect_Id's --
|
||||
-----------------------------------------
|
||||
|
||||
type Aspect_Entry is record
|
||||
Nam : Name_Id;
|
||||
Asp : Aspect_Id;
|
||||
|
@ -42,12 +75,10 @@ package body Aspects is
|
|||
(Name_Ada_2005, Aspect_Ada_2005),
|
||||
(Name_Ada_2012, Aspect_Ada_2012),
|
||||
(Name_Address, Aspect_Address),
|
||||
(Name_Aliased, Aspect_Aliased),
|
||||
(Name_Alignment, Aspect_Alignment),
|
||||
(Name_Atomic, Aspect_Atomic),
|
||||
(Name_Atomic_Components, Aspect_Atomic_Components),
|
||||
(Name_Bit_Order, Aspect_Bit_Order),
|
||||
(Name_C_Pass_By_Copy, Aspect_C_Pass_By_Copy),
|
||||
(Name_Component_Size, Aspect_Component_Size),
|
||||
(Name_Discard_Names, Aspect_Discard_Names),
|
||||
(Name_External_Tag, Aspect_External_Tag),
|
||||
|
@ -60,12 +91,9 @@ package body Aspects is
|
|||
(Name_Pack, Aspect_Pack),
|
||||
(Name_Persistent_BSS, Aspect_Persistent_BSS),
|
||||
(Name_Post, Aspect_Post),
|
||||
(Name_Postcondition, Aspect_Postcondition),
|
||||
(Name_Pre, Aspect_Pre),
|
||||
(Name_Precondition, Aspect_Precondition),
|
||||
(Name_Predicate, Aspect_Predicate),
|
||||
(Name_Preelaborable_Initialization, Aspect_Preelaborable_Initialization),
|
||||
(Name_Psect_Object, Aspect_Psect_Object),
|
||||
(Name_Pure_Function, Aspect_Pure_Function),
|
||||
(Name_Shared, Aspect_Shared),
|
||||
(Name_Size, Aspect_Size),
|
||||
|
@ -83,8 +111,31 @@ package body Aspects is
|
|||
(Name_Value_Size, Aspect_Value_Size),
|
||||
(Name_Volatile, Aspect_Volatile),
|
||||
(Name_Volatile_Components, Aspect_Volatile_Components),
|
||||
(Name_Warnings, Aspect_Warnings),
|
||||
(Name_Weak_External, Aspect_Weak_External));
|
||||
(Name_Warnings, Aspect_Warnings));
|
||||
|
||||
-------------------------------------
|
||||
-- Hash Table for Aspect Id Values --
|
||||
-------------------------------------
|
||||
|
||||
type AI_Hash_Range is range 0 .. 112;
|
||||
-- Size of hash table headers
|
||||
|
||||
function AI_Hash (F : Name_Id) return AI_Hash_Range;
|
||||
-- Hash function for hash table
|
||||
|
||||
function AI_Hash (F : Name_Id) return AI_Hash_Range is
|
||||
begin
|
||||
return AI_Hash_Range (F mod 113);
|
||||
end AI_Hash;
|
||||
|
||||
package Aspect_Id_Hash_Table is new
|
||||
GNAT.HTable.Simple_HTable
|
||||
(Header_Num => AI_Hash_Range,
|
||||
Element => Aspect_Id,
|
||||
No_Element => No_Aspect,
|
||||
Key => Name_Id,
|
||||
Hash => AI_Hash,
|
||||
Equal => "=");
|
||||
|
||||
-------------------
|
||||
-- Get_Aspect_Id --
|
||||
|
@ -92,13 +143,74 @@ package body Aspects is
|
|||
|
||||
function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is
|
||||
begin
|
||||
for J in Aspect_Names'Range loop
|
||||
if Aspect_Names (J).Nam = Name then
|
||||
return Aspect_Names (J).Asp;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
return No_Aspect;
|
||||
return Aspect_Id_Hash_Table.Get (Name);
|
||||
end Get_Aspect_Id;
|
||||
|
||||
---------------------------
|
||||
-- Aspect_Specifications --
|
||||
---------------------------
|
||||
|
||||
function Aspect_Specifications (N : Node_Id) return List_Id is
|
||||
begin
|
||||
return Aspect_Specifications_Hash_Table.Get (N);
|
||||
end Aspect_Specifications;
|
||||
|
||||
-----------------------------------
|
||||
-- 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;
|
||||
|
||||
-------------------------------
|
||||
-- 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;
|
||||
|
||||
-- Package initialization sets up Aspect Id hash table
|
||||
|
||||
begin
|
||||
for J in Aspect_Names'Range loop
|
||||
Aspect_Id_Hash_Table.Set (Aspect_Names (J).Nam, Aspect_Names (J).Asp);
|
||||
end loop;
|
||||
end Aspects;
|
||||
|
|
|
@ -29,25 +29,27 @@
|
|||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package defines the aspects that are recognized in aspect
|
||||
-- specifications. We separate this off in its own packages to that
|
||||
-- it can be accessed by the parser without dragging in Sem_Asp
|
||||
-- This package defines the aspects that are recognized by GNAT in aspect
|
||||
-- specifications. It also contains the subprograms for storing/retrieving
|
||||
-- aspect speciciations from the tree. The semantic processing for aspect
|
||||
-- specifications is found in Sem_Ch13.Analyze_Aspect_Specifications.
|
||||
|
||||
with Namet; use Namet;
|
||||
with Types; use Types;
|
||||
|
||||
package Aspects is
|
||||
|
||||
-- Type defining recognized aspects
|
||||
|
||||
type Aspect_Id is
|
||||
(No_Aspect, -- Dummy entry for no aspect
|
||||
Aspect_Ada_2005, -- GNAT
|
||||
Aspect_Ada_2012, -- GNAT
|
||||
Aspect_Address,
|
||||
Aspect_Aliased,
|
||||
Aspect_Alignment,
|
||||
Aspect_Atomic,
|
||||
Aspect_Atomic_Components,
|
||||
Aspect_Bit_Order,
|
||||
Aspect_C_Pass_By_Copy,
|
||||
Aspect_Component_Size,
|
||||
Aspect_Discard_Names,
|
||||
Aspect_External_Tag,
|
||||
|
@ -56,16 +58,14 @@ package Aspects is
|
|||
Aspect_Inline_Always, -- GNAT
|
||||
Aspect_Invariant,
|
||||
Aspect_Machine_Radix,
|
||||
Aspect_No_Return,
|
||||
Aspect_Object_Size, -- GNAT
|
||||
Aspect_Pack,
|
||||
Aspect_Persistent_BSS, -- GNAT
|
||||
Aspect_Post,
|
||||
Aspect_Postcondition, -- GNAT (equivalent to Post)
|
||||
Aspect_Pre,
|
||||
Aspect_Precondition, -- GNAT (equivalent to Pre)
|
||||
Aspect_Predicate, -- GNAT???
|
||||
Aspect_Preelaborable_Initialization,
|
||||
Aspect_Psect_Object, -- GNAT
|
||||
Aspect_Pure_Function, -- GNAT
|
||||
Aspect_Shared, -- GNAT (equivalent to Atomic)
|
||||
Aspect_Size,
|
||||
|
@ -83,17 +83,15 @@ package Aspects is
|
|||
Aspect_Value_Size, -- GNAT
|
||||
Aspect_Volatile,
|
||||
Aspect_Volatile_Components,
|
||||
Aspect_Warnings, -- GNAT
|
||||
Aspect_Weak_External); -- GNAT
|
||||
Aspect_Warnings); -- GNAT
|
||||
|
||||
-- The following array indicates aspects that accept 'Class
|
||||
|
||||
Class_Aspect_OK : constant array (Aspect_Id) of Boolean :=
|
||||
(Aspect_Invariant => True,
|
||||
Aspect_Pre => True,
|
||||
Aspect_Precondition => True,
|
||||
Aspect_Predicate => True,
|
||||
Aspect_Post => True,
|
||||
Aspect_Postcondition => True,
|
||||
others => False);
|
||||
|
||||
-- The following type is used for indicating allowed expression forms
|
||||
|
@ -110,12 +108,10 @@ package Aspects is
|
|||
Aspect_Ada_2005 => Optional,
|
||||
Aspect_Ada_2012 => Optional,
|
||||
Aspect_Address => Expression,
|
||||
Aspect_Aliased => Optional,
|
||||
Aspect_Alignment => Expression,
|
||||
Aspect_Atomic => Optional,
|
||||
Aspect_Atomic_Components => Optional,
|
||||
Aspect_Bit_Order => Expression,
|
||||
Aspect_C_Pass_By_Copy => Optional,
|
||||
Aspect_Component_Size => Expression,
|
||||
Aspect_Discard_Names => Optional,
|
||||
Aspect_External_Tag => Expression,
|
||||
|
@ -124,20 +120,18 @@ package Aspects is
|
|||
Aspect_Inline_Always => Optional,
|
||||
Aspect_Invariant => Expression,
|
||||
Aspect_Machine_Radix => Expression,
|
||||
Aspect_No_Return => Optional,
|
||||
Aspect_Object_Size => Expression,
|
||||
Aspect_Pack => Optional,
|
||||
Aspect_Persistent_BSS => Optional,
|
||||
Aspect_Pack => Optional,
|
||||
Aspect_Post => Expression,
|
||||
Aspect_Postcondition => Expression,
|
||||
Aspect_Pre => Expression,
|
||||
Aspect_Precondition => Expression,
|
||||
Aspect_Predicate => Expression,
|
||||
Aspect_Preelaborable_Initialization => Optional,
|
||||
Aspect_Psect_Object => Optional,
|
||||
Aspect_Pure_Function => Optional,
|
||||
Aspect_Shared => Optional,
|
||||
Aspect_Size => Expression,
|
||||
Aspect_Storage_Pool => Expression,
|
||||
Aspect_Storage_Pool => Name,
|
||||
Aspect_Storage_Size => Expression,
|
||||
Aspect_Stream_Size => Expression,
|
||||
Aspect_Suppress => Name,
|
||||
|
@ -151,11 +145,50 @@ package Aspects is
|
|||
Aspect_Value_Size => Expression,
|
||||
Aspect_Volatile => Optional,
|
||||
Aspect_Volatile_Components => Optional,
|
||||
Aspect_Warnings => Name,
|
||||
Aspect_Weak_External => Optional);
|
||||
Aspect_Warnings => Name);
|
||||
|
||||
function Get_Aspect_Id (Name : Name_Id) return Aspect_Id;
|
||||
pragma Inline (Get_Aspect_Id);
|
||||
-- Given a name Nam, returns the corresponding aspect id value. If the name
|
||||
-- does not match any aspect, then No_Aspect is returned as the result.
|
||||
|
||||
---------------------------------------------------
|
||||
-- Handling of Aspect Specifications in the Tree --
|
||||
---------------------------------------------------
|
||||
|
||||
-- Several kinds of declaration node permit aspect specifications in Ada
|
||||
-- 2012 mode. If there was room in all the corresponding 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.
|
||||
|
||||
end Aspects;
|
||||
|
|
|
@ -106,7 +106,7 @@ package body Debug is
|
|||
-- d.m For -gnatl, print full source only for main unit
|
||||
-- d.n Print source file names
|
||||
-- d.o Generate .NET listing of CIL code
|
||||
-- d.p
|
||||
-- d.p Enable the .NET CIL verifier
|
||||
-- d.q
|
||||
-- d.r Enable OK_To_Reorder_Components in non-variant records
|
||||
-- d.s Disable expansion of slice move, use memmove
|
||||
|
@ -534,6 +534,10 @@ package body Debug is
|
|||
-- d.o Generate listing showing the IL instructions generated by the .NET
|
||||
-- compiler for each subprogram.
|
||||
|
||||
-- d.p Enable the .NET CIL verifier. During development the verifier is
|
||||
-- disabled by default and this flag is used to enable it. In the
|
||||
-- future we will reverse this functionality.
|
||||
|
||||
-- d.r Forces the flag OK_To_Reorder_Components to be set in all record
|
||||
-- base types that have no discriminants.
|
||||
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -296,7 +296,7 @@ GNATLINK_OBJS = gnatlink.o \
|
|||
sdefault.o snames.o stylesw.o switch.o system.o table.o targparm.o tree_io.o \
|
||||
types.o validsw.o widechar.o
|
||||
|
||||
GNATMAKE_OBJS = a-except.o ali.o ali-util.o s-casuti.o \
|
||||
GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o \
|
||||
alloc.o atree.o binderr.o butil.o casing.o csets.o debug.o elists.o einfo.o\
|
||||
erroutc.o errutil.o err_vars.o fmap.o fname.o fname-uf.o fname-sf.o \
|
||||
gnatmake.o gnatvsn.o hostparm.o interfac.o i-c.o i-cstrin.o krunch.o lib.o \
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2007, 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 --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
|
@ -35,6 +35,91 @@ package body Ch13 is
|
|||
function P_Component_Clause return Node_Id;
|
||||
function P_Mod_Clause return Node_Id;
|
||||
|
||||
-----------------------------------
|
||||
-- Aspect_Specifications_Present --
|
||||
-----------------------------------
|
||||
|
||||
function Aspect_Specifications_Present return Boolean is
|
||||
Scan_State : Saved_Scan_State;
|
||||
Result : Boolean;
|
||||
|
||||
begin
|
||||
Save_Scan_State (Scan_State);
|
||||
|
||||
-- If we have a semicolon, test for semicolon followed by Aspect
|
||||
-- Specifications, in which case we decide the semicolon is accidental.
|
||||
|
||||
if Token = Tok_Semicolon then
|
||||
Scan; -- past semicolon
|
||||
|
||||
if Aspect_Specifications_Present then
|
||||
Error_Msg_SP ("|extra "";"" ignored");
|
||||
return True;
|
||||
|
||||
else
|
||||
Restore_Scan_State (Scan_State);
|
||||
return False;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Definitely must have WITH to consider aspect specs to be present
|
||||
|
||||
if Token /= Tok_With then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
-- Have a WITH, see if it looks like an aspect specification
|
||||
|
||||
Save_Scan_State (Scan_State);
|
||||
Scan; -- past WITH
|
||||
|
||||
-- If no identifier, then consider that we definitely do not have an
|
||||
-- aspect specification.
|
||||
|
||||
if Token /= Tok_Identifier then
|
||||
Result := False;
|
||||
|
||||
-- In Ada 2012 mode, we are less strict, and we consider that we have
|
||||
-- an aspect specification if the identifier is an aspect name (even if
|
||||
-- not followed by =>) or the identifier is not an aspect name but is
|
||||
-- followed by =>. P_Aspect_Specifications will generate messages if the
|
||||
-- aspect specification is ill-formed.
|
||||
|
||||
elsif Ada_Version >= Ada_2012 then
|
||||
if Get_Aspect_Id (Token_Name) /= No_Aspect then
|
||||
Result := True;
|
||||
else
|
||||
Scan; -- past identifier
|
||||
Result := Token = Tok_Arrow;
|
||||
end if;
|
||||
|
||||
-- If earlier than Ada 2012, check for valid aspect identifier followed
|
||||
-- by an arrow, and consider that this is still an aspect specification
|
||||
-- so we give an appropriate message.
|
||||
|
||||
else
|
||||
if Get_Aspect_Id (Token_Name) = No_Aspect then
|
||||
Result := False;
|
||||
|
||||
else
|
||||
Scan; -- past aspect name
|
||||
|
||||
if Token /= Tok_Arrow then
|
||||
Result := False;
|
||||
|
||||
else
|
||||
Restore_Scan_State (Scan_State);
|
||||
Error_Msg_SC ("|aspect specification is an Ada 2012 feature");
|
||||
Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
|
||||
return True;
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Restore_Scan_State (Scan_State);
|
||||
return Result;
|
||||
end Aspect_Specifications_Present;
|
||||
|
||||
--------------------------------------------
|
||||
-- 13.1 Representation Clause (also I.7) --
|
||||
--------------------------------------------
|
||||
|
@ -274,6 +359,163 @@ package body Ch13 is
|
|||
|
||||
-- Parsed by P_Representation_Clause (13.1)
|
||||
|
||||
------------------------------
|
||||
-- 13.1 Aspect Specifation --
|
||||
------------------------------
|
||||
|
||||
-- ASPECT_SPECIFICATION ::=
|
||||
-- with ASPECT_MARK [=> ASPECT_DEFINITION] {.
|
||||
-- ASPECT_MARK [=> ASPECT_DEFINITION] }
|
||||
|
||||
-- ASPECT_MARK ::= aspect_IDENTIFIER['Class]
|
||||
|
||||
-- ASPECT_DEFINITION ::= NAME | EXPRESSION
|
||||
|
||||
-- Error recovery: cannot raise Error_Resync
|
||||
|
||||
procedure P_Aspect_Specifications (Decl : Node_Id) is
|
||||
Aspects : List_Id;
|
||||
Aspect : Node_Id;
|
||||
A_Id : Aspect_Id;
|
||||
OK : Boolean;
|
||||
|
||||
begin
|
||||
-- Check if aspect specification present
|
||||
|
||||
if not Aspect_Specifications_Present then
|
||||
T_Semicolon;
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Aspect Specification is present
|
||||
|
||||
Scan; -- past WITH
|
||||
|
||||
-- Here we have an aspect specification to scan, note that we don;t
|
||||
-- set the flag till later, because it may turn out that we have no
|
||||
-- valid aspects in the list.
|
||||
|
||||
Aspects := Empty_List;
|
||||
loop
|
||||
OK := True;
|
||||
|
||||
if Token /= Tok_Identifier then
|
||||
Error_Msg_SC ("aspect identifier expected");
|
||||
Resync_Past_Semicolon;
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- We have an identifier (which should be an aspect identifier)
|
||||
|
||||
Aspect := Token_Node;
|
||||
A_Id := Get_Aspect_Id (Token_Name);
|
||||
Aspect :=
|
||||
Make_Aspect_Specification (Sloc (Aspect),
|
||||
Identifier => Token_Node);
|
||||
|
||||
-- No valid aspect identifier present
|
||||
|
||||
if A_Id = No_Aspect then
|
||||
Error_Msg_SC ("aspect identifier expected");
|
||||
|
||||
if Token = Tok_Apostrophe then
|
||||
Scan; -- past '
|
||||
Scan; -- past presumably CLASS
|
||||
end if;
|
||||
|
||||
if Token = Tok_Arrow then
|
||||
Scan; -- Past arrow
|
||||
Set_Expression (Aspect, P_Expression);
|
||||
OK := False;
|
||||
|
||||
elsif Token = Tok_Comma then
|
||||
OK := False;
|
||||
|
||||
else
|
||||
Resync_Past_Semicolon;
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- OK aspect scanned
|
||||
|
||||
else
|
||||
Scan; -- past identifier
|
||||
|
||||
-- Check for 'Class present
|
||||
|
||||
if Token = Tok_Apostrophe then
|
||||
if not Class_Aspect_OK (A_Id) then
|
||||
Error_Msg_Node_1 := Identifier (Aspect);
|
||||
Error_Msg_SC ("aspect& does not permit attribute here");
|
||||
Scan; -- past apostophe
|
||||
Scan; -- past presumed CLASS
|
||||
OK := False;
|
||||
|
||||
else
|
||||
Scan; -- past apostrophe
|
||||
|
||||
if Token /= Tok_Identifier
|
||||
or else Token_Name /= Name_Class
|
||||
then
|
||||
Error_Msg_SC ("Class attribute expected here");
|
||||
OK := False;
|
||||
|
||||
if Token = Tok_Identifier then
|
||||
Scan; -- past identifier not CLASS
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Test case of missing aspect definition
|
||||
|
||||
if Token = Tok_Comma or else Token = Tok_Semicolon then
|
||||
if Aspect_Argument (A_Id) /= Optional then
|
||||
Error_Msg_Node_1 := Aspect;
|
||||
Error_Msg_AP ("aspect& requires an aspect definition");
|
||||
OK := False;
|
||||
end if;
|
||||
|
||||
-- Here we have an aspect definition
|
||||
|
||||
else
|
||||
if Token = Tok_Arrow then
|
||||
Scan; -- past arrow
|
||||
else
|
||||
T_Arrow;
|
||||
OK := False;
|
||||
end if;
|
||||
|
||||
if Aspect_Argument (A_Id) = Name then
|
||||
Set_Expression (Aspect, P_Name);
|
||||
else
|
||||
Set_Expression (Aspect, P_Expression);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- If OK clause scanned, add it to the list
|
||||
|
||||
if OK then
|
||||
Append (Aspect, Aspects);
|
||||
end if;
|
||||
|
||||
if Token = Tok_Comma then
|
||||
Scan; -- past comma
|
||||
else
|
||||
T_Semicolon;
|
||||
exit;
|
||||
end if;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- If aspects scanned, store them
|
||||
|
||||
if Is_Non_Empty_List (Aspects) then
|
||||
Set_Parent (Aspects, Decl);
|
||||
Set_Aspect_Specifications (Decl, Aspects);
|
||||
end if;
|
||||
end P_Aspect_Specifications;
|
||||
|
||||
---------------------------------------------
|
||||
-- 13.4 Enumeration Representation Clause --
|
||||
---------------------------------------------
|
||||
|
|
|
@ -327,7 +327,7 @@ package body Ch3 is
|
|||
Type_Start_Col : Column_Number;
|
||||
Unknown_Dis : Boolean;
|
||||
|
||||
Typedef_Node : Node_Id;
|
||||
Typedef_Node : Node_Id;
|
||||
-- Normally holds type definition, except in the case of a private
|
||||
-- extension declaration, in which case it holds the declaration itself
|
||||
|
||||
|
@ -476,22 +476,18 @@ package body Ch3 is
|
|||
when Tok_Access |
|
||||
Tok_Not => -- Ada 2005 (AI-231)
|
||||
Typedef_Node := P_Access_Type_Definition;
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
when Tok_Array =>
|
||||
Typedef_Node := P_Array_Type_Definition;
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
when Tok_Delta =>
|
||||
Typedef_Node := P_Fixed_Point_Definition;
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
when Tok_Digits =>
|
||||
Typedef_Node := P_Floating_Point_Definition;
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
when Tok_In =>
|
||||
|
@ -500,12 +496,10 @@ package body Ch3 is
|
|||
when Tok_Integer_Literal =>
|
||||
T_Range;
|
||||
Typedef_Node := P_Signed_Integer_Type_Definition;
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
when Tok_Null =>
|
||||
Typedef_Node := P_Record_Definition;
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
when Tok_Left_Paren =>
|
||||
|
@ -517,12 +511,10 @@ package body Ch3 is
|
|||
Set_Comes_From_Source (End_Labl, False);
|
||||
|
||||
Set_End_Label (Typedef_Node, End_Labl);
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
when Tok_Mod =>
|
||||
Typedef_Node := P_Modular_Type_Definition;
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
when Tok_New =>
|
||||
|
@ -540,12 +532,10 @@ package body Ch3 is
|
|||
(Record_Extension_Part (Typedef_Node), End_Labl);
|
||||
end if;
|
||||
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
when Tok_Range =>
|
||||
Typedef_Node := P_Signed_Integer_Type_Definition;
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
when Tok_Record =>
|
||||
|
@ -557,7 +547,6 @@ package body Ch3 is
|
|||
Set_Comes_From_Source (End_Labl, False);
|
||||
|
||||
Set_End_Label (Typedef_Node, End_Labl);
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
when Tok_Tagged =>
|
||||
|
@ -640,7 +629,6 @@ package body Ch3 is
|
|||
end if;
|
||||
end if;
|
||||
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
when Tok_Limited =>
|
||||
|
@ -733,7 +721,6 @@ package body Ch3 is
|
|||
T_Private; -- past PRIVATE (or complain if not there!)
|
||||
end if;
|
||||
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
-- Here we have an identifier after the IS, which is certainly
|
||||
|
@ -748,7 +735,6 @@ package body Ch3 is
|
|||
|
||||
if not Token_Is_At_Start_Of_Line then
|
||||
Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
|
||||
TF_Semicolon;
|
||||
|
||||
-- If the identifier is at the start of the line, and is in the
|
||||
-- same column as the type declaration itself then we consider
|
||||
|
@ -769,7 +755,6 @@ package body Ch3 is
|
|||
|
||||
else
|
||||
Typedef_Node := P_Record_Definition;
|
||||
TF_Semicolon;
|
||||
end if;
|
||||
|
||||
exit;
|
||||
|
@ -779,13 +764,11 @@ package body Ch3 is
|
|||
when Tok_Interface =>
|
||||
Typedef_Node := P_Interface_Type_Definition (Abstract_Present);
|
||||
Abstract_Present := True;
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
when Tok_Private =>
|
||||
Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
|
||||
Scan; -- past PRIVATE
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
-- Ada 2005 (AI-345): Protected, synchronized or task interface
|
||||
|
@ -849,7 +832,6 @@ package body Ch3 is
|
|||
end if;
|
||||
end;
|
||||
|
||||
TF_Semicolon;
|
||||
exit;
|
||||
|
||||
-- Anything else is an error
|
||||
|
@ -933,6 +915,7 @@ package body Ch3 is
|
|||
|
||||
Set_Defining_Identifier (Decl_Node, Ident_Node);
|
||||
Set_Discriminant_Specifications (Decl_Node, Discr_List);
|
||||
P_Aspect_Specifications (Decl_Node);
|
||||
return Decl_Node;
|
||||
end P_Type_Declaration;
|
||||
|
||||
|
@ -980,7 +963,7 @@ package body Ch3 is
|
|||
|
||||
Set_Subtype_Indication
|
||||
(Decl_Node, P_Subtype_Indication (Not_Null_Present));
|
||||
TF_Semicolon;
|
||||
P_Aspect_Specifications (Decl_Node);
|
||||
return Decl_Node;
|
||||
end P_Subtype_Declaration;
|
||||
|
||||
|
@ -1836,8 +1819,8 @@ package body Ch3 is
|
|||
end if;
|
||||
end if;
|
||||
|
||||
TF_Semicolon;
|
||||
Set_Defining_Identifier (Decl_Node, Idents (Ident));
|
||||
P_Aspect_Specifications (Decl_Node);
|
||||
|
||||
if List_OK then
|
||||
if Ident < Num_Idents then
|
||||
|
@ -1976,7 +1959,16 @@ package body Ch3 is
|
|||
-- missing in the case of "type X is new Y record ..." or in the
|
||||
-- case of "type X is new Y null record".
|
||||
|
||||
if Token = Tok_With
|
||||
-- First make sure we don't have an aspect specification. If we do
|
||||
-- return now, so that our caller can check it (the WITH here is not
|
||||
-- part of a type extension).
|
||||
|
||||
if Aspect_Specifications_Present then
|
||||
return Typedef_Node;
|
||||
|
||||
-- OK, not an aspect specification, so continue test for extension
|
||||
|
||||
elsif Token = Tok_With
|
||||
or else Token = Tok_Record
|
||||
or else Token = Tok_Null
|
||||
then
|
||||
|
@ -3470,10 +3462,9 @@ package body Ch3 is
|
|||
Ident := Ident + 1;
|
||||
Restore_Scan_State (Scan_State);
|
||||
T_Colon;
|
||||
|
||||
end loop Ident_Loop;
|
||||
|
||||
TF_Semicolon;
|
||||
P_Aspect_Specifications (Decl_Node);
|
||||
end P_Component_Items;
|
||||
|
||||
--------------------------------
|
||||
|
|
|
@ -305,7 +305,7 @@ package body Ch6 is
|
|||
|
||||
Set_Defining_Unit_Name (Inst_Node, Name_Node);
|
||||
Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt);
|
||||
TF_Semicolon;
|
||||
P_Aspect_Specifications (Inst_Node);
|
||||
Pop_Scope_Stack; -- Don't need scope stack entry in this case
|
||||
|
||||
if Is_Overriding then
|
||||
|
@ -525,7 +525,7 @@ package body Ch6 is
|
|||
Set_Specification (Absdec_Node, Specification_Node);
|
||||
Pop_Scope_Stack; -- discard unneeded entry
|
||||
Scan; -- past ABSTRACT
|
||||
TF_Semicolon;
|
||||
P_Aspect_Specifications (Absdec_Node);
|
||||
return Absdec_Node;
|
||||
|
||||
-- Ada 2005 (AI-248): Parse a null procedure declaration
|
||||
|
|
|
@ -900,7 +900,7 @@ package body Ch9 is
|
|||
Discard_Junk_Node (P_Expression_No_Right_Paren);
|
||||
end if;
|
||||
|
||||
TF_Semicolon;
|
||||
P_Aspect_Specifications (Decl_Node);
|
||||
return Decl_Node;
|
||||
|
||||
exception
|
||||
|
|
|
@ -23,6 +23,7 @@
|
|||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Aspects; use Aspects;
|
||||
with Atree; use Atree;
|
||||
with Casing; use Casing;
|
||||
with Debug; use Debug;
|
||||
|
@ -836,6 +837,25 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
|
|||
package Ch13 is
|
||||
function P_Representation_Clause return Node_Id;
|
||||
|
||||
function Aspect_Specifications_Present return Boolean;
|
||||
-- This function tests whether the next keyword is WITH followed by
|
||||
-- something that looks reasonably like an aspect specification. If so,
|
||||
-- True is returned. Otherwise False is returned. In either case control
|
||||
-- returns with the token pointer unchanged (i.e. pointing to the WITH
|
||||
-- token in the case where True is returned). This function takes care
|
||||
-- of generating appropriate messages if aspect specifications appear
|
||||
-- in versions of Ada prior to Ada 2012.
|
||||
|
||||
procedure P_Aspect_Specifications (Decl : Node_Id);
|
||||
-- This subprogram is called with the current token pointing to either a
|
||||
-- WITH keyword starting an aspect specification, or a semicolon. In the
|
||||
-- former case, the aspect specifications are scanned out including the
|
||||
-- terminating semicolon, the Has_Aspect_Specifications flag is set in
|
||||
-- the given declaration node, and the list of aspect specifications is
|
||||
-- constructed and associated with this declaration node using a call to
|
||||
-- Set_Aspect_Specifications. If no WITH keyword is present, then this
|
||||
-- call has no effect other than scanning out the semicolon.
|
||||
|
||||
function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id;
|
||||
-- Function to parse a code statement. The caller has scanned out
|
||||
-- the name to be used as the subtype mark (but has not checked that
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1995-2009, AdaCore --
|
||||
-- Copyright (C) 1995-2010, AdaCore --
|
||||
-- --
|
||||
-- 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- --
|
||||
|
@ -110,7 +110,7 @@ package body System.HTable is
|
|||
|
||||
function Get_Non_Null return Elmt_Ptr is
|
||||
begin
|
||||
while Iterator_Ptr = Null_Ptr loop
|
||||
while Iterator_Ptr = Null_Ptr loop
|
||||
if Iterator_Index = Table'Last then
|
||||
Iterator_Started := False;
|
||||
return Null_Ptr;
|
||||
|
|
|
@ -237,10 +237,10 @@ package body Sem is
|
|||
Analyze_Formal_Object_Declaration (N);
|
||||
|
||||
when N_Formal_Package_Declaration =>
|
||||
Analyze_Formal_Package (N);
|
||||
Analyze_Formal_Package_Declaration (N);
|
||||
|
||||
when N_Formal_Subprogram_Declaration =>
|
||||
Analyze_Formal_Subprogram (N);
|
||||
Analyze_Formal_Subprogram_Declaration (N);
|
||||
|
||||
when N_Formal_Type_Declaration =>
|
||||
Analyze_Formal_Type_Declaration (N);
|
||||
|
@ -252,7 +252,7 @@ package body Sem is
|
|||
Analyze_Freeze_Entity (N);
|
||||
|
||||
when N_Full_Type_Declaration =>
|
||||
Analyze_Type_Declaration (N);
|
||||
Analyze_Full_Type_Declaration (N);
|
||||
|
||||
when N_Function_Call =>
|
||||
Analyze_Function_Call (N);
|
||||
|
@ -465,7 +465,7 @@ package body Sem is
|
|||
Analyze_Protected_Definition (N);
|
||||
|
||||
when N_Protected_Type_Declaration =>
|
||||
Analyze_Protected_Type (N);
|
||||
Analyze_Protected_Type_Declaration (N);
|
||||
|
||||
when N_Qualified_Expression =>
|
||||
Analyze_Qualified_Expression (N);
|
||||
|
@ -505,10 +505,10 @@ package body Sem is
|
|||
Analyze_Selective_Accept (N);
|
||||
|
||||
when N_Single_Protected_Declaration =>
|
||||
Analyze_Single_Protected (N);
|
||||
Analyze_Single_Protected_Declaration (N);
|
||||
|
||||
when N_Single_Task_Declaration =>
|
||||
Analyze_Single_Task (N);
|
||||
Analyze_Single_Task_Declaration (N);
|
||||
|
||||
when N_Slice =>
|
||||
Analyze_Slice (N);
|
||||
|
@ -550,7 +550,7 @@ package body Sem is
|
|||
Analyze_Task_Definition (N);
|
||||
|
||||
when N_Task_Type_Declaration =>
|
||||
Analyze_Task_Type (N);
|
||||
Analyze_Task_Type_Declaration (N);
|
||||
|
||||
when N_Terminate_Alternative =>
|
||||
Analyze_Terminate_Alternative (N);
|
||||
|
|
|
@ -1754,8 +1754,8 @@ package body Sem_Cat is
|
|||
-- Start of processing for Validate_Remote_Access_Object_Type_Declaration
|
||||
|
||||
begin
|
||||
-- We are called from Analyze_Type_Declaration, and the Nkind of the
|
||||
-- given node is N_Access_To_Object_Definition.
|
||||
-- We are called from Analyze_Full_Type_Declaration, and the Nkind of
|
||||
-- the given node is N_Access_To_Object_Definition.
|
||||
|
||||
if not Comes_From_Source (T)
|
||||
or else (not In_RCI_Declaration (Parent (T))
|
||||
|
@ -2055,7 +2055,7 @@ package body Sem_Cat is
|
|||
-- Start of processing for Validate_SP_Access_Object_Type_Decl
|
||||
|
||||
begin
|
||||
-- We are called from Sem_Ch3.Analyze_Type_Declaration, and the
|
||||
-- We are called from Sem_Ch3.Analyze_Full_Type_Declaration, and the
|
||||
-- Nkind of the given entity is N_Access_To_Object_Definition.
|
||||
|
||||
if not Comes_From_Source (T)
|
||||
|
|
|
@ -23,6 +23,7 @@
|
|||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Aspects; use Aspects;
|
||||
with Atree; use Atree;
|
||||
with Checks; use Checks;
|
||||
with Einfo; use Einfo;
|
||||
|
@ -39,6 +40,7 @@ with Rtsfind; use Rtsfind;
|
|||
with Sem; use Sem;
|
||||
with Sem_Ch5; use Sem_Ch5;
|
||||
with Sem_Ch8; use Sem_Ch8;
|
||||
with Sem_Ch13; use Sem_Ch13;
|
||||
with Sem_Res; use Sem_Res;
|
||||
with Sem_Util; use Sem_Util;
|
||||
with Sem_Warn; use Sem_Warn;
|
||||
|
@ -55,6 +57,7 @@ package body Sem_Ch11 is
|
|||
procedure Analyze_Exception_Declaration (N : Node_Id) is
|
||||
Id : constant Entity_Id := Defining_Identifier (N);
|
||||
PF : constant Boolean := Is_Pure (Current_Scope);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
begin
|
||||
Generate_Definition (Id);
|
||||
Enter_Name (Id);
|
||||
|
@ -63,6 +66,7 @@ package body Sem_Ch11 is
|
|||
Set_Etype (Id, Standard_Exception_Type);
|
||||
Set_Is_Statically_Allocated (Id);
|
||||
Set_Is_Pure (Id, PF);
|
||||
Analyze_Aspect_Specifications (N, Id, AS);
|
||||
end Analyze_Exception_Declaration;
|
||||
|
||||
--------------------------------
|
||||
|
|
|
@ -23,6 +23,7 @@
|
|||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Aspects; use Aspects;
|
||||
with Atree; use Atree;
|
||||
with Einfo; use Einfo;
|
||||
with Elists; use Elists;
|
||||
|
@ -1801,6 +1802,7 @@ package body Sem_Ch12 is
|
|||
procedure Analyze_Formal_Object_Declaration (N : Node_Id) is
|
||||
E : constant Node_Id := Default_Expression (N);
|
||||
Id : constant Node_Id := Defining_Identifier (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
K : Entity_Kind;
|
||||
T : Node_Id;
|
||||
|
||||
|
@ -1929,6 +1931,8 @@ package body Sem_Ch12 is
|
|||
("initialization not allowed for `IN OUT` formals", N);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Analyze_Aspect_Specifications (N, Id, AS);
|
||||
end Analyze_Formal_Object_Declaration;
|
||||
|
||||
----------------------------------------------
|
||||
|
@ -1972,13 +1976,14 @@ package body Sem_Ch12 is
|
|||
Check_Restriction (No_Fixed_Point, Def);
|
||||
end Analyze_Formal_Ordinary_Fixed_Point_Type;
|
||||
|
||||
----------------------------
|
||||
-- Analyze_Formal_Package --
|
||||
----------------------------
|
||||
----------------------------------------
|
||||
-- Analyze_Formal_Package_Declaration --
|
||||
----------------------------------------
|
||||
|
||||
procedure Analyze_Formal_Package (N : Node_Id) is
|
||||
procedure Analyze_Formal_Package_Declaration (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Pack_Id : constant Entity_Id := Defining_Identifier (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
Formal : Entity_Id;
|
||||
Gen_Id : constant Node_Id := Name (N);
|
||||
Gen_Decl : Node_Id;
|
||||
|
@ -2115,14 +2120,14 @@ package body Sem_Ch12 is
|
|||
if Ekind (Gen_Unit) /= E_Generic_Package then
|
||||
Error_Msg_N ("expect generic package name", Gen_Id);
|
||||
Restore_Env;
|
||||
return;
|
||||
goto Leave;
|
||||
|
||||
elsif Gen_Unit = Current_Scope then
|
||||
Error_Msg_N
|
||||
("generic package cannot be used as a formal package of itself",
|
||||
Gen_Id);
|
||||
Restore_Env;
|
||||
return;
|
||||
goto Leave;
|
||||
|
||||
elsif In_Open_Scopes (Gen_Unit) then
|
||||
if Is_Compilation_Unit (Gen_Unit)
|
||||
|
@ -2142,7 +2147,7 @@ package body Sem_Ch12 is
|
|||
& "within itself",
|
||||
Gen_Id);
|
||||
Restore_Env;
|
||||
return;
|
||||
goto Leave;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
|
@ -2190,7 +2195,7 @@ package body Sem_Ch12 is
|
|||
Remove_Parent;
|
||||
end if;
|
||||
|
||||
return;
|
||||
goto Leave;
|
||||
end;
|
||||
|
||||
Rewrite (N, New_N);
|
||||
|
@ -2273,7 +2278,9 @@ package body Sem_Ch12 is
|
|||
Set_Etype (Pack_Id, Standard_Void_Type);
|
||||
Set_Scope (Pack_Id, Scope (Formal));
|
||||
Set_Has_Completion (Pack_Id, True);
|
||||
end Analyze_Formal_Package;
|
||||
|
||||
<<Leave>> Analyze_Aspect_Specifications (N, Pack_Id, AS);
|
||||
end Analyze_Formal_Package_Declaration;
|
||||
|
||||
---------------------------------
|
||||
-- Analyze_Formal_Private_Type --
|
||||
|
@ -2323,14 +2330,15 @@ package body Sem_Ch12 is
|
|||
Set_Parent (Base, Parent (Def));
|
||||
end Analyze_Formal_Signed_Integer_Type;
|
||||
|
||||
-------------------------------
|
||||
-- Analyze_Formal_Subprogram --
|
||||
-------------------------------
|
||||
-------------------------------------------
|
||||
-- Analyze_Formal_Subprogram_Declaration --
|
||||
-------------------------------------------
|
||||
|
||||
procedure Analyze_Formal_Subprogram (N : Node_Id) is
|
||||
procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is
|
||||
Spec : constant Node_Id := Specification (N);
|
||||
Def : constant Node_Id := Default_Name (N);
|
||||
Nam : constant Entity_Id := Defining_Unit_Name (Spec);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
Subp : Entity_Id;
|
||||
|
||||
begin
|
||||
|
@ -2340,7 +2348,7 @@ package body Sem_Ch12 is
|
|||
|
||||
if Nkind (Nam) = N_Defining_Program_Unit_Name then
|
||||
Error_Msg_N ("name of formal subprogram must be a direct name", Nam);
|
||||
return;
|
||||
goto Leave;
|
||||
end if;
|
||||
|
||||
Analyze_Subprogram_Declaration (N);
|
||||
|
@ -2384,7 +2392,7 @@ package body Sem_Ch12 is
|
|||
|
||||
Analyze (Prefix (Def));
|
||||
Valid_Default_Attribute (Nam, Def);
|
||||
return;
|
||||
goto Leave;
|
||||
end if;
|
||||
|
||||
-- Default name may be overloaded, in which case the interpretation
|
||||
|
@ -2394,7 +2402,7 @@ package body Sem_Ch12 is
|
|||
-- can be a protected operation.
|
||||
|
||||
if Etype (Def) = Any_Type then
|
||||
return;
|
||||
goto Leave;
|
||||
|
||||
elsif Nkind (Def) = N_Selected_Component then
|
||||
if not Is_Overloadable (Entity (Selector_Name (Def))) then
|
||||
|
@ -2416,7 +2424,7 @@ package body Sem_Ch12 is
|
|||
|
||||
else
|
||||
Error_Msg_N ("expect valid subprogram name as default", Def);
|
||||
return;
|
||||
goto Leave;
|
||||
end if;
|
||||
|
||||
elsif Nkind (Def) = N_Character_Literal then
|
||||
|
@ -2429,7 +2437,7 @@ package body Sem_Ch12 is
|
|||
or else not Is_Overloadable (Entity (Def))
|
||||
then
|
||||
Error_Msg_N ("expect valid subprogram name as default", Def);
|
||||
return;
|
||||
goto Leave;
|
||||
|
||||
elsif not Is_Overloaded (Def) then
|
||||
Subp := Entity (Def);
|
||||
|
@ -2491,7 +2499,9 @@ package body Sem_Ch12 is
|
|||
end if;
|
||||
end if;
|
||||
end if;
|
||||
end Analyze_Formal_Subprogram;
|
||||
|
||||
<<Leave>> Analyze_Aspect_Specifications (N, Nam, AS);
|
||||
end Analyze_Formal_Subprogram_Declaration;
|
||||
|
||||
-------------------------------------
|
||||
-- Analyze_Formal_Type_Declaration --
|
||||
|
@ -2499,6 +2509,7 @@ package body Sem_Ch12 is
|
|||
|
||||
procedure Analyze_Formal_Type_Declaration (N : Node_Id) is
|
||||
Def : constant Node_Id := Formal_Type_Definition (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
T : Entity_Id;
|
||||
|
||||
begin
|
||||
|
@ -2564,6 +2575,7 @@ package body Sem_Ch12 is
|
|||
end case;
|
||||
|
||||
Set_Is_Generic_Type (T);
|
||||
Analyze_Aspect_Specifications (N, T, AS);
|
||||
end Analyze_Formal_Type_Declaration;
|
||||
|
||||
------------------------------------
|
||||
|
@ -2630,6 +2642,7 @@ package body Sem_Ch12 is
|
|||
|
||||
procedure Analyze_Generic_Package_Declaration (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
Id : Entity_Id;
|
||||
New_N : Node_Id;
|
||||
Save_Parent : Node_Id;
|
||||
|
@ -2740,6 +2753,8 @@ package body Sem_Ch12 is
|
|||
Check_References (Id);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Analyze_Aspect_Specifications (N, Id, AS);
|
||||
end Analyze_Generic_Package_Declaration;
|
||||
|
||||
--------------------------------------------
|
||||
|
@ -2747,6 +2762,7 @@ package body Sem_Ch12 is
|
|||
--------------------------------------------
|
||||
|
||||
procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
Spec : Node_Id;
|
||||
Id : Entity_Id;
|
||||
Formals : List_Id;
|
||||
|
@ -2865,6 +2881,7 @@ package body Sem_Ch12 is
|
|||
End_Scope;
|
||||
Exit_Generic_Scope (Id);
|
||||
Generate_Reference_To_Formals (Id);
|
||||
Analyze_Aspect_Specifications (N, Id, AS);
|
||||
end Analyze_Generic_Subprogram_Declaration;
|
||||
|
||||
-----------------------------------
|
||||
|
@ -2874,6 +2891,7 @@ package body Sem_Ch12 is
|
|||
procedure Analyze_Package_Instantiation (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Gen_Id : constant Node_Id := Name (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
|
||||
Act_Decl : Node_Id;
|
||||
Act_Decl_Name : Node_Id;
|
||||
|
@ -3014,7 +3032,7 @@ package body Sem_Ch12 is
|
|||
|
||||
if Etype (Gen_Unit) = Any_Type then
|
||||
Restore_Env;
|
||||
return;
|
||||
goto Leave;
|
||||
|
||||
elsif Ekind (Gen_Unit) /= E_Generic_Package then
|
||||
|
||||
|
@ -3029,7 +3047,7 @@ package body Sem_Ch12 is
|
|||
end if;
|
||||
|
||||
Restore_Env;
|
||||
return;
|
||||
goto Leave;
|
||||
end if;
|
||||
|
||||
if In_Extended_Main_Source_Unit (N) then
|
||||
|
@ -3072,7 +3090,7 @@ package body Sem_Ch12 is
|
|||
if In_Open_Scopes (Gen_Unit) then
|
||||
Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
|
||||
Restore_Env;
|
||||
return;
|
||||
goto Leave;
|
||||
|
||||
elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
|
||||
Error_Msg_Node_2 := Current_Scope;
|
||||
|
@ -3080,7 +3098,7 @@ package body Sem_Ch12 is
|
|||
("circular Instantiation: & instantiated in &!", N, Gen_Unit);
|
||||
Circularity_Detected := True;
|
||||
Restore_Env;
|
||||
return;
|
||||
goto Leave;
|
||||
|
||||
else
|
||||
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
|
||||
|
@ -3537,6 +3555,8 @@ package body Sem_Ch12 is
|
|||
Set_Defining_Identifier (N, Act_Decl_Id);
|
||||
end if;
|
||||
|
||||
<<Leave>> Analyze_Aspect_Specifications (N, Act_Decl_Id, AS);
|
||||
|
||||
exception
|
||||
when Instantiation_Error =>
|
||||
if Parent_Installed then
|
||||
|
@ -3890,6 +3910,7 @@ package body Sem_Ch12 is
|
|||
is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Gen_Id : constant Node_Id := Name (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
|
||||
Anon_Id : constant Entity_Id :=
|
||||
Make_Defining_Identifier (Sloc (Defining_Entity (N)),
|
||||
|
@ -4153,7 +4174,7 @@ package body Sem_Ch12 is
|
|||
Error_Msg_NE
|
||||
("circular Instantiation: & instantiated in &!", N, Gen_Unit);
|
||||
Circularity_Detected := True;
|
||||
return;
|
||||
goto Leave;
|
||||
end if;
|
||||
|
||||
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
|
||||
|
@ -4311,6 +4332,8 @@ package body Sem_Ch12 is
|
|||
Generic_Renamings_HTable.Reset;
|
||||
end if;
|
||||
|
||||
<<Leave>> Analyze_Aspect_Specifications (N, Act_Decl_Id, AS);
|
||||
|
||||
exception
|
||||
when Instantiation_Error =>
|
||||
if Parent_Installed then
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- 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 --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
|
@ -34,8 +34,8 @@ package Sem_Ch12 is
|
|||
procedure Analyze_Function_Instantiation (N : Node_Id);
|
||||
procedure Analyze_Formal_Object_Declaration (N : Node_Id);
|
||||
procedure Analyze_Formal_Type_Declaration (N : Node_Id);
|
||||
procedure Analyze_Formal_Subprogram (N : Node_Id);
|
||||
procedure Analyze_Formal_Package (N : Node_Id);
|
||||
procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id);
|
||||
procedure Analyze_Formal_Package_Declaration (N : Node_Id);
|
||||
|
||||
procedure Start_Generic;
|
||||
-- Must be invoked before starting to process a generic spec or body
|
||||
|
|
|
@ -23,6 +23,7 @@
|
|||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Aspects; use Aspects;
|
||||
with Atree; use Atree;
|
||||
with Checks; use Checks;
|
||||
with Einfo; use Einfo;
|
||||
|
@ -618,6 +619,217 @@ package body Sem_Ch13 is
|
|||
end if;
|
||||
end Alignment_Check_For_Esize_Change;
|
||||
|
||||
-----------------------------------
|
||||
-- Analyze_Aspect_Specifications --
|
||||
-----------------------------------
|
||||
|
||||
procedure Analyze_Aspect_Specifications
|
||||
(N : Node_Id;
|
||||
E : Entity_Id;
|
||||
L : List_Id)
|
||||
is
|
||||
Aspect : Node_Id;
|
||||
Ent : Node_Id;
|
||||
Result : Boolean;
|
||||
Ritem : Node_Id;
|
||||
|
||||
Ins_Node : Node_Id := N;
|
||||
-- Insert pragmas after this node
|
||||
|
||||
begin
|
||||
if L = No_List then
|
||||
return;
|
||||
end if;
|
||||
|
||||
Aspect := First (L);
|
||||
while Present (Aspect) loop
|
||||
declare
|
||||
Id : constant Node_Id := Identifier (Aspect);
|
||||
Expr : constant Node_Id := Expression (Aspect);
|
||||
Nam : constant Name_Id := Chars (Id);
|
||||
Anod : Node_Id;
|
||||
|
||||
begin
|
||||
-- Check for duplicate aspect
|
||||
|
||||
Anod := First (L);
|
||||
while Anod /= Aspect loop
|
||||
if Nam = Chars (Identifier (Anod)) then
|
||||
Error_Msg_Name_1 := Nam;
|
||||
Error_Msg_Sloc := Sloc (Anod);
|
||||
Error_Msg_NE
|
||||
("aspect% for & ignored, already given at#", Id, E);
|
||||
goto Continue;
|
||||
end if;
|
||||
|
||||
Next (Anod);
|
||||
end loop;
|
||||
|
||||
-- Processing based on specific aspect
|
||||
|
||||
case Get_Aspect_Id (Nam) is
|
||||
|
||||
-- No_Aspect should be impossible
|
||||
|
||||
when No_Aspect =>
|
||||
raise Program_Error;
|
||||
|
||||
-- Aspects taking an optional boolean argument. For all of
|
||||
-- these we just create a matching pragma and insert it,
|
||||
-- setting flag Cancel_Aspect if the expression is False.
|
||||
|
||||
when Aspect_Ada_2005 |
|
||||
Aspect_Ada_2012 |
|
||||
Aspect_Atomic |
|
||||
Aspect_Atomic_Components |
|
||||
Aspect_Discard_Names |
|
||||
Aspect_Favor_Top_Level |
|
||||
Aspect_Inline |
|
||||
Aspect_Inline_Always |
|
||||
Aspect_No_Return |
|
||||
Aspect_Pack |
|
||||
Aspect_Persistent_BSS |
|
||||
Aspect_Preelaborable_Initialization |
|
||||
Aspect_Pure_Function |
|
||||
Aspect_Shared |
|
||||
Aspect_Suppress_Debug_Info |
|
||||
Aspect_Unchecked_Union |
|
||||
Aspect_Universal_Aliasing |
|
||||
Aspect_Unmodified |
|
||||
Aspect_Unreferenced |
|
||||
Aspect_Unreferenced_Objects |
|
||||
Aspect_Volatile |
|
||||
Aspect_Volatile_Components =>
|
||||
|
||||
if No (Expr) then
|
||||
Result := True;
|
||||
|
||||
else
|
||||
Analyze_And_Resolve (Expr);
|
||||
|
||||
if not Is_OK_Static_Expression (Expr) then
|
||||
Error_Msg_N
|
||||
("static boolean expression required here", Expr);
|
||||
Result := True;
|
||||
|
||||
else
|
||||
Result := Is_True (Expr_Value (Expr));
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Ent := New_Occurrence_Of (E, Sloc (Id));
|
||||
|
||||
Ritem :=
|
||||
Make_Pragma (Sloc (Aspect),
|
||||
Pragma_Argument_Associations => New_List (Ent),
|
||||
Pragma_Identifier =>
|
||||
Make_Identifier (Sloc (Id), Chars (Id)));
|
||||
|
||||
if Result = False then
|
||||
Set_Aspect_Cancel (Ritem);
|
||||
end if;
|
||||
|
||||
-- Aspects corresponding to attribute definition clauses. We
|
||||
-- create the matching clause and insert it following the
|
||||
-- declaration in the tree.
|
||||
|
||||
when Aspect_Address |
|
||||
Aspect_Alignment |
|
||||
Aspect_Bit_Order |
|
||||
Aspect_Component_Size |
|
||||
Aspect_External_Tag |
|
||||
Aspect_Machine_Radix |
|
||||
Aspect_Object_Size |
|
||||
Aspect_Size |
|
||||
Aspect_Storage_Pool |
|
||||
Aspect_Storage_Size |
|
||||
Aspect_Stream_Size |
|
||||
Aspect_Value_Size =>
|
||||
|
||||
Ritem :=
|
||||
Make_Attribute_Definition_Clause (Sloc (Aspect),
|
||||
Name => New_Occurrence_Of (E, Sloc (Id)),
|
||||
Chars => Chars (Id),
|
||||
Expression => Relocate_Node (Expr));
|
||||
|
||||
-- Aspects corresponding to pragmas with two arguments, where
|
||||
-- the first argument is a local name referring to the entity,
|
||||
-- and the second argument is the aspect definition expression.
|
||||
|
||||
when Aspect_Suppress |
|
||||
Aspect_Unsuppress =>
|
||||
|
||||
Ritem :=
|
||||
Make_Pragma (Sloc (Aspect),
|
||||
Pragma_Argument_Associations => New_List (
|
||||
New_Occurrence_Of (E, Sloc (Expr)),
|
||||
Relocate_Node (Expr)),
|
||||
Pragma_Identifier =>
|
||||
Make_Identifier (Sloc (Id), Chars (Id)));
|
||||
|
||||
-- Aspects corresponding to pragmas with two arguments, where
|
||||
-- the second argument is a local name referring to the entity,
|
||||
-- and the first argument is the aspect definition expression.
|
||||
|
||||
when Aspect_Warnings =>
|
||||
|
||||
Ritem :=
|
||||
Make_Pragma (Sloc (Aspect),
|
||||
Pragma_Argument_Associations => New_List (
|
||||
Relocate_Node (Expr),
|
||||
New_Occurrence_Of (E, Sloc (Expr))),
|
||||
Pragma_Identifier =>
|
||||
Make_Identifier (Sloc (Id), Chars (Id)));
|
||||
|
||||
-- Aspect Post corresponds to pragma Postcondition with single
|
||||
-- argument that is the expression (we never give a message
|
||||
-- argument. This is inserted right after the declaration, to
|
||||
-- to get the required pragma placement.
|
||||
|
||||
when Aspect_Post =>
|
||||
|
||||
Insert_After (N,
|
||||
Make_Pragma (Sloc (Expr),
|
||||
Pragma_Argument_Associations => New_List (
|
||||
Relocate_Node (Expr)),
|
||||
Pragma_Identifier =>
|
||||
Make_Identifier (Sloc (Id), Name_Postcondition)));
|
||||
goto Continue;
|
||||
|
||||
-- Aspect Pre corresponds to pragma Precondition with single
|
||||
-- argument that is the expression (we never give a message
|
||||
-- argument. This is inserted right after the declaration, to
|
||||
-- get the required pragma placement.
|
||||
|
||||
when Aspect_Pre =>
|
||||
|
||||
Insert_After (N,
|
||||
Make_Pragma (Sloc (Expr),
|
||||
Pragma_Argument_Associations => New_List (
|
||||
Relocate_Node (Expr)),
|
||||
Pragma_Identifier =>
|
||||
Make_Identifier (Sloc (Id), Name_Precondition)));
|
||||
goto Continue;
|
||||
|
||||
-- Aspects currently unimplemented
|
||||
|
||||
when Aspect_Invariant |
|
||||
Aspect_Predicate =>
|
||||
|
||||
Error_Msg_N ("aspect& not implemented", Identifier (Aspect));
|
||||
goto Continue;
|
||||
end case;
|
||||
|
||||
Set_From_Aspect_Specification (Ritem);
|
||||
Insert_After (Ins_Node, Ritem);
|
||||
Ins_Node := Ritem;
|
||||
end;
|
||||
|
||||
<<Continue>>
|
||||
Next (Aspect);
|
||||
end loop;
|
||||
end Analyze_Aspect_Specifications;
|
||||
|
||||
-----------------------
|
||||
-- Analyze_At_Clause --
|
||||
-----------------------
|
||||
|
@ -684,6 +896,12 @@ package body Sem_Ch13 is
|
|||
-- Common processing for 'Read, 'Write, 'Input and 'Output attribute
|
||||
-- definition clauses.
|
||||
|
||||
function Duplicate_Clause return Boolean;
|
||||
-- This routine checks if the aspect for U_Ent being given by attribute
|
||||
-- definition clause N is for an aspect that has already been specified,
|
||||
-- and if so gives an error message. If there is a duplicate, True is
|
||||
-- returned, otherwise if there is no error, False is returned.
|
||||
|
||||
-----------------------------------
|
||||
-- Analyze_Stream_TSS_Definition --
|
||||
-----------------------------------
|
||||
|
@ -820,6 +1038,40 @@ package body Sem_Ch13 is
|
|||
end if;
|
||||
end Analyze_Stream_TSS_Definition;
|
||||
|
||||
----------------------
|
||||
-- Duplicate_Clause --
|
||||
----------------------
|
||||
|
||||
function Duplicate_Clause return Boolean is
|
||||
A : constant Node_Id :=
|
||||
Get_Attribute_Definition_Clause
|
||||
(U_Ent, Get_Attribute_Id (Chars (N)));
|
||||
|
||||
begin
|
||||
-- Nothing to do if this attribute definition clause comes from an
|
||||
-- aspect specification, since we could not be duplicating an
|
||||
-- explicit clause, and we dealt with the case of duplicated aspects
|
||||
-- in Analyze_Aspect_Specifications.
|
||||
|
||||
if From_Aspect_Specification (N) then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
-- Otherwise current pragma may duplicate previous pragma or a
|
||||
-- previously given aspect specification for the same pragma.
|
||||
|
||||
if Present (A) then
|
||||
if Entity (A) = U_Ent then
|
||||
Error_Msg_Name_1 := Chars (N);
|
||||
Error_Msg_Sloc := Sloc (A);
|
||||
Error_Msg_NE ("aspect% for & previously specified#", N, U_Ent);
|
||||
return True;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
return False;
|
||||
end Duplicate_Clause;
|
||||
|
||||
-- Start of processing for Analyze_Attribute_Definition_Clause
|
||||
|
||||
begin
|
||||
|
@ -928,6 +1180,8 @@ package body Sem_Ch13 is
|
|||
return;
|
||||
end if;
|
||||
|
||||
Set_Entity (N, U_Ent);
|
||||
|
||||
-- Switch on particular attribute
|
||||
|
||||
case Id is
|
||||
|
@ -969,8 +1223,8 @@ package body Sem_Ch13 is
|
|||
return;
|
||||
end if;
|
||||
|
||||
if Present (Address_Clause (U_Ent)) then
|
||||
Error_Msg_N ("address already given for &", Nam);
|
||||
if Duplicate_Clause then
|
||||
null;
|
||||
|
||||
-- Case of address clause for subprogram
|
||||
|
||||
|
@ -1235,9 +1489,8 @@ package body Sem_Ch13 is
|
|||
then
|
||||
Error_Msg_N ("alignment cannot be given for &", Nam);
|
||||
|
||||
elsif Has_Alignment_Clause (U_Ent) then
|
||||
Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent));
|
||||
Error_Msg_N ("alignment clause previously given#", N);
|
||||
elsif Duplicate_Clause then
|
||||
null;
|
||||
|
||||
elsif Align /= No_Uint then
|
||||
Set_Has_Alignment_Clause (U_Ent);
|
||||
|
@ -1266,6 +1519,9 @@ package body Sem_Ch13 is
|
|||
Error_Msg_N
|
||||
("Bit_Order can only be defined for record type", Nam);
|
||||
|
||||
elsif Duplicate_Clause then
|
||||
null;
|
||||
|
||||
else
|
||||
Analyze_And_Resolve (Expr, RTE (RE_Bit_Order));
|
||||
|
||||
|
@ -1307,9 +1563,8 @@ package body Sem_Ch13 is
|
|||
Btype := Base_Type (U_Ent);
|
||||
Ctyp := Component_Type (Btype);
|
||||
|
||||
if Has_Component_Size_Clause (Btype) then
|
||||
Error_Msg_N
|
||||
("component size clause for& previously given", Nam);
|
||||
if Duplicate_Clause then
|
||||
null;
|
||||
|
||||
elsif Rep_Item_Too_Early (Btype, N) then
|
||||
null;
|
||||
|
@ -1391,28 +1646,33 @@ package body Sem_Ch13 is
|
|||
Error_Msg_N ("should be a tagged type", Nam);
|
||||
end if;
|
||||
|
||||
Analyze_And_Resolve (Expr, Standard_String);
|
||||
if Duplicate_Clause then
|
||||
null;
|
||||
|
||||
if not Is_Static_Expression (Expr) then
|
||||
Flag_Non_Static_Expr
|
||||
("static string required for tag name!", Nam);
|
||||
end if;
|
||||
|
||||
if VM_Target = No_VM then
|
||||
Set_Has_External_Tag_Rep_Clause (U_Ent);
|
||||
else
|
||||
Error_Msg_Name_1 := Attr;
|
||||
Error_Msg_N
|
||||
("% attribute unsupported in this configuration", Nam);
|
||||
end if;
|
||||
Analyze_And_Resolve (Expr, Standard_String);
|
||||
|
||||
if not Is_Library_Level_Entity (U_Ent) then
|
||||
Error_Msg_NE
|
||||
("?non-unique external tag supplied for &", N, U_Ent);
|
||||
Error_Msg_N
|
||||
("?\same external tag applies to all subprogram calls", N);
|
||||
Error_Msg_N
|
||||
("?\corresponding internal tag cannot be obtained", N);
|
||||
if not Is_Static_Expression (Expr) then
|
||||
Flag_Non_Static_Expr
|
||||
("static string required for tag name!", Nam);
|
||||
end if;
|
||||
|
||||
if VM_Target = No_VM then
|
||||
Set_Has_External_Tag_Rep_Clause (U_Ent);
|
||||
else
|
||||
Error_Msg_Name_1 := Attr;
|
||||
Error_Msg_N
|
||||
("% attribute unsupported in this configuration", Nam);
|
||||
end if;
|
||||
|
||||
if not Is_Library_Level_Entity (U_Ent) then
|
||||
Error_Msg_NE
|
||||
("?non-unique external tag supplied for &", N, U_Ent);
|
||||
Error_Msg_N
|
||||
("?\same external tag applies to all subprogram calls", N);
|
||||
Error_Msg_N
|
||||
("?\corresponding internal tag cannot be obtained", N);
|
||||
end if;
|
||||
end if;
|
||||
end External_Tag;
|
||||
|
||||
|
@ -1437,9 +1697,8 @@ package body Sem_Ch13 is
|
|||
if not Is_Decimal_Fixed_Point_Type (U_Ent) then
|
||||
Error_Msg_N ("decimal fixed-point type expected for &", Nam);
|
||||
|
||||
elsif Has_Machine_Radix_Clause (U_Ent) then
|
||||
Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent));
|
||||
Error_Msg_N ("machine radix clause previously given#", N);
|
||||
elsif Duplicate_Clause then
|
||||
null;
|
||||
|
||||
elsif Radix /= No_Uint then
|
||||
Set_Has_Machine_Radix_Clause (U_Ent);
|
||||
|
@ -1471,8 +1730,8 @@ package body Sem_Ch13 is
|
|||
if not Is_Type (U_Ent) then
|
||||
Error_Msg_N ("Object_Size cannot be given for &", Nam);
|
||||
|
||||
elsif Has_Object_Size_Clause (U_Ent) then
|
||||
Error_Msg_N ("Object_Size already given for &", Nam);
|
||||
elsif Duplicate_Clause then
|
||||
null;
|
||||
|
||||
else
|
||||
Check_Size (Expr, U_Ent, Size, Biased);
|
||||
|
@ -1526,8 +1785,8 @@ package body Sem_Ch13 is
|
|||
begin
|
||||
FOnly := True;
|
||||
|
||||
if Has_Size_Clause (U_Ent) then
|
||||
Error_Msg_N ("size already given for &", Nam);
|
||||
if Duplicate_Clause then
|
||||
null;
|
||||
|
||||
elsif not Is_Type (U_Ent)
|
||||
and then Ekind (U_Ent) /= E_Variable
|
||||
|
@ -1709,8 +1968,7 @@ package body Sem_Ch13 is
|
|||
("storage pool cannot be given for a derived access type",
|
||||
Nam);
|
||||
|
||||
elsif Has_Storage_Size_Clause (U_Ent) then
|
||||
Error_Msg_N ("storage size already given for &", Nam);
|
||||
elsif Duplicate_Clause then
|
||||
return;
|
||||
|
||||
elsif Present (Associated_Storage_Pool (U_Ent)) then
|
||||
|
@ -1839,8 +2097,8 @@ package body Sem_Ch13 is
|
|||
("storage size cannot be given for a derived access type",
|
||||
Nam);
|
||||
|
||||
elsif Has_Storage_Size_Clause (Btype) then
|
||||
Error_Msg_N ("storage size already given for &", Nam);
|
||||
elsif Duplicate_Clause then
|
||||
null;
|
||||
|
||||
else
|
||||
Analyze_And_Resolve (Expr, Any_Integer);
|
||||
|
@ -1884,8 +2142,8 @@ package body Sem_Ch13 is
|
|||
Check_Restriction (No_Implementation_Attributes, N);
|
||||
end if;
|
||||
|
||||
if Has_Stream_Size_Clause (U_Ent) then
|
||||
Error_Msg_N ("Stream_Size already given for &", Nam);
|
||||
if Duplicate_Clause then
|
||||
null;
|
||||
|
||||
elsif Is_Elementary_Type (U_Ent) then
|
||||
if Size /= System_Storage_Unit
|
||||
|
@ -1929,11 +2187,8 @@ package body Sem_Ch13 is
|
|||
if not Is_Type (U_Ent) then
|
||||
Error_Msg_N ("Value_Size cannot be given for &", Nam);
|
||||
|
||||
elsif Present
|
||||
(Get_Attribute_Definition_Clause
|
||||
(U_Ent, Attribute_Value_Size))
|
||||
then
|
||||
Error_Msg_N ("Value_Size already given for &", Nam);
|
||||
elsif Duplicate_Clause then
|
||||
null;
|
||||
|
||||
elsif Is_Array_Type (U_Ent)
|
||||
and then not Is_Constrained (U_Ent)
|
||||
|
|
|
@ -36,6 +36,17 @@ package Sem_Ch13 is
|
|||
procedure Analyze_Record_Representation_Clause (N : Node_Id);
|
||||
procedure Analyze_Code_Statement (N : Node_Id);
|
||||
|
||||
procedure Analyze_Aspect_Specifications
|
||||
(N : Node_Id;
|
||||
E : Entity_Id;
|
||||
L : List_Id);
|
||||
-- This procedure is called to analyze aspect spefications for node N. E is
|
||||
-- the corresponding entity declared by the declaration node N, and L is
|
||||
-- the list of aspect specifications for this node. If L is No_List, the
|
||||
-- call is ignored. Note that we can't use a simpler interface of just
|
||||
-- passing the node N, since the analysis of the node may cause it to be
|
||||
-- rewritten to a node not permitting aspect specifications.
|
||||
|
||||
procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id);
|
||||
-- Called from Freeze where R is a record entity for which reverse bit
|
||||
-- order is specified and there is at least one component clause. Adjusts
|
||||
|
|
|
@ -23,6 +23,7 @@
|
|||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Aspects; use Aspects;
|
||||
with Atree; use Atree;
|
||||
with Checks; use Checks;
|
||||
with Debug; use Debug;
|
||||
|
@ -1113,7 +1114,7 @@ package body Sem_Ch3 is
|
|||
else
|
||||
if From_With_Type (Typ) then
|
||||
|
||||
-- AI05-151 : incomplete types are allowed in all basic
|
||||
-- AI05-151: Incomplete types are allowed in all basic
|
||||
-- declarations, including access to subprograms.
|
||||
|
||||
if Ada_Version >= Ada_2012 then
|
||||
|
@ -1618,6 +1619,7 @@ package body Sem_Ch3 is
|
|||
procedure Analyze_Component_Declaration (N : Node_Id) is
|
||||
Id : constant Entity_Id := Defining_Identifier (N);
|
||||
E : constant Node_Id := Expression (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
T : Entity_Id;
|
||||
P : Entity_Id;
|
||||
|
||||
|
@ -1944,6 +1946,7 @@ package body Sem_Ch3 is
|
|||
end if;
|
||||
|
||||
Set_Original_Record_Component (Id, Id);
|
||||
Analyze_Aspect_Specifications (N, Id, AS);
|
||||
end Analyze_Component_Declaration;
|
||||
|
||||
--------------------------
|
||||
|
@ -2069,6 +2072,318 @@ package body Sem_Ch3 is
|
|||
end loop;
|
||||
end Analyze_Declarations;
|
||||
|
||||
-----------------------------------
|
||||
-- Analyze_Full_Type_Declaration --
|
||||
-----------------------------------
|
||||
|
||||
procedure Analyze_Full_Type_Declaration (N : Node_Id) is
|
||||
Def : constant Node_Id := Type_Definition (N);
|
||||
Def_Id : constant Entity_Id := Defining_Identifier (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
T : Entity_Id;
|
||||
Prev : Entity_Id;
|
||||
|
||||
Is_Remote : constant Boolean :=
|
||||
(Is_Remote_Types (Current_Scope)
|
||||
or else Is_Remote_Call_Interface (Current_Scope))
|
||||
and then not (In_Private_Part (Current_Scope)
|
||||
or else In_Package_Body (Current_Scope));
|
||||
|
||||
procedure Check_Ops_From_Incomplete_Type;
|
||||
-- If there is a tagged incomplete partial view of the type, transfer
|
||||
-- its operations to the full view, and indicate that the type of the
|
||||
-- controlling parameter (s) is this full view.
|
||||
|
||||
------------------------------------
|
||||
-- Check_Ops_From_Incomplete_Type --
|
||||
------------------------------------
|
||||
|
||||
procedure Check_Ops_From_Incomplete_Type is
|
||||
Elmt : Elmt_Id;
|
||||
Formal : Entity_Id;
|
||||
Op : Entity_Id;
|
||||
|
||||
begin
|
||||
if Prev /= T
|
||||
and then Ekind (Prev) = E_Incomplete_Type
|
||||
and then Is_Tagged_Type (Prev)
|
||||
and then Is_Tagged_Type (T)
|
||||
then
|
||||
Elmt := First_Elmt (Primitive_Operations (Prev));
|
||||
while Present (Elmt) loop
|
||||
Op := Node (Elmt);
|
||||
Prepend_Elmt (Op, Primitive_Operations (T));
|
||||
|
||||
Formal := First_Formal (Op);
|
||||
while Present (Formal) loop
|
||||
if Etype (Formal) = Prev then
|
||||
Set_Etype (Formal, T);
|
||||
end if;
|
||||
|
||||
Next_Formal (Formal);
|
||||
end loop;
|
||||
|
||||
if Etype (Op) = Prev then
|
||||
Set_Etype (Op, T);
|
||||
end if;
|
||||
|
||||
Next_Elmt (Elmt);
|
||||
end loop;
|
||||
end if;
|
||||
end Check_Ops_From_Incomplete_Type;
|
||||
|
||||
-- Start of processing for Analyze_Full_Type_Declaration
|
||||
|
||||
begin
|
||||
Prev := Find_Type_Name (N);
|
||||
|
||||
-- The full view, if present, now points to the current type
|
||||
|
||||
-- Ada 2005 (AI-50217): If the type was previously decorated when
|
||||
-- imported through a LIMITED WITH clause, it appears as incomplete
|
||||
-- but has no full view.
|
||||
|
||||
-- If the incomplete view is tagged, a class_wide type has been
|
||||
-- created already. Use it for the full view as well, to prevent
|
||||
-- multiple incompatible class-wide types that may be created for
|
||||
-- self-referential anonymous access components.
|
||||
|
||||
if Ekind (Prev) = E_Incomplete_Type
|
||||
and then Present (Full_View (Prev))
|
||||
then
|
||||
T := Full_View (Prev);
|
||||
|
||||
if Is_Tagged_Type (Prev)
|
||||
and then Present (Class_Wide_Type (Prev))
|
||||
then
|
||||
Set_Ekind (T, Ekind (Prev)); -- will be reset later
|
||||
Set_Class_Wide_Type (T, Class_Wide_Type (Prev));
|
||||
Set_Etype (Class_Wide_Type (T), T);
|
||||
end if;
|
||||
|
||||
else
|
||||
T := Prev;
|
||||
end if;
|
||||
|
||||
Set_Is_Pure (T, Is_Pure (Current_Scope));
|
||||
|
||||
-- We set the flag Is_First_Subtype here. It is needed to set the
|
||||
-- corresponding flag for the Implicit class-wide-type created
|
||||
-- during tagged types processing.
|
||||
|
||||
Set_Is_First_Subtype (T, True);
|
||||
|
||||
-- Only composite types other than array types are allowed to have
|
||||
-- discriminants.
|
||||
|
||||
case Nkind (Def) is
|
||||
|
||||
-- For derived types, the rule will be checked once we've figured
|
||||
-- out the parent type.
|
||||
|
||||
when N_Derived_Type_Definition =>
|
||||
null;
|
||||
|
||||
-- For record types, discriminants are allowed
|
||||
|
||||
when N_Record_Definition =>
|
||||
null;
|
||||
|
||||
when others =>
|
||||
if Present (Discriminant_Specifications (N)) then
|
||||
Error_Msg_N
|
||||
("elementary or array type cannot have discriminants",
|
||||
Defining_Identifier
|
||||
(First (Discriminant_Specifications (N))));
|
||||
end if;
|
||||
end case;
|
||||
|
||||
-- Elaborate the type definition according to kind, and generate
|
||||
-- subsidiary (implicit) subtypes where needed. We skip this if it was
|
||||
-- already done (this happens during the reanalysis that follows a call
|
||||
-- to the high level optimizer).
|
||||
|
||||
if not Analyzed (T) then
|
||||
Set_Analyzed (T);
|
||||
|
||||
case Nkind (Def) is
|
||||
|
||||
when N_Access_To_Subprogram_Definition =>
|
||||
Access_Subprogram_Declaration (T, Def);
|
||||
|
||||
-- If this is a remote access to subprogram, we must create the
|
||||
-- equivalent fat pointer type, and related subprograms.
|
||||
|
||||
if Is_Remote then
|
||||
Process_Remote_AST_Declaration (N);
|
||||
end if;
|
||||
|
||||
-- Validate categorization rule against access type declaration
|
||||
-- usually a violation in Pure unit, Shared_Passive unit.
|
||||
|
||||
Validate_Access_Type_Declaration (T, N);
|
||||
|
||||
when N_Access_To_Object_Definition =>
|
||||
Access_Type_Declaration (T, Def);
|
||||
|
||||
-- Validate categorization rule against access type declaration
|
||||
-- usually a violation in Pure unit, Shared_Passive unit.
|
||||
|
||||
Validate_Access_Type_Declaration (T, N);
|
||||
|
||||
-- If we are in a Remote_Call_Interface package and define a
|
||||
-- RACW, then calling stubs and specific stream attributes
|
||||
-- must be added.
|
||||
|
||||
if Is_Remote
|
||||
and then Is_Remote_Access_To_Class_Wide_Type (Def_Id)
|
||||
then
|
||||
Add_RACW_Features (Def_Id);
|
||||
end if;
|
||||
|
||||
-- Set no strict aliasing flag if config pragma seen
|
||||
|
||||
if Opt.No_Strict_Aliasing then
|
||||
Set_No_Strict_Aliasing (Base_Type (Def_Id));
|
||||
end if;
|
||||
|
||||
when N_Array_Type_Definition =>
|
||||
Array_Type_Declaration (T, Def);
|
||||
|
||||
when N_Derived_Type_Definition =>
|
||||
Derived_Type_Declaration (T, N, T /= Def_Id);
|
||||
|
||||
when N_Enumeration_Type_Definition =>
|
||||
Enumeration_Type_Declaration (T, Def);
|
||||
|
||||
when N_Floating_Point_Definition =>
|
||||
Floating_Point_Type_Declaration (T, Def);
|
||||
|
||||
when N_Decimal_Fixed_Point_Definition =>
|
||||
Decimal_Fixed_Point_Type_Declaration (T, Def);
|
||||
|
||||
when N_Ordinary_Fixed_Point_Definition =>
|
||||
Ordinary_Fixed_Point_Type_Declaration (T, Def);
|
||||
|
||||
when N_Signed_Integer_Type_Definition =>
|
||||
Signed_Integer_Type_Declaration (T, Def);
|
||||
|
||||
when N_Modular_Type_Definition =>
|
||||
Modular_Type_Declaration (T, Def);
|
||||
|
||||
when N_Record_Definition =>
|
||||
Record_Type_Declaration (T, N, Prev);
|
||||
|
||||
-- If declaration has a parse error, nothing to elaborate.
|
||||
|
||||
when N_Error =>
|
||||
null;
|
||||
|
||||
when others =>
|
||||
raise Program_Error;
|
||||
|
||||
end case;
|
||||
end if;
|
||||
|
||||
if Etype (T) = Any_Type then
|
||||
goto Leave;
|
||||
end if;
|
||||
|
||||
-- Some common processing for all types
|
||||
|
||||
Set_Depends_On_Private (T, Has_Private_Component (T));
|
||||
Check_Ops_From_Incomplete_Type;
|
||||
|
||||
-- Both the declared entity, and its anonymous base type if one
|
||||
-- was created, need freeze nodes allocated.
|
||||
|
||||
declare
|
||||
B : constant Entity_Id := Base_Type (T);
|
||||
|
||||
begin
|
||||
-- In the case where the base type differs from the first subtype, we
|
||||
-- pre-allocate a freeze node, and set the proper link to the first
|
||||
-- subtype. Freeze_Entity will use this preallocated freeze node when
|
||||
-- it freezes the entity.
|
||||
|
||||
-- This does not apply if the base type is a generic type, whose
|
||||
-- declaration is independent of the current derived definition.
|
||||
|
||||
if B /= T and then not Is_Generic_Type (B) then
|
||||
Ensure_Freeze_Node (B);
|
||||
Set_First_Subtype_Link (Freeze_Node (B), T);
|
||||
end if;
|
||||
|
||||
-- A type that is imported through a limited_with clause cannot
|
||||
-- generate any code, and thus need not be frozen. However, an access
|
||||
-- type with an imported designated type needs a finalization list,
|
||||
-- which may be referenced in some other package that has non-limited
|
||||
-- visibility on the designated type. Thus we must create the
|
||||
-- finalization list at the point the access type is frozen, to
|
||||
-- prevent unsatisfied references at link time.
|
||||
|
||||
if not From_With_Type (T) or else Is_Access_Type (T) then
|
||||
Set_Has_Delayed_Freeze (T);
|
||||
end if;
|
||||
end;
|
||||
|
||||
-- Case where T is the full declaration of some private type which has
|
||||
-- been swapped in Defining_Identifier (N).
|
||||
|
||||
if T /= Def_Id and then Is_Private_Type (Def_Id) then
|
||||
Process_Full_View (N, T, Def_Id);
|
||||
|
||||
-- Record the reference. The form of this is a little strange, since
|
||||
-- the full declaration has been swapped in. So the first parameter
|
||||
-- here represents the entity to which a reference is made which is
|
||||
-- the "real" entity, i.e. the one swapped in, and the second
|
||||
-- parameter provides the reference location.
|
||||
|
||||
-- Also, we want to kill Has_Pragma_Unreferenced temporarily here
|
||||
-- since we don't want a complaint about the full type being an
|
||||
-- unwanted reference to the private type
|
||||
|
||||
declare
|
||||
B : constant Boolean := Has_Pragma_Unreferenced (T);
|
||||
begin
|
||||
Set_Has_Pragma_Unreferenced (T, False);
|
||||
Generate_Reference (T, T, 'c');
|
||||
Set_Has_Pragma_Unreferenced (T, B);
|
||||
end;
|
||||
|
||||
Set_Completion_Referenced (Def_Id);
|
||||
|
||||
-- For completion of incomplete type, process incomplete dependents
|
||||
-- and always mark the full type as referenced (it is the incomplete
|
||||
-- type that we get for any real reference).
|
||||
|
||||
elsif Ekind (Prev) = E_Incomplete_Type then
|
||||
Process_Incomplete_Dependents (N, T, Prev);
|
||||
Generate_Reference (Prev, Def_Id, 'c');
|
||||
Set_Completion_Referenced (Def_Id);
|
||||
|
||||
-- If not private type or incomplete type completion, this is a real
|
||||
-- definition of a new entity, so record it.
|
||||
|
||||
else
|
||||
Generate_Definition (Def_Id);
|
||||
end if;
|
||||
|
||||
if Chars (Scope (Def_Id)) = Name_System
|
||||
and then Chars (Def_Id) = Name_Address
|
||||
and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N)))
|
||||
then
|
||||
Set_Is_Descendent_Of_Address (Def_Id);
|
||||
Set_Is_Descendent_Of_Address (Base_Type (Def_Id));
|
||||
Set_Is_Descendent_Of_Address (Prev);
|
||||
end if;
|
||||
|
||||
Set_Optimize_Alignment_Flags (Def_Id);
|
||||
Check_Eliminated (Def_Id);
|
||||
|
||||
<<Leave>> Analyze_Aspect_Specifications (N, Def_Id, AS);
|
||||
end Analyze_Full_Type_Declaration;
|
||||
|
||||
----------------------------------
|
||||
-- Analyze_Incomplete_Type_Decl --
|
||||
----------------------------------
|
||||
|
@ -2329,6 +2644,7 @@ package body Sem_Ch3 is
|
|||
procedure Analyze_Object_Declaration (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Id : constant Entity_Id := Defining_Identifier (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
T : Entity_Id;
|
||||
Act_T : Entity_Id;
|
||||
|
||||
|
@ -2466,7 +2782,7 @@ package body Sem_Ch3 is
|
|||
T := Find_Type_Of_Object (Object_Definition (N), N);
|
||||
Set_Etype (Id, T);
|
||||
Set_Ekind (Id, E_Variable);
|
||||
return;
|
||||
goto Leave;
|
||||
end if;
|
||||
|
||||
-- In the normal case, enter identifier at the start to catch premature
|
||||
|
@ -2492,7 +2808,7 @@ package body Sem_Ch3 is
|
|||
if Error_Posted (Id) then
|
||||
Set_Etype (Id, T);
|
||||
Set_Ekind (Id, E_Variable);
|
||||
return;
|
||||
goto Leave;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
|
@ -3213,6 +3529,8 @@ package body Sem_Ch3 is
|
|||
then
|
||||
Check_Restriction (No_Local_Timing_Events, N);
|
||||
end if;
|
||||
|
||||
<<Leave>> Analyze_Aspect_Specifications (N, Id, AS);
|
||||
end Analyze_Object_Declaration;
|
||||
|
||||
---------------------------
|
||||
|
@ -3235,6 +3553,7 @@ package body Sem_Ch3 is
|
|||
procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
|
||||
T : constant Entity_Id := Defining_Identifier (N);
|
||||
Indic : constant Node_Id := Subtype_Indication (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
Parent_Type : Entity_Id;
|
||||
Parent_Base : Entity_Id;
|
||||
|
||||
|
@ -3268,16 +3587,16 @@ package body Sem_Ch3 is
|
|||
then
|
||||
Set_Ekind (T, Ekind (Parent_Type));
|
||||
Set_Etype (T, Any_Type);
|
||||
return;
|
||||
goto Leave;
|
||||
|
||||
elsif not Is_Tagged_Type (Parent_Type) then
|
||||
Error_Msg_N
|
||||
("parent of type extension must be a tagged type ", Indic);
|
||||
return;
|
||||
goto Leave;
|
||||
|
||||
elsif Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then
|
||||
Error_Msg_N ("premature derivation of incomplete type", Indic);
|
||||
return;
|
||||
goto Leave;
|
||||
|
||||
elsif Is_Concurrent_Type (Parent_Type) then
|
||||
Error_Msg_N
|
||||
|
@ -3288,7 +3607,7 @@ package body Sem_Ch3 is
|
|||
Set_Ekind (T, E_Limited_Private_Type);
|
||||
Set_Private_Dependents (T, New_Elmt_List);
|
||||
Set_Error_Posted (T);
|
||||
return;
|
||||
goto Leave;
|
||||
end if;
|
||||
|
||||
-- Perhaps the parent type should be changed to the class-wide type's
|
||||
|
@ -3297,7 +3616,7 @@ package body Sem_Ch3 is
|
|||
if Is_Class_Wide_Type (Parent_Type) then
|
||||
Error_Msg_N
|
||||
("parent of type extension must not be a class-wide type", Indic);
|
||||
return;
|
||||
goto Leave;
|
||||
end if;
|
||||
|
||||
if (not Is_Package_Or_Generic_Package (Current_Scope)
|
||||
|
@ -3420,6 +3739,8 @@ package body Sem_Ch3 is
|
|||
N, Parent_Type);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
<<Leave>> Analyze_Aspect_Specifications (N, T, AS);
|
||||
end Analyze_Private_Extension_Declaration;
|
||||
|
||||
---------------------------------
|
||||
|
@ -3431,6 +3752,7 @@ package body Sem_Ch3 is
|
|||
Skip : Boolean := False)
|
||||
is
|
||||
Id : constant Entity_Id := Defining_Identifier (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
T : Entity_Id;
|
||||
R_Checks : Check_Result;
|
||||
|
||||
|
@ -3718,7 +4040,7 @@ package body Sem_Ch3 is
|
|||
end if;
|
||||
|
||||
if Etype (Id) = Any_Type then
|
||||
return;
|
||||
goto Leave;
|
||||
end if;
|
||||
|
||||
-- Some common processing on all types
|
||||
|
@ -3832,6 +4154,8 @@ package body Sem_Ch3 is
|
|||
|
||||
Set_Optimize_Alignment_Flags (Id);
|
||||
Check_Eliminated (Id);
|
||||
|
||||
<<Leave>> Analyze_Aspect_Specifications (N, Id, AS);
|
||||
end Analyze_Subtype_Declaration;
|
||||
|
||||
--------------------------------
|
||||
|
@ -3855,314 +4179,6 @@ package body Sem_Ch3 is
|
|||
end if;
|
||||
end Analyze_Subtype_Indication;
|
||||
|
||||
------------------------------
|
||||
-- Analyze_Type_Declaration --
|
||||
------------------------------
|
||||
|
||||
procedure Analyze_Type_Declaration (N : Node_Id) is
|
||||
Def : constant Node_Id := Type_Definition (N);
|
||||
Def_Id : constant Entity_Id := Defining_Identifier (N);
|
||||
T : Entity_Id;
|
||||
Prev : Entity_Id;
|
||||
|
||||
Is_Remote : constant Boolean :=
|
||||
(Is_Remote_Types (Current_Scope)
|
||||
or else Is_Remote_Call_Interface (Current_Scope))
|
||||
and then not (In_Private_Part (Current_Scope)
|
||||
or else In_Package_Body (Current_Scope));
|
||||
|
||||
procedure Check_Ops_From_Incomplete_Type;
|
||||
-- If there is a tagged incomplete partial view of the type, transfer
|
||||
-- its operations to the full view, and indicate that the type of the
|
||||
-- controlling parameter (s) is this full view.
|
||||
|
||||
------------------------------------
|
||||
-- Check_Ops_From_Incomplete_Type --
|
||||
------------------------------------
|
||||
|
||||
procedure Check_Ops_From_Incomplete_Type is
|
||||
Elmt : Elmt_Id;
|
||||
Formal : Entity_Id;
|
||||
Op : Entity_Id;
|
||||
|
||||
begin
|
||||
if Prev /= T
|
||||
and then Ekind (Prev) = E_Incomplete_Type
|
||||
and then Is_Tagged_Type (Prev)
|
||||
and then Is_Tagged_Type (T)
|
||||
then
|
||||
Elmt := First_Elmt (Primitive_Operations (Prev));
|
||||
while Present (Elmt) loop
|
||||
Op := Node (Elmt);
|
||||
Prepend_Elmt (Op, Primitive_Operations (T));
|
||||
|
||||
Formal := First_Formal (Op);
|
||||
while Present (Formal) loop
|
||||
if Etype (Formal) = Prev then
|
||||
Set_Etype (Formal, T);
|
||||
end if;
|
||||
|
||||
Next_Formal (Formal);
|
||||
end loop;
|
||||
|
||||
if Etype (Op) = Prev then
|
||||
Set_Etype (Op, T);
|
||||
end if;
|
||||
|
||||
Next_Elmt (Elmt);
|
||||
end loop;
|
||||
end if;
|
||||
end Check_Ops_From_Incomplete_Type;
|
||||
|
||||
-- Start of processing for Analyze_Type_Declaration
|
||||
|
||||
begin
|
||||
Prev := Find_Type_Name (N);
|
||||
|
||||
-- The full view, if present, now points to the current type
|
||||
|
||||
-- Ada 2005 (AI-50217): If the type was previously decorated when
|
||||
-- imported through a LIMITED WITH clause, it appears as incomplete
|
||||
-- but has no full view.
|
||||
-- If the incomplete view is tagged, a class_wide type has been
|
||||
-- created already. Use it for the full view as well, to prevent
|
||||
-- multiple incompatible class-wide types that may be created for
|
||||
-- self-referential anonymous access components.
|
||||
|
||||
if Ekind (Prev) = E_Incomplete_Type
|
||||
and then Present (Full_View (Prev))
|
||||
then
|
||||
T := Full_View (Prev);
|
||||
|
||||
if Is_Tagged_Type (Prev)
|
||||
and then Present (Class_Wide_Type (Prev))
|
||||
then
|
||||
Set_Ekind (T, Ekind (Prev)); -- will be reset later
|
||||
Set_Class_Wide_Type (T, Class_Wide_Type (Prev));
|
||||
Set_Etype (Class_Wide_Type (T), T);
|
||||
end if;
|
||||
|
||||
else
|
||||
T := Prev;
|
||||
end if;
|
||||
|
||||
Set_Is_Pure (T, Is_Pure (Current_Scope));
|
||||
|
||||
-- We set the flag Is_First_Subtype here. It is needed to set the
|
||||
-- corresponding flag for the Implicit class-wide-type created
|
||||
-- during tagged types processing.
|
||||
|
||||
Set_Is_First_Subtype (T, True);
|
||||
|
||||
-- Only composite types other than array types are allowed to have
|
||||
-- discriminants.
|
||||
|
||||
case Nkind (Def) is
|
||||
|
||||
-- For derived types, the rule will be checked once we've figured
|
||||
-- out the parent type.
|
||||
|
||||
when N_Derived_Type_Definition =>
|
||||
null;
|
||||
|
||||
-- For record types, discriminants are allowed
|
||||
|
||||
when N_Record_Definition =>
|
||||
null;
|
||||
|
||||
when others =>
|
||||
if Present (Discriminant_Specifications (N)) then
|
||||
Error_Msg_N
|
||||
("elementary or array type cannot have discriminants",
|
||||
Defining_Identifier
|
||||
(First (Discriminant_Specifications (N))));
|
||||
end if;
|
||||
end case;
|
||||
|
||||
-- Elaborate the type definition according to kind, and generate
|
||||
-- subsidiary (implicit) subtypes where needed. We skip this if it was
|
||||
-- already done (this happens during the reanalysis that follows a call
|
||||
-- to the high level optimizer).
|
||||
|
||||
if not Analyzed (T) then
|
||||
Set_Analyzed (T);
|
||||
|
||||
case Nkind (Def) is
|
||||
|
||||
when N_Access_To_Subprogram_Definition =>
|
||||
Access_Subprogram_Declaration (T, Def);
|
||||
|
||||
-- If this is a remote access to subprogram, we must create the
|
||||
-- equivalent fat pointer type, and related subprograms.
|
||||
|
||||
if Is_Remote then
|
||||
Process_Remote_AST_Declaration (N);
|
||||
end if;
|
||||
|
||||
-- Validate categorization rule against access type declaration
|
||||
-- usually a violation in Pure unit, Shared_Passive unit.
|
||||
|
||||
Validate_Access_Type_Declaration (T, N);
|
||||
|
||||
when N_Access_To_Object_Definition =>
|
||||
Access_Type_Declaration (T, Def);
|
||||
|
||||
-- Validate categorization rule against access type declaration
|
||||
-- usually a violation in Pure unit, Shared_Passive unit.
|
||||
|
||||
Validate_Access_Type_Declaration (T, N);
|
||||
|
||||
-- If we are in a Remote_Call_Interface package and define a
|
||||
-- RACW, then calling stubs and specific stream attributes
|
||||
-- must be added.
|
||||
|
||||
if Is_Remote
|
||||
and then Is_Remote_Access_To_Class_Wide_Type (Def_Id)
|
||||
then
|
||||
Add_RACW_Features (Def_Id);
|
||||
end if;
|
||||
|
||||
-- Set no strict aliasing flag if config pragma seen
|
||||
|
||||
if Opt.No_Strict_Aliasing then
|
||||
Set_No_Strict_Aliasing (Base_Type (Def_Id));
|
||||
end if;
|
||||
|
||||
when N_Array_Type_Definition =>
|
||||
Array_Type_Declaration (T, Def);
|
||||
|
||||
when N_Derived_Type_Definition =>
|
||||
Derived_Type_Declaration (T, N, T /= Def_Id);
|
||||
|
||||
when N_Enumeration_Type_Definition =>
|
||||
Enumeration_Type_Declaration (T, Def);
|
||||
|
||||
when N_Floating_Point_Definition =>
|
||||
Floating_Point_Type_Declaration (T, Def);
|
||||
|
||||
when N_Decimal_Fixed_Point_Definition =>
|
||||
Decimal_Fixed_Point_Type_Declaration (T, Def);
|
||||
|
||||
when N_Ordinary_Fixed_Point_Definition =>
|
||||
Ordinary_Fixed_Point_Type_Declaration (T, Def);
|
||||
|
||||
when N_Signed_Integer_Type_Definition =>
|
||||
Signed_Integer_Type_Declaration (T, Def);
|
||||
|
||||
when N_Modular_Type_Definition =>
|
||||
Modular_Type_Declaration (T, Def);
|
||||
|
||||
when N_Record_Definition =>
|
||||
Record_Type_Declaration (T, N, Prev);
|
||||
|
||||
-- If declaration has a parse error, nothing to elaborate.
|
||||
|
||||
when N_Error =>
|
||||
null;
|
||||
|
||||
when others =>
|
||||
raise Program_Error;
|
||||
|
||||
end case;
|
||||
end if;
|
||||
|
||||
if Etype (T) = Any_Type then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Some common processing for all types
|
||||
|
||||
Set_Depends_On_Private (T, Has_Private_Component (T));
|
||||
Check_Ops_From_Incomplete_Type;
|
||||
|
||||
-- Both the declared entity, and its anonymous base type if one
|
||||
-- was created, need freeze nodes allocated.
|
||||
|
||||
declare
|
||||
B : constant Entity_Id := Base_Type (T);
|
||||
|
||||
begin
|
||||
-- In the case where the base type differs from the first subtype, we
|
||||
-- pre-allocate a freeze node, and set the proper link to the first
|
||||
-- subtype. Freeze_Entity will use this preallocated freeze node when
|
||||
-- it freezes the entity.
|
||||
|
||||
-- This does not apply if the base type is a generic type, whose
|
||||
-- declaration is independent of the current derived definition.
|
||||
|
||||
if B /= T and then not Is_Generic_Type (B) then
|
||||
Ensure_Freeze_Node (B);
|
||||
Set_First_Subtype_Link (Freeze_Node (B), T);
|
||||
end if;
|
||||
|
||||
-- A type that is imported through a limited_with clause cannot
|
||||
-- generate any code, and thus need not be frozen. However, an access
|
||||
-- type with an imported designated type needs a finalization list,
|
||||
-- which may be referenced in some other package that has non-limited
|
||||
-- visibility on the designated type. Thus we must create the
|
||||
-- finalization list at the point the access type is frozen, to
|
||||
-- prevent unsatisfied references at link time.
|
||||
|
||||
if not From_With_Type (T) or else Is_Access_Type (T) then
|
||||
Set_Has_Delayed_Freeze (T);
|
||||
end if;
|
||||
end;
|
||||
|
||||
-- Case where T is the full declaration of some private type which has
|
||||
-- been swapped in Defining_Identifier (N).
|
||||
|
||||
if T /= Def_Id and then Is_Private_Type (Def_Id) then
|
||||
Process_Full_View (N, T, Def_Id);
|
||||
|
||||
-- Record the reference. The form of this is a little strange, since
|
||||
-- the full declaration has been swapped in. So the first parameter
|
||||
-- here represents the entity to which a reference is made which is
|
||||
-- the "real" entity, i.e. the one swapped in, and the second
|
||||
-- parameter provides the reference location.
|
||||
|
||||
-- Also, we want to kill Has_Pragma_Unreferenced temporarily here
|
||||
-- since we don't want a complaint about the full type being an
|
||||
-- unwanted reference to the private type
|
||||
|
||||
declare
|
||||
B : constant Boolean := Has_Pragma_Unreferenced (T);
|
||||
begin
|
||||
Set_Has_Pragma_Unreferenced (T, False);
|
||||
Generate_Reference (T, T, 'c');
|
||||
Set_Has_Pragma_Unreferenced (T, B);
|
||||
end;
|
||||
|
||||
Set_Completion_Referenced (Def_Id);
|
||||
|
||||
-- For completion of incomplete type, process incomplete dependents
|
||||
-- and always mark the full type as referenced (it is the incomplete
|
||||
-- type that we get for any real reference).
|
||||
|
||||
elsif Ekind (Prev) = E_Incomplete_Type then
|
||||
Process_Incomplete_Dependents (N, T, Prev);
|
||||
Generate_Reference (Prev, Def_Id, 'c');
|
||||
Set_Completion_Referenced (Def_Id);
|
||||
|
||||
-- If not private type or incomplete type completion, this is a real
|
||||
-- definition of a new entity, so record it.
|
||||
|
||||
else
|
||||
Generate_Definition (Def_Id);
|
||||
end if;
|
||||
|
||||
if Chars (Scope (Def_Id)) = Name_System
|
||||
and then Chars (Def_Id) = Name_Address
|
||||
and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N)))
|
||||
then
|
||||
Set_Is_Descendent_Of_Address (Def_Id);
|
||||
Set_Is_Descendent_Of_Address (Base_Type (Def_Id));
|
||||
Set_Is_Descendent_Of_Address (Prev);
|
||||
end if;
|
||||
|
||||
Set_Optimize_Alignment_Flags (Def_Id);
|
||||
Check_Eliminated (Def_Id);
|
||||
end Analyze_Type_Declaration;
|
||||
|
||||
--------------------------
|
||||
-- Analyze_Variant_Part --
|
||||
--------------------------
|
||||
|
|
|
@ -28,6 +28,7 @@ with Types; use Types;
|
|||
|
||||
package Sem_Ch3 is
|
||||
procedure Analyze_Component_Declaration (N : Node_Id);
|
||||
procedure Analyze_Full_Type_Declaration (N : Node_Id);
|
||||
procedure Analyze_Incomplete_Type_Decl (N : Node_Id);
|
||||
procedure Analyze_Itype_Reference (N : Node_Id);
|
||||
procedure Analyze_Number_Declaration (N : Node_Id);
|
||||
|
@ -35,7 +36,6 @@ package Sem_Ch3 is
|
|||
procedure Analyze_Others_Choice (N : Node_Id);
|
||||
procedure Analyze_Private_Extension_Declaration (N : Node_Id);
|
||||
procedure Analyze_Subtype_Indication (N : Node_Id);
|
||||
procedure Analyze_Type_Declaration (N : Node_Id);
|
||||
procedure Analyze_Variant_Part (N : Node_Id);
|
||||
|
||||
procedure Analyze_Subtype_Declaration
|
||||
|
|
|
@ -23,6 +23,7 @@
|
|||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Aspects; use Aspects;
|
||||
with Atree; use Atree;
|
||||
with Checks; use Checks;
|
||||
with Debug; use Debug;
|
||||
|
@ -59,6 +60,7 @@ with Sem_Ch5; use Sem_Ch5;
|
|||
with Sem_Ch8; use Sem_Ch8;
|
||||
with Sem_Ch10; use Sem_Ch10;
|
||||
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;
|
||||
|
@ -352,6 +354,7 @@ package body Sem_Ch6 is
|
|||
Designator : constant Entity_Id :=
|
||||
Analyze_Subprogram_Specification (Specification (N));
|
||||
Scop : constant Entity_Id := Current_Scope;
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
|
||||
begin
|
||||
Generate_Definition (Designator);
|
||||
|
@ -381,6 +384,7 @@ package body Sem_Ch6 is
|
|||
|
||||
Generate_Reference_To_Formals (Designator);
|
||||
Check_Eliminated (Designator);
|
||||
Analyze_Aspect_Specifications (N, Designator, AS);
|
||||
end Analyze_Abstract_Subprogram_Declaration;
|
||||
|
||||
----------------------------------------
|
||||
|
@ -2696,9 +2700,10 @@ package body Sem_Ch6 is
|
|||
|
||||
procedure Analyze_Subprogram_Declaration (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
Scop : constant Entity_Id := Current_Scope;
|
||||
Designator : Entity_Id;
|
||||
Form : Node_Id;
|
||||
Scop : constant Entity_Id := Current_Scope;
|
||||
Null_Body : Node_Id := Empty;
|
||||
|
||||
-- Start of processing for Analyze_Subprogram_Declaration
|
||||
|
@ -2891,6 +2896,8 @@ package body Sem_Ch6 is
|
|||
Write_Location (Sloc (N));
|
||||
Write_Eol;
|
||||
end if;
|
||||
|
||||
Analyze_Aspect_Specifications (N, Designator, AS);
|
||||
end Analyze_Subprogram_Declaration;
|
||||
|
||||
--------------------------------------
|
||||
|
@ -8334,20 +8341,19 @@ package body Sem_Ch6 is
|
|||
if Is_Tagged_Type (Formal_Type) then
|
||||
null;
|
||||
|
||||
elsif Nkind_In (Parent (Parent (T)),
|
||||
N_Accept_Statement,
|
||||
N_Entry_Body,
|
||||
N_Subprogram_Body)
|
||||
elsif Nkind_In (Parent (Parent (T)), N_Accept_Statement,
|
||||
N_Entry_Body,
|
||||
N_Subprogram_Body)
|
||||
then
|
||||
Error_Msg_NE
|
||||
("invalid use of untagged incomplete type&",
|
||||
Ptype, Formal_Type);
|
||||
Ptype, Formal_Type);
|
||||
end if;
|
||||
|
||||
else
|
||||
Error_Msg_NE
|
||||
("invalid use of incomplete type&",
|
||||
Param_Spec, Formal_Type);
|
||||
Param_Spec, Formal_Type);
|
||||
|
||||
-- Further checks on the legality of incomplete types
|
||||
-- in formal parts are delayed until the freeze point
|
||||
|
@ -8356,8 +8362,9 @@ package body Sem_Ch6 is
|
|||
end if;
|
||||
|
||||
elsif Ekind (Formal_Type) = E_Void then
|
||||
Error_Msg_NE ("premature use of&",
|
||||
Parameter_Type (Param_Spec), Formal_Type);
|
||||
Error_Msg_NE
|
||||
("premature use of&",
|
||||
Parameter_Type (Param_Spec), Formal_Type);
|
||||
end if;
|
||||
|
||||
-- Ada 2005 (AI-231): Create and decorate an internal subtype
|
||||
|
@ -8378,8 +8385,7 @@ package body Sem_Ch6 is
|
|||
then
|
||||
Error_Msg_NE
|
||||
("`NOT NULL` not allowed (& already excludes null)",
|
||||
Param_Spec,
|
||||
Formal_Type);
|
||||
Param_Spec, Formal_Type);
|
||||
end if;
|
||||
|
||||
Formal_Type :=
|
||||
|
|
|
@ -28,6 +28,7 @@
|
|||
-- handling of private and full declarations, and the construction of dispatch
|
||||
-- tables for tagged types.
|
||||
|
||||
with Aspects; use Aspects;
|
||||
with Atree; use Atree;
|
||||
with Debug; use Debug;
|
||||
with Einfo; use Einfo;
|
||||
|
@ -51,6 +52,7 @@ with Sem_Ch6; use Sem_Ch6;
|
|||
with Sem_Ch8; use Sem_Ch8;
|
||||
with Sem_Ch10; use Sem_Ch10;
|
||||
with Sem_Ch12; use Sem_Ch12;
|
||||
with Sem_Ch13; use Sem_Ch13;
|
||||
with Sem_Disp; use Sem_Disp;
|
||||
with Sem_Eval; use Sem_Eval;
|
||||
with Sem_Prag; use Sem_Prag;
|
||||
|
@ -749,6 +751,7 @@ package body Sem_Ch7 is
|
|||
|
||||
procedure Analyze_Package_Declaration (N : Node_Id) is
|
||||
Id : constant Node_Id := Defining_Entity (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
|
||||
PF : Boolean;
|
||||
-- True when in the context of a declared pure library unit
|
||||
|
@ -768,7 +771,7 @@ package body Sem_Ch7 is
|
|||
-- package Pkg is ...
|
||||
|
||||
if From_With_Type (Id) then
|
||||
return;
|
||||
goto Leave;
|
||||
end if;
|
||||
|
||||
if Debug_Flag_C then
|
||||
|
@ -842,6 +845,8 @@ package body Sem_Ch7 is
|
|||
Write_Location (Sloc (N));
|
||||
Write_Eol;
|
||||
end if;
|
||||
|
||||
<<Leave>> Analyze_Aspect_Specifications (N, Id, AS);
|
||||
end Analyze_Package_Declaration;
|
||||
|
||||
-----------------------------------
|
||||
|
@ -1412,6 +1417,7 @@ package body Sem_Ch7 is
|
|||
procedure Analyze_Private_Type_Declaration (N : Node_Id) is
|
||||
PF : constant Boolean := Is_Pure (Enclosing_Lib_Unit_Entity);
|
||||
Id : constant Entity_Id := Defining_Identifier (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
|
||||
begin
|
||||
Generate_Definition (Id);
|
||||
|
@ -1426,6 +1432,7 @@ package body Sem_Ch7 is
|
|||
|
||||
New_Private_Type (N, Id, N);
|
||||
Set_Depends_On_Private (Id);
|
||||
Analyze_Aspect_Specifications (N, Id, AS);
|
||||
end Analyze_Private_Type_Declaration;
|
||||
|
||||
----------------------------------
|
||||
|
|
|
@ -23,6 +23,7 @@
|
|||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Aspects; use Aspects;
|
||||
with Atree; use Atree;
|
||||
with Checks; use Checks;
|
||||
with Einfo; use Einfo;
|
||||
|
@ -44,6 +45,7 @@ with Sem_Ch3; use Sem_Ch3;
|
|||
with Sem_Ch5; use Sem_Ch5;
|
||||
with Sem_Ch6; use Sem_Ch6;
|
||||
with Sem_Ch8; use Sem_Ch8;
|
||||
with Sem_Ch13; use Sem_Ch13;
|
||||
with Sem_Eval; use Sem_Eval;
|
||||
with Sem_Res; use Sem_Res;
|
||||
with Sem_Type; use Sem_Type;
|
||||
|
@ -873,6 +875,7 @@ package body Sem_Ch9 is
|
|||
D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N);
|
||||
Def_Id : constant Entity_Id := Defining_Identifier (N);
|
||||
Formals : constant List_Id := Parameter_Specifications (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
|
||||
begin
|
||||
Generate_Definition (Def_Id);
|
||||
|
@ -904,6 +907,7 @@ package body Sem_Ch9 is
|
|||
end if;
|
||||
|
||||
Generate_Reference_To_Formals (Def_Id);
|
||||
Analyze_Aspect_Specifications (N, Def_Id, AS);
|
||||
end Analyze_Entry_Declaration;
|
||||
|
||||
---------------------------------------
|
||||
|
@ -1122,19 +1126,20 @@ package body Sem_Ch9 is
|
|||
Process_End_Label (N, 'e', Current_Scope);
|
||||
end Analyze_Protected_Definition;
|
||||
|
||||
----------------------------
|
||||
-- Analyze_Protected_Type --
|
||||
----------------------------
|
||||
----------------------------------------
|
||||
-- Analyze_Protected_Type_Declaration --
|
||||
----------------------------------------
|
||||
|
||||
procedure Analyze_Protected_Type (N : Node_Id) is
|
||||
procedure Analyze_Protected_Type_Declaration (N : Node_Id) is
|
||||
Def_Id : constant Entity_Id := Defining_Identifier (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
E : Entity_Id;
|
||||
T : Entity_Id;
|
||||
|
||||
begin
|
||||
if No_Run_Time_Mode then
|
||||
Error_Msg_CRT ("protected type", N);
|
||||
return;
|
||||
goto Leave;
|
||||
end if;
|
||||
|
||||
Tasking_Used := True;
|
||||
|
@ -1254,7 +1259,9 @@ package body Sem_Ch9 is
|
|||
Process_Full_View (N, T, Def_Id);
|
||||
end if;
|
||||
end if;
|
||||
end Analyze_Protected_Type;
|
||||
|
||||
<<Leave>> Analyze_Aspect_Specifications (N, Def_Id, AS);
|
||||
end Analyze_Protected_Type_Declaration;
|
||||
|
||||
---------------------
|
||||
-- Analyze_Requeue --
|
||||
|
@ -1651,13 +1658,14 @@ package body Sem_Ch9 is
|
|||
end if;
|
||||
end Analyze_Selective_Accept;
|
||||
|
||||
------------------------------
|
||||
-- Analyze_Single_Protected --
|
||||
------------------------------
|
||||
------------------------------------------
|
||||
-- Analyze_Single_Protected_Declaration --
|
||||
------------------------------------------
|
||||
|
||||
procedure Analyze_Single_Protected (N : Node_Id) is
|
||||
procedure Analyze_Single_Protected_Declaration (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Id : constant Node_Id := Defining_Identifier (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
T : Entity_Id;
|
||||
T_Decl : Node_Id;
|
||||
O_Decl : Node_Id;
|
||||
|
@ -1704,16 +1712,18 @@ package body Sem_Ch9 is
|
|||
-- procedure directly. Otherwise the node would be expanded twice, with
|
||||
-- disastrous result.
|
||||
|
||||
Analyze_Protected_Type (N);
|
||||
end Analyze_Single_Protected;
|
||||
Analyze_Protected_Type_Declaration (N);
|
||||
Analyze_Aspect_Specifications (N, Id, AS);
|
||||
end Analyze_Single_Protected_Declaration;
|
||||
|
||||
-------------------------
|
||||
-- Analyze_Single_Task --
|
||||
-------------------------
|
||||
-------------------------------------
|
||||
-- Analyze_Single_Task_Declaration --
|
||||
-------------------------------------
|
||||
|
||||
procedure Analyze_Single_Task (N : Node_Id) is
|
||||
procedure Analyze_Single_Task_Declaration (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Id : constant Node_Id := Defining_Identifier (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
T : Entity_Id;
|
||||
T_Decl : Node_Id;
|
||||
O_Decl : Node_Id;
|
||||
|
@ -1768,8 +1778,9 @@ package body Sem_Ch9 is
|
|||
-- procedure directly. Otherwise the node would be expanded twice, with
|
||||
-- disastrous result.
|
||||
|
||||
Analyze_Task_Type (N);
|
||||
end Analyze_Single_Task;
|
||||
Analyze_Task_Type_Declaration (N);
|
||||
Analyze_Aspect_Specifications (N, Id, AS);
|
||||
end Analyze_Single_Task_Declaration;
|
||||
|
||||
-----------------------
|
||||
-- Analyze_Task_Body --
|
||||
|
@ -1935,12 +1946,13 @@ package body Sem_Ch9 is
|
|||
Process_End_Label (N, 'e', Current_Scope);
|
||||
end Analyze_Task_Definition;
|
||||
|
||||
-----------------------
|
||||
-- Analyze_Task_Type --
|
||||
-----------------------
|
||||
-----------------------------------
|
||||
-- Analyze_Task_Type_Declaration --
|
||||
-----------------------------------
|
||||
|
||||
procedure Analyze_Task_Type (N : Node_Id) is
|
||||
procedure Analyze_Task_Type_Declaration (N : Node_Id) is
|
||||
Def_Id : constant Entity_Id := Defining_Identifier (N);
|
||||
AS : constant List_Id := Aspect_Specifications (N);
|
||||
T : Entity_Id;
|
||||
|
||||
begin
|
||||
|
@ -2038,7 +2050,9 @@ package body Sem_Ch9 is
|
|||
Process_Full_View (N, T, Def_Id);
|
||||
end if;
|
||||
end if;
|
||||
end Analyze_Task_Type;
|
||||
|
||||
Analyze_Aspect_Specifications (N, Def_Id, AS);
|
||||
end Analyze_Task_Type_Declaration;
|
||||
|
||||
-----------------------------------
|
||||
-- Analyze_Terminate_Alternative --
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2007, 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 --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
|
@ -41,14 +41,14 @@ package Sem_Ch9 is
|
|||
procedure Analyze_Entry_Index_Specification (N : Node_Id);
|
||||
procedure Analyze_Protected_Body (N : Node_Id);
|
||||
procedure Analyze_Protected_Definition (N : Node_Id);
|
||||
procedure Analyze_Protected_Type (N : Node_Id);
|
||||
procedure Analyze_Protected_Type_Declaration (N : Node_Id);
|
||||
procedure Analyze_Requeue (N : Node_Id);
|
||||
procedure Analyze_Selective_Accept (N : Node_Id);
|
||||
procedure Analyze_Single_Protected (N : Node_Id);
|
||||
procedure Analyze_Single_Task (N : Node_Id);
|
||||
procedure Analyze_Single_Protected_Declaration (N : Node_Id);
|
||||
procedure Analyze_Single_Task_Declaration (N : Node_Id);
|
||||
procedure Analyze_Task_Body (N : Node_Id);
|
||||
procedure Analyze_Task_Definition (N : Node_Id);
|
||||
procedure Analyze_Task_Type (N : Node_Id);
|
||||
procedure Analyze_Task_Type_Declaration (N : Node_Id);
|
||||
procedure Analyze_Terminate_Alternative (N : Node_Id);
|
||||
procedure Analyze_Timed_Entry_Call (N : Node_Id);
|
||||
procedure Analyze_Triggering_Alternative (N : Node_Id);
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -3674,18 +3674,28 @@ package body Sem_Res is
|
|||
Apply_Range_Check (A, F_Typ);
|
||||
end if;
|
||||
|
||||
-- Ada 2005 (AI-231)
|
||||
-- Ada 2005 (AI-231): Note that the controlling parameter case
|
||||
-- already existed in Ada 95, which is partially checked
|
||||
-- elsewhere (see Checks), and we don't want the warning
|
||||
-- message to differ.
|
||||
|
||||
if Ada_Version >= Ada_2005
|
||||
and then Is_Access_Type (F_Typ)
|
||||
if Is_Access_Type (F_Typ)
|
||||
and then Can_Never_Be_Null (F_Typ)
|
||||
and then Known_Null (A)
|
||||
then
|
||||
Apply_Compile_Time_Constraint_Error
|
||||
(N => A,
|
||||
Msg => "(Ada 2005) null not allowed in "
|
||||
& "null-excluding formal?",
|
||||
Reason => CE_Null_Not_Allowed);
|
||||
if Is_Controlling_Formal (F) then
|
||||
Apply_Compile_Time_Constraint_Error
|
||||
(N => A,
|
||||
Msg => "null value not allowed here?",
|
||||
Reason => CE_Access_Check_Failed);
|
||||
|
||||
elsif Ada_Version >= Ada_2005 then
|
||||
Apply_Compile_Time_Constraint_Error
|
||||
(N => A,
|
||||
Msg => "(Ada 2005) null not allowed in "
|
||||
& "null-excluding formal?",
|
||||
Reason => CE_Null_Not_Allowed);
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
|
|
|
@ -32,10 +32,8 @@
|
|||
pragma Style_Checks (All_Checks);
|
||||
-- No subprogram ordering check, due to logical grouping
|
||||
|
||||
with Atree; use Atree;
|
||||
with Nlists; use Nlists;
|
||||
|
||||
with GNAT.HTable;
|
||||
with Aspects; use Aspects;
|
||||
with Atree; use Atree;
|
||||
|
||||
package body Sinfo is
|
||||
|
||||
|
@ -56,30 +54,6 @@ package body Sinfo is
|
|||
NT : Nodes.Table_Ptr renames Nodes.Table;
|
||||
-- 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
|
||||
GNAT.HTable.Simple_HTable
|
||||
(Header_Num => Hash_Range,
|
||||
Element => List_Id,
|
||||
No_Element => No_List,
|
||||
Key => Node_Id,
|
||||
Hash => AS_Hash,
|
||||
Equal => "=");
|
||||
|
||||
----------------------------
|
||||
-- Field Access Functions --
|
||||
----------------------------
|
||||
|
@ -282,6 +256,14 @@ package body Sinfo is
|
|||
return Node3 (N);
|
||||
end Array_Aggregate;
|
||||
|
||||
function Aspect_Cancel
|
||||
(N : Node_Id) return Boolean is
|
||||
begin
|
||||
pragma Assert (False
|
||||
or else NT (N).Nkind = N_Pragma);
|
||||
return Flag11 (N);
|
||||
end Aspect_Cancel;
|
||||
|
||||
function Assignment_OK
|
||||
(N : Node_Id) return Boolean is
|
||||
begin
|
||||
|
@ -1251,14 +1233,6 @@ package body Sinfo is
|
|||
return List1 (N);
|
||||
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
|
||||
(N : Node_Id) return Node_Id is
|
||||
begin
|
||||
|
@ -1333,6 +1307,15 @@ package body Sinfo is
|
|||
return Flag5 (N);
|
||||
end Forwards_OK;
|
||||
|
||||
function From_Aspect_Specification
|
||||
(N : Node_Id) return Boolean is
|
||||
begin
|
||||
pragma Assert (False
|
||||
or else NT (N).Nkind = N_Attribute_Definition_Clause
|
||||
or else NT (N).Nkind = N_Pragma);
|
||||
return Flag13 (N);
|
||||
end From_Aspect_Specification;
|
||||
|
||||
function From_At_End
|
||||
(N : Node_Id) return Boolean is
|
||||
begin
|
||||
|
@ -1869,14 +1852,6 @@ package body Sinfo is
|
|||
return Node2 (N);
|
||||
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
|
||||
(N : Node_Id) return Node_Id is
|
||||
begin
|
||||
|
@ -3229,6 +3204,14 @@ package body Sinfo is
|
|||
Set_Node3_With_Parent (N, Val);
|
||||
end Set_Array_Aggregate;
|
||||
|
||||
procedure Set_Aspect_Cancel
|
||||
(N : Node_Id; Val : Boolean := True) is
|
||||
begin
|
||||
pragma Assert (False
|
||||
or else NT (N).Nkind = N_Pragma);
|
||||
Set_Flag11 (N, Val);
|
||||
end Set_Aspect_Cancel;
|
||||
|
||||
procedure Set_Assignment_OK
|
||||
(N : Node_Id; Val : Boolean := True) is
|
||||
begin
|
||||
|
@ -4189,14 +4172,6 @@ package body Sinfo is
|
|||
Set_List1_With_Parent (N, Val);
|
||||
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
|
||||
(N : Node_Id; Val : Node_Id) is
|
||||
begin
|
||||
|
@ -4271,6 +4246,15 @@ package body Sinfo is
|
|||
Set_Flag5 (N, Val);
|
||||
end Set_Forwards_OK;
|
||||
|
||||
procedure Set_From_Aspect_Specification
|
||||
(N : Node_Id; Val : Boolean := True) is
|
||||
begin
|
||||
pragma Assert (False
|
||||
or else NT (N).Nkind = N_Attribute_Definition_Clause
|
||||
or else NT (N).Nkind = N_Pragma);
|
||||
Set_Flag13 (N, Val);
|
||||
end Set_From_Aspect_Specification;
|
||||
|
||||
procedure Set_From_At_End
|
||||
(N : Node_Id; Val : Boolean := True) is
|
||||
begin
|
||||
|
@ -4816,14 +4800,6 @@ package body Sinfo is
|
|||
Set_Node4_With_Parent (N, Val);
|
||||
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
|
||||
(N : Node_Id; Val : Boolean := True) is
|
||||
begin
|
||||
|
@ -6163,65 +6139,4 @@ package body Sinfo is
|
|||
return Chars (Pragma_Identifier (N));
|
||||
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;
|
||||
|
|
|
@ -455,13 +455,13 @@ package Sinfo is
|
|||
|
||||
-- The following flag fields appear in all nodes
|
||||
|
||||
-- Analyzed (Flag1)
|
||||
-- Analyzed
|
||||
-- This flag is used to indicate that a node (and all its children have
|
||||
-- been analyzed. It is used to avoid reanalysis of a node that has
|
||||
-- already been analyzed, both for efficiency and functional correctness
|
||||
-- reasons.
|
||||
|
||||
-- Comes_From_Source (Flag2)
|
||||
-- Comes_From_Source
|
||||
-- This flag is set if the node comes directly from an explicit construct
|
||||
-- in the source. It is normally on for any nodes built by the scanner or
|
||||
-- parser from the source program, with the exception that in a few cases
|
||||
|
@ -475,7 +475,7 @@ package Sinfo is
|
|||
-- from the source program (e.g. the allocator built for build-in-place
|
||||
-- case), and the Comes_From_Source flag is deliberately set.
|
||||
|
||||
-- Error_Posted (Flag3)
|
||||
-- Error_Posted
|
||||
-- This flag is used to avoid multiple error messages being posted on or
|
||||
-- referring to the same node. This flag is set if an error message
|
||||
-- refers to a node or is posted on its source location, and has the
|
||||
|
@ -587,6 +587,14 @@ package Sinfo is
|
|||
-- is used for translation of the at end handler into a normal exception
|
||||
-- handler.
|
||||
|
||||
-- Aspect_Cancel (Flag11-Sem)
|
||||
-- Processing of aspect specifications typically generates pragmas and
|
||||
-- attribute definition clauses that are inserted into the tree after
|
||||
-- the declaration node to get the desired aspect effect. In the case
|
||||
-- of Boolean aspects that use "=> False" to cancel the effect of an
|
||||
-- aspect (i.e. turn if off), the generated pragma has the Aspect_Cancel
|
||||
-- flag set to indicate that the pragma operates in the opposite sense.
|
||||
|
||||
-- Assignment_OK (Flag15-Sem)
|
||||
-- This flag is set in a subexpression node for an object, indicating
|
||||
-- that the associated object can be modified, even if this would not
|
||||
|
@ -1056,6 +1064,12 @@ package Sinfo is
|
|||
-- cannot figure it out. If both flags Forwards_OK and Backwards_OK are
|
||||
-- set, it means that the front end can assure no overlap of operands.
|
||||
|
||||
-- From_Aspect_Specification (Flag13-Sem)
|
||||
-- Processing of aspect specifications typically results in insertion in
|
||||
-- the tree of corresponding pragma or attribute definition clause nodes.
|
||||
-- These generated nodes have the From_Aspect_Specification flag set to
|
||||
-- indicate that they came from aspect specifications originally.
|
||||
|
||||
-- From_At_End (Flag4-Sem)
|
||||
-- This flag is set on an N_Raise_Statement node if it corresponds to
|
||||
-- the reraise statement generated as the last statement of an AT END
|
||||
|
@ -1996,11 +2010,13 @@ package Sinfo is
|
|||
-- Sloc points to PRAGMA
|
||||
-- Next_Pragma (Node1-Sem)
|
||||
-- Pragma_Argument_Associations (List2) (set to No_List if none)
|
||||
-- Debug_Statement (Node3) (set to Empty if not Debug, Assert)
|
||||
-- Debug_Statement (Node3) (set to Empty if not Debug)
|
||||
-- Pragma_Identifier (Node4)
|
||||
-- Next_Rep_Item (Node5-Sem)
|
||||
-- Pragma_Enabled (Flag5-Sem)
|
||||
-- From_Aspect_Specification (Flag13-Sem)
|
||||
-- Import_Interface_Present (Flag16-Sem)
|
||||
-- Aspect_Cancel (Flag11-Sem)
|
||||
|
||||
-- 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
|
||||
|
@ -2010,7 +2026,12 @@ package Sinfo is
|
|||
-- Note: a utility function Pragma_Name may be applied to pragma nodes
|
||||
-- to conveniently obtain the Chars field of the Pragma_Identifier.
|
||||
|
||||
--------------------------------------
|
||||
-- Note: if From_Aspect_Specification is set, then Sloc points to the
|
||||
-- aspect name, as does the Pragma_Identifier. In this case if the
|
||||
-- pragma has a local name argument (such as pragma Inline), it is
|
||||
-- resolved to point to the specific entity affected by the pragma.
|
||||
|
||||
--------------------------------------
|
||||
-- 2.8 Pragma Argument Association --
|
||||
--------------------------------------
|
||||
|
||||
|
@ -2818,7 +2839,7 @@ package Sinfo is
|
|||
|
||||
-- COMPONENT_DECLARATION ::=
|
||||
-- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
|
||||
-- [:= DEFAULT_EXPRESSION]
|
||||
-- [:= DEFAULT_EXPRESSION];
|
||||
|
||||
-- Note: although the syntax does not permit a component definition to
|
||||
-- be an anonymous array (and the parser will diagnose such an attempt
|
||||
|
@ -6395,30 +6416,48 @@ package Sinfo is
|
|||
-- Next_Rep_Item (Node5-Sem)
|
||||
-- From_At_Mod (Flag4-Sem)
|
||||
-- Check_Address_Alignment (Flag11-Sem)
|
||||
-- From_Aspect_Specification (Flag13-Sem)
|
||||
-- Address_Warning_Posted (Flag18-Sem)
|
||||
|
||||
----------------------------------
|
||||
-- 13.3.1 Aspect Specification --
|
||||
----------------------------------
|
||||
-- Note: if From_Aspect_Specification is set, then Sloc points to the
|
||||
-- aspect name, and Entity is resolved already to reference the entity
|
||||
-- to which the aspect applies.
|
||||
|
||||
-- ASPECT_SPECIFICATION ::=
|
||||
-- with ASPECT_MARK [=> ASPECT_DEFINITION] {.
|
||||
-- ASPECT_MARK [=> ASPECT_DEFINITION] }
|
||||
-----------------------------------
|
||||
-- 13.3.1 Aspect Specifications --
|
||||
-----------------------------------
|
||||
|
||||
-- ASPECT_MARK ::= aspect_IDENTIFIER['Class]
|
||||
-- We modify the RM grammar here, the RM grammar is:
|
||||
|
||||
-- ASPECT_DEFINITION ::= NAME | EXPRESSION
|
||||
-- ASPECT_SPECIFICATION ::=
|
||||
-- with ASPECT_MARK [=> ASPECT_DEFINITION] {.
|
||||
-- ASPECT_MARK [=> ASPECT_DEFINITION] }
|
||||
|
||||
-- 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.
|
||||
-- ASPECT_MARK ::= aspect_IDENTIFIER['Class]
|
||||
|
||||
-- ASPECT_DEFINITION ::= NAME | EXPRESSION
|
||||
|
||||
-- That's inconvenient, since there is no non-terminal name for a single
|
||||
-- entry in the list of aspects. So we use this grammar instead:
|
||||
|
||||
-- ASPECT_SPECIFICATIONS ::=
|
||||
-- with ASPECT_SPECIFICATION {, ASPECT_SPECIFICATION};
|
||||
|
||||
-- ASPECT_SPECIFICATION =>
|
||||
-- ASPECT_MARK [=> ASPECT_DEFINITION]
|
||||
|
||||
-- ASPECT_MARK ::= aspect_IDENTIFIER['Class]
|
||||
|
||||
-- ASPECT_DEFINITION ::= NAME | EXPRESSION
|
||||
|
||||
-- See separate package Aspects for details on the incorporation of
|
||||
-- these nodes into the tree, and how aspect specifications for a given
|
||||
-- declaration node are associated with that 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
|
||||
|
@ -7900,6 +7939,9 @@ package Sinfo is
|
|||
function Array_Aggregate
|
||||
(N : Node_Id) return Node_Id; -- Node3
|
||||
|
||||
function Aspect_Cancel
|
||||
(N : Node_Id) return Boolean; -- Flag11
|
||||
|
||||
function Assignment_OK
|
||||
(N : Node_Id) return Boolean; -- Flag15
|
||||
|
||||
|
@ -8197,9 +8239,6 @@ package Sinfo is
|
|||
function Expressions
|
||||
(N : Node_Id) return List_Id; -- List1
|
||||
|
||||
function First_Aspect
|
||||
(N : Node_Id) return Boolean; -- Flag4
|
||||
|
||||
function First_Bit
|
||||
(N : Node_Id) return Node_Id; -- Node3
|
||||
|
||||
|
@ -8227,6 +8266,9 @@ package Sinfo is
|
|||
function Forwards_OK
|
||||
(N : Node_Id) return Boolean; -- Flag5
|
||||
|
||||
function From_Aspect_Specification
|
||||
(N : Node_Id) return Boolean; -- Flag13
|
||||
|
||||
function From_At_End
|
||||
(N : Node_Id) return Boolean; -- Flag4
|
||||
|
||||
|
@ -8416,9 +8458,6 @@ package Sinfo is
|
|||
function Left_Opnd
|
||||
(N : Node_Id) return Node_Id; -- Node2
|
||||
|
||||
function Last_Aspect
|
||||
(N : Node_Id) return Boolean; -- Flag5
|
||||
|
||||
function Last_Bit
|
||||
(N : Node_Id) return Node_Id; -- Node4
|
||||
|
||||
|
@ -8845,6 +8884,9 @@ package Sinfo is
|
|||
procedure Set_Has_Aspect_Specifications
|
||||
(N : Node_Id; Val : Boolean := True); -- Flag3
|
||||
|
||||
procedure Set_Aspect_Cancel
|
||||
(N : Node_Id; Val : Boolean := True); -- Flag11
|
||||
|
||||
procedure Set_Assignment_OK
|
||||
(N : Node_Id; Val : Boolean := True); -- Flag15
|
||||
|
||||
|
@ -9139,9 +9181,6 @@ package Sinfo is
|
|||
procedure Set_Expressions
|
||||
(N : Node_Id; Val : List_Id); -- List1
|
||||
|
||||
procedure Set_First_Aspect
|
||||
(N : Node_Id; Val : Boolean := True); -- Flag4
|
||||
|
||||
procedure Set_First_Bit
|
||||
(N : Node_Id; Val : Node_Id); -- Node3
|
||||
|
||||
|
@ -9172,6 +9211,9 @@ package Sinfo is
|
|||
procedure Set_From_At_Mod
|
||||
(N : Node_Id; Val : Boolean := True); -- Flag4
|
||||
|
||||
procedure Set_From_Aspect_Specification
|
||||
(N : Node_Id; Val : Boolean := True); -- Flag13
|
||||
|
||||
procedure Set_From_At_End
|
||||
(N : Node_Id; Val : Boolean := True); -- Flag4
|
||||
|
||||
|
@ -9349,9 +9391,6 @@ package Sinfo is
|
|||
procedure Set_Kill_Range_Check
|
||||
(N : Node_Id; Val : Boolean := True); -- Flag11
|
||||
|
||||
procedure Set_Last_Aspect
|
||||
(N : Node_Id; Val : Boolean := True); -- Flag5
|
||||
|
||||
procedure Set_Last_Bit
|
||||
(N : Node_Id; Val : Node_Id); -- Node4
|
||||
|
||||
|
@ -11417,45 +11456,6 @@ package Sinfo is
|
|||
4 => 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 --
|
||||
--------------------
|
||||
|
@ -11481,6 +11481,7 @@ package Sinfo is
|
|||
pragma Inline (Alternatives);
|
||||
pragma Inline (Ancestor_Part);
|
||||
pragma Inline (Array_Aggregate);
|
||||
pragma Inline (Aspect_Cancel);
|
||||
pragma Inline (Assignment_OK);
|
||||
pragma Inline (Associated_Node);
|
||||
pragma Inline (At_End_Proc);
|
||||
|
@ -11580,7 +11581,6 @@ package Sinfo is
|
|||
pragma Inline (Explicit_Generic_Actual_Parameter);
|
||||
pragma Inline (Expression);
|
||||
pragma Inline (Expressions);
|
||||
pragma Inline (First_Aspect);
|
||||
pragma Inline (First_Bit);
|
||||
pragma Inline (First_Inlined_Subprogram);
|
||||
pragma Inline (First_Name);
|
||||
|
@ -11590,6 +11590,7 @@ package Sinfo is
|
|||
pragma Inline (Float_Truncate);
|
||||
pragma Inline (Formal_Type_Definition);
|
||||
pragma Inline (Forwards_OK);
|
||||
pragma Inline (From_Aspect_Specification);
|
||||
pragma Inline (From_At_End);
|
||||
pragma Inline (From_At_Mod);
|
||||
pragma Inline (From_Default);
|
||||
|
@ -11651,7 +11652,6 @@ package Sinfo is
|
|||
pragma Inline (Iteration_Scheme);
|
||||
pragma Inline (Itype);
|
||||
pragma Inline (Kill_Range_Check);
|
||||
pragma Inline (Last_Aspect);
|
||||
pragma Inline (Last_Bit);
|
||||
pragma Inline (Last_Name);
|
||||
pragma Inline (Library_Unit);
|
||||
|
@ -11792,6 +11792,7 @@ package Sinfo is
|
|||
pragma Inline (Set_Alternatives);
|
||||
pragma Inline (Set_Ancestor_Part);
|
||||
pragma Inline (Set_Array_Aggregate);
|
||||
pragma Inline (Set_Aspect_Cancel);
|
||||
pragma Inline (Set_Assignment_OK);
|
||||
pragma Inline (Set_Associated_Node);
|
||||
pragma Inline (Set_At_End_Proc);
|
||||
|
@ -11890,7 +11891,6 @@ package Sinfo is
|
|||
pragma Inline (Set_Explicit_Generic_Actual_Parameter);
|
||||
pragma Inline (Set_Expression);
|
||||
pragma Inline (Set_Expressions);
|
||||
pragma Inline (Set_First_Aspect);
|
||||
pragma Inline (Set_First_Bit);
|
||||
pragma Inline (Set_First_Inlined_Subprogram);
|
||||
pragma Inline (Set_First_Name);
|
||||
|
@ -11900,6 +11900,7 @@ package Sinfo is
|
|||
pragma Inline (Set_Float_Truncate);
|
||||
pragma Inline (Set_Formal_Type_Definition);
|
||||
pragma Inline (Set_Forwards_OK);
|
||||
pragma Inline (Set_From_Aspect_Specification);
|
||||
pragma Inline (Set_From_At_End);
|
||||
pragma Inline (Set_From_At_Mod);
|
||||
pragma Inline (Set_From_Default);
|
||||
|
@ -11961,7 +11962,6 @@ package Sinfo is
|
|||
pragma Inline (Set_Iteration_Scheme);
|
||||
pragma Inline (Set_Itype);
|
||||
pragma Inline (Set_Kill_Range_Check);
|
||||
pragma Inline (Set_Last_Aspect);
|
||||
pragma Inline (Set_Last_Bit);
|
||||
pragma Inline (Set_Last_Name);
|
||||
pragma Inline (Set_Library_Unit);
|
||||
|
|
|
@ -23,6 +23,7 @@
|
|||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Aspects; use Aspects;
|
||||
with Atree; use Atree;
|
||||
with Casing; use Casing;
|
||||
with Csets; use Csets;
|
||||
|
@ -182,6 +183,12 @@ package body Sprint is
|
|||
procedure Sprint_And_List (List : List_Id);
|
||||
-- Print the given list with items separated by vertical "and"
|
||||
|
||||
procedure Sprint_Aspect_Specifications (Node : Node_Id);
|
||||
-- Node is a declaration node that accepts aspect specifications. This
|
||||
-- procedure tests if aspect specifications are present, and if so prints
|
||||
-- them, with a terminating semicolon. If no aspect specifications are
|
||||
-- present, then a single semicolon is output.
|
||||
|
||||
procedure Sprint_Bar_List (List : List_Id);
|
||||
-- Print the given list with items separated by vertical bars
|
||||
|
||||
|
@ -619,6 +626,48 @@ package body Sprint is
|
|||
end if;
|
||||
end Sprint_And_List;
|
||||
|
||||
----------------------------------
|
||||
-- Sprint_Aspect_Specifications --
|
||||
----------------------------------
|
||||
|
||||
procedure Sprint_Aspect_Specifications (Node : Node_Id) is
|
||||
AS : List_Id;
|
||||
A : Node_Id;
|
||||
|
||||
begin
|
||||
if Has_Aspect_Specifications (Node) then
|
||||
AS := Aspect_Specifications (Node);
|
||||
Indent := Indent + 2;
|
||||
Write_Indent;
|
||||
Write_Str ("with ");
|
||||
Indent := Indent + 5;
|
||||
|
||||
A := First (AS);
|
||||
loop
|
||||
Sprint_Node (Identifier (A));
|
||||
|
||||
if Class_Present (A) then
|
||||
Write_Str ("'Class");
|
||||
end if;
|
||||
|
||||
if Present (Expression (A)) then
|
||||
Write_Str (" => ");
|
||||
Sprint_Node (Expression (A));
|
||||
end if;
|
||||
|
||||
Next (A);
|
||||
|
||||
exit when No (A);
|
||||
Write_Char (',');
|
||||
Write_Indent;
|
||||
end loop;
|
||||
|
||||
Indent := Indent - 7;
|
||||
end if;
|
||||
|
||||
Write_Char (';');
|
||||
end Sprint_Aspect_Specifications;
|
||||
|
||||
---------------------
|
||||
-- Sprint_Bar_List --
|
||||
---------------------
|
||||
|
@ -815,7 +864,8 @@ package body Sprint is
|
|||
Write_Indent;
|
||||
Sprint_Node (Specification (Node));
|
||||
Write_Str_With_Col_Check (" is ");
|
||||
Write_Str_Sloc ("abstract;");
|
||||
Write_Str_Sloc ("abstract");
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Accept_Alternative =>
|
||||
Sprint_Node_List (Pragmas_Before (Node));
|
||||
|
@ -1224,7 +1274,7 @@ package body Sprint is
|
|||
Sprint_Node (Expression (Node));
|
||||
end if;
|
||||
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
end if;
|
||||
|
||||
when N_Component_List =>
|
||||
|
@ -1453,7 +1503,7 @@ package body Sprint is
|
|||
end if;
|
||||
|
||||
Write_Param_Specs (Node);
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Entry_Index_Specification =>
|
||||
Write_Str_With_Col_Check_Sloc ("for ");
|
||||
|
@ -1499,7 +1549,7 @@ package body Sprint is
|
|||
Sprint_Node (Expression (Node));
|
||||
end if;
|
||||
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
end if;
|
||||
|
||||
when N_Exception_Handler =>
|
||||
|
@ -1625,7 +1675,7 @@ package body Sprint is
|
|||
Sprint_Node (Default_Name (Node));
|
||||
end if;
|
||||
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Formal_Concrete_Subprogram_Declaration =>
|
||||
Write_Indent_Str_Sloc ("with ");
|
||||
|
@ -1638,7 +1688,7 @@ package body Sprint is
|
|||
Sprint_Node (Default_Name (Node));
|
||||
end if;
|
||||
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Formal_Discrete_Type_Definition =>
|
||||
Write_Str_With_Col_Check_Sloc ("<>");
|
||||
|
@ -1686,7 +1736,7 @@ package body Sprint is
|
|||
Sprint_Node (Default_Expression (Node));
|
||||
end if;
|
||||
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
end if;
|
||||
|
||||
when N_Formal_Ordinary_Fixed_Point_Definition =>
|
||||
|
@ -1697,7 +1747,8 @@ package body Sprint is
|
|||
Write_Id (Defining_Identifier (Node));
|
||||
Write_Str_With_Col_Check (" is new ");
|
||||
Sprint_Node (Name (Node));
|
||||
Write_Str_With_Col_Check (" (<>);");
|
||||
Write_Str_With_Col_Check (" (<>)");
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Formal_Private_Type_Definition =>
|
||||
if Abstract_Present (Node) then
|
||||
|
@ -1729,7 +1780,7 @@ package body Sprint is
|
|||
|
||||
Write_Str_With_Col_Check (" is ");
|
||||
Sprint_Node (Formal_Type_Definition (Node));
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Free_Statement =>
|
||||
Write_Indent_Str_Sloc ("free ");
|
||||
|
@ -1770,7 +1821,7 @@ package body Sprint is
|
|||
Write_Discr_Specs (Node);
|
||||
Write_Str_With_Col_Check (" is ");
|
||||
Sprint_Node (Type_Definition (Node));
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Function_Call =>
|
||||
Set_Debug_Sloc;
|
||||
|
@ -1783,7 +1834,7 @@ package body Sprint is
|
|||
Write_Str_With_Col_Check (" is new ");
|
||||
Sprint_Node (Name (Node));
|
||||
Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Function_Specification =>
|
||||
Write_Str_With_Col_Check_Sloc ("function ");
|
||||
|
@ -1824,7 +1875,7 @@ package body Sprint is
|
|||
Sprint_Indented_List (Generic_Formal_Declarations (Node));
|
||||
Write_Indent;
|
||||
Sprint_Node (Specification (Node));
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Generic_Package_Renaming_Declaration =>
|
||||
Write_Indent_Str_Sloc ("generic package ");
|
||||
|
@ -1846,7 +1897,7 @@ package body Sprint is
|
|||
Sprint_Indented_List (Generic_Formal_Declarations (Node));
|
||||
Write_Indent;
|
||||
Sprint_Node (Specification (Node));
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Goto_Statement =>
|
||||
Write_Indent_Str_Sloc ("goto ");
|
||||
|
@ -2077,7 +2128,7 @@ package body Sprint is
|
|||
Sprint_Node (Expression (Node));
|
||||
end if;
|
||||
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
-- Handle implicit importation and implicit exportation of
|
||||
-- object declarations:
|
||||
|
@ -2318,7 +2369,7 @@ package body Sprint is
|
|||
Extra_Blank_Line;
|
||||
Write_Indent;
|
||||
Sprint_Node_Sloc (Specification (Node));
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Package_Instantiation =>
|
||||
Extra_Blank_Line;
|
||||
|
@ -2327,7 +2378,7 @@ package body Sprint is
|
|||
Write_Str (" is new ");
|
||||
Sprint_Node (Name (Node));
|
||||
Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Package_Renaming_Declaration =>
|
||||
Write_Indent_Str_Sloc ("package ");
|
||||
|
@ -2410,6 +2461,50 @@ package body Sprint is
|
|||
when N_Pop_Storage_Error_Label =>
|
||||
Write_Indent_Str ("%pop_storage_error_label");
|
||||
|
||||
when N_Private_Extension_Declaration =>
|
||||
Write_Indent_Str_Sloc ("type ");
|
||||
Write_Id (Defining_Identifier (Node));
|
||||
|
||||
if Present (Discriminant_Specifications (Node)) then
|
||||
Write_Discr_Specs (Node);
|
||||
elsif Unknown_Discriminants_Present (Node) then
|
||||
Write_Str_With_Col_Check ("(<>)");
|
||||
end if;
|
||||
|
||||
Write_Str_With_Col_Check (" is new ");
|
||||
Sprint_Node (Subtype_Indication (Node));
|
||||
|
||||
if Present (Interface_List (Node)) then
|
||||
Write_Str_With_Col_Check (" and ");
|
||||
Sprint_And_List (Interface_List (Node));
|
||||
end if;
|
||||
|
||||
Write_Str_With_Col_Check (" with private");
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Private_Type_Declaration =>
|
||||
Write_Indent_Str_Sloc ("type ");
|
||||
Write_Id (Defining_Identifier (Node));
|
||||
|
||||
if Present (Discriminant_Specifications (Node)) then
|
||||
Write_Discr_Specs (Node);
|
||||
elsif Unknown_Discriminants_Present (Node) then
|
||||
Write_Str_With_Col_Check ("(<>)");
|
||||
end if;
|
||||
|
||||
Write_Str (" is ");
|
||||
|
||||
if Tagged_Present (Node) then
|
||||
Write_Str_With_Col_Check ("tagged ");
|
||||
end if;
|
||||
|
||||
if Limited_Present (Node) then
|
||||
Write_Str_With_Col_Check ("limited ");
|
||||
end if;
|
||||
|
||||
Write_Str_With_Col_Check ("private");
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Push_Constraint_Error_Label =>
|
||||
Write_Indent_Str ("%push_constraint_error_label (");
|
||||
|
||||
|
@ -2458,48 +2553,6 @@ package body Sprint is
|
|||
|
||||
Sprint_Node (Expression (Node));
|
||||
|
||||
when N_Private_Type_Declaration =>
|
||||
Write_Indent_Str_Sloc ("type ");
|
||||
Write_Id (Defining_Identifier (Node));
|
||||
|
||||
if Present (Discriminant_Specifications (Node)) then
|
||||
Write_Discr_Specs (Node);
|
||||
elsif Unknown_Discriminants_Present (Node) then
|
||||
Write_Str_With_Col_Check ("(<>)");
|
||||
end if;
|
||||
|
||||
Write_Str (" is ");
|
||||
|
||||
if Tagged_Present (Node) then
|
||||
Write_Str_With_Col_Check ("tagged ");
|
||||
end if;
|
||||
|
||||
if Limited_Present (Node) then
|
||||
Write_Str_With_Col_Check ("limited ");
|
||||
end if;
|
||||
|
||||
Write_Str_With_Col_Check ("private;");
|
||||
|
||||
when N_Private_Extension_Declaration =>
|
||||
Write_Indent_Str_Sloc ("type ");
|
||||
Write_Id (Defining_Identifier (Node));
|
||||
|
||||
if Present (Discriminant_Specifications (Node)) then
|
||||
Write_Discr_Specs (Node);
|
||||
elsif Unknown_Discriminants_Present (Node) then
|
||||
Write_Str_With_Col_Check ("(<>)");
|
||||
end if;
|
||||
|
||||
Write_Str_With_Col_Check (" is new ");
|
||||
Sprint_Node (Subtype_Indication (Node));
|
||||
|
||||
if Present (Interface_List (Node)) then
|
||||
Write_Str_With_Col_Check (" and ");
|
||||
Sprint_And_List (Interface_List (Node));
|
||||
end if;
|
||||
|
||||
Write_Str_With_Col_Check (" with private;");
|
||||
|
||||
when N_Procedure_Call_Statement =>
|
||||
Write_Indent;
|
||||
Set_Debug_Sloc;
|
||||
|
@ -2513,7 +2566,7 @@ package body Sprint is
|
|||
Write_Str_With_Col_Check (" is new ");
|
||||
Sprint_Node (Name (Node));
|
||||
Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Procedure_Specification =>
|
||||
Write_Str_With_Col_Check_Sloc ("procedure ");
|
||||
|
@ -2560,7 +2613,7 @@ package body Sprint is
|
|||
|
||||
Sprint_Node (Protected_Definition (Node));
|
||||
Write_Id (Defining_Identifier (Node));
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Qualified_Expression =>
|
||||
Sprint_Node (Subtype_Mark (Node));
|
||||
|
@ -2756,7 +2809,7 @@ package body Sprint is
|
|||
Write_Str (" is");
|
||||
Sprint_Node (Protected_Definition (Node));
|
||||
Write_Id (Defining_Identifier (Node));
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Single_Task_Declaration =>
|
||||
Write_Indent_Str_Sloc ("task ");
|
||||
|
@ -2767,7 +2820,7 @@ package body Sprint is
|
|||
Sprint_Node (Task_Definition (Node));
|
||||
end if;
|
||||
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Selected_Component =>
|
||||
Sprint_Node (Prefix (Node));
|
||||
|
@ -2840,7 +2893,7 @@ package body Sprint is
|
|||
Write_Str_With_Col_Check (" is null");
|
||||
end if;
|
||||
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Subprogram_Info =>
|
||||
Sprint_Node (Identifier (Node));
|
||||
|
@ -2865,7 +2918,7 @@ package body Sprint is
|
|||
end if;
|
||||
|
||||
Sprint_Node (Subtype_Indication (Node));
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Subtype_Indication =>
|
||||
Sprint_Node_Sloc (Subtype_Mark (Node));
|
||||
|
@ -2928,11 +2981,10 @@ package body Sprint is
|
|||
Sprint_Node (Task_Definition (Node));
|
||||
end if;
|
||||
|
||||
Write_Char (';');
|
||||
Sprint_Aspect_Specifications (Node);
|
||||
|
||||
when N_Terminate_Alternative =>
|
||||
Sprint_Node_List (Pragmas_Before (Node));
|
||||
|
||||
Write_Indent;
|
||||
|
||||
if Present (Condition (Node)) then
|
||||
|
|
Loading…
Reference in New Issue