| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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 |