Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / ada / sem_ch13.adb
blob: 78415e666f4d8a7dad97ce0af27722fe21a14bad [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ C H 1 3 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Contracts; use Contracts;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Ghost; use Ghost;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Par_SCO; use Par_SCO;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Dim; use Sem_Dim;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Table;
with Targparm; use Targparm;
with Ttypes; use Ttypes;
with Tbuild; use Tbuild;
with Urealp; use Urealp;
with Warnsw; use Warnsw;
with GNAT.Heap_Sort_G;
package body Sem_Ch13 is
SSU : constant Pos := System_Storage_Unit;
-- Convenient short hand for commonly used constant
-----------------------
-- Local Subprograms --
-----------------------
procedure Adjust_Record_For_Reverse_Bit_Order_Ada_95 (R : Entity_Id);
-- Helper routine providing the original (pre-AI95-0133) behavior for
-- Adjust_Record_For_Reverse_Bit_Order.
procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint);
-- This routine is called after setting one of the sizes of type entity
-- Typ to Size. The purpose is to deal with the situation of a derived
-- type whose inherited alignment is no longer appropriate for the new
-- size value. In this case, we reset the Alignment to unknown.
function All_Static_Choices (L : List_Id) return Boolean;
-- Returns true if all elements of the list are OK static choices
-- as defined below for Is_Static_Choice. Used for case expression
-- alternatives and for the right operand of a membership test. An
-- others_choice is static if the corresponding expression is static.
-- The staticness of the bounds is checked separately.
procedure Build_Discrete_Static_Predicate
(Typ : Entity_Id;
Expr : Node_Id;
Nam : Name_Id);
-- Given a predicated type Typ, where Typ is a discrete static subtype,
-- whose predicate expression is Expr, tests if Expr is a static predicate,
-- and if so, builds the predicate range list. Nam is the name of the one
-- argument to the predicate function. Occurrences of the type name in the
-- predicate expression have been replaced by identifier references to this
-- name, which is unique, so any identifier with Chars matching Nam must be
-- a reference to the type. If the predicate is non-static, this procedure
-- returns doing nothing. If the predicate is static, then the predicate
-- list is stored in Static_Discrete_Predicate (Typ), and the Expr is
-- rewritten as a canonicalized membership operation.
function Build_Export_Import_Pragma
(Asp : Node_Id;
Id : Entity_Id) return Node_Id;
-- Create the corresponding pragma for aspect Export or Import denoted by
-- Asp. Id is the related entity subject to the aspect. Return Empty when
-- the expression of aspect Asp evaluates to False or is erroneous.
function Build_Predicate_Function_Declaration
(Typ : Entity_Id) return Node_Id;
-- Build the declaration for a predicate function. The declaration is built
-- at the end of the declarative part containing the type definition, which
-- may be before the freeze point of the type. The predicate expression is
-- preanalyzed at this point, to catch visibility errors.
procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id);
-- If Typ has predicates (indicated by Has_Predicates being set for Typ),
-- then either there are pragma Predicate entries on the rep chain for the
-- type (note that Predicate aspects are converted to pragma Predicate), or
-- there are inherited aspects from a parent type, or ancestor subtypes.
-- This procedure builds body for the Predicate function that tests these
-- predicates. N is the freeze node for the type. The spec of the function
-- is inserted before the freeze node, and the body of the function is
-- inserted after the freeze node. If the predicate expression has a least
-- one Raise_Expression, then this procedure also builds the M version of
-- the predicate function for use in membership tests.
procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id);
-- Called if both Storage_Pool and Storage_Size attribute definition
-- clauses (SP and SS) are present for entity Ent. Issue error message.
procedure Freeze_Entity_Checks (N : Node_Id);
-- Called from Analyze_Freeze_Entity and Analyze_Generic_Freeze Entity
-- to generate appropriate semantic checks that are delayed until this
-- point (they had to be delayed this long for cases of delayed aspects,
-- e.g. analysis of statically predicated subtypes in choices, for which
-- we have to be sure the subtypes in question are frozen before checking).
function Get_Alignment_Value (Expr : Node_Id) return Uint;
-- Given the expression for an alignment value, returns the corresponding
-- Uint value. If the value is inappropriate, then error messages are
-- posted as required, and a value of No_Uint is returned.
function Is_Operational_Item (N : Node_Id) return Boolean;
-- A specification for a stream attribute is allowed before the full type
-- is declared, as explained in AI-00137 and the corrigendum. Attributes
-- that do not specify a representation characteristic are operational
-- attributes.
function Is_Static_Choice (N : Node_Id) return Boolean;
-- Returns True if N represents a static choice (static subtype, or
-- static subtype indication, or static expression, or static range).
--
-- Note that this is a bit more inclusive than we actually need
-- (in particular membership tests do not allow the use of subtype
-- indications). But that doesn't matter, we have already checked
-- that the construct is legal to get this far.
function Is_Type_Related_Rep_Item (N : Node_Id) return Boolean;
-- Returns True for a representation clause/pragma that specifies a
-- type-related representation (as opposed to operational) aspect.
function Is_Predicate_Static
(Expr : Node_Id;
Nam : Name_Id) return Boolean;
-- Given predicate expression Expr, tests if Expr is predicate-static in
-- the sense of the rules in (RM 3.2.4 (15-24)). Occurrences of the type
-- name in the predicate expression have been replaced by references to
-- an identifier whose Chars field is Nam. This name is unique, so any
-- identifier with Chars matching Nam must be a reference to the type.
-- Returns True if the expression is predicate-static and False otherwise,
-- but is not in the business of setting flags or issuing error messages.
--
-- Only scalar types can have static predicates, so False is always
-- returned for non-scalar types.
--
-- Note: the RM seems to suggest that string types can also have static
-- predicates. But that really makes lttle sense as very few useful
-- predicates can be constructed for strings. Remember that:
--
-- "ABC" < "DEF"
--
-- is not a static expression. So even though the clearly faulty RM wording
-- allows the following:
--
-- subtype S is String with Static_Predicate => S < "DEF"
--
-- We can't allow this, otherwise we have predicate-static applying to a
-- larger class than static expressions, which was never intended.
procedure New_Put_Image_Subprogram
(N : Node_Id;
Ent : Entity_Id;
Subp : Entity_Id);
-- Similar to New_Stream_Subprogram, but for the Put_Image attribute
procedure New_Stream_Subprogram
(N : Node_Id;
Ent : Entity_Id;
Subp : Entity_Id;
Nam : TSS_Name_Type);
-- Create a subprogram renaming of a given stream attribute to the
-- designated subprogram and then in the tagged case, provide this as a
-- primitive operation, or in the untagged case make an appropriate TSS
-- entry. This is more properly an expansion activity than just semantics,
-- but the presence of user-defined stream functions for limited types
-- is a legality check, which is why this takes place here rather than in
-- exp_ch13, where it was previously. Nam indicates the name of the TSS
-- function to be generated.
--
-- To avoid elaboration anomalies with freeze nodes, for untagged types
-- we generate both a subprogram declaration and a subprogram renaming
-- declaration, so that the attribute specification is handled as a
-- renaming_as_body. For tagged types, the specification is one of the
-- primitive specs.
procedure No_Type_Rep_Item (N : Node_Id);
-- Output message indicating that no type-related aspects can be
-- specified due to some property of the parent type.
procedure Register_Address_Clause_Check
(N : Node_Id;
X : Entity_Id;
A : Uint;
Y : Entity_Id;
Off : Boolean);
-- Register a check for the address clause N. The rest of the parameters
-- are in keeping with the components of Address_Clause_Check_Record below.
procedure Validate_Aspect_Aggregate (N : Node_Id);
-- Check legality of operations given in the Ada 2022 Aggregate aspect for
-- containers.
procedure Resolve_Aspect_Aggregate
(Typ : Entity_Id;
Expr : Node_Id);
-- Resolve each one of the operations specified in the specification of
-- Aspect_Aggregate.
procedure Validate_Aspect_Stable_Properties
(E : Entity_Id; N : Node_Id; Class_Present : Boolean);
-- Check legality of functions given in the Ada 2022 Stable_Properties
-- (or Stable_Properties'Class) aspect.
procedure Validate_Storage_Model_Type_Aspect
(Typ : Entity_Id; ASN : Node_Id);
-- Check legality and completeness of the aggregate associations given in
-- the Storage_Model_Type aspect associated with Typ.
procedure Resolve_Storage_Model_Type_Argument
(N : Node_Id;
Typ : Entity_Id;
Addr_Type : in out Entity_Id;
Nam : Name_Id);
-- Resolve argument N to be of the proper kind (when a type or constant)
-- or to have the proper profile (when a subprogram).
procedure Resolve_Aspect_Stable_Properties
(Typ_Or_Subp : Entity_Id;
Expr : Node_Id;
Class_Present : Boolean);
-- Resolve each one of the functions specified in the specification of
-- aspect Stable_Properties (or Stable_Properties'Class).
procedure Resolve_Iterable_Operation
(N : Node_Id;
Cursor : Entity_Id;
Typ : Entity_Id;
Nam : Name_Id);
-- If the name of a primitive operation for an Iterable aspect is
-- overloaded, resolve according to required signature.
procedure Set_Biased
(E : Entity_Id;
N : Node_Id;
Msg : String;
Biased : Boolean := True);
-- If Biased is True, sets Has_Biased_Representation flag for E, and
-- outputs a warning message at node N if Warn_On_Biased_Representation is
-- is True. This warning inserts the string Msg to describe the construct
-- causing biasing.
-----------------------------------------------------------
-- Visibility of Discriminants in Aspect Specifications --
-----------------------------------------------------------
-- The discriminants of a type are visible when analyzing the aspect
-- specifications of a type declaration or protected type declaration,
-- but not when analyzing those of a subtype declaration. The following
-- routines enforce this distinction.
procedure Push_Type (E : Entity_Id);
-- Push scope E and make visible the discriminants of type entity E if E
-- has discriminants and is not a subtype.
procedure Pop_Type (E : Entity_Id);
-- Remove visibility to the discriminants of type entity E and pop the
-- scope stack if E has discriminants and is not a subtype.
----------------------------------------------
-- Table for Validate_Unchecked_Conversions --
----------------------------------------------
-- The following table collects unchecked conversions for validation.
-- Entries are made by Validate_Unchecked_Conversion and then the call
-- to Validate_Unchecked_Conversions does the actual error checking and
-- posting of warnings. The reason for this delayed processing is to take
-- advantage of back-annotations of size and alignment values performed by
-- the back end.
-- Note: the reason we store a Source_Ptr value instead of a Node_Id is
-- that by the time Validate_Unchecked_Conversions is called, Sprint will
-- already have modified all Sloc values if the -gnatD option is set.
type UC_Entry is record
Eloc : Source_Ptr; -- node used for posting warnings
Source : Entity_Id; -- source type for unchecked conversion
Target : Entity_Id; -- target type for unchecked conversion
Act_Unit : Entity_Id; -- actual function instantiated
end record;
package Unchecked_Conversions is new Table.Table (
Table_Component_Type => UC_Entry,
Table_Index_Type => Int,
Table_Low_Bound => 1,
Table_Initial => 50,
Table_Increment => 200,
Table_Name => "Unchecked_Conversions");
----------------------------------------
-- Table for Validate_Address_Clauses --
----------------------------------------
-- If an address clause has the form
-- for X'Address use Expr
-- where Expr has a value known at compile time or is of the form Y'Address
-- or recursively is a reference to a constant initialized with either of
-- these forms, and the value of Expr is not a multiple of X's alignment,
-- or if Y has a smaller alignment than X, then that merits a warning about
-- possible bad alignment. The following table collects address clauses of
-- this kind. We put these in a table so that they can be checked after the
-- back end has completed annotation of the alignments of objects, since we
-- can catch more cases that way.
type Address_Clause_Check_Record is record
N : Node_Id;
-- The address clause
X : Entity_Id;
-- The entity of the object subject to the address clause
A : Uint;
-- The value of the address in the first case
Y : Entity_Id;
-- The entity of the object being overlaid in the second case
Off : Boolean;
-- Whether the address is offset within Y in the second case
Alignment_Checks_Suppressed : Boolean;
-- Whether alignment checks are suppressed by an active scope suppress
-- setting. We need to save the value in order to be able to reuse it
-- after the back end has been run.
end record;
package Address_Clause_Checks is new Table.Table (
Table_Component_Type => Address_Clause_Check_Record,
Table_Index_Type => Int,
Table_Low_Bound => 1,
Table_Initial => 20,
Table_Increment => 200,
Table_Name => "Address_Clause_Checks");
function Alignment_Checks_Suppressed
(ACCR : Address_Clause_Check_Record) return Boolean;
-- Return whether the alignment check generated for the address clause
-- is suppressed.
---------------------------------
-- Alignment_Checks_Suppressed --
---------------------------------
function Alignment_Checks_Suppressed
(ACCR : Address_Clause_Check_Record) return Boolean
is
begin
if Checks_May_Be_Suppressed (ACCR.X) then
return Is_Check_Suppressed (ACCR.X, Alignment_Check);
else
return ACCR.Alignment_Checks_Suppressed;
end if;
end Alignment_Checks_Suppressed;
-----------------------------------------
-- Adjust_Record_For_Reverse_Bit_Order --
-----------------------------------------
procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is
Max_Machine_Scalar_Size : constant Uint :=
UI_From_Int (System_Max_Integer_Size);
-- We use this as the maximum machine scalar size
SSU : constant Uint := UI_From_Int (System_Storage_Unit);
CC : Node_Id;
Comp : Node_Id;
Num_CC : Natural;
begin
-- The processing done here used to depend on the Ada version, but the
-- behavior has been changed by AI95-0133. However this AI is a Binding
-- Interpretation, so we now implement it even in Ada 95 mode. But the
-- original behavior from unamended Ada 95 is available for the sake of
-- compatibility under the debugging switch -gnatd.p in Ada 95 mode.
if Ada_Version < Ada_2005 and then Debug_Flag_Dot_P then
Adjust_Record_For_Reverse_Bit_Order_Ada_95 (R);
return;
end if;
-- For Ada 2005, we do machine scalar processing, as fully described In
-- AI-133. This involves gathering all components which start at the
-- same byte offset and processing them together. Same approach is still
-- valid in later versions including Ada 2012.
-- Note that component clauses found on record types may be inherited,
-- in which case the layout of the component with such a clause still
-- has to be done at this point. Therefore, the processing done here
-- must exclusively rely on the Component_Clause of the component.
-- This first loop through components does two things. First it deals
-- with the case of components with component clauses whose length is
-- greater than the maximum machine scalar size (either accepting them
-- or rejecting as needed). Second, it counts the number of components
-- with component clauses whose length does not exceed this maximum for
-- later processing.
Num_CC := 0;
Comp := First_Component_Or_Discriminant (R);
while Present (Comp) loop
CC := Component_Clause (Comp);
if Present (CC) then
declare
Fbit : constant Uint := Static_Integer (First_Bit (CC));
Lbit : constant Uint := Static_Integer (Last_Bit (CC));
begin
-- Case of component with last bit >= max machine scalar
if Lbit >= Max_Machine_Scalar_Size then
-- This is allowed only if first bit is zero, and last bit
-- + 1 is a multiple of storage unit size.
if Fbit = 0 and then (Lbit + 1) mod SSU = 0 then
-- This is the case to give a warning if enabled
if Warn_On_Reverse_Bit_Order then
Error_Msg_N
("info: multi-byte field specified with "
& "non-standard Bit_Order?.v?", CC);
if Bytes_Big_Endian then
Error_Msg_N
("\bytes are not reversed "
& "(component is big-endian)?.v?", CC);
else
Error_Msg_N
("\bytes are not reversed "
& "(component is little-endian)?.v?", CC);
end if;
end if;
-- Give error message for RM 13.5.1(10) violation
else
Error_Msg_FE
("machine scalar rules not followed for&",
First_Bit (CC), Comp);
Error_Msg_Uint_1 := Lbit + 1;
Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
Error_Msg_F
("\last bit + 1 (^) exceeds maximum machine scalar "
& "size (^)", First_Bit (CC));
if (Lbit + 1) mod SSU /= 0 then
Error_Msg_Uint_1 := SSU;
Error_Msg_F
("\and is not a multiple of Storage_Unit (^) "
& "(RM 13.5.1(10))", First_Bit (CC));
else
Error_Msg_Uint_1 := Fbit;
Error_Msg_F
("\and first bit (^) is non-zero "
& "(RM 13.4.1(10))", First_Bit (CC));
end if;
end if;
-- OK case of machine scalar related component clause. For now,
-- just count them.
else
Num_CC := Num_CC + 1;
end if;
end;
end if;
Next_Component_Or_Discriminant (Comp);
end loop;
-- We need to sort the component clauses on the basis of the Position
-- values in the clause, so we can group clauses with the same Position
-- together to determine the relevant machine scalar size.
Sort_CC : declare
Comps : array (0 .. Num_CC) of Entity_Id;
-- Array to collect component and discriminant entities. The data
-- starts at index 1, the 0'th entry is for the sort routine.
function CP_Lt (Op1, Op2 : Natural) return Boolean;
-- Compare routine for Sort
procedure CP_Move (From : Natural; To : Natural);
-- Move routine for Sort
package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
MaxL : Uint;
-- Maximum last bit value of any component in this set
MSS : Uint;
-- Corresponding machine scalar size
Start : Natural;
Stop : Natural;
-- Start and stop positions in the component list of the set of
-- components with the same starting position (that constitute
-- components in a single machine scalar).
-----------
-- CP_Lt --
-----------
function CP_Lt (Op1, Op2 : Natural) return Boolean is
begin
return
Position (Component_Clause (Comps (Op1))) <
Position (Component_Clause (Comps (Op2)));
end CP_Lt;
-------------
-- CP_Move --
-------------
procedure CP_Move (From : Natural; To : Natural) is
begin
Comps (To) := Comps (From);
end CP_Move;
-- Start of processing for Sort_CC
begin
-- Collect the machine scalar relevant component clauses
Num_CC := 0;
Comp := First_Component_Or_Discriminant (R);
while Present (Comp) loop
declare
CC : constant Node_Id := Component_Clause (Comp);
begin
-- Collect only component clauses whose last bit is less than
-- machine scalar size. Any component clause whose last bit
-- exceeds this value does not take part in machine scalar
-- layout considerations. The test for Error_Posted makes sure
-- we exclude component clauses for which we already posted an
-- error.
if Present (CC)
and then not Error_Posted (Last_Bit (CC))
and then Static_Integer (Last_Bit (CC)) <
Max_Machine_Scalar_Size
then
Num_CC := Num_CC + 1;
Comps (Num_CC) := Comp;
end if;
end;
Next_Component_Or_Discriminant (Comp);
end loop;
-- Sort by ascending position number
Sorting.Sort (Num_CC);
-- We now have all the components whose size does not exceed the max
-- machine scalar value, sorted by starting position. In this loop we
-- gather groups of clauses starting at the same position, to process
-- them in accordance with AI-133.
Stop := 0;
while Stop < Num_CC loop
Start := Stop + 1;
Stop := Start;
MaxL :=
Static_Integer
(Last_Bit (Component_Clause (Comps (Start))));
while Stop < Num_CC loop
if Static_Integer
(Position (Component_Clause (Comps (Stop + 1)))) =
Static_Integer
(Position (Component_Clause (Comps (Stop))))
then
Stop := Stop + 1;
MaxL :=
UI_Max
(MaxL,
Static_Integer
(Last_Bit
(Component_Clause (Comps (Stop)))));
else
exit;
end if;
end loop;
-- Now we have a group of component clauses from Start to Stop
-- whose positions are identical, and MaxL is the maximum last
-- bit value of any of these components.
-- We need to determine the corresponding machine scalar size.
-- This loop assumes that machine scalar sizes are even, and that
-- each possible machine scalar has twice as many bits as the next
-- smaller one.
MSS := Max_Machine_Scalar_Size;
while MSS mod 2 = 0
and then (MSS / 2) >= SSU
and then (MSS / 2) > MaxL
loop
MSS := MSS / 2;
end loop;
-- Here is where we fix up the Component_Bit_Offset value to
-- account for the reverse bit order. Some examples of what needs
-- to be done for the case of a machine scalar size of 8 are:
-- First_Bit .. Last_Bit Component_Bit_Offset
-- old new old new
-- 0 .. 0 7 .. 7 0 7
-- 0 .. 1 6 .. 7 0 6
-- 0 .. 2 5 .. 7 0 5
-- 0 .. 7 0 .. 7 0 4
-- 1 .. 1 6 .. 6 1 6
-- 1 .. 4 3 .. 6 1 3
-- 4 .. 7 0 .. 3 4 0
-- The rule is that the first bit is obtained by subtracting the
-- old ending bit from machine scalar size - 1.
for C in Start .. Stop loop
declare
Comp : constant Entity_Id := Comps (C);
CC : constant Node_Id := Component_Clause (Comp);
FB : constant Uint := Static_Integer (First_Bit (CC));
LB : constant Uint := Static_Integer (Last_Bit (CC));
NFB : constant Uint := MSS - 1 - LB;
NLB : constant Uint := NFB + LB - FB;
Pos : constant Uint := Static_Integer (Position (CC));
begin
-- Do not warn for the artificial clause built for the tag
-- in Check_Record_Representation_Clause if it is inherited.
if Warn_On_Reverse_Bit_Order
and then Chars (Comp) /= Name_uTag
then
Error_Msg_Uint_1 := MSS;
Error_Msg_N
("info: reverse bit order in machine scalar of "
& "length^?.v?", First_Bit (CC));
Error_Msg_Uint_1 := NFB;
Error_Msg_Uint_2 := NLB;
if Bytes_Big_Endian then
Error_Msg_NE
("\big-endian range for component & is ^ .. ^?.v?",
First_Bit (CC), Comp);
else
Error_Msg_NE
("\little-endian range for component " &
"& is ^ .. ^?.v?",
First_Bit (CC), Comp);
end if;
end if;
Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
Set_Esize (Comp, 1 + (NLB - NFB));
Set_Normalized_First_Bit (Comp, NFB mod SSU);
Set_Normalized_Position (Comp, Pos + NFB / SSU);
end;
end loop;
end loop;
end Sort_CC;
end Adjust_Record_For_Reverse_Bit_Order;
------------------------------------------------
-- Adjust_Record_For_Reverse_Bit_Order_Ada_95 --
------------------------------------------------
procedure Adjust_Record_For_Reverse_Bit_Order_Ada_95 (R : Entity_Id) is
CC : Node_Id;
Comp : Node_Id;
begin
-- For Ada 95, we just renumber bits within a storage unit. We do the
-- same for Ada 83 mode, since we recognize the Bit_Order attribute in
-- Ada 83, and are free to add this extension.
Comp := First_Component_Or_Discriminant (R);
while Present (Comp) loop
CC := Component_Clause (Comp);
-- If component clause is present, then deal with the non-default
-- bit order case for Ada 95 mode.
-- We only do this processing for the base type, and in fact that
-- is important, since otherwise if there are record subtypes, we
-- could reverse the bits once for each subtype, which is wrong.
if Present (CC) and then Ekind (R) = E_Record_Type then
declare
CFB : constant Uint := Component_Bit_Offset (Comp);
CSZ : constant Uint := Esize (Comp);
CLC : constant Node_Id := Component_Clause (Comp);
Pos : constant Node_Id := Position (CLC);
FB : constant Node_Id := First_Bit (CLC);
Storage_Unit_Offset : constant Uint :=
CFB / System_Storage_Unit;
Start_Bit : constant Uint :=
CFB mod System_Storage_Unit;
begin
-- Cases where field goes over storage unit boundary
if Start_Bit + CSZ > System_Storage_Unit then
-- Allow multi-byte field but generate warning
if Start_Bit mod System_Storage_Unit = 0
and then CSZ mod System_Storage_Unit = 0
then
Error_Msg_N
("info: multi-byte field specified with non-standard "
& "Bit_Order?.v?", CLC);
if Bytes_Big_Endian then
Error_Msg_N
("\bytes are not reversed "
& "(component is big-endian)?.v?", CLC);
else
Error_Msg_N
("\bytes are not reversed "
& "(component is little-endian)?.v?", CLC);
end if;
-- Do not allow non-contiguous field
else
Error_Msg_N
("attempt to specify non-contiguous field not "
& "permitted", CLC);
Error_Msg_N
("\caused by non-standard Bit_Order specified in "
& "legacy Ada 95 mode", CLC);
end if;
-- Case where field fits in one storage unit
else
-- Give warning if suspicious component clause
if Intval (FB) >= System_Storage_Unit
and then Warn_On_Reverse_Bit_Order
then
Error_Msg_N
("info: Bit_Order clause does not affect byte "
& "ordering?.v?", Pos);
Error_Msg_Uint_1 :=
Intval (Pos) + Intval (FB) /
System_Storage_Unit;
Error_Msg_N
("info: position normalized to ^ before bit order "
& "interpreted?.v?", Pos);
end if;
-- Here is where we fix up the Component_Bit_Offset value
-- to account for the reverse bit order. Some examples of
-- what needs to be done are:
-- First_Bit .. Last_Bit Component_Bit_Offset
-- old new old new
-- 0 .. 0 7 .. 7 0 7
-- 0 .. 1 6 .. 7 0 6
-- 0 .. 2 5 .. 7 0 5
-- 0 .. 7 0 .. 7 0 4
-- 1 .. 1 6 .. 6 1 6
-- 1 .. 4 3 .. 6 1 3
-- 4 .. 7 0 .. 3 4 0
-- The rule is that the first bit is obtained by subtracting
-- the old ending bit from storage_unit - 1.
Set_Component_Bit_Offset (Comp,
(Storage_Unit_Offset * System_Storage_Unit) +
(System_Storage_Unit - 1) -
(Start_Bit + CSZ - 1));
Set_Normalized_Position (Comp,
Component_Bit_Offset (Comp) / System_Storage_Unit);
Set_Normalized_First_Bit (Comp,
Component_Bit_Offset (Comp) mod System_Storage_Unit);
end if;
end;
end if;
Next_Component_Or_Discriminant (Comp);
end loop;
end Adjust_Record_For_Reverse_Bit_Order_Ada_95;
-------------------------------------
-- Alignment_Check_For_Size_Change --
-------------------------------------
procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint) is
begin
-- If the alignment is known, and not set by a rep clause, and is
-- inconsistent with the size being set, then reset it to unknown,
-- we assume in this case that the size overrides the inherited
-- alignment, and that the alignment must be recomputed.
if Known_Alignment (Typ)
and then not Has_Alignment_Clause (Typ)
and then Present (Size)
and then Size mod (Alignment (Typ) * SSU) /= 0
then
Reinit_Alignment (Typ);
end if;
end Alignment_Check_For_Size_Change;
-----------------------------------
-- All_Membership_Choices_Static --
-----------------------------------
function All_Membership_Choices_Static (Expr : Node_Id) return Boolean is
pragma Assert (Nkind (Expr) in N_Membership_Test);
begin
pragma Assert
(Present (Right_Opnd (Expr))
xor
Present (Alternatives (Expr)));
if Present (Right_Opnd (Expr)) then
return Is_Static_Choice (Right_Opnd (Expr));
else
return All_Static_Choices (Alternatives (Expr));
end if;
end All_Membership_Choices_Static;
------------------------
-- All_Static_Choices --
------------------------
function All_Static_Choices (L : List_Id) return Boolean is
N : Node_Id;
begin
N := First (L);
while Present (N) loop
if not Is_Static_Choice (N) then
return False;
end if;
Next (N);
end loop;
return True;
end All_Static_Choices;
-------------------------------------
-- Analyze_Aspects_At_Freeze_Point --
-------------------------------------
procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id) is
procedure Analyze_Aspect_Default_Value (ASN : Node_Id);
-- This routine analyzes an Aspect_Default_[Component_]Value denoted by
-- the aspect specification node ASN.
procedure Check_Aspect_Too_Late (N : Node_Id);
-- This procedure is similar to Rep_Item_Too_Late for representation
-- aspects that apply to type and that do not have a corresponding
-- pragma.
-- Used to check in particular that the expression associated with
-- aspect node N for the given type (entity) of the aspect does not
-- appear too late according to the rules in RM 13.1(9) and 13.1(10).
procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id);
-- As discussed in the spec of Aspects (see Aspect_Delay declaration),
-- a derived type can inherit aspects from its parent which have been
-- specified at the time of the derivation using an aspect, as in:
--
-- type A is range 1 .. 10
-- with Size => Not_Defined_Yet;
-- ..
-- type B is new A;
-- ..
-- Not_Defined_Yet : constant := 64;
--
-- In this example, the Size of A is considered to be specified prior
-- to the derivation, and thus inherited, even though the value is not
-- known at the time of derivation. To deal with this, we use two entity
-- flags. The flag Has_Derived_Rep_Aspects is set in the parent type (A
-- here), and then the flag May_Inherit_Delayed_Rep_Aspects is set in
-- the derived type (B here). If this flag is set when the derived type
-- is frozen, then this procedure is called to ensure proper inheritance
-- of all delayed aspects from the parent type. The derived type is E,
-- the argument to Analyze_Aspects_At_Freeze_Point. ASN is the first
-- aspect specification node in the Rep_Item chain for the parent type.
procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id);
-- Given an aspect specification node ASN whose expression is an
-- optional Boolean, this routines creates the corresponding pragma
-- at the freezing point.
----------------------------------
-- Analyze_Aspect_Default_Value --
----------------------------------
procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is
Ent : constant Entity_Id := Entity (ASN);
Expr : constant Node_Id := Expression (ASN);
begin
Set_Has_Default_Aspect (Base_Type (Ent));
if Is_Scalar_Type (Ent) then
Set_Default_Aspect_Value (Base_Type (Ent), Expr);
else
Set_Default_Aspect_Component_Value (Base_Type (Ent), Expr);
end if;
Check_Aspect_Too_Late (ASN);
end Analyze_Aspect_Default_Value;
---------------------------
-- Check_Aspect_Too_Late --
---------------------------
procedure Check_Aspect_Too_Late (N : Node_Id) is
Typ : constant Entity_Id := Entity (N);
Expr : constant Node_Id := Expression (N);
function Find_Type_Reference
(Typ : Entity_Id; Expr : Node_Id) return Boolean;
-- Return True if a reference to type Typ is found in the expression
-- Expr.
-------------------------
-- Find_Type_Reference --
-------------------------
function Find_Type_Reference
(Typ : Entity_Id; Expr : Node_Id) return Boolean
is
function Find_Type (N : Node_Id) return Traverse_Result;
-- Set Found to True if N refers to Typ
---------------
-- Find_Type --
---------------
function Find_Type (N : Node_Id) return Traverse_Result is
begin
if N = Typ
or else (Nkind (N) in N_Identifier | N_Expanded_Name
and then Present (Entity (N))
and then Entity (N) = Typ)
then
return Abandon;
else
return OK;
end if;
end Find_Type;
function Search_Type_Reference is new Traverse_Func (Find_Type);
begin
return Search_Type_Reference (Expr) = Abandon;
end Find_Type_Reference;
Parent_Type : Entity_Id;
begin
-- Ensure Expr is analyzed so that e.g. all types are properly
-- resolved for Find_Type_Reference.
Analyze (Expr);
-- A self-referential aspect is illegal if it forces freezing the
-- entity before the corresponding aspect has been analyzed.
if Find_Type_Reference (Typ, Expr) then
Error_Msg_NE
("aspect specification causes premature freezing of&", N, Typ);
end if;
-- For representation aspects, check for case of untagged derived
-- type whose parent either has primitive operations (pre Ada 2022),
-- or is a by-reference type (RM 13.1(10)).
-- Strictly speaking the check also applies to Ada 2012 but it is
-- really too constraining for existing code already, so relax it.
-- ??? Confirming aspects should be allowed here.
if Is_Representation_Aspect (Get_Aspect_Id (N))
and then Is_Derived_Type (Typ)
and then not Is_Tagged_Type (Typ)
then
Parent_Type := Etype (Base_Type (Typ));
if Ada_Version <= Ada_2012
and then Has_Primitive_Operations (Parent_Type)
then
Error_Msg_N
("|representation aspect not permitted before Ada 2022: " &
"use -gnat2022!", N);
Error_Msg_NE
("\parent type & has primitive operations!", N, Parent_Type);
elsif Is_By_Reference_Type (Parent_Type) then
No_Type_Rep_Item (N);
Error_Msg_NE
("\parent type & is a by-reference type!", N, Parent_Type);
end if;
end if;
end Check_Aspect_Too_Late;
---------------------------------
-- Inherit_Delayed_Rep_Aspects --
---------------------------------
procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id) is
A_Id : constant Aspect_Id := Get_Aspect_Id (ASN);
P : constant Entity_Id := Entity (ASN);
-- Entity for parent type
N : Node_Id;
-- Item from Rep_Item chain
A : Aspect_Id;
begin
-- Loop through delayed aspects for the parent type
N := ASN;
while Present (N) loop
if Nkind (N) = N_Aspect_Specification then
exit when Entity (N) /= P;
if Is_Delayed_Aspect (N) then
A := Get_Aspect_Id (Chars (Identifier (N)));
-- Process delayed rep aspect. For Boolean attributes it is
-- not possible to cancel an attribute once set (the attempt
-- to use an aspect with xxx => False is an error) for a
-- derived type. So for those cases, we do not have to check
-- if a clause has been given for the derived type, since it
-- is harmless to set it again if it is already set.
case A is
-- Alignment
when Aspect_Alignment =>
if not Has_Alignment_Clause (E) then
Set_Alignment (E, Alignment (P));
end if;
-- Atomic
when Aspect_Atomic =>
if Is_Atomic (P) then
Set_Is_Atomic (E);
end if;
-- Atomic_Components
when Aspect_Atomic_Components =>
if Has_Atomic_Components (P) then
Set_Has_Atomic_Components (Base_Type (E));
end if;
-- Bit_Order
when Aspect_Bit_Order =>
if Is_Record_Type (E)
and then No (Get_Attribute_Definition_Clause
(E, Attribute_Bit_Order))
and then Reverse_Bit_Order (P)
then
Set_Reverse_Bit_Order (Base_Type (E));
end if;
-- Component_Size
when Aspect_Component_Size =>
if Is_Array_Type (E)
and then not Has_Component_Size_Clause (E)
then
Set_Component_Size
(Base_Type (E), Component_Size (P));
end if;
-- Machine_Radix
when Aspect_Machine_Radix =>
if Is_Decimal_Fixed_Point_Type (E)
and then not Has_Machine_Radix_Clause (E)
then
Set_Machine_Radix_10 (E, Machine_Radix_10 (P));
end if;
-- Object_Size (also Size which also sets Object_Size)
when Aspect_Object_Size
| Aspect_Size
=>
if not Has_Size_Clause (E)
and then
No (Get_Attribute_Definition_Clause
(E, Attribute_Object_Size))
then
Set_Esize (E, Esize (P));
end if;
-- Pack
when Aspect_Pack =>
if not Is_Packed (E) then
Set_Is_Packed (Base_Type (E));
if Is_Bit_Packed_Array (P) then
Set_Is_Bit_Packed_Array (Base_Type (E));
Set_Packed_Array_Impl_Type
(E, Packed_Array_Impl_Type (P));
end if;
end if;
-- Scalar_Storage_Order
when Aspect_Scalar_Storage_Order =>
if (Is_Record_Type (E) or else Is_Array_Type (E))
and then No (Get_Attribute_Definition_Clause
(E, Attribute_Scalar_Storage_Order))
and then Reverse_Storage_Order (P)
then
Set_Reverse_Storage_Order (Base_Type (E));
-- Clear default SSO indications, since the aspect
-- overrides the default.
Set_SSO_Set_Low_By_Default (Base_Type (E), False);
Set_SSO_Set_High_By_Default (Base_Type (E), False);
end if;
-- Small
when Aspect_Small =>
if Is_Fixed_Point_Type (E)
and then not Has_Small_Clause (E)
then
Set_Small_Value (E, Small_Value (P));
end if;
-- Storage_Size
when Aspect_Storage_Size =>
if (Is_Access_Type (E) or else Is_Task_Type (E))
and then not Has_Storage_Size_Clause (E)
then
Set_Storage_Size_Variable
(Base_Type (E), Storage_Size_Variable (P));
end if;
-- Value_Size
when Aspect_Value_Size =>
-- Value_Size is never inherited, it is either set by
-- default, or it is explicitly set for the derived
-- type. So nothing to do here.
null;
-- Volatile
when Aspect_Volatile =>
if Is_Volatile (P) then
Set_Is_Volatile (E);
end if;
-- Volatile_Full_Access (also Full_Access_Only)
when Aspect_Volatile_Full_Access
| Aspect_Full_Access_Only
=>
if Is_Volatile_Full_Access (P) then
Set_Is_Volatile_Full_Access (E);
end if;
-- Volatile_Components
when Aspect_Volatile_Components =>
if Has_Volatile_Components (P) then
Set_Has_Volatile_Components (Base_Type (E));
end if;
-- That should be all the Rep Aspects
when others =>
pragma Assert (Aspect_Delay (A_Id) /= Rep_Aspect);
null;
end case;
end if;
end if;
Next_Rep_Item (N);
end loop;
end Inherit_Delayed_Rep_Aspects;
-------------------------------------
-- Make_Pragma_From_Boolean_Aspect --
-------------------------------------
procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id) is
Ident : constant Node_Id := Identifier (ASN);
A_Name : constant Name_Id := Chars (Ident);
A_Id : constant Aspect_Id := Get_Aspect_Id (A_Name);
Ent : constant Entity_Id := Entity (ASN);
Expr : constant Node_Id := Expression (ASN);
Loc : constant Source_Ptr := Sloc (ASN);
procedure Check_False_Aspect_For_Derived_Type;
-- This procedure checks for the case of a false aspect for a derived
-- type, which improperly tries to cancel an aspect inherited from
-- the parent.
-----------------------------------------
-- Check_False_Aspect_For_Derived_Type --
-----------------------------------------
procedure Check_False_Aspect_For_Derived_Type is
Par : Node_Id;
begin
-- We are only checking derived types
if not Is_Derived_Type (E) then
return;
end if;
Par := Nearest_Ancestor (E);
case A_Id is
when Aspect_Atomic
| Aspect_Shared
=>
if not Is_Atomic (Par) then
return;
end if;
when Aspect_Atomic_Components =>
if not Has_Atomic_Components (Par) then
return;
end if;
when Aspect_Discard_Names =>
if not Discard_Names (Par) then
return;
end if;
when Aspect_Pack =>
if not Is_Packed (Par) then
return;
end if;
when Aspect_Unchecked_Union =>
if not Is_Unchecked_Union (Par) then
return;
end if;
when Aspect_Volatile =>
if not Is_Volatile (Par) then
return;
end if;
when Aspect_Volatile_Components =>
if not Has_Volatile_Components (Par) then
return;
end if;
when Aspect_Volatile_Full_Access
| Aspect_Full_Access_Only
=>
if not Is_Volatile_Full_Access (Par) then
return;
end if;
when others =>
return;
end case;
-- Fall through means we are canceling an inherited aspect
Error_Msg_Name_1 := A_Name;
Error_Msg_NE
("derived type& inherits aspect%, cannot cancel", Expr, E);
end Check_False_Aspect_For_Derived_Type;
-- Local variables
Prag : Node_Id;
P_Name : Name_Id;
-- Start of processing for Make_Pragma_From_Boolean_Aspect
begin
if Present (Expr) and then Is_False (Static_Boolean (Expr)) then
Check_False_Aspect_For_Derived_Type;
else
-- There is no Full_Access_Only pragma so use VFA instead
if A_Name = Name_Full_Access_Only then
P_Name := Name_Volatile_Full_Access;
else
P_Name := A_Name;
end if;
Prag :=
Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Sloc (Ident), P_Name),
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ident),
Expression => New_Occurrence_Of (Ent, Sloc (Ident)))));
Set_From_Aspect_Specification (Prag, True);
Set_Corresponding_Aspect (Prag, ASN);
Set_Aspect_Rep_Item (ASN, Prag);
Set_Is_Delayed_Aspect (Prag);
Set_Parent (Prag, ASN);
end if;
end Make_Pragma_From_Boolean_Aspect;
-- Local variables
A_Id : Aspect_Id;
ASN : Node_Id;
Ritem : Node_Id;
-- Start of processing for Analyze_Aspects_At_Freeze_Point
begin
-- Must be visible in current scope, but if this is a type from a nested
-- package it may be frozen from an object declaration in the enclosing
-- scope, so install the package declarations to complete the analysis
-- of the aspects, if any. If the package itself is frozen the type will
-- have been frozen as well.
if not Scope_Within_Or_Same (Current_Scope, Scope (E)) then
if Is_Type (E) and then From_Nested_Package (E) then
declare
Pack : constant Entity_Id := Scope (E);
begin
Push_Scope (Pack);
Install_Visible_Declarations (Pack);
Install_Private_Declarations (Pack);
Analyze_Aspects_At_Freeze_Point (E);
if Is_Private_Type (E)
and then Present (Full_View (E))
then
Analyze_Aspects_At_Freeze_Point (Full_View (E));
end if;
End_Package_Scope (Pack);
return;
end;
-- Aspects from other entities in different contexts are analyzed
-- elsewhere.
else
return;
end if;
end if;
-- Look for aspect specification entries for this entity
ASN := First_Rep_Item (E);
while Present (ASN) loop
if Nkind (ASN) = N_Aspect_Specification then
exit when Entity (ASN) /= E;
if Is_Delayed_Aspect (ASN) then
A_Id := Get_Aspect_Id (ASN);
case A_Id is
-- For aspects whose expression is an optional Boolean, make
-- the corresponding pragma at the freeze point.
when Boolean_Aspects
| Library_Unit_Aspects
=>
-- Aspects Export and Import require special handling.
-- Both are by definition Boolean and may benefit from
-- forward references, however their expressions are
-- treated as static. In addition, the syntax of their
-- corresponding pragmas requires extra "pieces" which
-- may also contain forward references. To account for
-- all of this, the corresponding pragma is created by
-- Analyze_Aspect_Export_Import, but is not analyzed as
-- the complete analysis must happen now.
-- Aspect Full_Access_Only must be analyzed last so that
-- aspects Volatile and Atomic, if any, are analyzed.
-- Skip creation of pragma Preelaborable_Initialization
-- in the case where the aspect has an expression,
-- because the pragma is only needed for setting flag
-- Known_To_Have_Preelab_Init, which is set by other
-- means following resolution of the aspect expression.
if A_Id not in Aspect_Export
| Aspect_Full_Access_Only
| Aspect_Import
and then (A_Id /= Aspect_Preelaborable_Initialization
or else not Present (Expression (ASN)))
then
Make_Pragma_From_Boolean_Aspect (ASN);
end if;
-- Special handling for aspects that don't correspond to
-- pragmas/attributes.
when Aspect_Default_Value
| Aspect_Default_Component_Value
=>
-- Do not inherit aspect for anonymous base type of a
-- scalar or array type, because they apply to the first
-- subtype of the type, and will be processed when that
-- first subtype is frozen.
if Is_Derived_Type (E)
and then not Comes_From_Source (E)
and then E /= First_Subtype (E)
then
null;
else
Analyze_Aspect_Default_Value (ASN);
end if;
-- Ditto for iterator aspects, because the corresponding
-- attributes may not have been analyzed yet.
when Aspect_Constant_Indexing
| Aspect_Default_Iterator
| Aspect_Iterator_Element
| Aspect_Variable_Indexing
=>
Analyze (Expression (ASN));
if Etype (Expression (ASN)) = Any_Type then
Error_Msg_NE
("\aspect must be fully defined before & is frozen",
ASN, E);
end if;
when Aspect_Integer_Literal
| Aspect_Real_Literal
| Aspect_String_Literal
=>
Validate_Literal_Aspect (E, ASN);
when Aspect_Iterable =>
Validate_Iterable_Aspect (E, ASN);
when Aspect_Designated_Storage_Model =>
Analyze_And_Resolve (Expression (ASN));
if not Is_Entity_Name (Expression (ASN))
or else not Is_Object (Entity (Expression (ASN)))
or else
not Present (Find_Aspect (Etype (Expression (ASN)),
Aspect_Storage_Model_Type))
then
Error_Msg_N
("must specify name of stand-alone object of type "
& "with aspect Storage_Model_Type",
Expression (ASN));
-- Set access type's Associated_Storage_Pool to denote
-- the Storage_Model_Type object given for the aspect
-- (even though that isn't actually an Ada storage pool).
else
Set_Associated_Storage_Pool
(E, Entity (Expression (ASN)));
end if;
when Aspect_Storage_Model_Type =>
Validate_Storage_Model_Type_Aspect (E, ASN);
when Aspect_Aggregate =>
null;
when others =>
null;
end case;
Ritem := Aspect_Rep_Item (ASN);
if Present (Ritem) then
Analyze (Ritem);
end if;
end if;
end if;
Next_Rep_Item (ASN);
end loop;
-- Make a second pass for a Full_Access_Only entry
ASN := First_Rep_Item (E);
while Present (ASN) loop
if Nkind (ASN) = N_Aspect_Specification then
exit when Entity (ASN) /= E;
if Get_Aspect_Id (ASN) = Aspect_Full_Access_Only then
Make_Pragma_From_Boolean_Aspect (ASN);
Ritem := Aspect_Rep_Item (ASN);
if Present (Ritem) then
Analyze (Ritem);
end if;
end if;
end if;
Next_Rep_Item (ASN);
end loop;
-- This is where we inherit delayed rep aspects from our parent. Note
-- that if we fell out of the above loop with ASN non-empty, it means
-- we hit an aspect for an entity other than E, and it must be the
-- type from which we were derived.
if May_Inherit_Delayed_Rep_Aspects (E) then
Inherit_Delayed_Rep_Aspects (ASN);
end if;
if In_Instance
and then E /= Base_Type (E)
and then Is_First_Subtype (E)
then
Inherit_Rep_Item_Chain (Base_Type (E), E);
end if;
end Analyze_Aspects_At_Freeze_Point;
-----------------------------------
-- Analyze_Aspect_Specifications --
-----------------------------------
procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is
pragma Assert (Present (E));
procedure Decorate (Asp : Node_Id; Prag : Node_Id);
-- Establish linkages between an aspect and its corresponding pragma
procedure Insert_Pragma
(Prag : Node_Id;
Is_Instance : Boolean := False);
-- Subsidiary to the analysis of aspects
-- Abstract_State
-- Attach_Handler
-- Contract_Cases
-- Depends
-- Ghost
-- Global
-- Initial_Condition
-- Initializes
-- Post
-- Pre
-- Refined_Depends
-- Refined_Global
-- Refined_State
-- SPARK_Mode
-- Subprogram_Variant
-- Warnings
-- Insert pragma Prag such that it mimics the placement of a source
-- pragma of the same kind. Flag Is_Generic should be set when the
-- context denotes a generic instance.
--------------
-- Decorate --
--------------
procedure Decorate (Asp : Node_Id; Prag : Node_Id) is
begin
Set_Aspect_Rep_Item (Asp, Prag);
Set_Corresponding_Aspect (Prag, Asp);
Set_From_Aspect_Specification (Prag);
Set_Parent (Prag, Asp);
end Decorate;
-------------------
-- Insert_Pragma --
-------------------
procedure Insert_Pragma
(Prag : Node_Id;
Is_Instance : Boolean := False)
is
Aux : Node_Id;
Decl : Node_Id;
Decls : List_Id;
Def : Node_Id;
Inserted : Boolean := False;
begin
-- When the aspect appears on an entry, package, protected unit,
-- subprogram, or task unit body, insert the generated pragma at the
-- top of the body declarations to emulate the behavior of a source
-- pragma.
-- package body Pack with Aspect is
-- package body Pack is
-- pragma Prag;
if Nkind (N) in N_Entry_Body
| N_Package_Body
| N_Protected_Body
| N_Subprogram_Body
| N_Task_Body
then
Decls := Declarations (N);
if No (Decls) then
Decls := New_List;
Set_Declarations (N, Decls);
end if;
Prepend_To (Decls, Prag);
-- When the aspect is associated with a [generic] package declaration
-- insert the generated pragma at the top of the visible declarations
-- to emulate the behavior of a source pragma.
-- package Pack with Aspect is
-- package Pack is
-- pragma Prag;
elsif Nkind (N) in N_Generic_Package_Declaration
| N_Package_Declaration
then
Decls := Visible_Declarations (Specification (N));
if No (Decls) then
Decls := New_List;
Set_Visible_Declarations (Specification (N), Decls);
end if;
-- The visible declarations of a generic instance have the
-- following structure:
-- <renamings of generic formals>
-- <renamings of internally-generated spec and body>
-- <first source declaration>
-- Insert the pragma before the first source declaration by
-- skipping the instance "header" to ensure proper visibility of
-- all formals.
if Is_Instance then
Decl := First (Decls);
while Present (Decl) loop
if Comes_From_Source (Decl) then
Insert_Before (Decl, Prag);
Inserted := True;
exit;
else
Next (Decl);
end if;
end loop;
-- The pragma is placed after the instance "header"
if not Inserted then
Append_To (Decls, Prag);
end if;
-- Otherwise this is not a generic instance
else
Prepend_To (Decls, Prag);
end if;
-- When the aspect is associated with a protected unit declaration,
-- insert the generated pragma at the top of the visible declarations
-- the emulate the behavior of a source pragma.
-- protected [type] Prot with Aspect is
-- protected [type] Prot is
-- pragma Prag;
elsif Nkind (N) = N_Protected_Type_Declaration then
Def := Protected_Definition (N);
if No (Def) then
Def :=
Make_Protected_Definition (Sloc (N),
Visible_Declarations => New_List,
End_Label => Empty);
Set_Protected_Definition (N, Def);
end if;
Decls := Visible_Declarations (Def);
if No (Decls) then
Decls := New_List;
Set_Visible_Declarations (Def, Decls);
end if;
Prepend_To (Decls, Prag);
-- When the aspect is associated with a task unit declaration, insert
-- insert the generated pragma at the top of the visible declarations
-- the emulate the behavior of a source pragma.
-- task [type] Prot with Aspect is
-- task [type] Prot is
-- pragma Prag;
elsif Nkind (N) = N_Task_Type_Declaration then
Def := Task_Definition (N);
if No (Def) then
Def :=
Make_Task_Definition (Sloc (N),
Visible_Declarations => New_List,
End_Label => Empty);
Set_Task_Definition (N, Def);
end if;
Decls := Visible_Declarations (Def);
if No (Decls) then
Decls := New_List;
Set_Visible_Declarations (Def, Decls);
end if;
Prepend_To (Decls, Prag);
-- When the context is a library unit, the pragma is added to the
-- Pragmas_After list.
elsif Nkind (Parent (N)) = N_Compilation_Unit then
Aux := Aux_Decls_Node (Parent (N));
if No (Pragmas_After (Aux)) then
Set_Pragmas_After (Aux, New_List);
end if;
Prepend (Prag, Pragmas_After (Aux));
-- Default, the pragma is inserted after the context
else
Insert_After (N, Prag);
end if;
end Insert_Pragma;
-- Local variables
Aspect : Node_Id;
Aitem : Node_Id := Empty;
Ent : Node_Id;
L : constant List_Id := Aspect_Specifications (N);
pragma Assert (Present (L));
Ins_Node : Node_Id := N;
-- Insert pragmas/attribute definition clause after this node when no
-- delayed analysis is required.
-- Start of processing for Analyze_Aspect_Specifications
begin
-- The general processing involves building an attribute definition
-- clause or a pragma node that corresponds to the aspect. Then in order
-- to delay the evaluation of this aspect to the freeze point, we attach
-- the corresponding pragma/attribute definition clause to the aspect
-- specification node, which is then placed in the Rep Item chain. In
-- this case we mark the entity by setting the flag Has_Delayed_Aspects
-- and we evaluate the rep item at the freeze point. When the aspect
-- doesn't have a corresponding pragma/attribute definition clause, then
-- its analysis is simply delayed at the freeze point.
-- Some special cases don't require delay analysis, thus the aspect is
-- analyzed right now.
-- Note that there is a special handling for Pre, Post, Test_Case,
-- Contract_Cases and Subprogram_Variant aspects. In these cases, we do
-- not have to worry about delay issues, since the pragmas themselves
-- deal with delay of visibility for the expression analysis. Thus, we
-- just insert the pragma after the node N.
-- Loop through aspects
Aspect := First (L);
Aspect_Loop : while Present (Aspect) loop
Analyze_One_Aspect : declare
Aspect_Exit : exception;
-- This exception is used to exit aspect processing completely. It
-- is used when an error is detected, and no further processing is
-- required. It is also used if an earlier error has left the tree
-- in a state where the aspect should not be processed.
Expr : constant Node_Id := Expression (Aspect);
Id : constant Node_Id := Identifier (Aspect);
Loc : constant Source_Ptr := Sloc (Aspect);
Nam : constant Name_Id := Chars (Id);
A_Id : constant Aspect_Id := Get_Aspect_Id (Nam);
Anod : Node_Id;
Delay_Required : Boolean;
-- Set False if delay is not required
Eloc : Source_Ptr := No_Location;
-- Source location of expression, modified when we split PPC's. It
-- is set below when Expr is present.
procedure Analyze_Aspect_Convention;
-- Perform analysis of aspect Convention
procedure Analyze_Aspect_Disable_Controlled;
-- Perform analysis of aspect Disable_Controlled
procedure Analyze_Aspect_Export_Import;
-- Perform analysis of aspects Export or Import
procedure Analyze_Aspect_External_Link_Name;
-- Perform analysis of aspects External_Name or Link_Name
procedure Analyze_Aspect_Implicit_Dereference;
-- Perform analysis of the Implicit_Dereference aspects
procedure Analyze_Aspect_Relaxed_Initialization;
-- Perform analysis of aspect Relaxed_Initialization
procedure Analyze_Aspect_Yield;
-- Perform analysis of aspect Yield
procedure Analyze_Aspect_Static;
-- Ada 2022 (AI12-0075): Perform analysis of aspect Static
procedure Check_Expr_Is_OK_Static_Expression
(Expr : Node_Id;
Typ : Entity_Id := Empty);
-- Check the specified expression Expr to make sure that it is a
-- static expression of the given type (i.e. it will be analyzed
-- and resolved using this type, which can be any valid argument
-- to Resolve, e.g. Any_Integer is OK). If not, give an error
-- and raise Aspect_Exit. If Typ is left Empty, then any static
-- expression is allowed. Includes checking that the expression
-- does not raise Constraint_Error.
function Directly_Specified
(Id : Entity_Id; A : Aspect_Id) return Boolean;
-- Returns True if the given aspect is directly (as opposed to
-- via any form of inheritance) specified for the given entity.
function Make_Aitem_Pragma
(Pragma_Argument_Associations : List_Id;
Pragma_Name : Name_Id) return Node_Id;
-- This is a wrapper for Make_Pragma used for converting aspects
-- to pragmas. It takes care of Sloc (set from Loc) and building
-- the pragma identifier from the given name. In addition the
-- flags Class_Present and Split_PPC are set from the aspect
-- node, as well as Is_Ignored. This routine also sets the
-- From_Aspect_Specification in the resulting pragma node to
-- True, and sets Corresponding_Aspect to point to the aspect.
-- The resulting pragma is assigned to Aitem.
-------------------------------
-- Analyze_Aspect_Convention --
-------------------------------
procedure Analyze_Aspect_Convention is
Conv : Node_Id;
Dummy_1 : Node_Id;
Dummy_2 : Node_Id;
Dummy_3 : Node_Id;
Expo : Node_Id;
Imp : Node_Id;
begin
-- Obtain all interfacing aspects that apply to the related
-- entity.
Get_Interfacing_Aspects
(Iface_Asp => Aspect,
Conv_Asp => Dummy_1,
EN_Asp => Dummy_2,
Expo_Asp => Expo,
Imp_Asp => Imp,
LN_Asp => Dummy_3,
Do_Checks => True);
-- The related entity is subject to aspect Export or Import.
-- Do not process Convention now because it must be analysed
-- as part of Export or Import.
if Present (Expo) or else Present (Imp) then
return;
-- Otherwise Convention appears by itself
else
-- The aspect specifies a particular convention
if Present (Expr) then
Conv := New_Copy_Tree (Expr);
-- Otherwise assume convention Ada
else
Conv := Make_Identifier (Loc, Name_Ada);
end if;
-- Generate:
-- pragma Convention (<Conv>, <E>);
Aitem := Make_Aitem_Pragma
(Pragma_Name => Name_Convention,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Conv),
Make_Pragma_Argument_Association (Loc,
Expression => New_Occurrence_Of (E, Loc))));
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
end if;
end Analyze_Aspect_Convention;
---------------------------------------
-- Analyze_Aspect_Disable_Controlled --
---------------------------------------
procedure Analyze_Aspect_Disable_Controlled is
begin
-- The aspect applies only to controlled records
if not (Ekind (E) = E_Record_Type
and then Is_Controlled_Active (E))
then
Error_Msg_N
("aspect % requires controlled record type", Aspect);
return;
end if;
-- Preanalyze the expression (if any) when the aspect resides
-- in a generic unit.
if Inside_A_Generic then
if Present (Expr) then
Preanalyze_And_Resolve (Expr, Any_Boolean);
end if;
-- Otherwise the aspect resides in a nongeneric context
else
-- A controlled record type loses its controlled semantics
-- when the expression statically evaluates to True.
if Present (Expr) then
Analyze_And_Resolve (Expr, Any_Boolean);
if Is_OK_Static_Expression (Expr) then
if Is_True (Static_Boolean (Expr)) then
Set_Disable_Controlled (E);
end if;
-- Otherwise the expression is not static
else
Error_Msg_N
("expression of aspect % must be static", Aspect);
end if;
-- Otherwise the aspect appears without an expression and
-- defaults to True.
else
Set_Disable_Controlled (E);
end if;
end if;
end Analyze_Aspect_Disable_Controlled;
----------------------------------
-- Analyze_Aspect_Export_Import --
----------------------------------
procedure Analyze_Aspect_Export_Import is
Dummy_1 : Node_Id;
Dummy_2 : Node_Id;
Dummy_3 : Node_Id;
Expo : Node_Id;
Imp : Node_Id;
begin
-- Obtain all interfacing aspects that apply to the related
-- entity.
Get_Interfacing_Aspects
(Iface_Asp => Aspect,
Conv_Asp => Dummy_1,
EN_Asp => Dummy_2,
Expo_Asp => Expo,
Imp_Asp => Imp,
LN_Asp => Dummy_3,
Do_Checks => True);
-- The related entity cannot be subject to both aspects Export
-- and Import.
if Present (Expo) and then Present (Imp) then
Error_Msg_N
("incompatible interfacing aspects given for &", E);
Error_Msg_Sloc := Sloc (Expo);
Error_Msg_N ("\aspect Export #", E);
Error_Msg_Sloc := Sloc (Imp);
Error_Msg_N ("\aspect Import #", E);
end if;
-- A variable is most likely modified from the outside. Take
-- the optimistic approach to avoid spurious errors.
if Ekind (E) = E_Variable then
Set_Never_Set_In_Source (E, False);
end if;
-- Resolve the expression of an Import or Export here, and
-- require it to be of type Boolean and static. This is not
-- quite right, because in general this should be delayed,
-- but that seems tricky for these, because normally Boolean
-- aspects are replaced with pragmas at the freeze point in
-- Make_Pragma_From_Boolean_Aspect.
if not Present (Expr)
or else Is_True (Static_Boolean (Expr))
then
if A_Id = Aspect_Import then
Set_Has_Completion (E);
Set_Is_Imported (E);
-- An imported object cannot be explicitly initialized
if Nkind (N) = N_Object_Declaration
and then Present (Expression (N))
then
Error_Msg_N
("imported entities cannot be initialized "
& "(RM B.1(24))", Expression (N));
end if;
else
pragma Assert (A_Id = Aspect_Export);
Set_Is_Exported (E);
end if;
-- Create the proper form of pragma Export or Import taking
-- into account Conversion, External_Name, and Link_Name.
Aitem := Build_Export_Import_Pragma (Aspect, E);
-- Otherwise the expression is either False or erroneous. There
-- is no corresponding pragma.
else
Aitem := Empty;
end if;
end Analyze_Aspect_Export_Import;
---------------------------------------
-- Analyze_Aspect_External_Link_Name --
---------------------------------------
procedure Analyze_Aspect_External_Link_Name is
Dummy_1 : Node_Id;
Dummy_2 : Node_Id;
Dummy_3 : Node_Id;
Expo : Node_Id;
Imp : Node_Id;
begin
-- Obtain all interfacing aspects that apply to the related
-- entity.
Get_Interfacing_Aspects
(Iface_Asp => Aspect,
Conv_Asp => Dummy_1,
EN_Asp => Dummy_2,
Expo_Asp => Expo,
Imp_Asp => Imp,
LN_Asp => Dummy_3,
Do_Checks => True);
-- Ensure that aspect External_Name applies to aspect Export or
-- Import.
if A_Id = Aspect_External_Name then
if No (Expo) and then No (Imp) then
Error_Msg_N
("aspect External_Name requires aspect Import or "
& "Export", Aspect);
end if;
-- Otherwise ensure that aspect Link_Name applies to aspect
-- Export or Import.
else
pragma Assert (A_Id = Aspect_Link_Name);
if No (Expo) and then No (Imp) then
Error_Msg_N
("aspect Link_Name requires aspect Import or Export",
Aspect);
end if;
end if;
end Analyze_Aspect_External_Link_Name;
-----------------------------------------
-- Analyze_Aspect_Implicit_Dereference --
-----------------------------------------
procedure Analyze_Aspect_Implicit_Dereference is
begin
if not Is_Type (E) or else not Has_Discriminants (E) then
Error_Msg_N
("aspect must apply to a type with discriminants", Expr);
elsif not Is_Entity_Name (Expr) then
Error_Msg_N
("aspect must name a discriminant of current type", Expr);
else
-- Discriminant type be an anonymous access type or an
-- anonymous access to subprogram.
-- Missing synchronized types???
declare
Disc : Entity_Id := First_Discriminant (E);
begin
while Present (Disc) loop
if Chars (Expr) = Chars (Disc)
and then Ekind (Etype (Disc)) in
E_Anonymous_Access_Subprogram_Type |
E_Anonymous_Access_Type
then
Set_Has_Implicit_Dereference (E);
Set_Has_Implicit_Dereference (Disc);
exit;
end if;
Next_Discriminant (Disc);
end loop;
-- Error if no proper access discriminant
if Present (Disc) then
-- For a type extension, check whether parent has
-- a reference discriminant, to verify that use is
-- proper.
if Is_Derived_Type (E)
and then Has_Discriminants (Etype (E))
then
declare
Parent_Disc : constant Entity_Id :=
Get_Reference_Discriminant (Etype (E));
begin
if Present (Parent_Disc)
and then Corresponding_Discriminant (Disc) /=
Parent_Disc
then
Error_Msg_N
("reference discriminant does not match "
& "discriminant of parent type", Expr);
end if;
end;
end if;
else
Error_Msg_NE
("not an access discriminant of&", Expr, E);
end if;
end;
end if;
end Analyze_Aspect_Implicit_Dereference;
-------------------------------------------
-- Analyze_Aspect_Relaxed_Initialization --
-------------------------------------------
procedure Analyze_Aspect_Relaxed_Initialization is
procedure Analyze_Relaxed_Parameter
(Subp_Id : Entity_Id;
Param : Node_Id;
Seen : in out Elist_Id);
-- Analyze parameter that appears in the expression of the
-- aspect Relaxed_Initialization.
-------------------------------
-- Analyze_Relaxed_Parameter --
-------------------------------
procedure Analyze_Relaxed_Parameter
(Subp_Id : Entity_Id;
Param : Node_Id;
Seen : in out Elist_Id)
is
begin
-- Set name of the aspect for error messages
Error_Msg_Name_1 := Nam;
-- The relaxed parameter is a formal parameter
if Nkind (Param) in N_Identifier | N_Expanded_Name then
Analyze (Param);
declare
Item : constant Entity_Id := Entity (Param);
begin
-- It must be a formal of the analyzed subprogram
if Scope (Item) = Subp_Id then
pragma Assert (Is_Formal (Item));
-- It must not have scalar or access type
if Is_Elementary_Type (Etype (Item)) then
Error_Msg_N ("illegal aspect % item", Param);
Error_Msg_N
("\item must not have elementary type", Param);
end if;
-- Detect duplicated items
if Contains (Seen, Item) then
Error_Msg_N ("duplicate aspect % item", Param);
else
Append_New_Elmt (Item, Seen);
end if;
else
Error_Msg_N ("illegal aspect % item", Param);
end if;
end;
-- The relaxed parameter is the function's Result attribute
elsif Is_Attribute_Result (Param) then
Analyze (Param);
declare
Pref : constant Node_Id := Prefix (Param);
begin
if Present (Pref)
and then
Nkind (Pref) in N_Identifier | N_Expanded_Name
and then
Entity (Pref) = Subp_Id
then
-- Function result must not have scalar or access
-- type.
if Is_Elementary_Type (Etype (Pref)) then
Error_Msg_N ("illegal aspect % item", Param);
Error_Msg_N
("\function result must not have elementary"
& " type", Param);
end if;
-- Detect duplicated items
if Contains (Seen, Subp_Id) then
Error_Msg_N ("duplicate aspect % item", Param);
else
Append_New_Elmt (Entity (Pref), Seen);
end if;
else
Error_Msg_N ("illegal aspect % item", Param);
end if;
end;
else
Error_Msg_N ("illegal aspect % item", Param);
end if;
end Analyze_Relaxed_Parameter;
-- Local variables
Seen : Elist_Id := No_Elist;
-- Items that appear in the relaxed initialization aspect
-- expression of a subprogram; for detecting duplicates.
Restore_Scope : Boolean;
-- Will be set to True if we need to restore the scope table
-- after analyzing the aspect expression.
Prev_Id : Entity_Id;
-- Start of processing for Analyze_Aspect_Relaxed_Initialization
begin
-- Set name of the aspect for error messages
Error_Msg_Name_1 := Nam;
-- Annotation of a type; no aspect expression is allowed.
-- For a private type, the aspect must be attached to the
-- partial view.
--
-- ??? Once the exact rule for this aspect is ready, we will
-- likely reject concurrent types, etc., so let's keep the code
-- for types and variable separate.
if Is_First_Subtype (E) then
Prev_Id := Incomplete_Or_Partial_View (E);
if Present (Prev_Id) then
-- Aspect may appear on the full view of an incomplete
-- type because the incomplete declaration cannot have
-- any aspects.
if Ekind (Prev_Id) = E_Incomplete_Type then
null;
else
Error_Msg_N ("aspect % must apply to partial view", N);
end if;
elsif Present (Expr) then
Error_Msg_N ("illegal aspect % expression", Expr);
end if;
-- Annotation of a variable; no aspect expression is allowed
elsif Ekind (E) = E_Variable then
if Present (Expr) then
Error_Msg_N ("illegal aspect % expression", Expr);
end if;
-- Annotation of a constant; no aspect expression is allowed.
-- For a deferred constant, the aspect must be attached to the
-- partial view.
elsif Ekind (E) = E_Constant then
if Present (Incomplete_Or_Partial_View (E)) then
Error_Msg_N
("aspect % must apply to deferred constant", N);
elsif Present (Expr) then
Error_Msg_N ("illegal aspect % expression", Expr);
end if;
-- Annotation of a subprogram; aspect expression is required
elsif Is_Subprogram_Or_Entry (E)
or else Is_Generic_Subprogram (E)
then
if Present (Expr) then
-- If we analyze subprogram body that acts as its own
-- spec, then the subprogram itself and its formals are
-- already installed; otherwise, we need to install them,
-- as they must be visible when analyzing the aspect
-- expression.
if In_Open_Scopes (E) then
Restore_Scope := False;
else
Restore_Scope := True;
Push_Scope (E);
-- Only formals of the subprogram itself can appear
-- in Relaxed_Initialization aspect expression, not
-- formals of the enclosing generic unit. (This is
-- different than in Precondition or Depends aspects,
-- where both kinds of formals are allowed.)
Install_Formals (E);
end if;
-- Aspect expression is either an aggregate with list of
-- parameters (and possibly the Result attribute for a
-- function).
if Nkind (Expr) = N_Aggregate then
-- Component associations in the aggregate must be a
-- parameter name followed by a static boolean
-- expression.
if Present (Component_Associations (Expr)) then
declare
Assoc : Node_Id :=
First (Component_Associations (Expr));
begin
while Present (Assoc) loop
if List_Length (Choices (Assoc)) = 1 then
Analyze_Relaxed_Parameter
(E, First (Choices (Assoc)), Seen);
if Inside_A_Generic then
Preanalyze_And_Resolve
(Expression (Assoc), Any_Boolean);
else
Analyze_And_Resolve
(Expression (Assoc), Any_Boolean);
end if;
if not Is_OK_Static_Expression
(Expression (Assoc))
then
Error_Msg_Name_1 := Nam;
Error_Msg_N
("expression of aspect %" &
"must be static", Aspect);
end if;
else
Error_Msg_Name_1 := Nam;
Error_Msg_N
("illegal aspect % expression", Expr);
end if;
Next (Assoc);
end loop;
end;
end if;
-- Expressions of the aggregate are parameter names
if Present (Expressions (Expr)) then
declare
Param : Node_Id := First (Expressions (Expr));
begin
while Present (Param) loop
Analyze_Relaxed_Parameter (E, Param, Seen);
Next (Param);
end loop;
end;
end if;
-- Mark the aggregate expression itself as analyzed;
-- its subexpressions were marked when they themselves
-- were analyzed.
Set_Analyzed (Expr);
-- Otherwise, it is a single name of a subprogram
-- parameter (or possibly the Result attribute for
-- a function).
else
Analyze_Relaxed_Parameter (E, Expr, Seen);
end if;
if Restore_Scope then
End_Scope;
end if;
else
Error_Msg_N ("missing expression for aspect %", N);
end if;
else
Error_Msg_N ("inappropriate entity for aspect %", E);
end if;
end Analyze_Aspect_Relaxed_Initialization;
---------------------------
-- Analyze_Aspect_Static --
---------------------------
procedure Analyze_Aspect_Static is
function Has_Convention_Intrinsic (L : List_Id) return Boolean;
-- Return True if L contains a pragma argument association
-- node representing a convention Intrinsic.
------------------------------
-- Has_Convention_Intrinsic --
------------------------------
function Has_Convention_Intrinsic
(L : List_Id) return Boolean
is
Arg : Node_Id := First (L);
begin
while Present (Arg) loop
if Nkind (Arg) = N_Pragma_Argument_Association
and then Chars (Arg) = Name_Convention
and then Chars (Expression (Arg)) = Name_Intrinsic
then
return True;
end if;
Next (Arg);
end loop;
return False;
end Has_Convention_Intrinsic;
Is_Imported_Intrinsic : Boolean;
begin
if Ada_Version < Ada_2022 then
Error_Msg_Ada_2022_Feature ("aspect %", Sloc (Aspect));
return;
end if;
Is_Imported_Intrinsic := Is_Imported (E)
and then
Has_Convention_Intrinsic
(Pragma_Argument_Associations (Import_Pragma (E)));
-- The aspect applies only to expression functions that
-- statisfy the requirements for a static expression function
-- (such as having an expression that is predicate-static) as
-- well as Intrinsic imported functions as a -gnatX extension.
if not Is_Expression_Function (E)
and then
not (Extensions_Allowed and then Is_Imported_Intrinsic)
then
if Extensions_Allowed then
Error_Msg_N
("aspect % requires intrinsic or expression function",
Aspect);
elsif Is_Imported_Intrinsic then
Error_Msg_N
("aspect % on intrinsic function is an extension: " &
"use -gnatX",
Aspect);
else
Error_Msg_N
("aspect % requires expression function", Aspect);
end if;
return;
-- Ada 2022 (AI12-0075): Check that the function satisfies
-- several requirements of static functions as specified in
-- RM 6.8(5.1-5.8). Note that some of the requirements given
-- there are checked elsewhere.
else
-- The expression of the expression function must be a
-- potentially static expression (RM 2022 6.8(3.2-3.4)).
-- That's checked in Sem_Ch6.Analyze_Expression_Function.
-- The function must not contain any calls to itself, which
-- is checked in Sem_Res.Resolve_Call.
-- Each formal must be of mode in and have a static subtype
declare
Formal : Entity_Id := First_Formal (E);
begin
while Present (Formal) loop
if Ekind (Formal) /= E_In_Parameter then
Error_Msg_N
("aspect % requires formals of mode IN",
Aspect);
return;
end if;
if not Is_Static_Subtype (Etype (Formal)) then
Error_Msg_N
("aspect % requires formals with static subtypes",
Aspect);
return;
end if;
Next_Formal (Formal);
end loop;
end;
-- The function's result subtype must be a static subtype
if not Is_Static_Subtype (Etype (E)) then
Error_Msg_N
("aspect % requires function with result of "
& "a static subtype",
Aspect);
return;
end if;
-- Check that the function does not have any applicable
-- precondition or postcondition expression.
for Asp in Pre_Post_Aspects loop
if Has_Aspect (E, Asp) then
Error_Msg_Name_1 := Aspect_Names (Asp);
Error_Msg_N
("aspect % is not allowed for a static "
& "expression function",
Find_Aspect (E, Asp));
return;
end if;
end loop;
-- ??? Must check that "for result type R, if the
-- function is a boundary entity for type R (see 7.3.2),
-- no type invariant applies to type R; if R has a
-- component type C, a similar rule applies to C."
end if;
-- When the expression is present, it must be static. If it
-- evaluates to True, the expression function is treated as
-- a static function. Otherwise the aspect appears without
-- an expression and defaults to True.
if Present (Expr) then
-- Preanalyze the expression when the aspect resides in a
-- generic unit. (Is this generic-related code necessary
-- for this aspect? It's modeled on what's done for aspect
-- Disable_Controlled. ???)
if Inside_A_Generic then
Preanalyze_And_Resolve (Expr, Any_Boolean);
-- Otherwise the aspect resides in a nongeneric context
else
Analyze_And_Resolve (Expr, Any_Boolean);
-- Error if the boolean expression is not static
if not Is_OK_Static_Expression (Expr) then
Error_Msg_N
("expression of aspect % must be static", Aspect);
end if;
end if;
end if;
end Analyze_Aspect_Static;
--------------------------
-- Analyze_Aspect_Yield --
--------------------------
procedure Analyze_Aspect_Yield is
Expr_Value : Boolean := False;
begin
-- Check valid declarations for 'Yield
if Nkind (N) in N_Abstract_Subprogram_Declaration
| N_Entry_Declaration
| N_Generic_Subprogram_Declaration
| N_Subprogram_Declaration
| N_Formal_Subprogram_Declaration
and then not Within_Protected_Type (E)
then
null;
elsif Within_Protected_Type (E) then
Error_Msg_N
("aspect% not applicable to protected operation", Id);
return;
else
Error_Msg_N
("aspect% only applicable to subprogram and entry "
& "declarations", Id);
return;
end if;
-- Evaluate its static expression (if available); otherwise it
-- defaults to True.
if No (Expr) then
Expr_Value := True;
-- Otherwise it must have a static boolean expression
else
if Inside_A_Generic then
Preanalyze_And_Resolve (Expr, Any_Boolean);
else
Analyze_And_Resolve (Expr, Any_Boolean);
end if;
if Is_OK_Static_Expression (Expr) then
if Is_True (Static_Boolean (Expr)) then
Expr_Value := True;
end if;
else
Error_Msg_N
("expression of aspect % must be static", Aspect);
end if;
end if;
if Expr_Value then
Set_Has_Yield_Aspect (E);
end if;
-- If the Yield aspect is specified for a dispatching
-- subprogram that inherits the aspect, the specified
-- value shall be confirming.
if Present (Expr)
and then Is_Dispatching_Operation (E)
and then Present (Overridden_Operation (E))
and then Has_Yield_Aspect (Overridden_Operation (E))
/= Is_True (Static_Boolean (Expr))
then
Error_Msg_N ("specification of inherited aspect% can only " &
"confirm parent value", Id);
end if;
end Analyze_Aspect_Yield;
----------------------------------------
-- Check_Expr_Is_OK_Static_Expression --
----------------------------------------
procedure Check_Expr_Is_OK_Static_Expression
(Expr : Node_Id;
Typ : Entity_Id := Empty)
is
begin
if Present (Typ) then
Analyze_And_Resolve (Expr, Typ);
else
Analyze_And_Resolve (Expr);
end if;
-- An expression cannot be considered static if its resolution
-- failed or if it's erroneous. Stop the analysis of the
-- related aspect.
if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
raise Aspect_Exit;
elsif Is_OK_Static_Expression (Expr) then
return;
-- Finally, we have a real error
else
Error_Msg_Name_1 := Nam;
Flag_Non_Static_Expr
("entity for aspect% must be a static expression",
Expr);
raise Aspect_Exit;
end if;
end Check_Expr_Is_OK_Static_Expression;
------------------------
-- Directly_Specified --
------------------------
function Directly_Specified
(Id : Entity_Id; A : Aspect_Id) return Boolean
is
Aspect_Spec : constant Node_Id := Find_Aspect (Id, A);
begin
return Present (Aspect_Spec) and then Entity (Aspect_Spec) = Id;
end Directly_Specified;
-----------------------
-- Make_Aitem_Pragma --
-----------------------
function Make_Aitem_Pragma
(Pragma_Argument_Associations : List_Id;
Pragma_Name : Name_Id) return Node_Id
is
Args : List_Id := Pragma_Argument_Associations;
Aitem : Node_Id;
begin
-- We should never get here if aspect was disabled
pragma Assert (not Is_Disabled (Aspect));
-- Certain aspects allow for an optional name or expression. Do
-- not generate a pragma with empty argument association list.
if No (Args) or else No (Expression (First (Args))) then
Args := No_List;
end if;
-- Build the pragma
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations => Args,
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Pragma_Name),
Class_Present => Class_Present (Aspect),
Split_PPC => Split_PPC (Aspect));
-- Set additional semantic fields
if Is_Ignored (Aspect) then
Set_Is_Ignored (Aitem);
elsif Is_Checked (Aspect) then
Set_Is_Checked (Aitem);
end if;
Set_Corresponding_Aspect (Aitem, Aspect);
Set_From_Aspect_Specification (Aitem);
return Aitem;
end Make_Aitem_Pragma;
-- Start of processing for Analyze_One_Aspect
begin
-- Skip aspect if already analyzed, to avoid looping in some cases
if Analyzed (Aspect) then
goto Continue;
end if;
-- Skip looking at aspect if it is totally disabled. Just mark it
-- as such for later reference in the tree. This also sets the
-- Is_Ignored and Is_Checked flags appropriately.
Check_Applicable_Policy (Aspect);
if Is_Disabled (Aspect) then
goto Continue;
end if;
-- Set the source location of expression, used in the case of
-- a failed precondition/postcondition or invariant. Note that
-- the source location of the expression is not usually the best
-- choice here. For example, it gets located on the last AND
-- keyword in a chain of boolean expressiond AND'ed together.
-- It is best to put the message on the first character of the
-- assertion, which is the effect of the First_Node call here.
if Present (Expr) then
Eloc := Sloc (First_Node (Expr));
end if;
-- Check restriction No_Implementation_Aspect_Specifications
if Implementation_Defined_Aspect (A_Id) then
Check_Restriction
(No_Implementation_Aspect_Specifications, Aspect);
end if;
-- Check restriction No_Specification_Of_Aspect
Check_Restriction_No_Specification_Of_Aspect (Aspect);
-- Mark aspect analyzed (actual analysis is delayed till later)
Set_Analyzed (Aspect);
Set_Entity (Aspect, E);
-- Build the reference to E that will be used in the built pragmas
Ent := New_Occurrence_Of (E, Sloc (Id));
if A_Id in Aspect_Attach_Handler | Aspect_Interrupt_Handler then
-- Treat the specification as a reference to the protected
-- operation, which might otherwise appear unreferenced and
-- generate spurious warnings.
Generate_Reference (E, Id);
end if;
-- Check for duplicate aspect. Note that the Comes_From_Source
-- test allows duplicate Pre/Post's that we generate internally
-- to escape being flagged here.
if No_Duplicates_Allowed (A_Id) then
Anod := First (L);
while Anod /= Aspect loop
if Comes_From_Source (Aspect)
and then Same_Aspect (A_Id, Get_Aspect_Id (Anod))
then
Error_Msg_Name_1 := Nam;
Error_Msg_Sloc := Sloc (Anod);
-- Case of same aspect specified twice
if Class_Present (Anod) = Class_Present (Aspect) then
if not Class_Present (Anod) then
Error_Msg_NE
("aspect% for & previously given#",
Id, E);
else
Error_Msg_NE
("aspect `%''Class` for & previously given#",
Id, E);
end if;
end if;
end if;
Next (Anod);
end loop;
end if;
-- Check some general restrictions on language defined aspects
if not Implementation_Defined_Aspect (A_Id)
or else A_Id in Aspect_Async_Readers
| Aspect_Async_Writers
| Aspect_Effective_Reads
| Aspect_Effective_Writes
| Aspect_Preelaborable_Initialization
then
Error_Msg_Name_1 := Nam;
-- Not allowed for renaming declarations. Examine the original
-- node because a subprogram renaming may have been rewritten
-- as a body.
if Nkind (Original_Node (N)) in N_Renaming_Declaration then
Error_Msg_N
("aspect % not allowed for renaming declaration",
Aspect);
end if;
-- Not allowed for formal type declarations in previous
-- versions of the language. Allowed for them only for
-- shared variable control aspects.
-- Original node is used in case expansion rewrote the node -
-- as is the case with generic derived types.
if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then
if Ada_Version < Ada_2022 then
Error_Msg_N
("aspect % not allowed for formal type declaration",
Aspect);
elsif A_Id not in Aspect_Atomic
| Aspect_Volatile
| Aspect_Independent
| Aspect_Atomic_Components
| Aspect_Independent_Components
| Aspect_Volatile_Components
| Aspect_Async_Readers
| Aspect_Async_Writers
| Aspect_Effective_Reads
| Aspect_Effective_Writes
| Aspect_Preelaborable_Initialization
then
Error_Msg_N
("aspect % not allowed for formal type declaration",
Aspect);
end if;
end if;
end if;
-- Copy expression for later processing by the procedures
-- Check_Aspect_At_[Freeze_Point | End_Of_Declarations]
-- The expression may be a subprogram name, and can
-- be an operator name that appears as a string, but
-- requires its own analysis procedure (see sem_ch6).
if Nkind (Expr) = N_Operator_Symbol then
Set_Entity (Id, Expr);
else
Set_Entity (Id, New_Copy_Tree (Expr));
end if;
-- Set Delay_Required as appropriate to aspect
case Aspect_Delay (A_Id) is
when Always_Delay =>
-- For Boolean aspects, do not delay if no expression
if A_Id in Boolean_Aspects | Library_Unit_Aspects then
Delay_Required := Present (Expr);
else
Delay_Required := True;
end if;
when Never_Delay =>
Delay_Required := False;
when Rep_Aspect =>
-- For Boolean aspects, do not delay if no expression except
-- for Full_Access_Only because we need to process it after
-- Volatile and Atomic, which can be independently delayed.
if A_Id in Boolean_Aspects
and then A_Id /= Aspect_Full_Access_Only
and then No (Expr)
then
Delay_Required := False;
-- For non-Boolean aspects, if the expression has the form
-- of an integer literal, then do not delay, since we know
-- the value cannot change. This optimization catches most
-- rep clause cases.
elsif A_Id not in Boolean_Aspects
and then Present (Expr)
and then Nkind (Expr) = N_Integer_Literal
then
Delay_Required := False;
-- For Alignment and various Size aspects, do not delay for
-- an attribute reference whose prefix is Standard, for
-- example Standard'Maximum_Alignment or Standard'Word_Size.
elsif A_Id in Aspect_Alignment
| Aspect_Component_Size
| Aspect_Object_Size
| Aspect_Size
| Aspect_Value_Size
and then Present (Expr)
and then Nkind (Expr) = N_Attribute_Reference
and then Nkind (Prefix (Expr)) = N_Identifier
and then Chars (Prefix (Expr)) = Name_Standard
then
Delay_Required := False;
-- All other cases are delayed
else
Delay_Required := True;
Set_Has_Delayed_Rep_Aspects (E);
end if;
end case;
if Delay_Required
and then (A_Id = Aspect_Stable_Properties
or else A_Id = Aspect_Designated_Storage_Model
or else A_Id = Aspect_Storage_Model_Type)
-- ??? It seems like we should do this for all aspects, not
-- just these, but that causes as-yet-undiagnosed regressions.
then
Set_Has_Delayed_Aspects (E);
Set_Is_Delayed_Aspect (Aspect);
end if;
-- Check 13.1(9.2/5): A representation aspect of a subtype or type
-- shall not be specified (whether by a representation item or an
-- aspect_specification) before the type is completely defined
-- (see 3.11.1).
if Is_Representation_Aspect (A_Id)
and then Rep_Item_Too_Early (E, N)
then
goto Continue;
end if;
-- Processing based on specific aspect
case A_Id is
when Aspect_Unimplemented =>
null; -- ??? temp for now
-- No_Aspect should be impossible
when No_Aspect =>
raise Program_Error;
-- Case 1: Aspects corresponding to attribute definition
-- clauses.
when Aspect_Address
| Aspect_Alignment
| Aspect_Bit_Order
| Aspect_Component_Size
| Aspect_Constant_Indexing
| Aspect_Default_Iterator
| Aspect_Dispatching_Domain
| Aspect_External_Tag
| Aspect_Input
| Aspect_Iterable
| Aspect_Iterator_Element
| Aspect_Machine_Radix
| Aspect_Object_Size
| Aspect_Output
| Aspect_Put_Image
| Aspect_Read
| Aspect_Scalar_Storage_Order
| Aspect_Simple_Storage_Pool
| Aspect_Size
| Aspect_Small
| Aspect_Storage_Pool
| Aspect_Stream_Size
| Aspect_Value_Size
| Aspect_Variable_Indexing
| Aspect_Write
=>
-- Indexing aspects apply only to tagged type
if A_Id in Aspect_Constant_Indexing
| Aspect_Variable_Indexing
and then not (Is_Type (E)
and then Is_Tagged_Type (E))
then
Error_Msg_N
("indexing aspect can only apply to a tagged type",
Aspect);
goto Continue;
end if;
-- For the case of aspect Address, we don't consider that we
-- know the entity is never set in the source, since it is
-- is likely aliasing is occurring.
-- Note: one might think that the analysis of the resulting
-- attribute definition clause would take care of that, but
-- that's not the case since it won't be from source.
if A_Id = Aspect_Address then
Set_Never_Set_In_Source (E, False);
end if;
-- Correctness of the profile of a stream operation is
-- verified at the freeze point, but we must detect the
-- illegal specification of this aspect for a subtype now,
-- to prevent malformed rep_item chains.
if A_Id in Aspect_Input
| Aspect_Output
| Aspect_Read
| Aspect_Write
then
if not Is_First_Subtype (E) then
Error_Msg_N
("local name must be a first subtype", Aspect);
goto Continue;
-- If stream aspect applies to the class-wide type,
-- the generated attribute definition applies to the
-- class-wide type as well.
elsif Class_Present (Aspect) then
Ent :=
Make_Attribute_Reference (Loc,
Prefix => Ent,
Attribute_Name => Name_Class);
end if;
end if;
-- Construct the attribute_definition_clause. The expression
-- in the aspect specification is simply shared with the
-- constructed attribute, because it will be fully analyzed
-- when the attribute is processed.
Aitem :=
Make_Attribute_Definition_Clause (Loc,
Name => Ent,
Chars => Nam,
Expression => Relocate_Node (Expr));
-- If the address is specified, then we treat the entity as
-- referenced, to avoid spurious warnings. This is analogous
-- to what is done with an attribute definition clause, but
-- here we don't want to generate a reference because this
-- is the point of definition of the entity.
if A_Id = Aspect_Address then
Set_Referenced (E);
end if;
-- Case 2: Aspects corresponding to pragmas
-- Case 2a: 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.
-- Linker_Section
when Aspect_Linker_Section =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => New_Occurrence_Of (E, Loc)),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Linker_Section);
-- Linker_Section does not need delaying, as its argument
-- must be a static string. Furthermore, if applied to
-- an object with an explicit initialization, the object
-- must be frozen in order to elaborate the initialization
-- code. (This is already done for types with implicit
-- initialization, such as protected types.)
if Nkind (N) = N_Object_Declaration
and then Has_Init_Expression (N)
then
Delay_Required := False;
end if;
-- Synchronization
-- Corresponds to pragma Implemented, construct the pragma
when Aspect_Synchronization =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => New_Occurrence_Of (E, Loc)),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Implemented);
-- Attach_Handler
when Aspect_Attach_Handler =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Attach_Handler);
-- We need to insert this pragma into the tree to get proper
-- processing and to look valid from a placement viewpoint.
Insert_Pragma (Aitem);
goto Continue;
-- Dynamic_Predicate, Predicate, Static_Predicate
when Aspect_Dynamic_Predicate
| Aspect_Predicate
| Aspect_Static_Predicate
=>
-- These aspects apply only to subtypes
if not Is_Type (E) then
Error_Msg_N
("predicate can only be specified for a subtype",
Aspect);
goto Continue;
elsif Is_Incomplete_Type (E) then
Error_Msg_N
("predicate cannot apply to incomplete view", Aspect);
elsif Is_Generic_Type (E) then
Error_Msg_N
("predicate cannot apply to formal type", Aspect);
goto Continue;
end if;
-- Construct the pragma (always a pragma Predicate, with
-- flags recording whether it is static/dynamic). We also
-- set flags recording this in the type itself.
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Predicate);
-- Mark type has predicates, and remember what kind of
-- aspect lead to this predicate (we need this to access
-- the right set of check policies later on).
Set_Has_Predicates (E);
if A_Id = Aspect_Dynamic_Predicate then
Set_Has_Dynamic_Predicate_Aspect (E);
-- If the entity has a dynamic predicate, any inherited
-- static predicate becomes dynamic as well, and the
-- predicate function includes the conjunction of both.
Set_Has_Static_Predicate_Aspect (E, False);
elsif A_Id = Aspect_Static_Predicate then
Set_Has_Static_Predicate_Aspect (E);
end if;
-- If the type is private, indicate that its completion
-- has a freeze node, because that is the one that will
-- be visible at freeze time.
if Is_Private_Type (E) and then Present (Full_View (E)) then
Set_Has_Predicates (Full_View (E));
if A_Id = Aspect_Dynamic_Predicate then
Set_Has_Dynamic_Predicate_Aspect (Full_View (E));
elsif A_Id = Aspect_Static_Predicate then
Set_Has_Static_Predicate_Aspect (Full_View (E));
end if;
Set_Has_Delayed_Aspects (Full_View (E));
Ensure_Freeze_Node (Full_View (E));
-- If there is an Underlying_Full_View, also create a
-- freeze node for that one.
if Is_Private_Type (Full_View (E)) then
declare
U_Full : constant Entity_Id :=
Underlying_Full_View (Full_View (E));
begin
if Present (U_Full) then
Set_Has_Delayed_Aspects (U_Full);
Ensure_Freeze_Node (U_Full);
end if;
end;
end if;
end if;
-- Predicate_Failure
when Aspect_Predicate_Failure =>
-- This aspect applies only to subtypes
if not Is_Type (E) then
Error_Msg_N
("predicate can only be specified for a subtype",
Aspect);
goto Continue;
elsif Is_Incomplete_Type (E) then
Error_Msg_N
("predicate cannot apply to incomplete view", Aspect);
goto Continue;
elsif not Has_Predicates (E) then
Error_Msg_N
("Predicate_Failure requires previous predicate" &
" specification", Aspect);
goto Continue;
elsif not (Directly_Specified (E, Aspect_Dynamic_Predicate)
or else Directly_Specified (E, Aspect_Static_Predicate)
or else Directly_Specified (E, Aspect_Predicate))
then
Error_Msg_N
("Predicate_Failure requires accompanying" &
" noninherited predicate specification", Aspect);
goto Continue;
end if;
-- Construct the pragma
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Predicate_Failure);
-- Case 2b: 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.
-- Convention
when Aspect_Convention =>
Analyze_Aspect_Convention;
goto Continue;
-- External_Name, Link_Name
when Aspect_External_Name
| Aspect_Link_Name
=>
Analyze_Aspect_External_Link_Name;
goto Continue;
-- CPU, Interrupt_Priority, Priority
-- These three aspects can be specified for a subprogram spec
-- or body, in which case we analyze the expression and export
-- the value of the aspect.
-- Previously, we generated an equivalent pragma for bodies
-- (note that the specs cannot contain these pragmas). The
-- pragma was inserted ahead of local declarations, rather than
-- after the body. This leads to a certain duplication between
-- the processing performed for the aspect and the pragma, but
-- given the straightforward handling required it is simpler
-- to duplicate than to translate the aspect in the spec into
-- a pragma in the declarative part of the body.
when Aspect_CPU
| Aspect_Interrupt_Priority
| Aspect_Priority
=>
-- Verify the expression is static when Static_Priorities is
-- enabled.
if not Is_OK_Static_Expression (Expr) then
Check_Restriction (Static_Priorities, Expr);
end if;
if Nkind (N) in N_Subprogram_Body | N_Subprogram_Declaration
then
-- Analyze the aspect expression
Analyze_And_Resolve (Expr, Standard_Integer);
-- Interrupt_Priority aspect not allowed for main
-- subprograms. RM D.1 does not forbid this explicitly,
-- but RM J.15.11(6/3) does not permit pragma
-- Interrupt_Priority for subprograms.
if A_Id = Aspect_Interrupt_Priority then
Error_Msg_N
("Interrupt_Priority aspect cannot apply to "
& "subprogram", Expr);
-- The expression must be static
elsif not Is_OK_Static_Expression (Expr) then
Flag_Non_Static_Expr
("aspect requires static expression!", Expr);
-- Check whether this is the main subprogram. Issue a
-- warning only if it is obviously not a main program
-- (when it has parameters or when the subprogram is
-- within a package).
elsif Present (Parameter_Specifications
(Specification (N)))
or else not Is_Compilation_Unit (Defining_Entity (N))
then
-- See RM D.1(14/3) and D.16(12/3)
Error_Msg_N
("aspect applied to subprogram other than the "
& "main subprogram has no effect??", Expr);
-- Otherwise check in range and export the value
-- For the CPU aspect
elsif A_Id = Aspect_CPU then
if Is_In_Range (Expr, RTE (RE_CPU_Range)) then
-- Value is correct so we export the value to make
-- it available at execution time.
Set_Main_CPU
(Main_Unit, UI_To_Int (Expr_Value (Expr)));
else
Error_Msg_N
("main subprogram 'C'P'U is out of range", Expr);
end if;
-- For the Priority aspect
elsif A_Id = Aspect_Priority then
if Is_In_Range (Expr, RTE (RE_Priority)) then
-- Value is correct so we export the value to make
-- it available at execution time.
Set_Main_Priority
(Main_Unit, UI_To_Int (Expr_Value (Expr)));
-- Ignore pragma if Relaxed_RM_Semantics to support
-- other targets/non GNAT compilers.
elsif not Relaxed_RM_Semantics then
Error_Msg_N
("main subprogram priority is out of range",
Expr);
end if;
end if;
-- Load an arbitrary entity from System.Tasking.Stages
-- or System.Tasking.Restricted.Stages (depending on
-- the supported profile) to make sure that one of these
-- packages is implicitly with'ed, since we need to have
-- the tasking run time active for the pragma Priority to
-- have any effect. Previously we with'ed the package
-- System.Tasking, but this package does not trigger the
-- required initialization of the run-time library.
if Restricted_Profile then
Discard_Node (RTE (RE_Activate_Restricted_Tasks));
else
Discard_Node (RTE (RE_Activate_Tasks));
end if;
-- Handling for these aspects in subprograms is complete
goto Continue;
-- For task and protected types pass the aspect as an
-- attribute.
else
Aitem :=
Make_Attribute_Definition_Clause (Loc,
Name => Ent,
Chars => Nam,
Expression => Relocate_Node (Expr));
end if;
-- Suppress/Unsuppress
when Aspect_Suppress
| Aspect_Unsuppress
=>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr)),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => New_Occurrence_Of (E, Loc))),
Pragma_Name => Nam);
Delay_Required := False;
-- Warnings
when Aspect_Warnings =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr)),
Make_Pragma_Argument_Association (Loc,
Expression => New_Occurrence_Of (E, Loc))),
Pragma_Name => Name_Warnings);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Case 2c: Aspects corresponding to pragmas with three
-- arguments.
-- Invariant aspects have a first argument that references the
-- entity, a second argument that is the expression and a third
-- argument that is an appropriate message.
-- Invariant, Type_Invariant
when Aspect_Invariant
| Aspect_Type_Invariant
=>
-- Analysis of the pragma will verify placement legality:
-- an invariant must apply to a private type, or appear in
-- the private part of a spec and apply to a completion.
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Invariant);
-- Add message unless exception messages are suppressed
if not Opt.Exception_Locations_Suppressed then
Append_To (Pragma_Argument_Associations (Aitem),
Make_Pragma_Argument_Association (Eloc,
Chars => Name_Message,
Expression =>
Make_String_Literal (Eloc,
Strval => "failed invariant from "
& Build_Location_String (Eloc))));
end if;
-- For Invariant case, insert immediately after the entity
-- declaration. We do not have to worry about delay issues
-- since the pragma processing takes care of this.
Delay_Required := False;
-- Case 2d : Aspects that correspond to a pragma with one
-- argument.
-- Abstract_State
-- Aspect Abstract_State introduces implicit declarations for
-- all state abstraction entities it defines. To emulate this
-- behavior, insert the pragma at the beginning of the visible
-- declarations of the related package so that it is analyzed
-- immediately.
when Aspect_Abstract_State => Abstract_State : declare
Context : Node_Id := N;
begin
-- When aspect Abstract_State appears on a generic package,
-- it is propagated to the package instance. The context in
-- this case is the instance spec.
if Nkind (Context) = N_Package_Instantiation then
Context := Instance_Spec (Context);
end if;
if Nkind (Context) in N_Generic_Package_Declaration
| N_Package_Declaration
then
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Abstract_State);
Decorate (Aspect, Aitem);
Insert_Pragma
(Prag => Aitem,
Is_Instance =>
Is_Generic_Instance (Defining_Entity (Context)));
else
Error_Msg_NE
("aspect & must apply to a package declaration",
Aspect, Id);
end if;
goto Continue;
end Abstract_State;
-- Aspect Async_Readers is never delayed because it is
-- equivalent to a source pragma which appears after the
-- related object declaration.
when Aspect_Async_Readers =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Async_Readers);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Aspect Async_Writers is never delayed because it is
-- equivalent to a source pragma which appears after the
-- related object declaration.
when Aspect_Async_Writers =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Async_Writers);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Aspect Constant_After_Elaboration is never delayed because
-- it is equivalent to a source pragma which appears after the
-- related object declaration.
when Aspect_Constant_After_Elaboration =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name =>
Name_Constant_After_Elaboration);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Aspect Default_Internal_Condition is never delayed because
-- it is equivalent to a source pragma which appears after the
-- related private type. To deal with forward references, the
-- generated pragma is stored in the rep chain of the related
-- private type as types do not carry contracts. The pragma is
-- wrapped inside of a procedure at the freeze point of the
-- private type's full view.
-- A type entity argument is appended to facilitate inheriting
-- the aspect from parent types (see Build_DIC_Procedure_Body),
-- though that extra argument isn't documented for the pragma.
when Aspect_Default_Initial_Condition =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr)),
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent)),
Pragma_Name =>
Name_Default_Initial_Condition);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Default_Storage_Pool
when Aspect_Default_Storage_Pool =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name =>
Name_Default_Storage_Pool);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Depends
-- Aspect Depends is never delayed because it is equivalent to
-- a source pragma which appears after the related subprogram.
-- To deal with forward references, the generated pragma is
-- stored in the contract of the related subprogram and later
-- analyzed at the end of the declarative region. See routine
-- Analyze_Depends_In_Decl_Part for details.
when Aspect_Depends =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Depends);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Aspect Effective_Reads is never delayed because it is
-- equivalent to a source pragma which appears after the
-- related object declaration.
when Aspect_Effective_Reads =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Effective_Reads);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Aspect Effective_Writes is never delayed because it is
-- equivalent to a source pragma which appears after the
-- related object declaration.
when Aspect_Effective_Writes =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Effective_Writes);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Aspect Extensions_Visible is never delayed because it is
-- equivalent to a source pragma which appears after the
-- related subprogram.
when Aspect_Extensions_Visible =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Extensions_Visible);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Aspect Ghost is never delayed because it is equivalent to a
-- source pragma which appears at the top of [generic] package
-- declarations or after an object, a [generic] subprogram, or
-- a type declaration.
when Aspect_Ghost =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Ghost);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Global
-- Aspect Global is never delayed because it is equivalent to
-- a source pragma which appears after the related subprogram.
-- To deal with forward references, the generated pragma is
-- stored in the contract of the related subprogram and later
-- analyzed at the end of the declarative region. See routine
-- Analyze_Global_In_Decl_Part for details.
when Aspect_Global =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Global);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Initial_Condition
-- Aspect Initial_Condition is never delayed because it is
-- equivalent to a source pragma which appears after the
-- related package. To deal with forward references, the
-- generated pragma is stored in the contract of the related
-- package and later analyzed at the end of the declarative
-- region. See routine Analyze_Initial_Condition_In_Decl_Part
-- for details.
when Aspect_Initial_Condition => Initial_Condition : declare
Context : Node_Id := N;
begin
-- When aspect Initial_Condition appears on a generic
-- package, it is propagated to the package instance. The
-- context in this case is the instance spec.
if Nkind (Context) = N_Package_Instantiation then
Context := Instance_Spec (Context);
end if;
if Nkind (Context) in N_Generic_Package_Declaration
| N_Package_Declaration
then
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name =>
Name_Initial_Condition);
Decorate (Aspect, Aitem);
Insert_Pragma
(Prag => Aitem,
Is_Instance =>
Is_Generic_Instance (Defining_Entity (Context)));
-- Otherwise the context is illegal
else
Error_Msg_NE
("aspect & must apply to a package declaration",
Aspect, Id);
end if;
goto Continue;
end Initial_Condition;
-- Initializes
-- Aspect Initializes is never delayed because it is equivalent
-- to a source pragma appearing after the related package. To
-- deal with forward references, the generated pragma is stored
-- in the contract of the related package and later analyzed at
-- the end of the declarative region. For details, see routine
-- Analyze_Initializes_In_Decl_Part.
when Aspect_Initializes => Initializes : declare
Context : Node_Id := N;
begin
-- When aspect Initializes appears on a generic package,
-- it is propagated to the package instance. The context
-- in this case is the instance spec.
if Nkind (Context) = N_Package_Instantiation then
Context := Instance_Spec (Context);
end if;
if Nkind (Context) in N_Generic_Package_Declaration
| N_Package_Declaration
then
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Initializes);
Decorate (Aspect, Aitem);
Insert_Pragma
(Prag => Aitem,
Is_Instance =>
Is_Generic_Instance (Defining_Entity (Context)));
-- Otherwise the context is illegal
else
Error_Msg_NE
("aspect & must apply to a package declaration",
Aspect, Id);
end if;
goto Continue;
end Initializes;
-- Max_Entry_Queue_Depth
when Aspect_Max_Entry_Queue_Depth =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Max_Entry_Queue_Depth);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Max_Entry_Queue_Length
when Aspect_Max_Entry_Queue_Length =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Max_Entry_Queue_Length);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Max_Queue_Length
when Aspect_Max_Queue_Length =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Max_Queue_Length);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Aspect No_Caching is never delayed because it is equivalent
-- to a source pragma which appears after the related object
-- declaration.
when Aspect_No_Caching =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_No_Caching);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- No_Controlled_Parts, No_Task_Parts
when Aspect_No_Controlled_Parts | Aspect_No_Task_Parts =>
-- Check appropriate type argument
if not Is_Type (E) then
Error_Msg_N
("aspect % can only be applied to types", E);
end if;
-- Disallow subtypes
if Nkind (Declaration_Node (E)) = N_Subtype_Declaration then
Error_Msg_N
("aspect % cannot be applied to subtypes", E);
end if;
-- Resolve the expression to a boolean
if Present (Expr) then
Check_Expr_Is_OK_Static_Expression (Expr, Any_Boolean);
end if;
goto Continue;
-- Obsolescent
when Aspect_Obsolescent => declare
Args : List_Id;
begin
if No (Expr) then
Args := No_List;
else
Args := New_List (
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr)));
end if;
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => Args,
Pragma_Name => Name_Obsolescent);
end;
-- Part_Of
when Aspect_Part_Of =>
if Nkind (N) in N_Object_Declaration
| N_Package_Instantiation
or else Is_Single_Concurrent_Type_Declaration (N)
then
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Part_Of);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
else
Error_Msg_NE
("aspect & must apply to package instantiation, "
& "object, single protected type or single task type",
Aspect, Id);
end if;
goto Continue;
-- SPARK_Mode
when Aspect_SPARK_Mode =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_SPARK_Mode);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Refined_Depends
-- Aspect Refined_Depends is never delayed because it is
-- equivalent to a source pragma which appears in the
-- declarations of the related subprogram body. To deal with
-- forward references, the generated pragma is stored in the
-- contract of the related subprogram body and later analyzed
-- at the end of the declarative region. For details, see
-- routine Analyze_Refined_Depends_In_Decl_Part.
when Aspect_Refined_Depends =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Refined_Depends);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Refined_Global
-- Aspect Refined_Global is never delayed because it is
-- equivalent to a source pragma which appears in the
-- declarations of the related subprogram body. To deal with
-- forward references, the generated pragma is stored in the
-- contract of the related subprogram body and later analyzed
-- at the end of the declarative region. For details, see
-- routine Analyze_Refined_Global_In_Decl_Part.
when Aspect_Refined_Global =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Refined_Global);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Refined_Post
when Aspect_Refined_Post =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Refined_Post);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Refined_State
when Aspect_Refined_State =>
-- The corresponding pragma for Refined_State is inserted in
-- the declarations of the related package body. This action
-- synchronizes both the source and from-aspect versions of
-- the pragma.
if Nkind (N) = N_Package_Body then
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Refined_State);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
-- Otherwise the context is illegal
else
Error_Msg_NE
("aspect & must apply to a package body", Aspect, Id);
end if;
goto Continue;
-- Relative_Deadline
when Aspect_Relative_Deadline =>
Aitem := Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Relative_Deadline);
-- If the aspect applies to a task, the corresponding pragma