1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Elists
; use Elists
;
32 with Errout
; use Errout
;
33 with Expander
; use Expander
;
34 with Exp_Disp
; use Exp_Disp
;
35 with Exp_Tss
; use Exp_Tss
;
36 with Exp_Util
; use Exp_Util
;
37 with Freeze
; use Freeze
;
38 with Ghost
; use Ghost
;
40 with Lib
.Xref
; use Lib
.Xref
;
41 with Namet
; use Namet
;
42 with Nlists
; use Nlists
;
43 with Nmake
; use Nmake
;
45 with Par_SCO
; use Par_SCO
;
46 with Restrict
; use Restrict
;
47 with Rident
; use Rident
;
48 with Rtsfind
; use Rtsfind
;
50 with Sem_Aux
; use Sem_Aux
;
51 with Sem_Case
; use Sem_Case
;
52 with Sem_Ch3
; use Sem_Ch3
;
53 with Sem_Ch6
; use Sem_Ch6
;
54 with Sem_Ch7
; use Sem_Ch7
;
55 with Sem_Ch8
; use Sem_Ch8
;
56 with Sem_Dim
; use Sem_Dim
;
57 with Sem_Disp
; use Sem_Disp
;
58 with Sem_Eval
; use Sem_Eval
;
59 with Sem_Prag
; use Sem_Prag
;
60 with Sem_Res
; use Sem_Res
;
61 with Sem_Type
; use Sem_Type
;
62 with Sem_Util
; use Sem_Util
;
63 with Sem_Warn
; use Sem_Warn
;
64 with Sinfo
; use Sinfo
;
65 with Sinput
; use Sinput
;
66 with Snames
; use Snames
;
67 with Stand
; use Stand
;
68 with Targparm
; use Targparm
;
69 with Ttypes
; use Ttypes
;
70 with Tbuild
; use Tbuild
;
71 with Urealp
; use Urealp
;
72 with Warnsw
; use Warnsw
;
74 with GNAT
.Heap_Sort_G
;
76 package body Sem_Ch13
is
78 SSU
: constant Pos
:= System_Storage_Unit
;
79 -- Convenient short hand for commonly used constant
81 -----------------------
82 -- Local Subprograms --
83 -----------------------
85 procedure Adjust_Record_For_Reverse_Bit_Order_Ada_95
(R
: Entity_Id
);
86 -- Helper routine providing the original (pre-AI95-0133) behavior for
87 -- Adjust_Record_For_Reverse_Bit_Order.
89 procedure Alignment_Check_For_Size_Change
(Typ
: Entity_Id
; Size
: Uint
);
90 -- This routine is called after setting one of the sizes of type entity
91 -- Typ to Size. The purpose is to deal with the situation of a derived
92 -- type whose inherited alignment is no longer appropriate for the new
93 -- size value. In this case, we reset the Alignment to unknown.
95 procedure Build_Discrete_Static_Predicate
99 -- Given a predicated type Typ, where Typ is a discrete static subtype,
100 -- whose predicate expression is Expr, tests if Expr is a static predicate,
101 -- and if so, builds the predicate range list. Nam is the name of the one
102 -- argument to the predicate function. Occurrences of the type name in the
103 -- predicate expression have been replaced by identifier references to this
104 -- name, which is unique, so any identifier with Chars matching Nam must be
105 -- a reference to the type. If the predicate is non-static, this procedure
106 -- returns doing nothing. If the predicate is static, then the predicate
107 -- list is stored in Static_Discrete_Predicate (Typ), and the Expr is
108 -- rewritten as a canonicalized membership operation.
110 function Build_Export_Import_Pragma
112 Id
: Entity_Id
) return Node_Id
;
113 -- Create the corresponding pragma for aspect Export or Import denoted by
114 -- Asp. Id is the related entity subject to the aspect. Return Empty when
115 -- the expression of aspect Asp evaluates to False or is erroneous.
117 function Build_Predicate_Function_Declaration
118 (Typ
: Entity_Id
) return Node_Id
;
119 -- Build the declaration for a predicate function. The declaration is built
120 -- at the end of the declarative part containing the type definition, which
121 -- may be before the freeze point of the type. The predicate expression is
122 -- pre-analyzed at this point, to catch visibility errors.
124 procedure Build_Predicate_Functions
(Typ
: Entity_Id
; N
: Node_Id
);
125 -- If Typ has predicates (indicated by Has_Predicates being set for Typ),
126 -- then either there are pragma Predicate entries on the rep chain for the
127 -- type (note that Predicate aspects are converted to pragma Predicate), or
128 -- there are inherited aspects from a parent type, or ancestor subtypes.
129 -- This procedure builds body for the Predicate function that tests these
130 -- predicates. N is the freeze node for the type. The spec of the function
131 -- is inserted before the freeze node, and the body of the function is
132 -- inserted after the freeze node. If the predicate expression has a least
133 -- one Raise_Expression, then this procedure also builds the M version of
134 -- the predicate function for use in membership tests.
136 procedure Check_Pool_Size_Clash
(Ent
: Entity_Id
; SP
, SS
: Node_Id
);
137 -- Called if both Storage_Pool and Storage_Size attribute definition
138 -- clauses (SP and SS) are present for entity Ent. Issue error message.
140 procedure Freeze_Entity_Checks
(N
: Node_Id
);
141 -- Called from Analyze_Freeze_Entity and Analyze_Generic_Freeze Entity
142 -- to generate appropriate semantic checks that are delayed until this
143 -- point (they had to be delayed this long for cases of delayed aspects,
144 -- e.g. analysis of statically predicated subtypes in choices, for which
145 -- we have to be sure the subtypes in question are frozen before checking).
147 function Get_Alignment_Value
(Expr
: Node_Id
) return Uint
;
148 -- Given the expression for an alignment value, returns the corresponding
149 -- Uint value. If the value is inappropriate, then error messages are
150 -- posted as required, and a value of No_Uint is returned.
152 function Is_Operational_Item
(N
: Node_Id
) return Boolean;
153 -- A specification for a stream attribute is allowed before the full type
154 -- is declared, as explained in AI-00137 and the corrigendum. Attributes
155 -- that do not specify a representation characteristic are operational
158 function Is_Predicate_Static
160 Nam
: Name_Id
) return Boolean;
161 -- Given predicate expression Expr, tests if Expr is predicate-static in
162 -- the sense of the rules in (RM 3.2.4 (15-24)). Occurrences of the type
163 -- name in the predicate expression have been replaced by references to
164 -- an identifier whose Chars field is Nam. This name is unique, so any
165 -- identifier with Chars matching Nam must be a reference to the type.
166 -- Returns True if the expression is predicate-static and False otherwise,
167 -- but is not in the business of setting flags or issuing error messages.
169 -- Only scalar types can have static predicates, so False is always
170 -- returned for non-scalar types.
172 -- Note: the RM seems to suggest that string types can also have static
173 -- predicates. But that really makes lttle sense as very few useful
174 -- predicates can be constructed for strings. Remember that:
178 -- is not a static expression. So even though the clearly faulty RM wording
179 -- allows the following:
181 -- subtype S is String with Static_Predicate => S < "DEF"
183 -- We can't allow this, otherwise we have predicate-static applying to a
184 -- larger class than static expressions, which was never intended.
186 procedure New_Stream_Subprogram
190 Nam
: TSS_Name_Type
);
191 -- Create a subprogram renaming of a given stream attribute to the
192 -- designated subprogram and then in the tagged case, provide this as a
193 -- primitive operation, or in the untagged case make an appropriate TSS
194 -- entry. This is more properly an expansion activity than just semantics,
195 -- but the presence of user-defined stream functions for limited types
196 -- is a legality check, which is why this takes place here rather than in
197 -- exp_ch13, where it was previously. Nam indicates the name of the TSS
198 -- function to be generated.
200 -- To avoid elaboration anomalies with freeze nodes, for untagged types
201 -- we generate both a subprogram declaration and a subprogram renaming
202 -- declaration, so that the attribute specification is handled as a
203 -- renaming_as_body. For tagged types, the specification is one of the
206 procedure Resolve_Iterable_Operation
211 -- If the name of a primitive operation for an Iterable aspect is
212 -- overloaded, resolve according to required signature.
218 Biased
: Boolean := True);
219 -- If Biased is True, sets Has_Biased_Representation flag for E, and
220 -- outputs a warning message at node N if Warn_On_Biased_Representation is
221 -- is True. This warning inserts the string Msg to describe the construct
224 ---------------------------------------------------
225 -- Table for Validate_Compile_Time_Warning_Error --
226 ---------------------------------------------------
228 -- The following table collects pragmas Compile_Time_Error and Compile_
229 -- Time_Warning for validation. Entries are made by calls to subprogram
230 -- Validate_Compile_Time_Warning_Error, and the call to the procedure
231 -- Validate_Compile_Time_Warning_Errors does the actual error checking
232 -- and posting of warning and error messages. The reason for this delayed
233 -- processing is to take advantage of back-annotations of attributes size
234 -- and alignment values performed by the back end.
236 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
237 -- that by the time Validate_Unchecked_Conversions is called, Sprint will
238 -- already have modified all Sloc values if the -gnatD option is set.
240 type CTWE_Entry
is record
242 -- Source location used in warnings and error messages
245 -- Pragma Compile_Time_Error or Compile_Time_Warning
248 -- The scope which encloses the pragma
251 package Compile_Time_Warnings_Errors
is new Table
.Table
(
252 Table_Component_Type
=> CTWE_Entry
,
253 Table_Index_Type
=> Int
,
254 Table_Low_Bound
=> 1,
256 Table_Increment
=> 200,
257 Table_Name
=> "Compile_Time_Warnings_Errors");
259 ----------------------------------------------
260 -- Table for Validate_Unchecked_Conversions --
261 ----------------------------------------------
263 -- The following table collects unchecked conversions for validation.
264 -- Entries are made by Validate_Unchecked_Conversion and then the call
265 -- to Validate_Unchecked_Conversions does the actual error checking and
266 -- posting of warnings. The reason for this delayed processing is to take
267 -- advantage of back-annotations of size and alignment values performed by
270 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
271 -- that by the time Validate_Unchecked_Conversions is called, Sprint will
272 -- already have modified all Sloc values if the -gnatD option is set.
274 type UC_Entry
is record
275 Eloc
: Source_Ptr
; -- node used for posting warnings
276 Source
: Entity_Id
; -- source type for unchecked conversion
277 Target
: Entity_Id
; -- target type for unchecked conversion
278 Act_Unit
: Entity_Id
; -- actual function instantiated
281 package Unchecked_Conversions
is new Table
.Table
(
282 Table_Component_Type
=> UC_Entry
,
283 Table_Index_Type
=> Int
,
284 Table_Low_Bound
=> 1,
286 Table_Increment
=> 200,
287 Table_Name
=> "Unchecked_Conversions");
289 ----------------------------------------
290 -- Table for Validate_Address_Clauses --
291 ----------------------------------------
293 -- If an address clause has the form
295 -- for X'Address use Expr
297 -- where Expr has a value known at compile time or is of the form Y'Address
298 -- or recursively is a reference to a constant initialized with either of
299 -- these forms, and the value of Expr is not a multiple of X's alignment,
300 -- or if Y has a smaller alignment than X, then that merits a warning about
301 -- possible bad alignment. The following table collects address clauses of
302 -- this kind. We put these in a table so that they can be checked after the
303 -- back end has completed annotation of the alignments of objects, since we
304 -- can catch more cases that way.
306 type Address_Clause_Check_Record
is record
308 -- The address clause
311 -- The entity of the object subject to the address clause
314 -- The value of the address in the first case
317 -- The entity of the object being overlaid in the second case
320 -- Whether the address is offset within Y in the second case
323 package Address_Clause_Checks
is new Table
.Table
(
324 Table_Component_Type
=> Address_Clause_Check_Record
,
325 Table_Index_Type
=> Int
,
326 Table_Low_Bound
=> 1,
328 Table_Increment
=> 200,
329 Table_Name
=> "Address_Clause_Checks");
331 -----------------------------------------
332 -- Adjust_Record_For_Reverse_Bit_Order --
333 -----------------------------------------
335 procedure Adjust_Record_For_Reverse_Bit_Order
(R
: Entity_Id
) is
336 Max_Machine_Scalar_Size
: constant Uint
:=
338 (Standard_Long_Long_Integer_Size
);
339 -- We use this as the maximum machine scalar size
341 SSU
: constant Uint
:= UI_From_Int
(System_Storage_Unit
);
348 -- Processing here used to depend on Ada version: the behavior was
349 -- changed by AI95-0133. However this AI is a Binding interpretation,
350 -- so we now implement it even in Ada 95 mode. The original behavior
351 -- from unamended Ada 95 is still available for compatibility under
352 -- debugging switch -gnatd.
354 if Ada_Version
< Ada_2005
and then Debug_Flag_Dot_P
then
355 Adjust_Record_For_Reverse_Bit_Order_Ada_95
(R
);
359 -- For Ada 2005, we do machine scalar processing, as fully described In
360 -- AI-133. This involves gathering all components which start at the
361 -- same byte offset and processing them together. Same approach is still
362 -- valid in later versions including Ada 2012.
364 -- This first loop through components does two things. First it deals
365 -- with the case of components with component clauses whose length is
366 -- greater than the maximum machine scalar size (either accepting them
367 -- or rejecting as needed). Second, it counts the number of components
368 -- with component clauses whose length does not exceed this maximum for
372 Comp
:= First_Component_Or_Discriminant
(R
);
373 while Present
(Comp
) loop
374 CC
:= Component_Clause
(Comp
);
378 Fbit
: constant Uint
:= Static_Integer
(First_Bit
(CC
));
379 Lbit
: constant Uint
:= Static_Integer
(Last_Bit
(CC
));
382 -- Case of component with last bit >= max machine scalar
384 if Lbit
>= Max_Machine_Scalar_Size
then
386 -- This is allowed only if first bit is zero, and last bit
387 -- + 1 is a multiple of storage unit size.
389 if Fbit
= 0 and then (Lbit
+ 1) mod SSU
= 0 then
391 -- This is the case to give a warning if enabled
393 if Warn_On_Reverse_Bit_Order
then
395 ("info: multi-byte field specified with "
396 & "non-standard Bit_Order?V?", CC
);
398 if Bytes_Big_Endian
then
400 ("\bytes are not reversed "
401 & "(component is big-endian)?V?", CC
);
404 ("\bytes are not reversed "
405 & "(component is little-endian)?V?", CC
);
409 -- Give error message for RM 13.5.1(10) violation
413 ("machine scalar rules not followed for&",
414 First_Bit
(CC
), Comp
);
416 Error_Msg_Uint_1
:= Lbit
+ 1;
417 Error_Msg_Uint_2
:= Max_Machine_Scalar_Size
;
419 ("\last bit + 1 (^) exceeds maximum machine scalar "
420 & "size (^)", First_Bit
(CC
));
422 if (Lbit
+ 1) mod SSU
/= 0 then
423 Error_Msg_Uint_1
:= SSU
;
425 ("\and is not a multiple of Storage_Unit (^) "
426 & "(RM 13.5.1(10))", First_Bit
(CC
));
429 Error_Msg_Uint_1
:= Fbit
;
431 ("\and first bit (^) is non-zero "
432 & "(RM 13.4.1(10))", First_Bit
(CC
));
436 -- OK case of machine scalar related component clause. For now,
440 Num_CC
:= Num_CC
+ 1;
445 Next_Component_Or_Discriminant
(Comp
);
448 -- We need to sort the component clauses on the basis of the Position
449 -- values in the clause, so we can group clauses with the same Position
450 -- together to determine the relevant machine scalar size.
453 Comps
: array (0 .. Num_CC
) of Entity_Id
;
454 -- Array to collect component and discriminant entities. The data
455 -- starts at index 1, the 0'th entry is for the sort routine.
457 function CP_Lt
(Op1
, Op2
: Natural) return Boolean;
458 -- Compare routine for Sort
460 procedure CP_Move
(From
: Natural; To
: Natural);
461 -- Move routine for Sort
463 package Sorting
is new GNAT
.Heap_Sort_G
(CP_Move
, CP_Lt
);
466 -- Maximum last bit value of any component in this set
469 -- Corresponding machine scalar size
473 -- Start and stop positions in the component list of the set of
474 -- components with the same starting position (that constitute
475 -- components in a single machine scalar).
481 function CP_Lt
(Op1
, Op2
: Natural) return Boolean is
484 Position
(Component_Clause
(Comps
(Op1
))) <
485 Position
(Component_Clause
(Comps
(Op2
)));
492 procedure CP_Move
(From
: Natural; To
: Natural) is
494 Comps
(To
) := Comps
(From
);
497 -- Start of processing for Sort_CC
500 -- Collect the machine scalar relevant component clauses
503 Comp
:= First_Component_Or_Discriminant
(R
);
504 while Present
(Comp
) loop
506 CC
: constant Node_Id
:= Component_Clause
(Comp
);
509 -- Collect only component clauses whose last bit is less than
510 -- machine scalar size. Any component clause whose last bit
511 -- exceeds this value does not take part in machine scalar
512 -- layout considerations. The test for Error_Posted makes sure
513 -- we exclude component clauses for which we already posted an
517 and then not Error_Posted
(Last_Bit
(CC
))
518 and then Static_Integer
(Last_Bit
(CC
)) <
519 Max_Machine_Scalar_Size
521 Num_CC
:= Num_CC
+ 1;
522 Comps
(Num_CC
) := Comp
;
526 Next_Component_Or_Discriminant
(Comp
);
529 -- Sort by ascending position number
531 Sorting
.Sort
(Num_CC
);
533 -- We now have all the components whose size does not exceed the max
534 -- machine scalar value, sorted by starting position. In this loop we
535 -- gather groups of clauses starting at the same position, to process
536 -- them in accordance with AI-133.
539 while Stop
< Num_CC
loop
544 (Last_Bit
(Component_Clause
(Comps
(Start
))));
545 while Stop
< Num_CC
loop
547 (Position
(Component_Clause
(Comps
(Stop
+ 1)))) =
549 (Position
(Component_Clause
(Comps
(Stop
))))
557 (Component_Clause
(Comps
(Stop
)))));
563 -- Now we have a group of component clauses from Start to Stop
564 -- whose positions are identical, and MaxL is the maximum last
565 -- bit value of any of these components.
567 -- We need to determine the corresponding machine scalar size.
568 -- This loop assumes that machine scalar sizes are even, and that
569 -- each possible machine scalar has twice as many bits as the next
572 MSS
:= Max_Machine_Scalar_Size
;
574 and then (MSS
/ 2) >= SSU
575 and then (MSS
/ 2) > MaxL
580 -- Here is where we fix up the Component_Bit_Offset value to
581 -- account for the reverse bit order. Some examples of what needs
582 -- to be done for the case of a machine scalar size of 8 are:
584 -- First_Bit .. Last_Bit Component_Bit_Offset
596 -- The rule is that the first bit is obtained by subtracting the
597 -- old ending bit from machine scalar size - 1.
599 for C
in Start
.. Stop
loop
601 Comp
: constant Entity_Id
:= Comps
(C
);
602 CC
: constant Node_Id
:= Component_Clause
(Comp
);
604 LB
: constant Uint
:= Static_Integer
(Last_Bit
(CC
));
605 NFB
: constant Uint
:= MSS
- Uint_1
- LB
;
606 NLB
: constant Uint
:= NFB
+ Esize
(Comp
) - 1;
607 Pos
: constant Uint
:= Static_Integer
(Position
(CC
));
610 if Warn_On_Reverse_Bit_Order
then
611 Error_Msg_Uint_1
:= MSS
;
613 ("info: reverse bit order in machine scalar of "
614 & "length^?V?", First_Bit
(CC
));
615 Error_Msg_Uint_1
:= NFB
;
616 Error_Msg_Uint_2
:= NLB
;
618 if Bytes_Big_Endian
then
620 ("\big-endian range for component & is ^ .. ^?V?",
621 First_Bit
(CC
), Comp
);
624 ("\little-endian range for component & is ^ .. ^?V?",
625 First_Bit
(CC
), Comp
);
629 Set_Component_Bit_Offset
(Comp
, Pos
* SSU
+ NFB
);
630 Set_Normalized_Position
(Comp
, Pos
+ NFB
/ SSU
);
631 Set_Normalized_First_Bit
(Comp
, NFB
mod SSU
);
636 end Adjust_Record_For_Reverse_Bit_Order
;
638 ------------------------------------------------
639 -- Adjust_Record_For_Reverse_Bit_Order_Ada_95 --
640 ------------------------------------------------
642 procedure Adjust_Record_For_Reverse_Bit_Order_Ada_95
(R
: Entity_Id
) is
647 -- For Ada 95, we just renumber bits within a storage unit. We do the
648 -- same for Ada 83 mode, since we recognize the Bit_Order attribute in
649 -- Ada 83, and are free to add this extension.
651 Comp
:= First_Component_Or_Discriminant
(R
);
652 while Present
(Comp
) loop
653 CC
:= Component_Clause
(Comp
);
655 -- If component clause is present, then deal with the non-default
656 -- bit order case for Ada 95 mode.
658 -- We only do this processing for the base type, and in fact that
659 -- is important, since otherwise if there are record subtypes, we
660 -- could reverse the bits once for each subtype, which is wrong.
662 if Present
(CC
) and then Ekind
(R
) = E_Record_Type
then
664 CFB
: constant Uint
:= Component_Bit_Offset
(Comp
);
665 CSZ
: constant Uint
:= Esize
(Comp
);
666 CLC
: constant Node_Id
:= Component_Clause
(Comp
);
667 Pos
: constant Node_Id
:= Position
(CLC
);
668 FB
: constant Node_Id
:= First_Bit
(CLC
);
670 Storage_Unit_Offset
: constant Uint
:=
671 CFB
/ System_Storage_Unit
;
673 Start_Bit
: constant Uint
:=
674 CFB
mod System_Storage_Unit
;
677 -- Cases where field goes over storage unit boundary
679 if Start_Bit
+ CSZ
> System_Storage_Unit
then
681 -- Allow multi-byte field but generate warning
683 if Start_Bit
mod System_Storage_Unit
= 0
684 and then CSZ
mod System_Storage_Unit
= 0
687 ("info: multi-byte field specified with non-standard "
688 & "Bit_Order?V?", CLC
);
690 if Bytes_Big_Endian
then
692 ("\bytes are not reversed "
693 & "(component is big-endian)?V?", CLC
);
696 ("\bytes are not reversed "
697 & "(component is little-endian)?V?", CLC
);
700 -- Do not allow non-contiguous field
704 ("attempt to specify non-contiguous field not "
707 ("\caused by non-standard Bit_Order specified in "
708 & "legacy Ada 95 mode", CLC
);
711 -- Case where field fits in one storage unit
714 -- Give warning if suspicious component clause
716 if Intval
(FB
) >= System_Storage_Unit
717 and then Warn_On_Reverse_Bit_Order
720 ("info: Bit_Order clause does not affect byte "
721 & "ordering?V?", Pos
);
723 Intval
(Pos
) + Intval
(FB
) /
726 ("info: position normalized to ^ before bit order "
727 & "interpreted?V?", Pos
);
730 -- Here is where we fix up the Component_Bit_Offset value
731 -- to account for the reverse bit order. Some examples of
732 -- what needs to be done are:
734 -- First_Bit .. Last_Bit Component_Bit_Offset
746 -- The rule is that the first bit is is obtained by
747 -- subtracting the old ending bit from storage_unit - 1.
749 Set_Component_Bit_Offset
(Comp
,
750 (Storage_Unit_Offset
* System_Storage_Unit
) +
751 (System_Storage_Unit
- 1) -
752 (Start_Bit
+ CSZ
- 1));
754 Set_Normalized_Position
(Comp
,
755 Component_Bit_Offset
(Comp
) / System_Storage_Unit
);
757 Set_Normalized_First_Bit
(Comp
,
758 Component_Bit_Offset
(Comp
) mod System_Storage_Unit
);
763 Next_Component_Or_Discriminant
(Comp
);
765 end Adjust_Record_For_Reverse_Bit_Order_Ada_95
;
767 -------------------------------------
768 -- Alignment_Check_For_Size_Change --
769 -------------------------------------
771 procedure Alignment_Check_For_Size_Change
(Typ
: Entity_Id
; Size
: Uint
) is
773 -- If the alignment is known, and not set by a rep clause, and is
774 -- inconsistent with the size being set, then reset it to unknown,
775 -- we assume in this case that the size overrides the inherited
776 -- alignment, and that the alignment must be recomputed.
778 if Known_Alignment
(Typ
)
779 and then not Has_Alignment_Clause
(Typ
)
780 and then Size
mod (Alignment
(Typ
) * SSU
) /= 0
782 Init_Alignment
(Typ
);
784 end Alignment_Check_For_Size_Change
;
786 -------------------------------------
787 -- Analyze_Aspects_At_Freeze_Point --
788 -------------------------------------
790 procedure Analyze_Aspects_At_Freeze_Point
(E
: Entity_Id
) is
791 procedure Analyze_Aspect_Default_Value
(ASN
: Node_Id
);
792 -- This routine analyzes an Aspect_Default_[Component_]Value denoted by
793 -- the aspect specification node ASN.
795 procedure Inherit_Delayed_Rep_Aspects
(ASN
: Node_Id
);
796 -- As discussed in the spec of Aspects (see Aspect_Delay declaration),
797 -- a derived type can inherit aspects from its parent which have been
798 -- specified at the time of the derivation using an aspect, as in:
800 -- type A is range 1 .. 10
801 -- with Size => Not_Defined_Yet;
805 -- Not_Defined_Yet : constant := 64;
807 -- In this example, the Size of A is considered to be specified prior
808 -- to the derivation, and thus inherited, even though the value is not
809 -- known at the time of derivation. To deal with this, we use two entity
810 -- flags. The flag Has_Derived_Rep_Aspects is set in the parent type (A
811 -- here), and then the flag May_Inherit_Delayed_Rep_Aspects is set in
812 -- the derived type (B here). If this flag is set when the derived type
813 -- is frozen, then this procedure is called to ensure proper inheritance
814 -- of all delayed aspects from the parent type. The derived type is E,
815 -- the argument to Analyze_Aspects_At_Freeze_Point. ASN is the first
816 -- aspect specification node in the Rep_Item chain for the parent type.
818 procedure Make_Pragma_From_Boolean_Aspect
(ASN
: Node_Id
);
819 -- Given an aspect specification node ASN whose expression is an
820 -- optional Boolean, this routines creates the corresponding pragma
821 -- at the freezing point.
823 ----------------------------------
824 -- Analyze_Aspect_Default_Value --
825 ----------------------------------
827 procedure Analyze_Aspect_Default_Value
(ASN
: Node_Id
) is
828 A_Id
: constant Aspect_Id
:= Get_Aspect_Id
(ASN
);
829 Ent
: constant Entity_Id
:= Entity
(ASN
);
830 Expr
: constant Node_Id
:= Expression
(ASN
);
831 Id
: constant Node_Id
:= Identifier
(ASN
);
834 Error_Msg_Name_1
:= Chars
(Id
);
836 if not Is_Type
(Ent
) then
837 Error_Msg_N
("aspect% can only apply to a type", Id
);
840 elsif not Is_First_Subtype
(Ent
) then
841 Error_Msg_N
("aspect% cannot apply to subtype", Id
);
844 elsif A_Id
= Aspect_Default_Value
845 and then not Is_Scalar_Type
(Ent
)
847 Error_Msg_N
("aspect% can only be applied to scalar type", Id
);
850 elsif A_Id
= Aspect_Default_Component_Value
then
851 if not Is_Array_Type
(Ent
) then
852 Error_Msg_N
("aspect% can only be applied to array type", Id
);
855 elsif not Is_Scalar_Type
(Component_Type
(Ent
)) then
856 Error_Msg_N
("aspect% requires scalar components", Id
);
861 Set_Has_Default_Aspect
(Base_Type
(Ent
));
863 if Is_Scalar_Type
(Ent
) then
864 Set_Default_Aspect_Value
(Base_Type
(Ent
), Expr
);
866 Set_Default_Aspect_Component_Value
(Base_Type
(Ent
), Expr
);
868 end Analyze_Aspect_Default_Value
;
870 ---------------------------------
871 -- Inherit_Delayed_Rep_Aspects --
872 ---------------------------------
874 procedure Inherit_Delayed_Rep_Aspects
(ASN
: Node_Id
) is
875 A_Id
: constant Aspect_Id
:= Get_Aspect_Id
(ASN
);
876 P
: constant Entity_Id
:= Entity
(ASN
);
877 -- Entithy for parent type
880 -- Item from Rep_Item chain
885 -- Loop through delayed aspects for the parent type
888 while Present
(N
) loop
889 if Nkind
(N
) = N_Aspect_Specification
then
890 exit when Entity
(N
) /= P
;
892 if Is_Delayed_Aspect
(N
) then
893 A
:= Get_Aspect_Id
(Chars
(Identifier
(N
)));
895 -- Process delayed rep aspect. For Boolean attributes it is
896 -- not possible to cancel an attribute once set (the attempt
897 -- to use an aspect with xxx => False is an error) for a
898 -- derived type. So for those cases, we do not have to check
899 -- if a clause has been given for the derived type, since it
900 -- is harmless to set it again if it is already set.
906 when Aspect_Alignment
=>
907 if not Has_Alignment_Clause
(E
) then
908 Set_Alignment
(E
, Alignment
(P
));
913 when Aspect_Atomic
=>
914 if Is_Atomic
(P
) then
920 when Aspect_Atomic_Components
=>
921 if Has_Atomic_Components
(P
) then
922 Set_Has_Atomic_Components
(Base_Type
(E
));
927 when Aspect_Bit_Order
=>
928 if Is_Record_Type
(E
)
929 and then No
(Get_Attribute_Definition_Clause
930 (E
, Attribute_Bit_Order
))
931 and then Reverse_Bit_Order
(P
)
933 Set_Reverse_Bit_Order
(Base_Type
(E
));
938 when Aspect_Component_Size
=>
940 and then not Has_Component_Size_Clause
(E
)
943 (Base_Type
(E
), Component_Size
(P
));
948 when Aspect_Machine_Radix
=>
949 if Is_Decimal_Fixed_Point_Type
(E
)
950 and then not Has_Machine_Radix_Clause
(E
)
952 Set_Machine_Radix_10
(E
, Machine_Radix_10
(P
));
955 -- Object_Size (also Size which also sets Object_Size)
957 when Aspect_Object_Size
960 if not Has_Size_Clause
(E
)
962 No
(Get_Attribute_Definition_Clause
963 (E
, Attribute_Object_Size
))
965 Set_Esize
(E
, Esize
(P
));
971 if not Is_Packed
(E
) then
972 Set_Is_Packed
(Base_Type
(E
));
974 if Is_Bit_Packed_Array
(P
) then
975 Set_Is_Bit_Packed_Array
(Base_Type
(E
));
976 Set_Packed_Array_Impl_Type
977 (E
, Packed_Array_Impl_Type
(P
));
981 -- Scalar_Storage_Order
983 when Aspect_Scalar_Storage_Order
=>
984 if (Is_Record_Type
(E
) or else Is_Array_Type
(E
))
985 and then No
(Get_Attribute_Definition_Clause
986 (E
, Attribute_Scalar_Storage_Order
))
987 and then Reverse_Storage_Order
(P
)
989 Set_Reverse_Storage_Order
(Base_Type
(E
));
991 -- Clear default SSO indications, since the aspect
992 -- overrides the default.
994 Set_SSO_Set_Low_By_Default
(Base_Type
(E
), False);
995 Set_SSO_Set_High_By_Default
(Base_Type
(E
), False);
1000 when Aspect_Small
=>
1001 if Is_Fixed_Point_Type
(E
)
1002 and then not Has_Small_Clause
(E
)
1004 Set_Small_Value
(E
, Small_Value
(P
));
1009 when Aspect_Storage_Size
=>
1010 if (Is_Access_Type
(E
) or else Is_Task_Type
(E
))
1011 and then not Has_Storage_Size_Clause
(E
)
1013 Set_Storage_Size_Variable
1014 (Base_Type
(E
), Storage_Size_Variable
(P
));
1019 when Aspect_Value_Size
=>
1021 -- Value_Size is never inherited, it is either set by
1022 -- default, or it is explicitly set for the derived
1023 -- type. So nothing to do here.
1029 when Aspect_Volatile
=>
1030 if Is_Volatile
(P
) then
1031 Set_Is_Volatile
(E
);
1034 -- Volatile_Full_Access
1036 when Aspect_Volatile_Full_Access
=>
1037 if Is_Volatile_Full_Access
(P
) then
1038 Set_Is_Volatile_Full_Access
(E
);
1041 -- Volatile_Components
1043 when Aspect_Volatile_Components
=>
1044 if Has_Volatile_Components
(P
) then
1045 Set_Has_Volatile_Components
(Base_Type
(E
));
1048 -- That should be all the Rep Aspects
1051 pragma Assert
(Aspect_Delay
(A_Id
) /= Rep_Aspect
);
1057 N
:= Next_Rep_Item
(N
);
1059 end Inherit_Delayed_Rep_Aspects
;
1061 -------------------------------------
1062 -- Make_Pragma_From_Boolean_Aspect --
1063 -------------------------------------
1065 procedure Make_Pragma_From_Boolean_Aspect
(ASN
: Node_Id
) is
1066 Ident
: constant Node_Id
:= Identifier
(ASN
);
1067 A_Name
: constant Name_Id
:= Chars
(Ident
);
1068 A_Id
: constant Aspect_Id
:= Get_Aspect_Id
(A_Name
);
1069 Ent
: constant Entity_Id
:= Entity
(ASN
);
1070 Expr
: constant Node_Id
:= Expression
(ASN
);
1071 Loc
: constant Source_Ptr
:= Sloc
(ASN
);
1073 procedure Check_False_Aspect_For_Derived_Type
;
1074 -- This procedure checks for the case of a false aspect for a derived
1075 -- type, which improperly tries to cancel an aspect inherited from
1078 -----------------------------------------
1079 -- Check_False_Aspect_For_Derived_Type --
1080 -----------------------------------------
1082 procedure Check_False_Aspect_For_Derived_Type
is
1086 -- We are only checking derived types
1088 if not Is_Derived_Type
(E
) then
1092 Par
:= Nearest_Ancestor
(E
);
1098 if not Is_Atomic
(Par
) then
1102 when Aspect_Atomic_Components
=>
1103 if not Has_Atomic_Components
(Par
) then
1107 when Aspect_Discard_Names
=>
1108 if not Discard_Names
(Par
) then
1113 if not Is_Packed
(Par
) then
1117 when Aspect_Unchecked_Union
=>
1118 if not Is_Unchecked_Union
(Par
) then
1122 when Aspect_Volatile
=>
1123 if not Is_Volatile
(Par
) then
1127 when Aspect_Volatile_Components
=>
1128 if not Has_Volatile_Components
(Par
) then
1132 when Aspect_Volatile_Full_Access
=>
1133 if not Is_Volatile_Full_Access
(Par
) then
1141 -- Fall through means we are canceling an inherited aspect
1143 Error_Msg_Name_1
:= A_Name
;
1145 ("derived type& inherits aspect%, cannot cancel", Expr
, E
);
1146 end Check_False_Aspect_For_Derived_Type
;
1152 -- Start of processing for Make_Pragma_From_Boolean_Aspect
1155 -- Note that we know Expr is present, because for a missing Expr
1156 -- argument, we knew it was True and did not need to delay the
1157 -- evaluation to the freeze point.
1159 if Is_False
(Static_Boolean
(Expr
)) then
1160 Check_False_Aspect_For_Derived_Type
;
1165 Pragma_Identifier
=>
1166 Make_Identifier
(Sloc
(Ident
), Chars
(Ident
)),
1167 Pragma_Argument_Associations
=> New_List
(
1168 Make_Pragma_Argument_Association
(Sloc
(Ident
),
1169 Expression
=> New_Occurrence_Of
(Ent
, Sloc
(Ident
)))));
1171 Set_From_Aspect_Specification
(Prag
, True);
1172 Set_Corresponding_Aspect
(Prag
, ASN
);
1173 Set_Aspect_Rep_Item
(ASN
, Prag
);
1174 Set_Is_Delayed_Aspect
(Prag
);
1175 Set_Parent
(Prag
, ASN
);
1177 end Make_Pragma_From_Boolean_Aspect
;
1185 -- Start of processing for Analyze_Aspects_At_Freeze_Point
1188 -- Must be visible in current scope, but if this is a type from a nested
1189 -- package it may be frozen from an object declaration in the enclosing
1190 -- scope, so install the package declarations to complete the analysis
1191 -- of the aspects, if any. If the package itself is frozen the type will
1192 -- have been frozen as well.
1194 if not Scope_Within_Or_Same
(Current_Scope
, Scope
(E
)) then
1195 if Is_Type
(E
) and then From_Nested_Package
(E
) then
1197 Pack
: constant Entity_Id
:= Scope
(E
);
1201 Install_Visible_Declarations
(Pack
);
1202 Install_Private_Declarations
(Pack
);
1203 Analyze_Aspects_At_Freeze_Point
(E
);
1205 if Is_Private_Type
(E
)
1206 and then Present
(Full_View
(E
))
1208 Analyze_Aspects_At_Freeze_Point
(Full_View
(E
));
1211 End_Package_Scope
(Pack
);
1215 -- Aspects from other entities in different contexts are analyzed
1223 -- Look for aspect specification entries for this entity
1225 ASN
:= First_Rep_Item
(E
);
1226 while Present
(ASN
) loop
1227 if Nkind
(ASN
) = N_Aspect_Specification
then
1228 exit when Entity
(ASN
) /= E
;
1230 if Is_Delayed_Aspect
(ASN
) then
1231 A_Id
:= Get_Aspect_Id
(ASN
);
1235 -- For aspects whose expression is an optional Boolean, make
1236 -- the corresponding pragma at the freeze point.
1238 when Boolean_Aspects
1239 | Library_Unit_Aspects
1241 -- Aspects Export and Import require special handling.
1242 -- Both are by definition Boolean and may benefit from
1243 -- forward references, however their expressions are
1244 -- treated as static. In addition, the syntax of their
1245 -- corresponding pragmas requires extra "pieces" which
1246 -- may also contain forward references. To account for
1247 -- all of this, the corresponding pragma is created by
1248 -- Analyze_Aspect_Export_Import, but is not analyzed as
1249 -- the complete analysis must happen now.
1251 if A_Id
= Aspect_Export
or else A_Id
= Aspect_Import
then
1254 -- Otherwise create a corresponding pragma
1257 Make_Pragma_From_Boolean_Aspect
(ASN
);
1260 -- Special handling for aspects that don't correspond to
1261 -- pragmas/attributes.
1263 when Aspect_Default_Value
1264 | Aspect_Default_Component_Value
1266 -- Do not inherit aspect for anonymous base type of a
1267 -- scalar or array type, because they apply to the first
1268 -- subtype of the type, and will be processed when that
1269 -- first subtype is frozen.
1271 if Is_Derived_Type
(E
)
1272 and then not Comes_From_Source
(E
)
1273 and then E
/= First_Subtype
(E
)
1277 Analyze_Aspect_Default_Value
(ASN
);
1280 -- Ditto for iterator aspects, because the corresponding
1281 -- attributes may not have been analyzed yet.
1283 when Aspect_Constant_Indexing
1284 | Aspect_Default_Iterator
1285 | Aspect_Iterator_Element
1286 | Aspect_Variable_Indexing
1288 Analyze
(Expression
(ASN
));
1290 if Etype
(Expression
(ASN
)) = Any_Type
then
1292 ("\aspect must be fully defined before & is frozen",
1296 when Aspect_Iterable
=>
1297 Validate_Iterable_Aspect
(E
, ASN
);
1303 Ritem
:= Aspect_Rep_Item
(ASN
);
1305 if Present
(Ritem
) then
1311 Next_Rep_Item
(ASN
);
1314 -- This is where we inherit delayed rep aspects from our parent. Note
1315 -- that if we fell out of the above loop with ASN non-empty, it means
1316 -- we hit an aspect for an entity other than E, and it must be the
1317 -- type from which we were derived.
1319 if May_Inherit_Delayed_Rep_Aspects
(E
) then
1320 Inherit_Delayed_Rep_Aspects
(ASN
);
1322 end Analyze_Aspects_At_Freeze_Point
;
1324 -----------------------------------
1325 -- Analyze_Aspect_Specifications --
1326 -----------------------------------
1328 procedure Analyze_Aspect_Specifications
(N
: Node_Id
; E
: Entity_Id
) is
1329 procedure Decorate
(Asp
: Node_Id
; Prag
: Node_Id
);
1330 -- Establish linkages between an aspect and its corresponding pragma
1332 procedure Insert_Pragma
1334 Is_Instance
: Boolean := False);
1335 -- Subsidiary to the analysis of aspects
1342 -- Initial_Condition
1351 -- Insert pragma Prag such that it mimics the placement of a source
1352 -- pragma of the same kind. Flag Is_Generic should be set when the
1353 -- context denotes a generic instance.
1359 procedure Decorate
(Asp
: Node_Id
; Prag
: Node_Id
) is
1361 Set_Aspect_Rep_Item
(Asp
, Prag
);
1362 Set_Corresponding_Aspect
(Prag
, Asp
);
1363 Set_From_Aspect_Specification
(Prag
);
1364 Set_Parent
(Prag
, Asp
);
1371 procedure Insert_Pragma
1373 Is_Instance
: Boolean := False)
1379 Inserted
: Boolean := False;
1382 -- When the aspect appears on an entry, package, protected unit,
1383 -- subprogram, or task unit body, insert the generated pragma at the
1384 -- top of the body declarations to emulate the behavior of a source
1387 -- package body Pack with Aspect is
1389 -- package body Pack is
1392 if Nkind_In
(N
, N_Entry_Body
,
1398 Decls
:= Declarations
(N
);
1402 Set_Declarations
(N
, Decls
);
1405 Prepend_To
(Decls
, Prag
);
1407 -- When the aspect is associated with a [generic] package declaration
1408 -- insert the generated pragma at the top of the visible declarations
1409 -- to emulate the behavior of a source pragma.
1411 -- package Pack with Aspect is
1416 elsif Nkind_In
(N
, N_Generic_Package_Declaration
,
1417 N_Package_Declaration
)
1419 Decls
:= Visible_Declarations
(Specification
(N
));
1423 Set_Visible_Declarations
(Specification
(N
), Decls
);
1426 -- The visible declarations of a generic instance have the
1427 -- following structure:
1429 -- <renamings of generic formals>
1430 -- <renamings of internally-generated spec and body>
1431 -- <first source declaration>
1433 -- Insert the pragma before the first source declaration by
1434 -- skipping the instance "header" to ensure proper visibility of
1438 Decl
:= First
(Decls
);
1439 while Present
(Decl
) loop
1440 if Comes_From_Source
(Decl
) then
1441 Insert_Before
(Decl
, Prag
);
1449 -- The pragma is placed after the instance "header"
1451 if not Inserted
then
1452 Append_To
(Decls
, Prag
);
1455 -- Otherwise this is not a generic instance
1458 Prepend_To
(Decls
, Prag
);
1461 -- When the aspect is associated with a protected unit declaration,
1462 -- insert the generated pragma at the top of the visible declarations
1463 -- the emulate the behavior of a source pragma.
1465 -- protected [type] Prot with Aspect is
1467 -- protected [type] Prot is
1470 elsif Nkind
(N
) = N_Protected_Type_Declaration
then
1471 Def
:= Protected_Definition
(N
);
1475 Make_Protected_Definition
(Sloc
(N
),
1476 Visible_Declarations
=> New_List
,
1477 End_Label
=> Empty
);
1479 Set_Protected_Definition
(N
, Def
);
1482 Decls
:= Visible_Declarations
(Def
);
1486 Set_Visible_Declarations
(Def
, Decls
);
1489 Prepend_To
(Decls
, Prag
);
1491 -- When the aspect is associated with a task unit declaration, insert
1492 -- insert the generated pragma at the top of the visible declarations
1493 -- the emulate the behavior of a source pragma.
1495 -- task [type] Prot with Aspect is
1497 -- task [type] Prot is
1500 elsif Nkind
(N
) = N_Task_Type_Declaration
then
1501 Def
:= Task_Definition
(N
);
1505 Make_Task_Definition
(Sloc
(N
),
1506 Visible_Declarations
=> New_List
,
1507 End_Label
=> Empty
);
1509 Set_Task_Definition
(N
, Def
);
1512 Decls
:= Visible_Declarations
(Def
);
1516 Set_Visible_Declarations
(Def
, Decls
);
1519 Prepend_To
(Decls
, Prag
);
1521 -- When the context is a library unit, the pragma is added to the
1522 -- Pragmas_After list.
1524 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
1525 Aux
:= Aux_Decls_Node
(Parent
(N
));
1527 if No
(Pragmas_After
(Aux
)) then
1528 Set_Pragmas_After
(Aux
, New_List
);
1531 Prepend
(Prag
, Pragmas_After
(Aux
));
1533 -- Default, the pragma is inserted after the context
1536 Insert_After
(N
, Prag
);
1546 L
: constant List_Id
:= Aspect_Specifications
(N
);
1548 Ins_Node
: Node_Id
:= N
;
1549 -- Insert pragmas/attribute definition clause after this node when no
1550 -- delayed analysis is required.
1552 -- Start of processing for Analyze_Aspect_Specifications
1555 -- The general processing involves building an attribute definition
1556 -- clause or a pragma node that corresponds to the aspect. Then in order
1557 -- to delay the evaluation of this aspect to the freeze point, we attach
1558 -- the corresponding pragma/attribute definition clause to the aspect
1559 -- specification node, which is then placed in the Rep Item chain. In
1560 -- this case we mark the entity by setting the flag Has_Delayed_Aspects
1561 -- and we evaluate the rep item at the freeze point. When the aspect
1562 -- doesn't have a corresponding pragma/attribute definition clause, then
1563 -- its analysis is simply delayed at the freeze point.
1565 -- Some special cases don't require delay analysis, thus the aspect is
1566 -- analyzed right now.
1568 -- Note that there is a special handling for Pre, Post, Test_Case,
1569 -- Contract_Cases aspects. In these cases, we do not have to worry
1570 -- about delay issues, since the pragmas themselves deal with delay
1571 -- of visibility for the expression analysis. Thus, we just insert
1572 -- the pragma after the node N.
1574 pragma Assert
(Present
(L
));
1576 -- Loop through aspects
1578 Aspect
:= First
(L
);
1579 Aspect_Loop
: while Present
(Aspect
) loop
1580 Analyze_One_Aspect
: declare
1581 Expr
: constant Node_Id
:= Expression
(Aspect
);
1582 Id
: constant Node_Id
:= Identifier
(Aspect
);
1583 Loc
: constant Source_Ptr
:= Sloc
(Aspect
);
1584 Nam
: constant Name_Id
:= Chars
(Id
);
1585 A_Id
: constant Aspect_Id
:= Get_Aspect_Id
(Nam
);
1588 Delay_Required
: Boolean;
1589 -- Set False if delay is not required
1591 Eloc
: Source_Ptr
:= No_Location
;
1592 -- Source location of expression, modified when we split PPC's. It
1593 -- is set below when Expr is present.
1595 procedure Analyze_Aspect_Convention
;
1596 -- Perform analysis of aspect Convention
1598 procedure Analyze_Aspect_Export_Import
;
1599 -- Perform analysis of aspects Export or Import
1601 procedure Analyze_Aspect_External_Link_Name
;
1602 -- Perform analysis of aspects External_Name or Link_Name
1604 procedure Analyze_Aspect_Implicit_Dereference
;
1605 -- Perform analysis of the Implicit_Dereference aspects
1607 procedure Make_Aitem_Pragma
1608 (Pragma_Argument_Associations
: List_Id
;
1609 Pragma_Name
: Name_Id
);
1610 -- This is a wrapper for Make_Pragma used for converting aspects
1611 -- to pragmas. It takes care of Sloc (set from Loc) and building
1612 -- the pragma identifier from the given name. In addition the
1613 -- flags Class_Present and Split_PPC are set from the aspect
1614 -- node, as well as Is_Ignored. This routine also sets the
1615 -- From_Aspect_Specification in the resulting pragma node to
1616 -- True, and sets Corresponding_Aspect to point to the aspect.
1617 -- The resulting pragma is assigned to Aitem.
1619 -------------------------------
1620 -- Analyze_Aspect_Convention --
1621 -------------------------------
1623 procedure Analyze_Aspect_Convention
is
1632 -- Obtain all interfacing aspects that apply to the related
1635 Get_Interfacing_Aspects
1636 (Iface_Asp
=> Aspect
,
1637 Conv_Asp
=> Dummy_1
,
1644 -- The related entity is subject to aspect Export or Import.
1645 -- Do not process Convention now because it must be analysed
1646 -- as part of Export or Import.
1648 if Present
(Expo
) or else Present
(Imp
) then
1651 -- Otherwise Convention appears by itself
1654 -- The aspect specifies a particular convention
1656 if Present
(Expr
) then
1657 Conv
:= New_Copy_Tree
(Expr
);
1659 -- Otherwise assume convention Ada
1662 Conv
:= Make_Identifier
(Loc
, Name_Ada
);
1666 -- pragma Convention (<Conv>, <E>);
1669 (Pragma_Name
=> Name_Convention
,
1670 Pragma_Argument_Associations
=> New_List
(
1671 Make_Pragma_Argument_Association
(Loc
,
1672 Expression
=> Conv
),
1673 Make_Pragma_Argument_Association
(Loc
,
1674 Expression
=> New_Occurrence_Of
(E
, Loc
))));
1676 Decorate
(Aspect
, Aitem
);
1677 Insert_Pragma
(Aitem
);
1679 end Analyze_Aspect_Convention
;
1681 ----------------------------------
1682 -- Analyze_Aspect_Export_Import --
1683 ----------------------------------
1685 procedure Analyze_Aspect_Export_Import
is
1693 -- Obtain all interfacing aspects that apply to the related
1696 Get_Interfacing_Aspects
1697 (Iface_Asp
=> Aspect
,
1698 Conv_Asp
=> Dummy_1
,
1705 -- The related entity cannot be subject to both aspects Export
1708 if Present
(Expo
) and then Present
(Imp
) then
1710 ("incompatible interfacing aspects given for &", E
);
1711 Error_Msg_Sloc
:= Sloc
(Expo
);
1712 Error_Msg_N
("\aspect `Export` #", E
);
1713 Error_Msg_Sloc
:= Sloc
(Imp
);
1714 Error_Msg_N
("\aspect `Import` #", E
);
1717 -- A variable is most likely modified from the outside. Take
1718 -- the optimistic approach to avoid spurious errors.
1720 if Ekind
(E
) = E_Variable
then
1721 Set_Never_Set_In_Source
(E
, False);
1724 -- Resolve the expression of an Import or Export here, and
1725 -- require it to be of type Boolean and static. This is not
1726 -- quite right, because in general this should be delayed,
1727 -- but that seems tricky for these, because normally Boolean
1728 -- aspects are replaced with pragmas at the freeze point in
1729 -- Make_Pragma_From_Boolean_Aspect.
1731 if not Present
(Expr
)
1732 or else Is_True
(Static_Boolean
(Expr
))
1734 if A_Id
= Aspect_Import
then
1735 Set_Has_Completion
(E
);
1736 Set_Is_Imported
(E
);
1738 -- An imported object cannot be explicitly initialized
1740 if Nkind
(N
) = N_Object_Declaration
1741 and then Present
(Expression
(N
))
1744 ("imported entities cannot be initialized "
1745 & "(RM B.1(24))", Expression
(N
));
1749 pragma Assert
(A_Id
= Aspect_Export
);
1750 Set_Is_Exported
(E
);
1753 -- Create the proper form of pragma Export or Import taking
1754 -- into account Conversion, External_Name, and Link_Name.
1756 Aitem
:= Build_Export_Import_Pragma
(Aspect
, E
);
1758 -- Otherwise the expression is either False or erroneous. There
1759 -- is no corresponding pragma.
1764 end Analyze_Aspect_Export_Import
;
1766 ---------------------------------------
1767 -- Analyze_Aspect_External_Link_Name --
1768 ---------------------------------------
1770 procedure Analyze_Aspect_External_Link_Name
is
1778 -- Obtain all interfacing aspects that apply to the related
1781 Get_Interfacing_Aspects
1782 (Iface_Asp
=> Aspect
,
1783 Conv_Asp
=> Dummy_1
,
1790 -- Ensure that aspect External_Name applies to aspect Export or
1793 if A_Id
= Aspect_External_Name
then
1794 if No
(Expo
) and then No
(Imp
) then
1796 ("aspect `External_Name` requires aspect `Import` or "
1797 & "`Export`", Aspect
);
1800 -- Otherwise ensure that aspect Link_Name applies to aspect
1801 -- Export or Import.
1804 pragma Assert
(A_Id
= Aspect_Link_Name
);
1805 if No
(Expo
) and then No
(Imp
) then
1807 ("aspect `Link_Name` requires aspect `Import` or "
1808 & "`Export`", Aspect
);
1811 end Analyze_Aspect_External_Link_Name
;
1813 -----------------------------------------
1814 -- Analyze_Aspect_Implicit_Dereference --
1815 -----------------------------------------
1817 procedure Analyze_Aspect_Implicit_Dereference
is
1819 Parent_Disc
: Entity_Id
;
1822 if not Is_Type
(E
) or else not Has_Discriminants
(E
) then
1824 ("aspect must apply to a type with discriminants", Expr
);
1826 elsif not Is_Entity_Name
(Expr
) then
1828 ("aspect must name a discriminant of current type", Expr
);
1831 -- Discriminant type be an anonymous access type or an
1832 -- anonymous access to subprogram.
1834 -- Missing synchronized types???
1836 Disc
:= First_Discriminant
(E
);
1837 while Present
(Disc
) loop
1838 if Chars
(Expr
) = Chars
(Disc
)
1839 and then Ekind_In
(Etype
(Disc
),
1840 E_Anonymous_Access_Subprogram_Type
,
1841 E_Anonymous_Access_Type
)
1843 Set_Has_Implicit_Dereference
(E
);
1844 Set_Has_Implicit_Dereference
(Disc
);
1848 Next_Discriminant
(Disc
);
1851 -- Error if no proper access discriminant
1854 Error_Msg_NE
("not an access discriminant of&", Expr
, E
);
1859 -- For a type extension, check whether parent has a
1860 -- reference discriminant, to verify that use is proper.
1862 if Is_Derived_Type
(E
)
1863 and then Has_Discriminants
(Etype
(E
))
1865 Parent_Disc
:= Get_Reference_Discriminant
(Etype
(E
));
1867 if Present
(Parent_Disc
)
1868 and then Corresponding_Discriminant
(Disc
) /= Parent_Disc
1871 ("reference discriminant does not match discriminant "
1872 & "of parent type", Expr
);
1875 end Analyze_Aspect_Implicit_Dereference
;
1877 -----------------------
1878 -- Make_Aitem_Pragma --
1879 -----------------------
1881 procedure Make_Aitem_Pragma
1882 (Pragma_Argument_Associations
: List_Id
;
1883 Pragma_Name
: Name_Id
)
1885 Args
: List_Id
:= Pragma_Argument_Associations
;
1888 -- We should never get here if aspect was disabled
1890 pragma Assert
(not Is_Disabled
(Aspect
));
1892 -- Certain aspects allow for an optional name or expression. Do
1893 -- not generate a pragma with empty argument association list.
1895 if No
(Args
) or else No
(Expression
(First
(Args
))) then
1903 Pragma_Argument_Associations
=> Args
,
1904 Pragma_Identifier
=>
1905 Make_Identifier
(Sloc
(Id
), Pragma_Name
),
1906 Class_Present
=> Class_Present
(Aspect
),
1907 Split_PPC
=> Split_PPC
(Aspect
));
1909 -- Set additional semantic fields
1911 if Is_Ignored
(Aspect
) then
1912 Set_Is_Ignored
(Aitem
);
1913 elsif Is_Checked
(Aspect
) then
1914 Set_Is_Checked
(Aitem
);
1917 Set_Corresponding_Aspect
(Aitem
, Aspect
);
1918 Set_From_Aspect_Specification
(Aitem
);
1919 end Make_Aitem_Pragma
;
1921 -- Start of processing for Analyze_One_Aspect
1924 -- Skip aspect if already analyzed, to avoid looping in some cases
1926 if Analyzed
(Aspect
) then
1930 -- Skip looking at aspect if it is totally disabled. Just mark it
1931 -- as such for later reference in the tree. This also sets the
1932 -- Is_Ignored and Is_Checked flags appropriately.
1934 Check_Applicable_Policy
(Aspect
);
1936 if Is_Disabled
(Aspect
) then
1940 -- Set the source location of expression, used in the case of
1941 -- a failed precondition/postcondition or invariant. Note that
1942 -- the source location of the expression is not usually the best
1943 -- choice here. For example, it gets located on the last AND
1944 -- keyword in a chain of boolean expressiond AND'ed together.
1945 -- It is best to put the message on the first character of the
1946 -- assertion, which is the effect of the First_Node call here.
1948 if Present
(Expr
) then
1949 Eloc
:= Sloc
(First_Node
(Expr
));
1952 -- Check restriction No_Implementation_Aspect_Specifications
1954 if Implementation_Defined_Aspect
(A_Id
) then
1956 (No_Implementation_Aspect_Specifications
, Aspect
);
1959 -- Check restriction No_Specification_Of_Aspect
1961 Check_Restriction_No_Specification_Of_Aspect
(Aspect
);
1963 -- Mark aspect analyzed (actual analysis is delayed till later)
1965 Set_Analyzed
(Aspect
);
1966 Set_Entity
(Aspect
, E
);
1968 -- Build the reference to E that will be used in the built pragmas
1970 Ent
:= New_Occurrence_Of
(E
, Sloc
(Id
));
1972 if A_Id
= Aspect_Attach_Handler
1973 or else A_Id
= Aspect_Interrupt_Handler
1976 -- Treat the specification as a reference to the protected
1977 -- operation, which might otherwise appear unreferenced and
1978 -- generate spurious warnings.
1980 Generate_Reference
(E
, Id
);
1983 -- Check for duplicate aspect. Note that the Comes_From_Source
1984 -- test allows duplicate Pre/Post's that we generate internally
1985 -- to escape being flagged here.
1987 if No_Duplicates_Allowed
(A_Id
) then
1989 while Anod
/= Aspect
loop
1990 if Comes_From_Source
(Aspect
)
1991 and then Same_Aspect
(A_Id
, Get_Aspect_Id
(Anod
))
1993 Error_Msg_Name_1
:= Nam
;
1994 Error_Msg_Sloc
:= Sloc
(Anod
);
1996 -- Case of same aspect specified twice
1998 if Class_Present
(Anod
) = Class_Present
(Aspect
) then
1999 if not Class_Present
(Anod
) then
2001 ("aspect% for & previously given#",
2005 ("aspect `%''Class` for & previously given#",
2015 -- Check some general restrictions on language defined aspects
2017 if not Implementation_Defined_Aspect
(A_Id
) then
2018 Error_Msg_Name_1
:= Nam
;
2020 -- Not allowed for renaming declarations. Examine the original
2021 -- node because a subprogram renaming may have been rewritten
2024 if Nkind
(Original_Node
(N
)) in N_Renaming_Declaration
then
2026 ("aspect % not allowed for renaming declaration",
2030 -- Not allowed for formal type declarations
2032 if Nkind
(N
) = N_Formal_Type_Declaration
then
2034 ("aspect % not allowed for formal type declaration",
2039 -- Copy expression for later processing by the procedures
2040 -- Check_Aspect_At_[Freeze_Point | End_Of_Declarations]
2042 Set_Entity
(Id
, New_Copy_Tree
(Expr
));
2044 -- Set Delay_Required as appropriate to aspect
2046 case Aspect_Delay
(A_Id
) is
2047 when Always_Delay
=>
2048 Delay_Required
:= True;
2051 Delay_Required
:= False;
2055 -- If expression has the form of an integer literal, then
2056 -- do not delay, since we know the value cannot change.
2057 -- This optimization catches most rep clause cases.
2059 -- For Boolean aspects, don't delay if no expression
2061 if A_Id
in Boolean_Aspects
and then No
(Expr
) then
2062 Delay_Required
:= False;
2064 -- For non-Boolean aspects, don't delay if integer literal,
2065 -- unless the aspect is Alignment, which affects the
2066 -- freezing of an initialized object.
2068 elsif A_Id
not in Boolean_Aspects
2069 and then A_Id
/= Aspect_Alignment
2070 and then Present
(Expr
)
2071 and then Nkind
(Expr
) = N_Integer_Literal
2073 Delay_Required
:= False;
2075 -- All other cases are delayed
2078 Delay_Required
:= True;
2079 Set_Has_Delayed_Rep_Aspects
(E
);
2083 -- Processing based on specific aspect
2086 when Aspect_Unimplemented
=>
2087 null; -- ??? temp for now
2089 -- No_Aspect should be impossible
2092 raise Program_Error
;
2094 -- Case 1: Aspects corresponding to attribute definition
2100 | Aspect_Component_Size
2101 | Aspect_Constant_Indexing
2102 | Aspect_Default_Iterator
2103 | Aspect_Dispatching_Domain
2104 | Aspect_External_Tag
2107 | Aspect_Iterator_Element
2108 | Aspect_Machine_Radix
2109 | Aspect_Object_Size
2112 | Aspect_Scalar_Storage_Order
2113 | Aspect_Secondary_Stack_Size
2114 | Aspect_Simple_Storage_Pool
2117 | Aspect_Storage_Pool
2118 | Aspect_Stream_Size
2120 | Aspect_Variable_Indexing
2123 -- Indexing aspects apply only to tagged type
2125 if (A_Id
= Aspect_Constant_Indexing
2127 A_Id
= Aspect_Variable_Indexing
)
2128 and then not (Is_Type
(E
)
2129 and then Is_Tagged_Type
(E
))
2132 ("indexing aspect can only apply to a tagged type",
2137 -- For the case of aspect Address, we don't consider that we
2138 -- know the entity is never set in the source, since it is
2139 -- is likely aliasing is occurring.
2141 -- Note: one might think that the analysis of the resulting
2142 -- attribute definition clause would take care of that, but
2143 -- that's not the case since it won't be from source.
2145 if A_Id
= Aspect_Address
then
2146 Set_Never_Set_In_Source
(E
, False);
2149 -- Correctness of the profile of a stream operation is
2150 -- verified at the freeze point, but we must detect the
2151 -- illegal specification of this aspect for a subtype now,
2152 -- to prevent malformed rep_item chains.
2154 if A_Id
= Aspect_Input
or else
2155 A_Id
= Aspect_Output
or else
2156 A_Id
= Aspect_Read
or else
2159 if not Is_First_Subtype
(E
) then
2161 ("local name must be a first subtype", Aspect
);
2164 -- If stream aspect applies to the class-wide type,
2165 -- the generated attribute definition applies to the
2166 -- class-wide type as well.
2168 elsif Class_Present
(Aspect
) then
2170 Make_Attribute_Reference
(Loc
,
2172 Attribute_Name
=> Name_Class
);
2176 -- Construct the attribute definition clause
2179 Make_Attribute_Definition_Clause
(Loc
,
2181 Chars
=> Chars
(Id
),
2182 Expression
=> Relocate_Node
(Expr
));
2184 -- If the address is specified, then we treat the entity as
2185 -- referenced, to avoid spurious warnings. This is analogous
2186 -- to what is done with an attribute definition clause, but
2187 -- here we don't want to generate a reference because this
2188 -- is the point of definition of the entity.
2190 if A_Id
= Aspect_Address
then
2194 -- Case 2: Aspects corresponding to pragmas
2196 -- Case 2a: Aspects corresponding to pragmas with two
2197 -- arguments, where the first argument is a local name
2198 -- referring to the entity, and the second argument is the
2199 -- aspect definition expression.
2201 -- Linker_Section/Suppress/Unsuppress
2203 when Aspect_Linker_Section
2208 (Pragma_Argument_Associations
=> New_List
(
2209 Make_Pragma_Argument_Association
(Loc
,
2210 Expression
=> New_Occurrence_Of
(E
, Loc
)),
2211 Make_Pragma_Argument_Association
(Sloc
(Expr
),
2212 Expression
=> Relocate_Node
(Expr
))),
2213 Pragma_Name
=> Chars
(Id
));
2215 -- Linker_Section does not need delaying, as its argument
2216 -- must be a static string. Furthermore, if applied to
2217 -- an object with an explicit initialization, the object
2218 -- must be frozen in order to elaborate the initialization
2219 -- code. (This is already done for types with implicit
2220 -- initialization, such as protected types.)
2222 if A_Id
= Aspect_Linker_Section
2223 and then Nkind
(N
) = N_Object_Declaration
2224 and then Has_Init_Expression
(N
)
2226 Delay_Required
:= False;
2231 -- Corresponds to pragma Implemented, construct the pragma
2233 when Aspect_Synchronization
=>
2235 (Pragma_Argument_Associations
=> New_List
(
2236 Make_Pragma_Argument_Association
(Loc
,
2237 Expression
=> New_Occurrence_Of
(E
, Loc
)),
2238 Make_Pragma_Argument_Association
(Sloc
(Expr
),
2239 Expression
=> Relocate_Node
(Expr
))),
2240 Pragma_Name
=> Name_Implemented
);
2244 when Aspect_Attach_Handler
=>
2246 (Pragma_Argument_Associations
=> New_List
(
2247 Make_Pragma_Argument_Association
(Sloc
(Ent
),
2249 Make_Pragma_Argument_Association
(Sloc
(Expr
),
2250 Expression
=> Relocate_Node
(Expr
))),
2251 Pragma_Name
=> Name_Attach_Handler
);
2253 -- We need to insert this pragma into the tree to get proper
2254 -- processing and to look valid from a placement viewpoint.
2256 Insert_Pragma
(Aitem
);
2259 -- Dynamic_Predicate, Predicate, Static_Predicate
2261 when Aspect_Dynamic_Predicate
2263 | Aspect_Static_Predicate
2265 -- These aspects apply only to subtypes
2267 if not Is_Type
(E
) then
2269 ("predicate can only be specified for a subtype",
2273 elsif Is_Incomplete_Type
(E
) then
2275 ("predicate cannot apply to incomplete view", Aspect
);
2279 -- Construct the pragma (always a pragma Predicate, with
2280 -- flags recording whether it is static/dynamic). We also
2281 -- set flags recording this in the type itself.
2284 (Pragma_Argument_Associations
=> New_List
(
2285 Make_Pragma_Argument_Association
(Sloc
(Ent
),
2287 Make_Pragma_Argument_Association
(Sloc
(Expr
),
2288 Expression
=> Relocate_Node
(Expr
))),
2289 Pragma_Name
=> Name_Predicate
);
2291 -- Mark type has predicates, and remember what kind of
2292 -- aspect lead to this predicate (we need this to access
2293 -- the right set of check policies later on).
2295 Set_Has_Predicates
(E
);
2297 if A_Id
= Aspect_Dynamic_Predicate
then
2298 Set_Has_Dynamic_Predicate_Aspect
(E
);
2300 -- If the entity has a dynamic predicate, any inherited
2301 -- static predicate becomes dynamic as well, and the
2302 -- predicate function includes the conjunction of both.
2304 Set_Has_Static_Predicate_Aspect
(E
, False);
2306 elsif A_Id
= Aspect_Static_Predicate
then
2307 Set_Has_Static_Predicate_Aspect
(E
);
2310 -- If the type is private, indicate that its completion
2311 -- has a freeze node, because that is the one that will
2312 -- be visible at freeze time.
2314 if Is_Private_Type
(E
) and then Present
(Full_View
(E
)) then
2315 Set_Has_Predicates
(Full_View
(E
));
2317 if A_Id
= Aspect_Dynamic_Predicate
then
2318 Set_Has_Dynamic_Predicate_Aspect
(Full_View
(E
));
2319 elsif A_Id
= Aspect_Static_Predicate
then
2320 Set_Has_Static_Predicate_Aspect
(Full_View
(E
));
2323 Set_Has_Delayed_Aspects
(Full_View
(E
));
2324 Ensure_Freeze_Node
(Full_View
(E
));
2327 -- Predicate_Failure
2329 when Aspect_Predicate_Failure
=>
2331 -- This aspect applies only to subtypes
2333 if not Is_Type
(E
) then
2335 ("predicate can only be specified for a subtype",
2339 elsif Is_Incomplete_Type
(E
) then
2341 ("predicate cannot apply to incomplete view", Aspect
);
2345 -- Construct the pragma
2348 (Pragma_Argument_Associations
=> New_List
(
2349 Make_Pragma_Argument_Association
(Sloc
(Ent
),
2351 Make_Pragma_Argument_Association
(Sloc
(Expr
),
2352 Expression
=> Relocate_Node
(Expr
))),
2353 Pragma_Name
=> Name_Predicate_Failure
);
2355 Set_Has_Predicates
(E
);
2357 -- If the type is private, indicate that its completion
2358 -- has a freeze node, because that is the one that will
2359 -- be visible at freeze time.
2361 if Is_Private_Type
(E
) and then Present
(Full_View
(E
)) then
2362 Set_Has_Predicates
(Full_View
(E
));
2363 Set_Has_Delayed_Aspects
(Full_View
(E
));
2364 Ensure_Freeze_Node
(Full_View
(E
));
2367 -- Case 2b: Aspects corresponding to pragmas with two
2368 -- arguments, where the second argument is a local name
2369 -- referring to the entity, and the first argument is the
2370 -- aspect definition expression.
2374 when Aspect_Convention
=>
2375 Analyze_Aspect_Convention
;
2378 -- External_Name, Link_Name
2380 when Aspect_External_Name
2383 Analyze_Aspect_External_Link_Name
;
2386 -- CPU, Interrupt_Priority, Priority
2388 -- These three aspects can be specified for a subprogram spec
2389 -- or body, in which case we analyze the expression and export
2390 -- the value of the aspect.
2392 -- Previously, we generated an equivalent pragma for bodies
2393 -- (note that the specs cannot contain these pragmas). The
2394 -- pragma was inserted ahead of local declarations, rather than
2395 -- after the body. This leads to a certain duplication between
2396 -- the processing performed for the aspect and the pragma, but
2397 -- given the straightforward handling required it is simpler
2398 -- to duplicate than to translate the aspect in the spec into
2399 -- a pragma in the declarative part of the body.
2402 | Aspect_Interrupt_Priority
2405 if Nkind_In
(N
, N_Subprogram_Body
,
2406 N_Subprogram_Declaration
)
2408 -- Analyze the aspect expression
2410 Analyze_And_Resolve
(Expr
, Standard_Integer
);
2412 -- Interrupt_Priority aspect not allowed for main
2413 -- subprograms. RM D.1 does not forbid this explicitly,
2414 -- but RM J.15.11(6/3) does not permit pragma
2415 -- Interrupt_Priority for subprograms.
2417 if A_Id
= Aspect_Interrupt_Priority
then
2419 ("Interrupt_Priority aspect cannot apply to "
2420 & "subprogram", Expr
);
2422 -- The expression must be static
2424 elsif not Is_OK_Static_Expression
(Expr
) then
2425 Flag_Non_Static_Expr
2426 ("aspect requires static expression!", Expr
);
2428 -- Check whether this is the main subprogram. Issue a
2429 -- warning only if it is obviously not a main program
2430 -- (when it has parameters or when the subprogram is
2431 -- within a package).
2433 elsif Present
(Parameter_Specifications
2434 (Specification
(N
)))
2435 or else not Is_Compilation_Unit
(Defining_Entity
(N
))
2437 -- See RM D.1(14/3) and D.16(12/3)
2440 ("aspect applied to subprogram other than the "
2441 & "main subprogram has no effect??", Expr
);
2443 -- Otherwise check in range and export the value
2445 -- For the CPU aspect
2447 elsif A_Id
= Aspect_CPU
then
2448 if Is_In_Range
(Expr
, RTE
(RE_CPU_Range
)) then
2450 -- Value is correct so we export the value to make
2451 -- it available at execution time.
2454 (Main_Unit
, UI_To_Int
(Expr_Value
(Expr
)));
2458 ("main subprogram CPU is out of range", Expr
);
2461 -- For the Priority aspect
2463 elsif A_Id
= Aspect_Priority
then
2464 if Is_In_Range
(Expr
, RTE
(RE_Priority
)) then
2466 -- Value is correct so we export the value to make
2467 -- it available at execution time.
2470 (Main_Unit
, UI_To_Int
(Expr_Value
(Expr
)));
2472 -- Ignore pragma if Relaxed_RM_Semantics to support
2473 -- other targets/non GNAT compilers.
2475 elsif not Relaxed_RM_Semantics
then
2477 ("main subprogram priority is out of range",
2482 -- Load an arbitrary entity from System.Tasking.Stages
2483 -- or System.Tasking.Restricted.Stages (depending on
2484 -- the supported profile) to make sure that one of these
2485 -- packages is implicitly with'ed, since we need to have
2486 -- the tasking run time active for the pragma Priority to
2487 -- have any effect. Previously we with'ed the package
2488 -- System.Tasking, but this package does not trigger the
2489 -- required initialization of the run-time library.
2492 Discard
: Entity_Id
;
2494 if Restricted_Profile
then
2495 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
2497 Discard
:= RTE
(RE_Activate_Tasks
);
2501 -- Handling for these aspects in subprograms is complete
2505 -- For task and protected types pass the aspect as an
2510 Make_Attribute_Definition_Clause
(Loc
,
2512 Chars
=> Chars
(Id
),
2513 Expression
=> Relocate_Node
(Expr
));
2518 when Aspect_Warnings
=>
2520 (Pragma_Argument_Associations
=> New_List
(
2521 Make_Pragma_Argument_Association
(Sloc
(Expr
),
2522 Expression
=> Relocate_Node
(Expr
)),
2523 Make_Pragma_Argument_Association
(Loc
,
2524 Expression
=> New_Occurrence_Of
(E
, Loc
))),
2525 Pragma_Name
=> Chars
(Id
));
2527 Decorate
(Aspect
, Aitem
);
2528 Insert_Pragma
(Aitem
);
2531 -- Case 2c: Aspects corresponding to pragmas with three
2534 -- Invariant aspects have a first argument that references the
2535 -- entity, a second argument that is the expression and a third
2536 -- argument that is an appropriate message.
2538 -- Invariant, Type_Invariant
2540 when Aspect_Invariant
2541 | Aspect_Type_Invariant
2543 -- Analysis of the pragma will verify placement legality:
2544 -- an invariant must apply to a private type, or appear in
2545 -- the private part of a spec and apply to a completion.
2548 (Pragma_Argument_Associations
=> New_List
(
2549 Make_Pragma_Argument_Association
(Sloc
(Ent
),
2551 Make_Pragma_Argument_Association
(Sloc
(Expr
),
2552 Expression
=> Relocate_Node
(Expr
))),
2553 Pragma_Name
=> Name_Invariant
);
2555 -- Add message unless exception messages are suppressed
2557 if not Opt
.Exception_Locations_Suppressed
then
2558 Append_To
(Pragma_Argument_Associations
(Aitem
),
2559 Make_Pragma_Argument_Association
(Eloc
,
2560 Chars
=> Name_Message
,
2562 Make_String_Literal
(Eloc
,
2563 Strval
=> "failed invariant from "
2564 & Build_Location_String
(Eloc
))));
2567 -- For Invariant case, insert immediately after the entity
2568 -- declaration. We do not have to worry about delay issues
2569 -- since the pragma processing takes care of this.
2571 Delay_Required
:= False;
2573 -- Case 2d : Aspects that correspond to a pragma with one
2578 -- Aspect Abstract_State introduces implicit declarations for
2579 -- all state abstraction entities it defines. To emulate this
2580 -- behavior, insert the pragma at the beginning of the visible
2581 -- declarations of the related package so that it is analyzed
2584 when Aspect_Abstract_State
=> Abstract_State
: declare
2585 Context
: Node_Id
:= N
;
2588 -- When aspect Abstract_State appears on a generic package,
2589 -- it is propageted to the package instance. The context in
2590 -- this case is the instance spec.
2592 if Nkind
(Context
) = N_Package_Instantiation
then
2593 Context
:= Instance_Spec
(Context
);
2596 if Nkind_In
(Context
, N_Generic_Package_Declaration
,
2597 N_Package_Declaration
)
2600 (Pragma_Argument_Associations
=> New_List
(
2601 Make_Pragma_Argument_Association
(Loc
,
2602 Expression
=> Relocate_Node
(Expr
))),
2603 Pragma_Name
=> Name_Abstract_State
);
2605 Decorate
(Aspect
, Aitem
);
2609 Is_Generic_Instance
(Defining_Entity
(Context
)));
2613 ("aspect & must apply to a package declaration",
2620 -- Aspect Async_Readers is never delayed because it is
2621 -- equivalent to a source pragma which appears after the
2622 -- related object declaration.
2624 when Aspect_Async_Readers
=>
2626 (Pragma_Argument_Associations
=> New_List
(
2627 Make_Pragma_Argument_Association
(Loc
,
2628 Expression
=> Relocate_Node
(Expr
))),
2629 Pragma_Name
=> Name_Async_Readers
);
2631 Decorate
(Aspect
, Aitem
);
2632 Insert_Pragma
(Aitem
);
2635 -- Aspect Async_Writers is never delayed because it is
2636 -- equivalent to a source pragma which appears after the
2637 -- related object declaration.
2639 when Aspect_Async_Writers
=>
2641 (Pragma_Argument_Associations
=> New_List
(
2642 Make_Pragma_Argument_Association
(Loc
,
2643 Expression
=> Relocate_Node
(Expr
))),
2644 Pragma_Name
=> Name_Async_Writers
);
2646 Decorate
(Aspect
, Aitem
);
2647 Insert_Pragma
(Aitem
);
2650 -- Aspect Constant_After_Elaboration is never delayed because
2651 -- it is equivalent to a source pragma which appears after the
2652 -- related object declaration.
2654 when Aspect_Constant_After_Elaboration
=>
2656 (Pragma_Argument_Associations
=> New_List
(
2657 Make_Pragma_Argument_Association
(Loc
,
2658 Expression
=> Relocate_Node
(Expr
))),
2660 Name_Constant_After_Elaboration
);
2662 Decorate
(Aspect
, Aitem
);
2663 Insert_Pragma
(Aitem
);
2666 -- Aspect Default_Internal_Condition is never delayed because
2667 -- it is equivalent to a source pragma which appears after the
2668 -- related private type. To deal with forward references, the
2669 -- generated pragma is stored in the rep chain of the related
2670 -- private type as types do not carry contracts. The pragma is
2671 -- wrapped inside of a procedure at the freeze point of the
2672 -- private type's full view.
2674 when Aspect_Default_Initial_Condition
=>
2676 (Pragma_Argument_Associations
=> New_List
(
2677 Make_Pragma_Argument_Association
(Loc
,
2678 Expression
=> Relocate_Node
(Expr
))),
2680 Name_Default_Initial_Condition
);
2682 Decorate
(Aspect
, Aitem
);
2683 Insert_Pragma
(Aitem
);
2686 -- Default_Storage_Pool
2688 when Aspect_Default_Storage_Pool
=>
2690 (Pragma_Argument_Associations
=> New_List
(
2691 Make_Pragma_Argument_Association
(Loc
,
2692 Expression
=> Relocate_Node
(Expr
))),
2694 Name_Default_Storage_Pool
);
2696 Decorate
(Aspect
, Aitem
);
2697 Insert_Pragma
(Aitem
);
2702 -- Aspect Depends is never delayed because it is equivalent to
2703 -- a source pragma which appears after the related subprogram.
2704 -- To deal with forward references, the generated pragma is
2705 -- stored in the contract of the related subprogram and later
2706 -- analyzed at the end of the declarative region. See routine
2707 -- Analyze_Depends_In_Decl_Part for details.
2709 when Aspect_Depends
=>
2711 (Pragma_Argument_Associations
=> New_List
(
2712 Make_Pragma_Argument_Association
(Loc
,
2713 Expression
=> Relocate_Node
(Expr
))),
2714 Pragma_Name
=> Name_Depends
);
2716 Decorate
(Aspect
, Aitem
);
2717 Insert_Pragma
(Aitem
);
2720 -- Aspect Effecitve_Reads is never delayed because it is
2721 -- equivalent to a source pragma which appears after the
2722 -- related object declaration.
2724 when Aspect_Effective_Reads
=>
2726 (Pragma_Argument_Associations
=> New_List
(
2727 Make_Pragma_Argument_Association
(Loc
,
2728 Expression
=> Relocate_Node
(Expr
))),
2729 Pragma_Name
=> Name_Effective_Reads
);
2731 Decorate
(Aspect
, Aitem
);
2732 Insert_Pragma
(Aitem
);
2735 -- Aspect Effective_Writes is never delayed because it is
2736 -- equivalent to a source pragma which appears after the
2737 -- related object declaration.
2739 when Aspect_Effective_Writes
=>
2741 (Pragma_Argument_Associations
=> New_List
(
2742 Make_Pragma_Argument_Association
(Loc
,
2743 Expression
=> Relocate_Node
(Expr
))),
2744 Pragma_Name
=> Name_Effective_Writes
);
2746 Decorate
(Aspect
, Aitem
);
2747 Insert_Pragma
(Aitem
);
2750 -- Aspect Extensions_Visible is never delayed because it is
2751 -- equivalent to a source pragma which appears after the
2752 -- related subprogram.
2754 when Aspect_Extensions_Visible
=>
2756 (Pragma_Argument_Associations
=> New_List
(
2757 Make_Pragma_Argument_Association
(Loc
,
2758 Expression
=> Relocate_Node
(Expr
))),
2759 Pragma_Name
=> Name_Extensions_Visible
);
2761 Decorate
(Aspect
, Aitem
);
2762 Insert_Pragma
(Aitem
);
2765 -- Aspect Ghost is never delayed because it is equivalent to a
2766 -- source pragma which appears at the top of [generic] package
2767 -- declarations or after an object, a [generic] subprogram, or
2768 -- a type declaration.
2770 when Aspect_Ghost
=>
2772 (Pragma_Argument_Associations
=> New_List
(
2773 Make_Pragma_Argument_Association
(Loc
,
2774 Expression
=> Relocate_Node
(Expr
))),
2775 Pragma_Name
=> Name_Ghost
);
2777 Decorate
(Aspect
, Aitem
);
2778 Insert_Pragma
(Aitem
);
2783 -- Aspect Global is never delayed because it is equivalent to
2784 -- a source pragma which appears after the related subprogram.
2785 -- To deal with forward references, the generated pragma is
2786 -- stored in the contract of the related subprogram and later
2787 -- analyzed at the end of the declarative region. See routine
2788 -- Analyze_Global_In_Decl_Part for details.
2790 when Aspect_Global
=>
2792 (Pragma_Argument_Associations
=> New_List
(
2793 Make_Pragma_Argument_Association
(Loc
,
2794 Expression
=> Relocate_Node
(Expr
))),
2795 Pragma_Name
=> Name_Global
);
2797 Decorate
(Aspect
, Aitem
);
2798 Insert_Pragma
(Aitem
);
2801 -- Initial_Condition
2803 -- Aspect Initial_Condition is never delayed because it is
2804 -- equivalent to a source pragma which appears after the
2805 -- related package. To deal with forward references, the
2806 -- generated pragma is stored in the contract of the related
2807 -- package and later analyzed at the end of the declarative
2808 -- region. See routine Analyze_Initial_Condition_In_Decl_Part
2811 when Aspect_Initial_Condition
=> Initial_Condition
: declare
2812 Context
: Node_Id
:= N
;
2815 -- When aspect Initial_Condition appears on a generic
2816 -- package, it is propageted to the package instance. The
2817 -- context in this case is the instance spec.
2819 if Nkind
(Context
) = N_Package_Instantiation
then
2820 Context
:= Instance_Spec
(Context
);
2823 if Nkind_In
(Context
, N_Generic_Package_Declaration
,
2824 N_Package_Declaration
)
2827 (Pragma_Argument_Associations
=> New_List
(
2828 Make_Pragma_Argument_Association
(Loc
,
2829 Expression
=> Relocate_Node
(Expr
))),
2831 Name_Initial_Condition
);
2833 Decorate
(Aspect
, Aitem
);
2837 Is_Generic_Instance
(Defining_Entity
(Context
)));
2839 -- Otherwise the context is illegal
2843 ("aspect & must apply to a package declaration",
2848 end Initial_Condition
;
2852 -- Aspect Initializes is never delayed because it is equivalent
2853 -- to a source pragma appearing after the related package. To
2854 -- deal with forward references, the generated pragma is stored
2855 -- in the contract of the related package and later analyzed at
2856 -- the end of the declarative region. For details, see routine
2857 -- Analyze_Initializes_In_Decl_Part.
2859 when Aspect_Initializes
=> Initializes
: declare
2860 Context
: Node_Id
:= N
;
2863 -- When aspect Initializes appears on a generic package,
2864 -- it is propageted to the package instance. The context
2865 -- in this case is the instance spec.
2867 if Nkind
(Context
) = N_Package_Instantiation
then
2868 Context
:= Instance_Spec
(Context
);
2871 if Nkind_In
(Context
, N_Generic_Package_Declaration
,
2872 N_Package_Declaration
)
2875 (Pragma_Argument_Associations
=> New_List
(
2876 Make_Pragma_Argument_Association
(Loc
,
2877 Expression
=> Relocate_Node
(Expr
))),
2878 Pragma_Name
=> Name_Initializes
);
2880 Decorate
(Aspect
, Aitem
);
2884 Is_Generic_Instance
(Defining_Entity
(Context
)));
2886 -- Otherwise the context is illegal
2890 ("aspect & must apply to a package declaration",
2899 when Aspect_Max_Queue_Length
=>
2901 (Pragma_Argument_Associations
=> New_List
(
2902 Make_Pragma_Argument_Association
(Loc
,
2903 Expression
=> Relocate_Node
(Expr
))),
2904 Pragma_Name
=> Name_Max_Queue_Length
);
2906 Decorate
(Aspect
, Aitem
);
2907 Insert_Pragma
(Aitem
);
2912 when Aspect_Obsolescent
=> declare
2920 Make_Pragma_Argument_Association
(Sloc
(Expr
),
2921 Expression
=> Relocate_Node
(Expr
)));
2925 (Pragma_Argument_Associations
=> Args
,
2926 Pragma_Name
=> Chars
(Id
));
2931 when Aspect_Part_Of
=>
2932 if Nkind_In
(N
, N_Object_Declaration
,
2933 N_Package_Instantiation
)
2934 or else Is_Single_Concurrent_Type_Declaration
(N
)
2937 (Pragma_Argument_Associations
=> New_List
(
2938 Make_Pragma_Argument_Association
(Loc
,
2939 Expression
=> Relocate_Node
(Expr
))),
2940 Pragma_Name
=> Name_Part_Of
);
2942 Decorate
(Aspect
, Aitem
);
2943 Insert_Pragma
(Aitem
);
2947 ("aspect & must apply to package instantiation, "
2948 & "object, single protected type or single task type",
2956 when Aspect_SPARK_Mode
=>
2958 (Pragma_Argument_Associations
=> New_List
(
2959 Make_Pragma_Argument_Association
(Loc
,
2960 Expression
=> Relocate_Node
(Expr
))),
2961 Pragma_Name
=> Name_SPARK_Mode
);
2963 Decorate
(Aspect
, Aitem
);
2964 Insert_Pragma
(Aitem
);
2969 -- Aspect Refined_Depends is never delayed because it is
2970 -- equivalent to a source pragma which appears in the
2971 -- declarations of the related subprogram body. To deal with
2972 -- forward references, the generated pragma is stored in the
2973 -- contract of the related subprogram body and later analyzed
2974 -- at the end of the declarative region. For details, see
2975 -- routine Analyze_Refined_Depends_In_Decl_Part.
2977 when Aspect_Refined_Depends
=>
2979 (Pragma_Argument_Associations
=> New_List
(
2980 Make_Pragma_Argument_Association
(Loc
,
2981 Expression
=> Relocate_Node
(Expr
))),
2982 Pragma_Name
=> Name_Refined_Depends
);
2984 Decorate
(Aspect
, Aitem
);
2985 Insert_Pragma
(Aitem
);
2990 -- Aspect Refined_Global is never delayed because it is
2991 -- equivalent to a source pragma which appears in the
2992 -- declarations of the related subprogram body. To deal with
2993 -- forward references, the generated pragma is stored in the
2994 -- contract of the related subprogram body and later analyzed
2995 -- at the end of the declarative region. For details, see
2996 -- routine Analyze_Refined_Global_In_Decl_Part.
2998 when Aspect_Refined_Global
=>
3000 (Pragma_Argument_Associations
=> New_List
(
3001 Make_Pragma_Argument_Association
(Loc
,
3002 Expression
=> Relocate_Node
(Expr
))),
3003 Pragma_Name
=> Name_Refined_Global
);
3005 Decorate
(Aspect
, Aitem
);
3006 Insert_Pragma
(Aitem
);
3011 when Aspect_Refined_Post
=>
3013 (Pragma_Argument_Associations
=> New_List
(
3014 Make_Pragma_Argument_Association
(Loc
,
3015 Expression
=> Relocate_Node
(Expr
))),
3016 Pragma_Name
=> Name_Refined_Post
);
3018 Decorate
(Aspect
, Aitem
);
3019 Insert_Pragma
(Aitem
);
3024 when Aspect_Refined_State
=>
3026 -- The corresponding pragma for Refined_State is inserted in
3027 -- the declarations of the related package body. This action
3028 -- synchronizes both the source and from-aspect versions of
3031 if Nkind
(N
) = N_Package_Body
then
3033 (Pragma_Argument_Associations
=> New_List
(
3034 Make_Pragma_Argument_Association
(Loc
,
3035 Expression
=> Relocate_Node
(Expr
))),
3036 Pragma_Name
=> Name_Refined_State
);
3038 Decorate
(Aspect
, Aitem
);
3039 Insert_Pragma
(Aitem
);
3041 -- Otherwise the context is illegal
3045 ("aspect & must apply to a package body", Aspect
, Id
);
3050 -- Relative_Deadline
3052 when Aspect_Relative_Deadline
=>
3054 (Pragma_Argument_Associations
=> New_List
(
3055 Make_Pragma_Argument_Association
(Loc
,
3056 Expression
=> Relocate_Node
(Expr
))),
3057 Pragma_Name
=> Name_Relative_Deadline
);
3059 -- If the aspect applies to a task, the corresponding pragma
3060 -- must appear within its declarations, not after.
3062 if Nkind
(N
) = N_Task_Type_Declaration
then
3068 if No
(Task_Definition
(N
)) then
3069 Set_Task_Definition
(N
,
3070 Make_Task_Definition
(Loc
,
3071 Visible_Declarations
=> New_List
,
3072 End_Label
=> Empty
));
3075 Def
:= Task_Definition
(N
);
3076 V
:= Visible_Declarations
(Def
);
3077 if not Is_Empty_List
(V
) then
3078 Insert_Before
(First
(V
), Aitem
);
3081 Set_Visible_Declarations
(Def
, New_List
(Aitem
));
3088 -- Aspect Volatile_Function is never delayed because it is
3089 -- equivalent to a source pragma which appears after the
3090 -- related subprogram.
3092 when Aspect_Volatile_Function
=>
3094 (Pragma_Argument_Associations
=> New_List
(
3095 Make_Pragma_Argument_Association
(Loc
,
3096 Expression
=> Relocate_Node
(Expr
))),
3097 Pragma_Name
=> Name_Volatile_Function
);
3099 Decorate
(Aspect
, Aitem
);
3100 Insert_Pragma
(Aitem
);
3103 -- Case 2e: Annotate aspect
3105 when Aspect_Annotate
=>
3112 -- The argument can be a single identifier
3114 if Nkind
(Expr
) = N_Identifier
then
3116 -- One level of parens is allowed
3118 if Paren_Count
(Expr
) > 1 then
3119 Error_Msg_F
("extra parentheses ignored", Expr
);
3122 Set_Paren_Count
(Expr
, 0);
3124 -- Add the single item to the list
3126 Args
:= New_List
(Expr
);
3128 -- Otherwise we must have an aggregate
3130 elsif Nkind
(Expr
) = N_Aggregate
then
3132 -- Must be positional
3134 if Present
(Component_Associations
(Expr
)) then
3136 ("purely positional aggregate required", Expr
);
3140 -- Must not be parenthesized
3142 if Paren_Count
(Expr
) /= 0 then
3143 Error_Msg_F
("extra parentheses ignored", Expr
);
3146 -- List of arguments is list of aggregate expressions
3148 Args
:= Expressions
(Expr
);
3150 -- Anything else is illegal
3153 Error_Msg_F
("wrong form for Annotate aspect", Expr
);
3157 -- Prepare pragma arguments
3160 Arg
:= First
(Args
);
3161 while Present
(Arg
) loop
3163 Make_Pragma_Argument_Association
(Sloc
(Arg
),
3164 Expression
=> Relocate_Node
(Arg
)));
3169 Make_Pragma_Argument_Association
(Sloc
(Ent
),
3170 Chars
=> Name_Entity
,
3171 Expression
=> Ent
));
3174 (Pragma_Argument_Associations
=> Pargs
,
3175 Pragma_Name
=> Name_Annotate
);
3178 -- Case 3 : Aspects that don't correspond to pragma/attribute
3179 -- definition clause.
3181 -- Case 3a: The aspects listed below don't correspond to
3182 -- pragmas/attributes but do require delayed analysis.
3184 -- Default_Value can only apply to a scalar type
3186 when Aspect_Default_Value
=>
3187 if not Is_Scalar_Type
(E
) then
3189 ("aspect Default_Value must apply to a scalar type", N
);
3194 -- Default_Component_Value can only apply to an array type
3195 -- with scalar components.
3197 when Aspect_Default_Component_Value
=>
3198 if not (Is_Array_Type
(E
)
3199 and then Is_Scalar_Type
(Component_Type
(E
)))
3202 ("aspect Default_Component_Value can only apply to an "
3203 & "array of scalar components", N
);
3208 -- Case 3b: The aspects listed below don't correspond to
3209 -- pragmas/attributes and don't need delayed analysis.
3211 -- Implicit_Dereference
3213 -- For Implicit_Dereference, External_Name and Link_Name, only
3214 -- the legality checks are done during the analysis, thus no
3215 -- delay is required.
3217 when Aspect_Implicit_Dereference
=>
3218 Analyze_Aspect_Implicit_Dereference
;
3223 when Aspect_Dimension
=>
3224 Analyze_Aspect_Dimension
(N
, Id
, Expr
);
3229 when Aspect_Dimension_System
=>
3230 Analyze_Aspect_Dimension_System
(N
, Id
, Expr
);
3233 -- Case 4: Aspects requiring special handling
3235 -- Pre/Post/Test_Case/Contract_Cases whose corresponding
3236 -- pragmas take care of the delay.
3240 -- Aspects Pre/Post generate Precondition/Postcondition pragmas
3241 -- with a first argument that is the expression, and a second
3242 -- argument that is an informative message if the test fails.
3243 -- This is inserted right after the declaration, to get the
3244 -- required pragma placement. The processing for the pragmas
3245 -- takes care of the required delay.
3247 when Pre_Post_Aspects
=> Pre_Post
: declare
3251 if A_Id
= Aspect_Pre
or else A_Id
= Aspect_Precondition
then
3252 Pname
:= Name_Precondition
;
3254 Pname
:= Name_Postcondition
;
3257 -- Check that the class-wide predicate cannot be applied to
3258 -- an operation of a synchronized type. AI12-0182 forbids
3259 -- these altogether, while earlier language semantics made
3260 -- them legal on tagged synchronized types.
3262 -- Other legality checks are performed when analyzing the
3263 -- contract of the operation.
3265 if Class_Present
(Aspect
)
3266 and then Is_Concurrent_Type
(Current_Scope
)
3267 and then Ekind_In
(E
, E_Entry
, E_Function
, E_Procedure
)
3269 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Aspect
);
3271 ("aspect % can only be specified for a primitive "
3272 & "operation of a tagged type", Aspect
);
3277 -- If the expressions is of the form A and then B, then
3278 -- we generate separate Pre/Post aspects for the separate
3279 -- clauses. Since we allow multiple pragmas, there is no
3280 -- problem in allowing multiple Pre/Post aspects internally.
3281 -- These should be treated in reverse order (B first and
3282 -- A second) since they are later inserted just after N in
3283 -- the order they are treated. This way, the pragma for A
3284 -- ends up preceding the pragma for B, which may have an
3285 -- importance for the error raised (either constraint error
3286 -- or precondition error).
3288 -- We do not do this for Pre'Class, since we have to put
3289 -- these conditions together in a complex OR expression.
3291 -- We do not do this in ASIS mode, as ASIS relies on the
3292 -- original node representing the complete expression, when
3293 -- retrieving it through the source aspect table.
3296 and then (Pname
= Name_Postcondition
3297 or else not Class_Present
(Aspect
))
3299 while Nkind
(Expr
) = N_And_Then
loop
3300 Insert_After
(Aspect
,
3301 Make_Aspect_Specification
(Sloc
(Left_Opnd
(Expr
)),
3302 Identifier
=> Identifier
(Aspect
),
3303 Expression
=> Relocate_Node
(Left_Opnd
(Expr
)),
3304 Class_Present
=> Class_Present
(Aspect
),
3305 Split_PPC
=> True));
3306 Rewrite
(Expr
, Relocate_Node
(Right_Opnd
(Expr
)));
3307 Eloc
:= Sloc
(Expr
);
3311 -- Build the precondition/postcondition pragma
3313 -- Add note about why we do NOT need Copy_Tree here???
3316 (Pragma_Argument_Associations
=> New_List
(
3317 Make_Pragma_Argument_Association
(Eloc
,
3318 Chars
=> Name_Check
,
3319 Expression
=> Relocate_Node
(Expr
))),
3320 Pragma_Name
=> Pname
);
3322 -- Add message unless exception messages are suppressed
3324 if not Opt
.Exception_Locations_Suppressed
then
3325 Append_To
(Pragma_Argument_Associations
(Aitem
),
3326 Make_Pragma_Argument_Association
(Eloc
,
3327 Chars
=> Name_Message
,
3329 Make_String_Literal
(Eloc
,
3331 & Get_Name_String
(Pname
)
3333 & Build_Location_String
(Eloc
))));
3336 Set_Is_Delayed_Aspect
(Aspect
);
3338 -- For Pre/Post cases, insert immediately after the entity
3339 -- declaration, since that is the required pragma placement.
3340 -- Note that for these aspects, we do not have to worry
3341 -- about delay issues, since the pragmas themselves deal
3342 -- with delay of visibility for the expression analysis.
3344 Insert_Pragma
(Aitem
);
3351 when Aspect_Test_Case
=> Test_Case
: declare
3353 Comp_Expr
: Node_Id
;
3354 Comp_Assn
: Node_Id
;
3360 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3361 Error_Msg_Name_1
:= Nam
;
3362 Error_Msg_N
("incorrect placement of aspect `%`", E
);
3366 if Nkind
(Expr
) /= N_Aggregate
then
3367 Error_Msg_Name_1
:= Nam
;
3369 ("wrong syntax for aspect `%` for &", Id
, E
);
3373 -- Make pragma expressions refer to the original aspect
3374 -- expressions through the Original_Node link. This is used
3375 -- in semantic analysis for ASIS mode, so that the original
3376 -- expression also gets analyzed.
3378 Comp_Expr
:= First
(Expressions
(Expr
));
3379 while Present
(Comp_Expr
) loop
3380 New_Expr
:= Relocate_Node
(Comp_Expr
);
3382 Make_Pragma_Argument_Association
(Sloc
(Comp_Expr
),
3383 Expression
=> New_Expr
));
3387 Comp_Assn
:= First
(Component_Associations
(Expr
));
3388 while Present
(Comp_Assn
) loop
3389 if List_Length
(Choices
(Comp_Assn
)) /= 1
3391 Nkind
(First
(Choices
(Comp_Assn
))) /= N_Identifier
3393 Error_Msg_Name_1
:= Nam
;
3395 ("wrong syntax for aspect `%` for &", Id
, E
);
3400 Make_Pragma_Argument_Association
(Sloc
(Comp_Assn
),
3401 Chars
=> Chars
(First
(Choices
(Comp_Assn
))),
3403 Relocate_Node
(Expression
(Comp_Assn
))));
3407 -- Build the test-case pragma
3410 (Pragma_Argument_Associations
=> Args
,
3411 Pragma_Name
=> Nam
);
3416 when Aspect_Contract_Cases
=>
3418 (Pragma_Argument_Associations
=> New_List
(
3419 Make_Pragma_Argument_Association
(Loc
,
3420 Expression
=> Relocate_Node
(Expr
))),
3421 Pragma_Name
=> Nam
);
3423 Decorate
(Aspect
, Aitem
);
3424 Insert_Pragma
(Aitem
);
3427 -- Case 5: Special handling for aspects with an optional
3428 -- boolean argument.
3430 -- In the delayed case, the corresponding pragma cannot be
3431 -- generated yet because the evaluation of the boolean needs
3432 -- to be delayed till the freeze point.
3434 when Boolean_Aspects
3435 | Library_Unit_Aspects
3437 Set_Is_Boolean_Aspect
(Aspect
);
3439 -- Lock_Free aspect only apply to protected objects
3441 if A_Id
= Aspect_Lock_Free
then
3442 if Ekind
(E
) /= E_Protected_Type
then
3443 Error_Msg_Name_1
:= Nam
;
3445 ("aspect % only applies to a protected object",
3449 -- Set the Uses_Lock_Free flag to True if there is no
3450 -- expression or if the expression is True. The
3451 -- evaluation of this aspect should be delayed to the
3452 -- freeze point (why???)
3455 or else Is_True
(Static_Boolean
(Expr
))
3457 Set_Uses_Lock_Free
(E
);
3460 Record_Rep_Item
(E
, Aspect
);
3465 elsif A_Id
= Aspect_Export
or else A_Id
= Aspect_Import
then
3466 Analyze_Aspect_Export_Import
;
3468 -- Disable_Controlled
3470 elsif A_Id
= Aspect_Disable_Controlled
then
3471 if Ekind
(E
) /= E_Record_Type
3472 or else not Is_Controlled
(E
)
3475 ("aspect % requires controlled record type", Aspect
);
3479 -- If we're in a generic template, we don't want to try
3480 -- to disable controlled types, because typical usage is
3481 -- "Disable_Controlled => not <some_check>'Enabled", and
3482 -- the value of Enabled is not known until we see a
3483 -- particular instance. In such a context, we just need
3484 -- to preanalyze the expression for legality.
3486 if Expander_Active
then
3487 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
3489 if not Present
(Expr
)
3490 or else Is_True
(Static_Boolean
(Expr
))
3492 Set_Disable_Controlled
(E
);
3495 elsif Serious_Errors_Detected
= 0 then
3496 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
3502 -- Library unit aspects require special handling in the case
3503 -- of a package declaration, the pragma needs to be inserted
3504 -- in the list of declarations for the associated package.
3505 -- There is no issue of visibility delay for these aspects.
3507 if A_Id
in Library_Unit_Aspects
3509 Nkind_In
(N
, N_Package_Declaration
,
3510 N_Generic_Package_Declaration
)
3511 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
3513 -- Aspect is legal on a local instantiation of a library-
3514 -- level generic unit.
3516 and then not Is_Generic_Instance
(Defining_Entity
(N
))
3519 ("incorrect context for library unit aspect&", Id
);
3523 -- Cases where we do not delay, includes all cases where the
3524 -- expression is missing other than the above cases.
3526 if not Delay_Required
or else No
(Expr
) then
3528 -- Exclude aspects Export and Import because their pragma
3529 -- syntax does not map directly to a Boolean aspect.
3531 if A_Id
/= Aspect_Export
3532 and then A_Id
/= Aspect_Import
3535 (Pragma_Argument_Associations
=> New_List
(
3536 Make_Pragma_Argument_Association
(Sloc
(Ent
),
3537 Expression
=> Ent
)),
3538 Pragma_Name
=> Chars
(Id
));
3541 Delay_Required
:= False;
3543 -- In general cases, the corresponding pragma/attribute
3544 -- definition clause will be inserted later at the freezing
3545 -- point, and we do not need to build it now.
3553 -- This is special because for access types we need to generate
3554 -- an attribute definition clause. This also works for single
3555 -- task declarations, but it does not work for task type
3556 -- declarations, because we have the case where the expression
3557 -- references a discriminant of the task type. That can't use
3558 -- an attribute definition clause because we would not have
3559 -- visibility on the discriminant. For that case we must
3560 -- generate a pragma in the task definition.
3562 when Aspect_Storage_Size
=>
3566 if Ekind
(E
) = E_Task_Type
then
3568 Decl
: constant Node_Id
:= Declaration_Node
(E
);
3571 pragma Assert
(Nkind
(Decl
) = N_Task_Type_Declaration
);
3573 -- If no task definition, create one
3575 if No
(Task_Definition
(Decl
)) then
3576 Set_Task_Definition
(Decl
,
3577 Make_Task_Definition
(Loc
,
3578 Visible_Declarations
=> Empty_List
,
3579 End_Label
=> Empty
));
3582 -- Create a pragma and put it at the start of the task
3583 -- definition for the task type declaration.
3586 (Pragma_Argument_Associations
=> New_List
(
3587 Make_Pragma_Argument_Association
(Loc
,
3588 Expression
=> Relocate_Node
(Expr
))),
3589 Pragma_Name
=> Name_Storage_Size
);
3593 Visible_Declarations
(Task_Definition
(Decl
)));
3597 -- All other cases, generate attribute definition
3601 Make_Attribute_Definition_Clause
(Loc
,
3603 Chars
=> Chars
(Id
),
3604 Expression
=> Relocate_Node
(Expr
));
3608 -- Attach the corresponding pragma/attribute definition clause to
3609 -- the aspect specification node.
3611 if Present
(Aitem
) then
3612 Set_From_Aspect_Specification
(Aitem
);
3615 -- In the context of a compilation unit, we directly put the
3616 -- pragma in the Pragmas_After list of the N_Compilation_Unit_Aux
3617 -- node (no delay is required here) except for aspects on a
3618 -- subprogram body (see below) and a generic package, for which we
3619 -- need to introduce the pragma before building the generic copy
3620 -- (see sem_ch12), and for package instantiations, where the
3621 -- library unit pragmas are better handled early.
3623 if Nkind
(Parent
(N
)) = N_Compilation_Unit
3624 and then (Present
(Aitem
) or else Is_Boolean_Aspect
(Aspect
))
3627 Aux
: constant Node_Id
:= Aux_Decls_Node
(Parent
(N
));
3630 pragma Assert
(Nkind
(Aux
) = N_Compilation_Unit_Aux
);
3632 -- For a Boolean aspect, create the corresponding pragma if
3633 -- no expression or if the value is True.
3635 if Is_Boolean_Aspect
(Aspect
) and then No
(Aitem
) then
3636 if Is_True
(Static_Boolean
(Expr
)) then
3638 (Pragma_Argument_Associations
=> New_List
(
3639 Make_Pragma_Argument_Association
(Sloc
(Ent
),
3640 Expression
=> Ent
)),
3641 Pragma_Name
=> Chars
(Id
));
3643 Set_From_Aspect_Specification
(Aitem
, True);
3644 Set_Corresponding_Aspect
(Aitem
, Aspect
);
3651 -- If the aspect is on a subprogram body (relevant aspect
3652 -- is Inline), add the pragma in front of the declarations.
3654 if Nkind
(N
) = N_Subprogram_Body
then
3655 if No
(Declarations
(N
)) then
3656 Set_Declarations
(N
, New_List
);
3659 Prepend
(Aitem
, Declarations
(N
));
3661 elsif Nkind
(N
) = N_Generic_Package_Declaration
then
3662 if No
(Visible_Declarations
(Specification
(N
))) then
3663 Set_Visible_Declarations
(Specification
(N
), New_List
);
3667 Visible_Declarations
(Specification
(N
)));
3669 elsif Nkind
(N
) = N_Package_Instantiation
then
3671 Spec
: constant Node_Id
:=
3672 Specification
(Instance_Spec
(N
));
3674 if No
(Visible_Declarations
(Spec
)) then
3675 Set_Visible_Declarations
(Spec
, New_List
);
3678 Prepend
(Aitem
, Visible_Declarations
(Spec
));
3682 if No
(Pragmas_After
(Aux
)) then
3683 Set_Pragmas_After
(Aux
, New_List
);
3686 Append
(Aitem
, Pragmas_After
(Aux
));
3693 -- The evaluation of the aspect is delayed to the freezing point.
3694 -- The pragma or attribute clause if there is one is then attached
3695 -- to the aspect specification which is put in the rep item list.
3697 if Delay_Required
then
3698 if Present
(Aitem
) then
3699 Set_Is_Delayed_Aspect
(Aitem
);
3700 Set_Aspect_Rep_Item
(Aspect
, Aitem
);
3701 Set_Parent
(Aitem
, Aspect
);
3704 Set_Is_Delayed_Aspect
(Aspect
);
3706 -- In the case of Default_Value, link the aspect to base type
3707 -- as well, even though it appears on a first subtype. This is
3708 -- mandated by the semantics of the aspect. Do not establish
3709 -- the link when processing the base type itself as this leads
3710 -- to a rep item circularity. Verify that we are dealing with
3711 -- a scalar type to prevent cascaded errors.
3713 if A_Id
= Aspect_Default_Value
3714 and then Is_Scalar_Type
(E
)
3715 and then Base_Type
(E
) /= E
3717 Set_Has_Delayed_Aspects
(Base_Type
(E
));
3718 Record_Rep_Item
(Base_Type
(E
), Aspect
);
3721 Set_Has_Delayed_Aspects
(E
);
3722 Record_Rep_Item
(E
, Aspect
);
3724 -- When delay is not required and the context is a package or a
3725 -- subprogram body, insert the pragma in the body declarations.
3727 elsif Nkind_In
(N
, N_Package_Body
, N_Subprogram_Body
) then
3728 if No
(Declarations
(N
)) then
3729 Set_Declarations
(N
, New_List
);
3732 -- The pragma is added before source declarations
3734 Prepend_To
(Declarations
(N
), Aitem
);
3736 -- When delay is not required and the context is not a compilation
3737 -- unit, we simply insert the pragma/attribute definition clause
3740 elsif Present
(Aitem
) then
3741 Insert_After
(Ins_Node
, Aitem
);
3744 end Analyze_One_Aspect
;
3748 end loop Aspect_Loop
;
3750 if Has_Delayed_Aspects
(E
) then
3751 Ensure_Freeze_Node
(E
);
3753 end Analyze_Aspect_Specifications
;
3755 ---------------------------------------------------
3756 -- Analyze_Aspect_Specifications_On_Body_Or_Stub --
3757 ---------------------------------------------------
3759 procedure Analyze_Aspect_Specifications_On_Body_Or_Stub
(N
: Node_Id
) is
3760 Body_Id
: constant Entity_Id
:= Defining_Entity
(N
);
3762 procedure Diagnose_Misplaced_Aspects
(Spec_Id
: Entity_Id
);
3763 -- Body [stub] N has aspects, but they are not properly placed. Emit an
3764 -- error message depending on the aspects involved. Spec_Id denotes the
3765 -- entity of the corresponding spec.
3767 --------------------------------
3768 -- Diagnose_Misplaced_Aspects --
3769 --------------------------------
3771 procedure Diagnose_Misplaced_Aspects
(Spec_Id
: Entity_Id
) is
3772 procedure Misplaced_Aspect_Error
3775 -- Emit an error message concerning misplaced aspect Asp. Ref_Nam is
3776 -- the name of the refined version of the aspect.
3778 ----------------------------
3779 -- Misplaced_Aspect_Error --
3780 ----------------------------
3782 procedure Misplaced_Aspect_Error
3786 Asp_Nam
: constant Name_Id
:= Chars
(Identifier
(Asp
));
3787 Asp_Id
: constant Aspect_Id
:= Get_Aspect_Id
(Asp_Nam
);
3790 -- The corresponding spec already contains the aspect in question
3791 -- and the one appearing on the body must be the refined form:
3793 -- procedure P with Global ...;
3794 -- procedure P with Global ... is ... end P;
3798 if Has_Aspect
(Spec_Id
, Asp_Id
) then
3799 Error_Msg_Name_1
:= Asp_Nam
;
3801 -- Subunits cannot carry aspects that apply to a subprogram
3804 if Nkind
(Parent
(N
)) = N_Subunit
then
3805 Error_Msg_N
("aspect % cannot apply to a subunit", Asp
);
3807 -- Otherwise suggest the refined form
3810 Error_Msg_Name_2
:= Ref_Nam
;
3811 Error_Msg_N
("aspect % should be %", Asp
);
3814 -- Otherwise the aspect must appear on the spec, not on the body
3817 -- procedure P with Global ... is ... end P;
3821 ("aspect specification must appear on initial declaration",
3824 end Misplaced_Aspect_Error
;
3831 -- Start of processing for Diagnose_Misplaced_Aspects
3834 -- Iterate over the aspect specifications and emit specific errors
3835 -- where applicable.
3837 Asp
:= First
(Aspect_Specifications
(N
));
3838 while Present
(Asp
) loop
3839 Asp_Nam
:= Chars
(Identifier
(Asp
));
3841 -- Do not emit errors on aspects that can appear on a subprogram
3842 -- body. This scenario occurs when the aspect specification list
3843 -- contains both misplaced and properly placed aspects.
3845 if Aspect_On_Body_Or_Stub_OK
(Get_Aspect_Id
(Asp_Nam
)) then
3848 -- Special diagnostics for SPARK aspects
3850 elsif Asp_Nam
= Name_Depends
then
3851 Misplaced_Aspect_Error
(Asp
, Name_Refined_Depends
);
3853 elsif Asp_Nam
= Name_Global
then
3854 Misplaced_Aspect_Error
(Asp
, Name_Refined_Global
);
3856 elsif Asp_Nam
= Name_Post
then
3857 Misplaced_Aspect_Error
(Asp
, Name_Refined_Post
);
3859 -- Otherwise a language-defined aspect is misplaced
3863 ("aspect specification must appear on initial declaration",
3869 end Diagnose_Misplaced_Aspects
;
3873 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(N
);
3875 -- Start of processing for Analyze_Aspects_On_Body_Or_Stub
3878 -- Language-defined aspects cannot be associated with a subprogram body
3879 -- [stub] if the subprogram has a spec. Certain implementation defined
3880 -- aspects are allowed to break this rule (for all applicable cases, see
3881 -- table Aspects.Aspect_On_Body_Or_Stub_OK).
3883 if Spec_Id
/= Body_Id
and then not Aspects_On_Body_Or_Stub_OK
(N
) then
3884 Diagnose_Misplaced_Aspects
(Spec_Id
);
3886 Analyze_Aspect_Specifications
(N
, Body_Id
);
3888 end Analyze_Aspect_Specifications_On_Body_Or_Stub
;
3890 -----------------------
3891 -- Analyze_At_Clause --
3892 -----------------------
3894 -- An at clause is replaced by the corresponding Address attribute
3895 -- definition clause that is the preferred approach in Ada 95.
3897 procedure Analyze_At_Clause
(N
: Node_Id
) is
3898 CS
: constant Boolean := Comes_From_Source
(N
);
3901 -- This is an obsolescent feature
3903 Check_Restriction
(No_Obsolescent_Features
, N
);
3905 if Warn_On_Obsolescent_Feature
then
3907 ("?j?at clause is an obsolescent feature (RM J.7(2))", N
);
3909 ("\?j?use address attribute definition clause instead", N
);
3912 -- Rewrite as address clause
3915 Make_Attribute_Definition_Clause
(Sloc
(N
),
3916 Name
=> Identifier
(N
),
3917 Chars
=> Name_Address
,
3918 Expression
=> Expression
(N
)));
3920 -- We preserve Comes_From_Source, since logically the clause still comes
3921 -- from the source program even though it is changed in form.
3923 Set_Comes_From_Source
(N
, CS
);
3925 -- Analyze rewritten clause
3927 Analyze_Attribute_Definition_Clause
(N
);
3928 end Analyze_At_Clause
;
3930 -----------------------------------------
3931 -- Analyze_Attribute_Definition_Clause --
3932 -----------------------------------------
3934 procedure Analyze_Attribute_Definition_Clause
(N
: Node_Id
) is
3935 Loc
: constant Source_Ptr
:= Sloc
(N
);
3936 Nam
: constant Node_Id
:= Name
(N
);
3937 Attr
: constant Name_Id
:= Chars
(N
);
3938 Expr
: constant Node_Id
:= Expression
(N
);
3939 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attr
);
3942 -- The entity of Nam after it is analyzed. In the case of an incomplete
3943 -- type, this is the underlying type.
3946 -- The underlying entity to which the attribute applies. Generally this
3947 -- is the Underlying_Type of Ent, except in the case where the clause
3948 -- applies to the full view of an incomplete or private type, in which
3949 -- case U_Ent is just a copy of Ent.
3951 FOnly
: Boolean := False;
3952 -- Reset to True for subtype specific attribute (Alignment, Size)
3953 -- and for stream attributes, i.e. those cases where in the call to
3954 -- Rep_Item_Too_Late, FOnly is set True so that only the freezing rules
3955 -- are checked. Note that the case of stream attributes is not clear
3956 -- from the RM, but see AI95-00137. Also, the RM seems to disallow
3957 -- Storage_Size for derived task types, but that is also clearly
3960 procedure Analyze_Stream_TSS_Definition
(TSS_Nam
: TSS_Name_Type
);
3961 -- Common processing for 'Read, 'Write, 'Input and 'Output attribute
3962 -- definition clauses.
3964 function Duplicate_Clause
return Boolean;
3965 -- This routine checks if the aspect for U_Ent being given by attribute
3966 -- definition clause N is for an aspect that has already been specified,
3967 -- and if so gives an error message. If there is a duplicate, True is
3968 -- returned, otherwise if there is no error, False is returned.
3970 procedure Check_Indexing_Functions
;
3971 -- Check that the function in Constant_Indexing or Variable_Indexing
3972 -- attribute has the proper type structure. If the name is overloaded,
3973 -- check that some interpretation is legal.
3975 procedure Check_Iterator_Functions
;
3976 -- Check that there is a single function in Default_Iterator attribute
3977 -- that has the proper type structure.
3979 function Check_Primitive_Function
(Subp
: Entity_Id
) return Boolean;
3980 -- Common legality check for the previous two
3982 -----------------------------------
3983 -- Analyze_Stream_TSS_Definition --
3984 -----------------------------------
3986 procedure Analyze_Stream_TSS_Definition
(TSS_Nam
: TSS_Name_Type
) is
3987 Subp
: Entity_Id
:= Empty
;
3992 Is_Read
: constant Boolean := (TSS_Nam
= TSS_Stream_Read
);
3993 -- True for Read attribute, False for other attributes
3995 function Has_Good_Profile
3997 Report
: Boolean := False) return Boolean;
3998 -- Return true if the entity is a subprogram with an appropriate
3999 -- profile for the attribute being defined. If result is False and
4000 -- Report is True, function emits appropriate error.
4002 ----------------------
4003 -- Has_Good_Profile --
4004 ----------------------
4006 function Has_Good_Profile
4008 Report
: Boolean := False) return Boolean
4010 Expected_Ekind
: constant array (Boolean) of Entity_Kind
:=
4011 (False => E_Procedure
, True => E_Function
);
4012 Is_Function
: constant Boolean := (TSS_Nam
= TSS_Stream_Input
);
4017 if Ekind
(Subp
) /= Expected_Ekind
(Is_Function
) then
4021 F
:= First_Formal
(Subp
);
4024 or else Ekind
(Etype
(F
)) /= E_Anonymous_Access_Type
4025 or else Designated_Type
(Etype
(F
)) /=
4026 Class_Wide_Type
(RTE
(RE_Root_Stream_Type
))
4031 if not Is_Function
then
4035 Expected_Mode
: constant array (Boolean) of Entity_Kind
:=
4036 (False => E_In_Parameter
,
4037 True => E_Out_Parameter
);
4039 if Parameter_Mode
(F
) /= Expected_Mode
(Is_Read
) then
4046 -- If the attribute specification comes from an aspect
4047 -- specification for a class-wide stream, the parameter must be
4048 -- a class-wide type of the entity to which the aspect applies.
4050 if From_Aspect_Specification
(N
)
4051 and then Class_Present
(Parent
(N
))
4052 and then Is_Class_Wide_Type
(Typ
)
4058 Typ
:= Etype
(Subp
);
4061 -- Verify that the prefix of the attribute and the local name for
4062 -- the type of the formal match, or one is the class-wide of the
4063 -- other, in the case of a class-wide stream operation.
4065 if Base_Type
(Typ
) = Base_Type
(Ent
)
4066 or else (Is_Class_Wide_Type
(Typ
)
4067 and then Typ
= Class_Wide_Type
(Base_Type
(Ent
)))
4068 or else (Is_Class_Wide_Type
(Ent
)
4069 and then Ent
= Class_Wide_Type
(Base_Type
(Typ
)))
4076 if Present
(Next_Formal
(F
)) then
4079 elsif not Is_Scalar_Type
(Typ
)
4080 and then not Is_First_Subtype
(Typ
)
4081 and then not Is_Class_Wide_Type
(Typ
)
4083 if Report
and not Is_First_Subtype
(Typ
) then
4085 ("subtype of formal in stream operation must be a first "
4086 & "subtype", Parameter_Type
(Parent
(F
)));
4094 end Has_Good_Profile
;
4096 -- Start of processing for Analyze_Stream_TSS_Definition
4101 if not Is_Type
(U_Ent
) then
4102 Error_Msg_N
("local name must be a subtype", Nam
);
4105 elsif not Is_First_Subtype
(U_Ent
) then
4106 Error_Msg_N
("local name must be a first subtype", Nam
);
4110 Pnam
:= TSS
(Base_Type
(U_Ent
), TSS_Nam
);
4112 -- If Pnam is present, it can be either inherited from an ancestor
4113 -- type (in which case it is legal to redefine it for this type), or
4114 -- be a previous definition of the attribute for the same type (in
4115 -- which case it is illegal).
4117 -- In the first case, it will have been analyzed already, and we
4118 -- can check that its profile does not match the expected profile
4119 -- for a stream attribute of U_Ent. In the second case, either Pnam
4120 -- has been analyzed (and has the expected profile), or it has not
4121 -- been analyzed yet (case of a type that has not been frozen yet
4122 -- and for which the stream attribute has been set using Set_TSS).
4125 and then (No
(First_Entity
(Pnam
)) or else Has_Good_Profile
(Pnam
))
4127 Error_Msg_Sloc
:= Sloc
(Pnam
);
4128 Error_Msg_Name_1
:= Attr
;
4129 Error_Msg_N
("% attribute already defined #", Nam
);
4135 if Is_Entity_Name
(Expr
) then
4136 if not Is_Overloaded
(Expr
) then
4137 if Has_Good_Profile
(Entity
(Expr
), Report
=> True) then
4138 Subp
:= Entity
(Expr
);
4142 Get_First_Interp
(Expr
, I
, It
);
4143 while Present
(It
.Nam
) loop
4144 if Has_Good_Profile
(It
.Nam
) then
4149 Get_Next_Interp
(I
, It
);
4154 if Present
(Subp
) then
4155 if Is_Abstract_Subprogram
(Subp
) then
4156 Error_Msg_N
("stream subprogram must not be abstract", Expr
);
4159 -- A stream subprogram for an interface type must be a null
4160 -- procedure (RM 13.13.2 (38/3)). Note that the class-wide type
4161 -- of an interface is not an interface type (3.9.4 (6.b/2)).
4163 elsif Is_Interface
(U_Ent
)
4164 and then not Is_Class_Wide_Type
(U_Ent
)
4165 and then not Inside_A_Generic
4167 (Ekind
(Subp
) = E_Function
4171 (Unit_Declaration_Node
(Ultimate_Alias
(Subp
)))))
4174 ("stream subprogram for interface type must be null "
4175 & "procedure", Expr
);
4178 Set_Entity
(Expr
, Subp
);
4179 Set_Etype
(Expr
, Etype
(Subp
));
4181 New_Stream_Subprogram
(N
, U_Ent
, Subp
, TSS_Nam
);
4184 Error_Msg_Name_1
:= Attr
;
4185 Error_Msg_N
("incorrect expression for% attribute", Expr
);
4187 end Analyze_Stream_TSS_Definition
;
4189 ------------------------------
4190 -- Check_Indexing_Functions --
4191 ------------------------------
4193 procedure Check_Indexing_Functions
is
4194 Indexing_Found
: Boolean := False;
4196 procedure Check_Inherited_Indexing
;
4197 -- For a derived type, check that no indexing aspect is specified
4198 -- for the type if it is also inherited
4200 procedure Check_One_Function
(Subp
: Entity_Id
);
4201 -- Check one possible interpretation. Sets Indexing_Found True if a
4202 -- legal indexing function is found.
4204 procedure Illegal_Indexing
(Msg
: String);
4205 -- Diagnose illegal indexing function if not overloaded. In the
4206 -- overloaded case indicate that no legal interpretation exists.
4208 ------------------------------
4209 -- Check_Inherited_Indexing --
4210 ------------------------------
4212 procedure Check_Inherited_Indexing
is
4213 Inherited
: Node_Id
;
4216 if Attr
= Name_Constant_Indexing
then
4218 Find_Aspect
(Etype
(Ent
), Aspect_Constant_Indexing
);
4219 else pragma Assert
(Attr
= Name_Variable_Indexing
);
4221 Find_Aspect
(Etype
(Ent
), Aspect_Variable_Indexing
);
4224 if Present
(Inherited
) then
4225 if Debug_Flag_Dot_XX
then
4228 -- OK if current attribute_definition_clause is expansion of
4229 -- inherited aspect.
4231 elsif Aspect_Rep_Item
(Inherited
) = N
then
4234 -- Indicate the operation that must be overridden, rather than
4235 -- redefining the indexing aspect.
4239 ("indexing function already inherited from parent type");
4241 ("!override & instead",
4242 N
, Entity
(Expression
(Inherited
)));
4245 end Check_Inherited_Indexing
;
4247 ------------------------
4248 -- Check_One_Function --
4249 ------------------------
4251 procedure Check_One_Function
(Subp
: Entity_Id
) is
4252 Default_Element
: Node_Id
;
4253 Ret_Type
: constant Entity_Id
:= Etype
(Subp
);
4256 if not Is_Overloadable
(Subp
) then
4257 Illegal_Indexing
("illegal indexing function for type&");
4260 elsif Scope
(Subp
) /= Scope
(Ent
) then
4261 if Nkind
(Expr
) = N_Expanded_Name
then
4263 -- Indexing function can't be declared elsewhere
4266 ("indexing function must be declared in scope of type&");
4271 elsif No
(First_Formal
(Subp
)) then
4273 ("Indexing requires a function that applies to type&");
4276 elsif No
(Next_Formal
(First_Formal
(Subp
))) then
4278 ("indexing function must have at least two parameters");
4281 elsif Is_Derived_Type
(Ent
) then
4282 Check_Inherited_Indexing
;
4285 if not Check_Primitive_Function
(Subp
) then
4287 ("Indexing aspect requires a function that applies to type&");
4291 -- If partial declaration exists, verify that it is not tagged.
4293 if Ekind
(Current_Scope
) = E_Package
4294 and then Has_Private_Declaration
(Ent
)
4295 and then From_Aspect_Specification
(N
)
4297 List_Containing
(Parent
(Ent
)) =
4298 Private_Declarations
4299 (Specification
(Unit_Declaration_Node
(Current_Scope
)))
4300 and then Nkind
(N
) = N_Attribute_Definition_Clause
4307 First
(Visible_Declarations
4309 (Unit_Declaration_Node
(Current_Scope
))));
4311 while Present
(Decl
) loop
4312 if Nkind
(Decl
) = N_Private_Type_Declaration
4313 and then Ent
= Full_View
(Defining_Identifier
(Decl
))
4314 and then Tagged_Present
(Decl
)
4315 and then No
(Aspect_Specifications
(Decl
))
4318 ("Indexing aspect cannot be specified on full view "
4319 & "if partial view is tagged");
4328 -- An indexing function must return either the default element of
4329 -- the container, or a reference type. For variable indexing it
4330 -- must be the latter.
4333 Find_Value_Of_Aspect
4334 (Etype
(First_Formal
(Subp
)), Aspect_Iterator_Element
);
4336 if Present
(Default_Element
) then
4337 Analyze
(Default_Element
);
4339 if Is_Entity_Name
(Default_Element
)
4340 and then not Covers
(Entity
(Default_Element
), Ret_Type
)
4344 ("wrong return type for indexing function");
4349 -- For variable_indexing the return type must be a reference type
4351 if Attr
= Name_Variable_Indexing
then
4352 if not Has_Implicit_Dereference
(Ret_Type
) then
4354 ("variable indexing must return a reference type");
4357 elsif Is_Access_Constant
4358 (Etype
(First_Discriminant
(Ret_Type
)))
4361 ("variable indexing must return an access to variable");
4366 if Has_Implicit_Dereference
(Ret_Type
)
4368 Is_Access_Constant
(Etype
(First_Discriminant
(Ret_Type
)))
4371 ("constant indexing must return an access to constant");
4374 elsif Is_Access_Type
(Etype
(First_Formal
(Subp
)))
4375 and then not Is_Access_Constant
(Etype
(First_Formal
(Subp
)))
4378 ("constant indexing must apply to an access to constant");
4383 -- All checks succeeded.
4385 Indexing_Found
:= True;
4386 end Check_One_Function
;
4388 -----------------------
4389 -- Illegal_Indexing --
4390 -----------------------
4392 procedure Illegal_Indexing
(Msg
: String) is
4394 Error_Msg_NE
(Msg
, N
, Ent
);
4395 end Illegal_Indexing
;
4397 -- Start of processing for Check_Indexing_Functions
4401 Check_Inherited_Indexing
;
4406 if not Is_Overloaded
(Expr
) then
4407 Check_One_Function
(Entity
(Expr
));
4415 Indexing_Found
:= False;
4416 Get_First_Interp
(Expr
, I
, It
);
4417 while Present
(It
.Nam
) loop
4419 -- Note that analysis will have added the interpretation
4420 -- that corresponds to the dereference. We only check the
4421 -- subprogram itself. Ignore homonyms that may come from
4422 -- derived types in the context.
4424 if Is_Overloadable
(It
.Nam
)
4425 and then Comes_From_Source
(It
.Nam
)
4427 Check_One_Function
(It
.Nam
);
4430 Get_Next_Interp
(I
, It
);
4435 if not Indexing_Found
and then not Error_Posted
(N
) then
4437 ("aspect Indexing requires a local function that applies to "
4438 & "type&", Expr
, Ent
);
4440 end Check_Indexing_Functions
;
4442 ------------------------------
4443 -- Check_Iterator_Functions --
4444 ------------------------------
4446 procedure Check_Iterator_Functions
is
4447 function Valid_Default_Iterator
(Subp
: Entity_Id
) return Boolean;
4448 -- Check one possible interpretation for validity
4450 ----------------------------
4451 -- Valid_Default_Iterator --
4452 ----------------------------
4454 function Valid_Default_Iterator
(Subp
: Entity_Id
) return Boolean is
4455 Root_T
: constant Entity_Id
:= Root_Type
(Etype
(Etype
(Subp
)));
4459 if not Check_Primitive_Function
(Subp
) then
4462 -- The return type must be derived from a type in an instance
4463 -- of Iterator.Interfaces, and thus its root type must have a
4466 elsif Chars
(Root_T
) /= Name_Forward_Iterator
4467 and then Chars
(Root_T
) /= Name_Reversible_Iterator
4472 Formal
:= First_Formal
(Subp
);
4475 -- False if any subsequent formal has no default expression
4477 Formal
:= Next_Formal
(Formal
);
4478 while Present
(Formal
) loop
4479 if No
(Expression
(Parent
(Formal
))) then
4483 Next_Formal
(Formal
);
4486 -- True if all subsequent formals have default expressions
4489 end Valid_Default_Iterator
;
4491 -- Start of processing for Check_Iterator_Functions
4496 if not Is_Entity_Name
(Expr
) then
4497 Error_Msg_N
("aspect Iterator must be a function name", Expr
);
4500 if not Is_Overloaded
(Expr
) then
4501 if not Check_Primitive_Function
(Entity
(Expr
)) then
4503 ("aspect Indexing requires a function that applies to type&",
4504 Entity
(Expr
), Ent
);
4507 -- Flag the default_iterator as well as the denoted function.
4509 if not Valid_Default_Iterator
(Entity
(Expr
)) then
4510 Error_Msg_N
("improper function for default iterator!", Expr
);
4515 Default
: Entity_Id
:= Empty
;
4520 Get_First_Interp
(Expr
, I
, It
);
4521 while Present
(It
.Nam
) loop
4522 if not Check_Primitive_Function
(It
.Nam
)
4523 or else not Valid_Default_Iterator
(It
.Nam
)
4527 elsif Present
(Default
) then
4529 -- An explicit one should override an implicit one
4531 if Comes_From_Source
(Default
) =
4532 Comes_From_Source
(It
.Nam
)
4534 Error_Msg_N
("default iterator must be unique", Expr
);
4535 Error_Msg_Sloc
:= Sloc
(Default
);
4536 Error_Msg_N
("\\possible interpretation#", Expr
);
4537 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
4538 Error_Msg_N
("\\possible interpretation#", Expr
);
4540 elsif Comes_From_Source
(It
.Nam
) then
4547 Get_Next_Interp
(I
, It
);
4550 if Present
(Default
) then
4551 Set_Entity
(Expr
, Default
);
4552 Set_Is_Overloaded
(Expr
, False);
4555 ("no interpretation is a valid default iterator!", Expr
);
4559 end Check_Iterator_Functions
;
4561 -------------------------------
4562 -- Check_Primitive_Function --
4563 -------------------------------
4565 function Check_Primitive_Function
(Subp
: Entity_Id
) return Boolean is
4569 if Ekind
(Subp
) /= E_Function
then
4573 if No
(First_Formal
(Subp
)) then
4576 Ctrl
:= Etype
(First_Formal
(Subp
));
4579 -- To be a primitive operation subprogram has to be in same scope.
4581 if Scope
(Ctrl
) /= Scope
(Subp
) then
4585 -- Type of formal may be the class-wide type, an access to such,
4586 -- or an incomplete view.
4589 or else Ctrl
= Class_Wide_Type
(Ent
)
4591 (Ekind
(Ctrl
) = E_Anonymous_Access_Type
4592 and then (Designated_Type
(Ctrl
) = Ent
4594 Designated_Type
(Ctrl
) = Class_Wide_Type
(Ent
)))
4596 (Ekind
(Ctrl
) = E_Incomplete_Type
4597 and then Full_View
(Ctrl
) = Ent
)
4605 end Check_Primitive_Function
;
4607 ----------------------
4608 -- Duplicate_Clause --
4609 ----------------------
4611 function Duplicate_Clause
return Boolean is
4615 -- Nothing to do if this attribute definition clause comes from
4616 -- an aspect specification, since we could not be duplicating an
4617 -- explicit clause, and we dealt with the case of duplicated aspects
4618 -- in Analyze_Aspect_Specifications.
4620 if From_Aspect_Specification
(N
) then
4624 -- Otherwise current clause may duplicate previous clause, or a
4625 -- previously given pragma or aspect specification for the same
4628 A
:= Get_Rep_Item
(U_Ent
, Chars
(N
), Check_Parents
=> False);
4631 Error_Msg_Name_1
:= Chars
(N
);
4632 Error_Msg_Sloc
:= Sloc
(A
);
4634 Error_Msg_NE
("aspect% for & previously given#", N
, U_Ent
);
4639 end Duplicate_Clause
;
4641 -- Start of processing for Analyze_Attribute_Definition_Clause
4644 -- The following code is a defense against recursion. Not clear that
4645 -- this can happen legitimately, but perhaps some error situations can
4646 -- cause it, and we did see this recursion during testing.
4648 if Analyzed
(N
) then
4651 Set_Analyzed
(N
, True);
4654 Check_Restriction_No_Use_Of_Attribute
(N
);
4656 -- Ignore some selected attributes in CodePeer mode since they are not
4657 -- relevant in this context.
4659 if CodePeer_Mode
then
4662 -- Ignore Component_Size in CodePeer mode, to avoid changing the
4663 -- internal representation of types by implicitly packing them.
4665 when Attribute_Component_Size
=>
4666 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
4674 -- Process Ignore_Rep_Clauses option
4676 if Ignore_Rep_Clauses
then
4679 -- The following should be ignored. They do not affect legality
4680 -- and may be target dependent. The basic idea of -gnatI is to
4681 -- ignore any rep clauses that may be target dependent but do not
4682 -- affect legality (except possibly to be rejected because they
4683 -- are incompatible with the compilation target).
4685 when Attribute_Alignment
4686 | Attribute_Bit_Order
4687 | Attribute_Component_Size
4688 | Attribute_Default_Scalar_Storage_Order
4689 | Attribute_Machine_Radix
4690 | Attribute_Object_Size
4691 | Attribute_Scalar_Storage_Order
4694 | Attribute_Stream_Size
4695 | Attribute_Value_Size
4697 Kill_Rep_Clause
(N
);
4700 -- The following should not be ignored, because in the first place
4701 -- they are reasonably portable, and should not cause problems
4702 -- in compiling code from another target, and also they do affect
4703 -- legality, e.g. failing to provide a stream attribute for a type
4704 -- may make a program illegal.
4706 when Attribute_External_Tag
4710 | Attribute_Simple_Storage_Pool
4711 | Attribute_Storage_Pool
4712 | Attribute_Storage_Size
4717 -- We do not do anything here with address clauses, they will be
4718 -- removed by Freeze later on, but for now, it works better to
4719 -- keep them in the tree.
4721 when Attribute_Address
=>
4724 -- Other cases are errors ("attribute& cannot be set with
4725 -- definition clause"), which will be caught below.
4733 Ent
:= Entity
(Nam
);
4735 if Rep_Item_Too_Early
(Ent
, N
) then
4739 -- Rep clause applies to full view of incomplete type or private type if
4740 -- we have one (if not, this is a premature use of the type). However,
4741 -- certain semantic checks need to be done on the specified entity (i.e.
4742 -- the private view), so we save it in Ent.
4744 if Is_Private_Type
(Ent
)
4745 and then Is_Derived_Type
(Ent
)
4746 and then not Is_Tagged_Type
(Ent
)
4747 and then No
(Full_View
(Ent
))
4749 -- If this is a private type whose completion is a derivation from
4750 -- another private type, there is no full view, and the attribute
4751 -- belongs to the type itself, not its underlying parent.
4755 elsif Ekind
(Ent
) = E_Incomplete_Type
then
4757 -- The attribute applies to the full view, set the entity of the
4758 -- attribute definition accordingly.
4760 Ent
:= Underlying_Type
(Ent
);
4762 Set_Entity
(Nam
, Ent
);
4765 U_Ent
:= Underlying_Type
(Ent
);
4768 -- Avoid cascaded error
4770 if Etype
(Nam
) = Any_Type
then
4773 -- Must be declared in current scope or in case of an aspect
4774 -- specification, must be visible in current scope.
4776 elsif Scope
(Ent
) /= Current_Scope
4778 not (From_Aspect_Specification
(N
)
4779 and then Scope_Within_Or_Same
(Current_Scope
, Scope
(Ent
)))
4781 Error_Msg_N
("entity must be declared in this scope", Nam
);
4784 -- Must not be a source renaming (we do have some cases where the
4785 -- expander generates a renaming, and those cases are OK, in such
4786 -- cases any attribute applies to the renamed object as well).
4788 elsif Is_Object
(Ent
)
4789 and then Present
(Renamed_Object
(Ent
))
4791 -- Case of renamed object from source, this is an error
4793 if Comes_From_Source
(Renamed_Object
(Ent
)) then
4794 Get_Name_String
(Chars
(N
));
4795 Error_Msg_Strlen
:= Name_Len
;
4796 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
4798 ("~ clause not allowed for a renaming declaration "
4799 & "(RM 13.1(6))", Nam
);
4802 -- For the case of a compiler generated renaming, the attribute
4803 -- definition clause applies to the renamed object created by the
4804 -- expander. The easiest general way to handle this is to create a
4805 -- copy of the attribute definition clause for this object.
4807 elsif Is_Entity_Name
(Renamed_Object
(Ent
)) then
4809 Make_Attribute_Definition_Clause
(Loc
,
4811 New_Occurrence_Of
(Entity
(Renamed_Object
(Ent
)), Loc
),
4813 Expression
=> Duplicate_Subexpr
(Expression
(N
))));
4815 -- If the renamed object is not an entity, it must be a dereference
4816 -- of an unconstrained function call, and we must introduce a new
4817 -- declaration to capture the expression. This is needed in the case
4818 -- of 'Alignment, where the original declaration must be rewritten.
4822 (Nkind
(Renamed_Object
(Ent
)) = N_Explicit_Dereference
);
4826 -- If no underlying entity, use entity itself, applies to some
4827 -- previously detected error cases ???
4829 elsif No
(U_Ent
) then
4832 -- Cannot specify for a subtype (exception Object/Value_Size)
4834 elsif Is_Type
(U_Ent
)
4835 and then not Is_First_Subtype
(U_Ent
)
4836 and then Id
/= Attribute_Object_Size
4837 and then Id
/= Attribute_Value_Size
4838 and then not From_At_Mod
(N
)
4840 Error_Msg_N
("cannot specify attribute for subtype", Nam
);
4844 Set_Entity
(N
, U_Ent
);
4846 -- Switch on particular attribute
4854 -- Address attribute definition clause
4856 when Attribute_Address
=> Address
: begin
4858 -- A little error check, catch for X'Address use X'Address;
4860 if Nkind
(Nam
) = N_Identifier
4861 and then Nkind
(Expr
) = N_Attribute_Reference
4862 and then Attribute_Name
(Expr
) = Name_Address
4863 and then Nkind
(Prefix
(Expr
)) = N_Identifier
4864 and then Chars
(Nam
) = Chars
(Prefix
(Expr
))
4867 ("address for & is self-referencing", Prefix
(Expr
), Ent
);
4871 -- Not that special case, carry on with analysis of expression
4873 Analyze_And_Resolve
(Expr
, RTE
(RE_Address
));
4875 -- Even when ignoring rep clauses we need to indicate that the
4876 -- entity has an address clause and thus it is legal to declare
4877 -- it imported. Freeze will get rid of the address clause later.
4878 -- Also call Set_Address_Taken to indicate that an address clause
4879 -- was present, even if we are about to remove it.
4881 if Ignore_Rep_Clauses
then
4882 Set_Address_Taken
(U_Ent
);
4884 if Ekind_In
(U_Ent
, E_Variable
, E_Constant
) then
4885 Record_Rep_Item
(U_Ent
, N
);
4891 if Duplicate_Clause
then
4894 -- Case of address clause for subprogram
4896 elsif Is_Subprogram
(U_Ent
) then
4897 if Has_Homonym
(U_Ent
) then
4899 ("address clause cannot be given for overloaded "
4900 & "subprogram", Nam
);
4904 -- For subprograms, all address clauses are permitted, and we
4905 -- mark the subprogram as having a deferred freeze so that Gigi
4906 -- will not elaborate it too soon.
4908 -- Above needs more comments, what is too soon about???
4910 Set_Has_Delayed_Freeze
(U_Ent
);
4912 -- Case of address clause for entry
4914 elsif Ekind
(U_Ent
) = E_Entry
then
4915 if Nkind
(Parent
(N
)) = N_Task_Body
then
4917 ("entry address must be specified in task spec", Nam
);
4921 -- For entries, we require a constant address
4923 Check_Constant_Address_Clause
(Expr
, U_Ent
);
4925 -- Special checks for task types
4927 if Is_Task_Type
(Scope
(U_Ent
))
4928 and then Comes_From_Source
(Scope
(U_Ent
))
4931 ("??entry address declared for entry in task type", N
);
4933 ("\??only one task can be declared of this type", N
);
4936 -- Entry address clauses are obsolescent
4938 Check_Restriction
(No_Obsolescent_Features
, N
);
4940 if Warn_On_Obsolescent_Feature
then
4942 ("?j?attaching interrupt to task entry is an obsolescent "
4943 & "feature (RM J.7.1)", N
);
4945 ("\?j?use interrupt procedure instead", N
);
4948 -- Case of an address clause for a class-wide object, which is
4949 -- considered erroneous.
4951 elsif Is_Class_Wide_Type
(Etype
(U_Ent
)) then
4953 ("??class-wide object & must not be overlaid", Nam
, U_Ent
);
4955 ("\??Program_Error will be raised at run time", Nam
);
4956 Insert_Action
(Declaration_Node
(U_Ent
),
4957 Make_Raise_Program_Error
(Loc
,
4958 Reason
=> PE_Overlaid_Controlled_Object
));
4961 -- Case of address clause for an object
4963 elsif Ekind_In
(U_Ent
, E_Constant
, E_Variable
) then
4965 Expr
: constant Node_Id
:= Expression
(N
);
4970 -- Exported variables cannot have an address clause, because
4971 -- this cancels the effect of the pragma Export.
4973 if Is_Exported
(U_Ent
) then
4975 ("cannot export object with address clause", Nam
);
4979 Find_Overlaid_Entity
(N
, O_Ent
, Off
);
4981 if Present
(O_Ent
) then
4983 -- If the object overlays a constant object, mark it so
4985 if Is_Constant_Object
(O_Ent
) then
4986 Set_Overlays_Constant
(U_Ent
);
4989 -- If the address clause is of the form:
4991 -- for X'Address use Y'Address;
4995 -- C : constant Address := Y'Address;
4997 -- for X'Address use C;
4999 -- then we make an entry in the table to check the size
5000 -- and alignment of the overlaying variable. But we defer
5001 -- this check till after code generation to take full
5002 -- advantage of the annotation done by the back end.
5004 -- If the entity has a generic type, the check will be
5005 -- performed in the instance if the actual type justifies
5006 -- it, and we do not insert the clause in the table to
5007 -- prevent spurious warnings.
5009 -- Note: we used to test Comes_From_Source and only give
5010 -- this warning for source entities, but we have removed
5011 -- this test. It really seems bogus to generate overlays
5012 -- that would trigger this warning in generated code.
5013 -- Furthermore, by removing the test, we handle the
5014 -- aspect case properly.
5016 if Is_Object
(O_Ent
)
5017 and then not Is_Generic_Type
(Etype
(U_Ent
))
5018 and then Address_Clause_Overlay_Warnings
5020 Address_Clause_Checks
.Append
5021 ((N
, U_Ent
, No_Uint
, O_Ent
, Off
));
5024 -- If this is not an overlay, mark a variable as being
5025 -- volatile to prevent unwanted optimizations. It's a
5026 -- conservative interpretation of RM 13.3(19) for the
5027 -- cases where the compiler cannot detect potential
5028 -- aliasing issues easily and it also covers the case
5029 -- of an absolute address where the volatile aspect is
5030 -- kind of implicit.
5032 if Ekind
(U_Ent
) = E_Variable
then
5033 Set_Treat_As_Volatile
(U_Ent
);
5036 -- Make an entry in the table for an absolute address as
5037 -- above to check that the value is compatible with the
5038 -- alignment of the object.
5041 Addr
: constant Node_Id
:= Address_Value
(Expr
);
5043 if Compile_Time_Known_Value
(Addr
)
5044 and then Address_Clause_Overlay_Warnings
5046 Address_Clause_Checks
.Append
5047 ((N
, U_Ent
, Expr_Value
(Addr
), Empty
, False));
5052 -- Issue an unconditional warning for a constant overlaying
5053 -- a variable. For the reverse case, we will issue it only
5054 -- if the variable is modified.
5056 if Ekind
(U_Ent
) = E_Constant
5057 and then Present
(O_Ent
)
5058 and then not Overlays_Constant
(U_Ent
)
5059 and then Address_Clause_Overlay_Warnings
5061 Error_Msg_N
("??constant overlays a variable", Expr
);
5063 -- Imported variables can have an address clause, but then
5064 -- the import is pretty meaningless except to suppress
5065 -- initializations, so we do not need such variables to
5066 -- be statically allocated (and in fact it causes trouble
5067 -- if the address clause is a local value).
5069 elsif Is_Imported
(U_Ent
) then
5070 Set_Is_Statically_Allocated
(U_Ent
, False);
5073 -- We mark a possible modification of a variable with an
5074 -- address clause, since it is likely aliasing is occurring.
5076 Note_Possible_Modification
(Nam
, Sure
=> False);
5078 -- Legality checks on the address clause for initialized
5079 -- objects is deferred until the freeze point, because
5080 -- a subsequent pragma might indicate that the object
5081 -- is imported and thus not initialized. Also, the address
5082 -- clause might involve entities that have yet to be
5085 Set_Has_Delayed_Freeze
(U_Ent
);
5087 -- If an initialization call has been generated for this
5088 -- object, it needs to be deferred to after the freeze node
5089 -- we have just now added, otherwise GIGI will see a
5090 -- reference to the variable (as actual to the IP call)
5091 -- before its definition.
5094 Init_Call
: constant Node_Id
:=
5095 Remove_Init_Call
(U_Ent
, N
);
5098 if Present
(Init_Call
) then
5099 Append_Freeze_Action
(U_Ent
, Init_Call
);
5101 -- Reset Initialization_Statements pointer so that
5102 -- if there is a pragma Import further down, it can
5103 -- clear any default initialization.
5105 Set_Initialization_Statements
(U_Ent
, Init_Call
);
5109 -- Entity has delayed freeze, so we will generate an
5110 -- alignment check at the freeze point unless suppressed.
5112 if not Range_Checks_Suppressed
(U_Ent
)
5113 and then not Alignment_Checks_Suppressed
(U_Ent
)
5115 Set_Check_Address_Alignment
(N
);
5118 -- Kill the size check code, since we are not allocating
5119 -- the variable, it is somewhere else.
5121 Kill_Size_Check_Code
(U_Ent
);
5124 -- Not a valid entity for an address clause
5127 Error_Msg_N
("address cannot be given for &", Nam
);
5135 -- Alignment attribute definition clause
5137 when Attribute_Alignment
=> Alignment
: declare
5138 Align
: constant Uint
:= Get_Alignment_Value
(Expr
);
5139 Max_Align
: constant Uint
:= UI_From_Int
(Maximum_Alignment
);
5144 if not Is_Type
(U_Ent
)
5145 and then Ekind
(U_Ent
) /= E_Variable
5146 and then Ekind
(U_Ent
) /= E_Constant
5148 Error_Msg_N
("alignment cannot be given for &", Nam
);
5150 elsif Duplicate_Clause
then
5153 elsif Align
/= No_Uint
then
5154 Set_Has_Alignment_Clause
(U_Ent
);
5156 -- Tagged type case, check for attempt to set alignment to a
5157 -- value greater than Max_Align, and reset if so. This error
5158 -- is suppressed in ASIS mode to allow for different ASIS
5159 -- back ends or ASIS-based tools to query the illegal clause.
5161 if Is_Tagged_Type
(U_Ent
)
5162 and then Align
> Max_Align
5163 and then not ASIS_Mode
5166 ("alignment for & set to Maximum_Aligment??", Nam
);
5167 Set_Alignment
(U_Ent
, Max_Align
);
5172 Set_Alignment
(U_Ent
, Align
);
5175 -- For an array type, U_Ent is the first subtype. In that case,
5176 -- also set the alignment of the anonymous base type so that
5177 -- other subtypes (such as the itypes for aggregates of the
5178 -- type) also receive the expected alignment.
5180 if Is_Array_Type
(U_Ent
) then
5181 Set_Alignment
(Base_Type
(U_Ent
), Align
);
5190 -- Bit_Order attribute definition clause
5192 when Attribute_Bit_Order
=>
5193 if not Is_Record_Type
(U_Ent
) then
5195 ("Bit_Order can only be defined for record type", Nam
);
5197 elsif Duplicate_Clause
then
5201 Analyze_And_Resolve
(Expr
, RTE
(RE_Bit_Order
));
5203 if Etype
(Expr
) = Any_Type
then
5206 elsif not Is_OK_Static_Expression
(Expr
) then
5207 Flag_Non_Static_Expr
5208 ("Bit_Order requires static expression!", Expr
);
5211 if (Expr_Value
(Expr
) = 0) /= Bytes_Big_Endian
then
5212 Set_Reverse_Bit_Order
(Base_Type
(U_Ent
), True);
5217 --------------------
5218 -- Component_Size --
5219 --------------------
5221 -- Component_Size attribute definition clause
5223 when Attribute_Component_Size
=> Component_Size_Case
: declare
5224 Csize
: constant Uint
:= Static_Integer
(Expr
);
5228 New_Ctyp
: Entity_Id
;
5232 if not Is_Array_Type
(U_Ent
) then
5233 Error_Msg_N
("component size requires array type", Nam
);
5237 Btype
:= Base_Type
(U_Ent
);
5238 Ctyp
:= Component_Type
(Btype
);
5240 if Duplicate_Clause
then
5243 elsif Rep_Item_Too_Early
(Btype
, N
) then
5246 elsif Csize
/= No_Uint
then
5247 Check_Size
(Expr
, Ctyp
, Csize
, Biased
);
5249 -- For the biased case, build a declaration for a subtype that
5250 -- will be used to represent the biased subtype that reflects
5251 -- the biased representation of components. We need the subtype
5252 -- to get proper conversions on referencing elements of the
5257 Make_Defining_Identifier
(Loc
,
5259 New_External_Name
(Chars
(U_Ent
), 'C', 0, 'T'));
5262 Make_Subtype_Declaration
(Loc
,
5263 Defining_Identifier
=> New_Ctyp
,
5264 Subtype_Indication
=>
5265 New_Occurrence_Of
(Component_Type
(Btype
), Loc
));
5267 Set_Parent
(Decl
, N
);
5268 Analyze
(Decl
, Suppress
=> All_Checks
);
5270 Set_Has_Delayed_Freeze
(New_Ctyp
, False);
5271 Set_Esize
(New_Ctyp
, Csize
);
5272 Set_RM_Size
(New_Ctyp
, Csize
);
5273 Init_Alignment
(New_Ctyp
);
5274 Set_Is_Itype
(New_Ctyp
, True);
5275 Set_Associated_Node_For_Itype
(New_Ctyp
, U_Ent
);
5277 Set_Component_Type
(Btype
, New_Ctyp
);
5278 Set_Biased
(New_Ctyp
, N
, "component size clause");
5281 Set_Component_Size
(Btype
, Csize
);
5283 -- Deal with warning on overridden size
5285 if Warn_On_Overridden_Size
5286 and then Has_Size_Clause
(Ctyp
)
5287 and then RM_Size
(Ctyp
) /= Csize
5290 ("component size overrides size clause for&?S?", N
, Ctyp
);
5293 Set_Has_Component_Size_Clause
(Btype
, True);
5294 Set_Has_Non_Standard_Rep
(Btype
, True);
5296 end Component_Size_Case
;
5298 -----------------------
5299 -- Constant_Indexing --
5300 -----------------------
5302 when Attribute_Constant_Indexing
=>
5303 Check_Indexing_Functions
;
5309 when Attribute_CPU
=>
5311 -- CPU attribute definition clause not allowed except from aspect
5314 if From_Aspect_Specification
(N
) then
5315 if not Is_Task_Type
(U_Ent
) then
5316 Error_Msg_N
("CPU can only be defined for task", Nam
);
5318 elsif Duplicate_Clause
then
5322 -- The expression must be analyzed in the special manner
5323 -- described in "Handling of Default and Per-Object
5324 -- Expressions" in sem.ads.
5326 -- The visibility to the discriminants must be restored
5328 Push_Scope_And_Install_Discriminants
(U_Ent
);
5329 Preanalyze_Spec_Expression
(Expr
, RTE
(RE_CPU_Range
));
5330 Uninstall_Discriminants_And_Pop_Scope
(U_Ent
);
5332 if not Is_OK_Static_Expression
(Expr
) then
5333 Check_Restriction
(Static_Priorities
, Expr
);
5339 ("attribute& cannot be set with definition clause", N
);
5342 ----------------------
5343 -- Default_Iterator --
5344 ----------------------
5346 when Attribute_Default_Iterator
=> Default_Iterator
: declare
5351 -- If target type is untagged, further checks are irrelevant
5353 if not Is_Tagged_Type
(U_Ent
) then
5355 ("aspect Default_Iterator applies to tagged type", Nam
);
5359 Check_Iterator_Functions
;
5363 if not Is_Entity_Name
(Expr
)
5364 or else Ekind
(Entity
(Expr
)) /= E_Function
5366 Error_Msg_N
("aspect Iterator must be a function", Expr
);
5369 Func
:= Entity
(Expr
);
5372 -- The type of the first parameter must be T, T'class, or a
5373 -- corresponding access type (5.5.1 (8/3). If function is
5374 -- parameterless label type accordingly.
5376 if No
(First_Formal
(Func
)) then
5379 Typ
:= Etype
(First_Formal
(Func
));
5383 or else Typ
= Class_Wide_Type
(U_Ent
)
5384 or else (Is_Access_Type
(Typ
)
5385 and then Designated_Type
(Typ
) = U_Ent
)
5386 or else (Is_Access_Type
(Typ
)
5387 and then Designated_Type
(Typ
) =
5388 Class_Wide_Type
(U_Ent
))
5394 ("Default Iterator must be a primitive of&", Func
, U_Ent
);
5396 end Default_Iterator
;
5398 ------------------------
5399 -- Dispatching_Domain --
5400 ------------------------
5402 when Attribute_Dispatching_Domain
=>
5404 -- Dispatching_Domain attribute definition clause not allowed
5405 -- except from aspect specification.
5407 if From_Aspect_Specification
(N
) then
5408 if not Is_Task_Type
(U_Ent
) then
5410 ("Dispatching_Domain can only be defined for task", Nam
);
5412 elsif Duplicate_Clause
then
5416 -- The expression must be analyzed in the special manner
5417 -- described in "Handling of Default and Per-Object
5418 -- Expressions" in sem.ads.
5420 -- The visibility to the discriminants must be restored
5422 Push_Scope_And_Install_Discriminants
(U_Ent
);
5424 Preanalyze_Spec_Expression
5425 (Expr
, RTE
(RE_Dispatching_Domain
));
5427 Uninstall_Discriminants_And_Pop_Scope
(U_Ent
);
5432 ("attribute& cannot be set with definition clause", N
);
5439 when Attribute_External_Tag
=>
5440 if not Is_Tagged_Type
(U_Ent
) then
5441 Error_Msg_N
("should be a tagged type", Nam
);
5444 if Duplicate_Clause
then
5448 Analyze_And_Resolve
(Expr
, Standard_String
);
5450 if not Is_OK_Static_Expression
(Expr
) then
5451 Flag_Non_Static_Expr
5452 ("static string required for tag name!", Nam
);
5455 if not Is_Library_Level_Entity
(U_Ent
) then
5457 ("??non-unique external tag supplied for &", N
, U_Ent
);
5459 ("\??same external tag applies to all subprogram calls",
5462 ("\??corresponding internal tag cannot be obtained", N
);
5466 --------------------------
5467 -- Implicit_Dereference --
5468 --------------------------
5470 when Attribute_Implicit_Dereference
=>
5472 -- Legality checks already performed at the point of the type
5473 -- declaration, aspect is not delayed.
5481 when Attribute_Input
=>
5482 Analyze_Stream_TSS_Definition
(TSS_Stream_Input
);
5483 Set_Has_Specified_Stream_Input
(Ent
);
5485 ------------------------
5486 -- Interrupt_Priority --
5487 ------------------------
5489 when Attribute_Interrupt_Priority
=>
5491 -- Interrupt_Priority attribute definition clause not allowed
5492 -- except from aspect specification.
5494 if From_Aspect_Specification
(N
) then
5495 if not Is_Concurrent_Type
(U_Ent
) then
5497 ("Interrupt_Priority can only be defined for task and "
5498 & "protected object", Nam
);
5500 elsif Duplicate_Clause
then
5504 -- The expression must be analyzed in the special manner
5505 -- described in "Handling of Default and Per-Object
5506 -- Expressions" in sem.ads.
5508 -- The visibility to the discriminants must be restored
5510 Push_Scope_And_Install_Discriminants
(U_Ent
);
5512 Preanalyze_Spec_Expression
5513 (Expr
, RTE
(RE_Interrupt_Priority
));
5515 Uninstall_Discriminants_And_Pop_Scope
(U_Ent
);
5517 -- Check the No_Task_At_Interrupt_Priority restriction
5519 if Is_Task_Type
(U_Ent
) then
5520 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
5526 ("attribute& cannot be set with definition clause", N
);
5533 when Attribute_Iterable
=>
5536 if Nkind
(Expr
) /= N_Aggregate
then
5537 Error_Msg_N
("aspect Iterable must be an aggregate", Expr
);
5544 Assoc
:= First
(Component_Associations
(Expr
));
5545 while Present
(Assoc
) loop
5546 if not Is_Entity_Name
(Expression
(Assoc
)) then
5547 Error_Msg_N
("value must be a function", Assoc
);
5554 ----------------------
5555 -- Iterator_Element --
5556 ----------------------
5558 when Attribute_Iterator_Element
=>
5561 if not Is_Entity_Name
(Expr
)
5562 or else not Is_Type
(Entity
(Expr
))
5564 Error_Msg_N
("aspect Iterator_Element must be a type", Expr
);
5571 -- Machine radix attribute definition clause
5573 when Attribute_Machine_Radix
=> Machine_Radix
: declare
5574 Radix
: constant Uint
:= Static_Integer
(Expr
);
5577 if not Is_Decimal_Fixed_Point_Type
(U_Ent
) then
5578 Error_Msg_N
("decimal fixed-point type expected for &", Nam
);
5580 elsif Duplicate_Clause
then
5583 elsif Radix
/= No_Uint
then
5584 Set_Has_Machine_Radix_Clause
(U_Ent
);
5585 Set_Has_Non_Standard_Rep
(Base_Type
(U_Ent
));
5590 elsif Radix
= 10 then
5591 Set_Machine_Radix_10
(U_Ent
);
5593 -- The following error is suppressed in ASIS mode to allow for
5594 -- different ASIS back ends or ASIS-based tools to query the
5597 elsif not ASIS_Mode
then
5598 Error_Msg_N
("machine radix value must be 2 or 10", Expr
);
5607 -- Object_Size attribute definition clause
5609 when Attribute_Object_Size
=> Object_Size
: declare
5610 Size
: constant Uint
:= Static_Integer
(Expr
);
5613 pragma Warnings
(Off
, Biased
);
5616 if not Is_Type
(U_Ent
) then
5617 Error_Msg_N
("Object_Size cannot be given for &", Nam
);
5619 elsif Duplicate_Clause
then
5623 Check_Size
(Expr
, U_Ent
, Size
, Biased
);
5625 -- The following errors are suppressed in ASIS mode to allow
5626 -- for different ASIS back ends or ASIS-based tools to query
5627 -- the illegal clause.
5632 elsif Is_Scalar_Type
(U_Ent
) then
5633 if Size
/= 8 and then Size
/= 16 and then Size
/= 32
5634 and then UI_Mod
(Size
, 64) /= 0
5637 ("Object_Size must be 8, 16, 32, or multiple of 64",
5641 elsif Size
mod 8 /= 0 then
5642 Error_Msg_N
("Object_Size must be a multiple of 8", Expr
);
5645 Set_Esize
(U_Ent
, Size
);
5646 Set_Has_Object_Size_Clause
(U_Ent
);
5647 Alignment_Check_For_Size_Change
(U_Ent
, Size
);
5655 when Attribute_Output
=>
5656 Analyze_Stream_TSS_Definition
(TSS_Stream_Output
);
5657 Set_Has_Specified_Stream_Output
(Ent
);
5663 when Attribute_Priority
=>
5665 -- Priority attribute definition clause not allowed except from
5666 -- aspect specification.
5668 if From_Aspect_Specification
(N
) then
5669 if not (Is_Concurrent_Type
(U_Ent
)
5670 or else Ekind
(U_Ent
) = E_Procedure
)
5673 ("Priority can only be defined for task and protected "
5676 elsif Duplicate_Clause
then
5680 -- The expression must be analyzed in the special manner
5681 -- described in "Handling of Default and Per-Object
5682 -- Expressions" in sem.ads.
5684 -- The visibility to the discriminants must be restored
5686 Push_Scope_And_Install_Discriminants
(U_Ent
);
5687 Preanalyze_Spec_Expression
(Expr
, Standard_Integer
);
5688 Uninstall_Discriminants_And_Pop_Scope
(U_Ent
);
5690 if not Is_OK_Static_Expression
(Expr
) then
5691 Check_Restriction
(Static_Priorities
, Expr
);
5697 ("attribute& cannot be set with definition clause", N
);
5704 when Attribute_Read
=>
5705 Analyze_Stream_TSS_Definition
(TSS_Stream_Read
);
5706 Set_Has_Specified_Stream_Read
(Ent
);
5708 --------------------------
5709 -- Scalar_Storage_Order --
5710 --------------------------
5712 -- Scalar_Storage_Order attribute definition clause
5714 when Attribute_Scalar_Storage_Order
=>
5715 if not (Is_Record_Type
(U_Ent
) or else Is_Array_Type
(U_Ent
)) then
5717 ("Scalar_Storage_Order can only be defined for record or "
5718 & "array type", Nam
);
5720 elsif Duplicate_Clause
then
5724 Analyze_And_Resolve
(Expr
, RTE
(RE_Bit_Order
));
5726 if Etype
(Expr
) = Any_Type
then
5729 elsif not Is_OK_Static_Expression
(Expr
) then
5730 Flag_Non_Static_Expr
5731 ("Scalar_Storage_Order requires static expression!", Expr
);
5733 elsif (Expr_Value
(Expr
) = 0) /= Bytes_Big_Endian
then
5735 -- Here for the case of a non-default (i.e. non-confirming)
5736 -- Scalar_Storage_Order attribute definition.
5738 if Support_Nondefault_SSO_On_Target
then
5739 Set_Reverse_Storage_Order
(Base_Type
(U_Ent
), True);
5742 ("non-default Scalar_Storage_Order not supported on "
5747 -- Clear SSO default indications since explicit setting of the
5748 -- order overrides the defaults.
5750 Set_SSO_Set_Low_By_Default
(Base_Type
(U_Ent
), False);
5751 Set_SSO_Set_High_By_Default
(Base_Type
(U_Ent
), False);
5754 --------------------------
5755 -- Secondary_Stack_Size --
5756 --------------------------
5758 when Attribute_Secondary_Stack_Size
=>
5760 -- Secondary_Stack_Size attribute definition clause not allowed
5761 -- except from aspect specification.
5763 if From_Aspect_Specification
(N
) then
5764 if not Is_Task_Type
(U_Ent
) then
5766 ("Secondary Stack Size can only be defined for task", Nam
);
5768 elsif Duplicate_Clause
then
5772 Check_Restriction
(No_Secondary_Stack
, Expr
);
5774 -- The expression must be analyzed in the special manner
5775 -- described in "Handling of Default and Per-Object
5776 -- Expressions" in sem.ads.
5778 -- The visibility to the discriminants must be restored
5780 Push_Scope_And_Install_Discriminants
(U_Ent
);
5781 Preanalyze_Spec_Expression
(Expr
, Any_Integer
);
5782 Uninstall_Discriminants_And_Pop_Scope
(U_Ent
);
5784 if not Is_OK_Static_Expression
(Expr
) then
5785 Check_Restriction
(Static_Storage_Size
, Expr
);
5791 ("attribute& cannot be set with definition clause", N
);
5798 -- Size attribute definition clause
5800 when Attribute_Size
=> Size
: declare
5801 Size
: constant Uint
:= Static_Integer
(Expr
);
5808 if Duplicate_Clause
then
5811 elsif not Is_Type
(U_Ent
)
5812 and then Ekind
(U_Ent
) /= E_Variable
5813 and then Ekind
(U_Ent
) /= E_Constant
5815 Error_Msg_N
("size cannot be given for &", Nam
);
5817 elsif Is_Array_Type
(U_Ent
)
5818 and then not Is_Constrained
(U_Ent
)
5821 ("size cannot be given for unconstrained array", Nam
);
5823 elsif Size
/= No_Uint
then
5824 if Is_Type
(U_Ent
) then
5827 Etyp
:= Etype
(U_Ent
);
5830 -- Check size, note that Gigi is in charge of checking that the
5831 -- size of an array or record type is OK. Also we do not check
5832 -- the size in the ordinary fixed-point case, since it is too
5833 -- early to do so (there may be subsequent small clause that
5834 -- affects the size). We can check the size if a small clause
5835 -- has already been given.
5837 if not Is_Ordinary_Fixed_Point_Type
(U_Ent
)
5838 or else Has_Small_Clause
(U_Ent
)
5840 Check_Size
(Expr
, Etyp
, Size
, Biased
);
5841 Set_Biased
(U_Ent
, N
, "size clause", Biased
);
5844 -- For types set RM_Size and Esize if possible
5846 if Is_Type
(U_Ent
) then
5847 Set_RM_Size
(U_Ent
, Size
);
5849 -- For elementary types, increase Object_Size to power of 2,
5850 -- but not less than a storage unit in any case (normally
5851 -- this means it will be byte addressable).
5853 -- For all other types, nothing else to do, we leave Esize
5854 -- (object size) unset, the back end will set it from the
5855 -- size and alignment in an appropriate manner.
5857 -- In both cases, we check whether the alignment must be
5858 -- reset in the wake of the size change.
5860 if Is_Elementary_Type
(U_Ent
) then
5861 if Size
<= System_Storage_Unit
then
5862 Init_Esize
(U_Ent
, System_Storage_Unit
);
5863 elsif Size
<= 16 then
5864 Init_Esize
(U_Ent
, 16);
5865 elsif Size
<= 32 then
5866 Init_Esize
(U_Ent
, 32);
5868 Set_Esize
(U_Ent
, (Size
+ 63) / 64 * 64);
5871 Alignment_Check_For_Size_Change
(U_Ent
, Esize
(U_Ent
));
5873 Alignment_Check_For_Size_Change
(U_Ent
, Size
);
5876 -- For objects, set Esize only
5879 -- The following error is suppressed in ASIS mode to allow
5880 -- for different ASIS back ends or ASIS-based tools to query
5881 -- the illegal clause.
5883 if Is_Elementary_Type
(Etyp
)
5884 and then Size
/= System_Storage_Unit
5885 and then Size
/= System_Storage_Unit
* 2
5886 and then Size
/= System_Storage_Unit
* 4
5887 and then Size
/= System_Storage_Unit
* 8
5888 and then not ASIS_Mode
5890 Error_Msg_Uint_1
:= UI_From_Int
(System_Storage_Unit
);
5891 Error_Msg_Uint_2
:= Error_Msg_Uint_1
* 8;
5893 ("size for primitive object must be a power of 2 in "
5894 & "the range ^-^", N
);
5897 Set_Esize
(U_Ent
, Size
);
5900 Set_Has_Size_Clause
(U_Ent
);
5908 -- Small attribute definition clause
5910 when Attribute_Small
=> Small
: declare
5911 Implicit_Base
: constant Entity_Id
:= Base_Type
(U_Ent
);
5915 Analyze_And_Resolve
(Expr
, Any_Real
);
5917 if Etype
(Expr
) = Any_Type
then
5920 elsif not Is_OK_Static_Expression
(Expr
) then
5921 Flag_Non_Static_Expr
5922 ("small requires static expression!", Expr
);
5926 Small
:= Expr_Value_R
(Expr
);
5928 if Small
<= Ureal_0
then
5929 Error_Msg_N
("small value must be greater than zero", Expr
);
5935 if not Is_Ordinary_Fixed_Point_Type
(U_Ent
) then
5937 ("small requires an ordinary fixed point type", Nam
);
5939 elsif Has_Small_Clause
(U_Ent
) then
5940 Error_Msg_N
("small already given for &", Nam
);
5942 elsif Small
> Delta_Value
(U_Ent
) then
5944 ("small value must not be greater than delta value", Nam
);
5947 Set_Small_Value
(U_Ent
, Small
);
5948 Set_Small_Value
(Implicit_Base
, Small
);
5949 Set_Has_Small_Clause
(U_Ent
);
5950 Set_Has_Small_Clause
(Implicit_Base
);
5951 Set_Has_Non_Standard_Rep
(Implicit_Base
);
5959 -- Storage_Pool attribute definition clause
5961 when Attribute_Simple_Storage_Pool
5962 | Attribute_Storage_Pool
5964 Storage_Pool
: declare
5969 if Ekind
(U_Ent
) = E_Access_Subprogram_Type
then
5971 ("storage pool cannot be given for access-to-subprogram type",
5975 elsif not Ekind_In
(U_Ent
, E_Access_Type
, E_General_Access_Type
)
5978 ("storage pool can only be given for access types", Nam
);
5981 elsif Is_Derived_Type
(U_Ent
) then
5983 ("storage pool cannot be given for a derived access type",
5986 elsif Duplicate_Clause
then
5989 elsif Present
(Associated_Storage_Pool
(U_Ent
)) then
5990 Error_Msg_N
("storage pool already given for &", Nam
);
5994 -- Check for Storage_Size previously given
5997 SS
: constant Node_Id
:=
5998 Get_Attribute_Definition_Clause
5999 (U_Ent
, Attribute_Storage_Size
);
6001 if Present
(SS
) then
6002 Check_Pool_Size_Clash
(U_Ent
, N
, SS
);
6006 -- Storage_Pool case
6008 if Id
= Attribute_Storage_Pool
then
6010 (Expr
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
6012 -- In the Simple_Storage_Pool case, we allow a variable of any
6013 -- simple storage pool type, so we Resolve without imposing an
6017 Analyze_And_Resolve
(Expr
);
6019 if not Present
(Get_Rep_Pragma
6020 (Etype
(Expr
), Name_Simple_Storage_Pool_Type
))
6023 ("expression must be of a simple storage pool type", Expr
);
6027 if not Denotes_Variable
(Expr
) then
6028 Error_Msg_N
("storage pool must be a variable", Expr
);
6032 if Nkind
(Expr
) = N_Type_Conversion
then
6033 T
:= Etype
(Expression
(Expr
));
6038 -- The Stack_Bounded_Pool is used internally for implementing
6039 -- access types with a Storage_Size. Since it only work properly
6040 -- when used on one specific type, we need to check that it is not
6041 -- hijacked improperly:
6043 -- type T is access Integer;
6044 -- for T'Storage_Size use n;
6045 -- type Q is access Float;
6046 -- for Q'Storage_Size use T'Storage_Size; -- incorrect
6048 if RTE_Available
(RE_Stack_Bounded_Pool
)
6049 and then Base_Type
(T
) = RTE
(RE_Stack_Bounded_Pool
)
6051 Error_Msg_N
("non-shareable internal Pool", Expr
);
6055 -- If the argument is a name that is not an entity name, then
6056 -- we construct a renaming operation to define an entity of
6057 -- type storage pool.
6059 if not Is_Entity_Name
(Expr
)
6060 and then Is_Object_Reference
(Expr
)
6062 Pool
:= Make_Temporary
(Loc
, 'P', Expr
);
6065 Rnode
: constant Node_Id
:=
6066 Make_Object_Renaming_Declaration
(Loc
,
6067 Defining_Identifier
=> Pool
,
6069 New_Occurrence_Of
(Etype
(Expr
), Loc
),
6073 -- If the attribute definition clause comes from an aspect
6074 -- clause, then insert the renaming before the associated
6075 -- entity's declaration, since the attribute clause has
6076 -- not yet been appended to the declaration list.
6078 if From_Aspect_Specification
(N
) then
6079 Insert_Before
(Parent
(Entity
(N
)), Rnode
);
6081 Insert_Before
(N
, Rnode
);
6085 Set_Associated_Storage_Pool
(U_Ent
, Pool
);
6088 elsif Is_Entity_Name
(Expr
) then
6089 Pool
:= Entity
(Expr
);
6091 -- If pool is a renamed object, get original one. This can
6092 -- happen with an explicit renaming, and within instances.
6094 while Present
(Renamed_Object
(Pool
))
6095 and then Is_Entity_Name
(Renamed_Object
(Pool
))
6097 Pool
:= Entity
(Renamed_Object
(Pool
));
6100 if Present
(Renamed_Object
(Pool
))
6101 and then Nkind
(Renamed_Object
(Pool
)) = N_Type_Conversion
6102 and then Is_Entity_Name
(Expression
(Renamed_Object
(Pool
)))
6104 Pool
:= Entity
(Expression
(Renamed_Object
(Pool
)));
6107 Set_Associated_Storage_Pool
(U_Ent
, Pool
);
6109 elsif Nkind
(Expr
) = N_Type_Conversion
6110 and then Is_Entity_Name
(Expression
(Expr
))
6111 and then Nkind
(Original_Node
(Expr
)) = N_Attribute_Reference
6113 Pool
:= Entity
(Expression
(Expr
));
6114 Set_Associated_Storage_Pool
(U_Ent
, Pool
);
6117 Error_Msg_N
("incorrect reference to a Storage Pool", Expr
);
6126 -- Storage_Size attribute definition clause
6128 when Attribute_Storage_Size
=> Storage_Size
: declare
6129 Btype
: constant Entity_Id
:= Base_Type
(U_Ent
);
6132 if Is_Task_Type
(U_Ent
) then
6134 -- Check obsolescent (but never obsolescent if from aspect)
6136 if not From_Aspect_Specification
(N
) then
6137 Check_Restriction
(No_Obsolescent_Features
, N
);
6139 if Warn_On_Obsolescent_Feature
then
6141 ("?j?storage size clause for task is an obsolescent "
6142 & "feature (RM J.9)", N
);
6143 Error_Msg_N
("\?j?use Storage_Size pragma instead", N
);
6150 if not Is_Access_Type
(U_Ent
)
6151 and then Ekind
(U_Ent
) /= E_Task_Type
6153 Error_Msg_N
("storage size cannot be given for &", Nam
);
6155 elsif Is_Access_Type
(U_Ent
) and Is_Derived_Type
(U_Ent
) then
6157 ("storage size cannot be given for a derived access type",
6160 elsif Duplicate_Clause
then
6164 Analyze_And_Resolve
(Expr
, Any_Integer
);
6166 if Is_Access_Type
(U_Ent
) then
6168 -- Check for Storage_Pool previously given
6171 SP
: constant Node_Id
:=
6172 Get_Attribute_Definition_Clause
6173 (U_Ent
, Attribute_Storage_Pool
);
6176 if Present
(SP
) then
6177 Check_Pool_Size_Clash
(U_Ent
, SP
, N
);
6181 -- Special case of for x'Storage_Size use 0
6183 if Is_OK_Static_Expression
(Expr
)
6184 and then Expr_Value
(Expr
) = 0
6186 Set_No_Pool_Assigned
(Btype
);
6190 Set_Has_Storage_Size_Clause
(Btype
);
6198 when Attribute_Stream_Size
=> Stream_Size
: declare
6199 Size
: constant Uint
:= Static_Integer
(Expr
);
6202 if Ada_Version
<= Ada_95
then
6203 Check_Restriction
(No_Implementation_Attributes
, N
);
6206 if Duplicate_Clause
then
6209 elsif Is_Elementary_Type
(U_Ent
) then
6211 -- The following errors are suppressed in ASIS mode to allow
6212 -- for different ASIS back ends or ASIS-based tools to query
6213 -- the illegal clause.
6218 elsif Size
/= System_Storage_Unit
6219 and then Size
/= System_Storage_Unit
* 2
6220 and then Size
/= System_Storage_Unit
* 4
6221 and then Size
/= System_Storage_Unit
* 8
6223 Error_Msg_Uint_1
:= UI_From_Int
(System_Storage_Unit
);
6225 ("stream size for elementary type must be a power of 2 "
6226 & "and at least ^", N
);
6228 elsif RM_Size
(U_Ent
) > Size
then
6229 Error_Msg_Uint_1
:= RM_Size
(U_Ent
);
6231 ("stream size for elementary type must be a power of 2 "
6232 & "and at least ^", N
);
6235 Set_Has_Stream_Size_Clause
(U_Ent
);
6238 Error_Msg_N
("Stream_Size cannot be given for &", Nam
);
6246 -- Value_Size attribute definition clause
6248 when Attribute_Value_Size
=> Value_Size
: declare
6249 Size
: constant Uint
:= Static_Integer
(Expr
);
6253 if not Is_Type
(U_Ent
) then
6254 Error_Msg_N
("Value_Size cannot be given for &", Nam
);
6256 elsif Duplicate_Clause
then
6259 elsif Is_Array_Type
(U_Ent
)
6260 and then not Is_Constrained
(U_Ent
)
6263 ("Value_Size cannot be given for unconstrained array", Nam
);
6266 if Is_Elementary_Type
(U_Ent
) then
6267 Check_Size
(Expr
, U_Ent
, Size
, Biased
);
6268 Set_Biased
(U_Ent
, N
, "value size clause", Biased
);
6271 Set_RM_Size
(U_Ent
, Size
);
6275 -----------------------
6276 -- Variable_Indexing --
6277 -----------------------
6279 when Attribute_Variable_Indexing
=>
6280 Check_Indexing_Functions
;
6286 when Attribute_Write
=>
6287 Analyze_Stream_TSS_Definition
(TSS_Stream_Write
);
6288 Set_Has_Specified_Stream_Write
(Ent
);
6290 -- All other attributes cannot be set
6294 ("attribute& cannot be set with definition clause", N
);
6297 -- The test for the type being frozen must be performed after any
6298 -- expression the clause has been analyzed since the expression itself
6299 -- might cause freezing that makes the clause illegal.
6301 if Rep_Item_Too_Late
(U_Ent
, N
, FOnly
) then
6304 end Analyze_Attribute_Definition_Clause
;
6306 ----------------------------
6307 -- Analyze_Code_Statement --
6308 ----------------------------
6310 procedure Analyze_Code_Statement
(N
: Node_Id
) is
6311 HSS
: constant Node_Id
:= Parent
(N
);
6312 SBody
: constant Node_Id
:= Parent
(HSS
);
6313 Subp
: constant Entity_Id
:= Current_Scope
;
6320 -- Accept foreign code statements for CodePeer. The analysis is skipped
6321 -- to avoid rejecting unrecognized constructs.
6323 if CodePeer_Mode
then
6328 -- Analyze and check we get right type, note that this implements the
6329 -- requirement (RM 13.8(1)) that Machine_Code be with'ed, since that is
6330 -- the only way that Asm_Insn could possibly be visible.
6332 Analyze_And_Resolve
(Expression
(N
));
6334 if Etype
(Expression
(N
)) = Any_Type
then
6336 elsif Etype
(Expression
(N
)) /= RTE
(RE_Asm_Insn
) then
6337 Error_Msg_N
("incorrect type for code statement", N
);
6341 Check_Code_Statement
(N
);
6343 -- Make sure we appear in the handled statement sequence of a subprogram
6346 if Nkind
(HSS
) /= N_Handled_Sequence_Of_Statements
6347 or else Nkind
(SBody
) /= N_Subprogram_Body
6350 ("code statement can only appear in body of subprogram", N
);
6354 -- Do remaining checks (RM 13.8(3)) if not already done
6356 if not Is_Machine_Code_Subprogram
(Subp
) then
6357 Set_Is_Machine_Code_Subprogram
(Subp
);
6359 -- No exception handlers allowed
6361 if Present
(Exception_Handlers
(HSS
)) then
6363 ("exception handlers not permitted in machine code subprogram",
6364 First
(Exception_Handlers
(HSS
)));
6367 -- No declarations other than use clauses and pragmas (we allow
6368 -- certain internally generated declarations as well).
6370 Decl
:= First
(Declarations
(SBody
));
6371 while Present
(Decl
) loop
6372 DeclO
:= Original_Node
(Decl
);
6373 if Comes_From_Source
(DeclO
)
6374 and not Nkind_In
(DeclO
, N_Pragma
,
6375 N_Use_Package_Clause
,
6377 N_Implicit_Label_Declaration
)
6380 ("this declaration not allowed in machine code subprogram",
6387 -- No statements other than code statements, pragmas, and labels.
6388 -- Again we allow certain internally generated statements.
6390 -- In Ada 2012, qualified expressions are names, and the code
6391 -- statement is initially parsed as a procedure call.
6393 Stmt
:= First
(Statements
(HSS
));
6394 while Present
(Stmt
) loop
6395 StmtO
:= Original_Node
(Stmt
);
6397 -- A procedure call transformed into a code statement is OK
6399 if Ada_Version
>= Ada_2012
6400 and then Nkind
(StmtO
) = N_Procedure_Call_Statement
6401 and then Nkind
(Name
(StmtO
)) = N_Qualified_Expression
6405 elsif Comes_From_Source
(StmtO
)
6406 and then not Nkind_In
(StmtO
, N_Pragma
,
6411 ("this statement is not allowed in machine code subprogram",
6418 end Analyze_Code_Statement
;
6420 -----------------------------------------------
6421 -- Analyze_Enumeration_Representation_Clause --
6422 -----------------------------------------------
6424 procedure Analyze_Enumeration_Representation_Clause
(N
: Node_Id
) is
6425 Ident
: constant Node_Id
:= Identifier
(N
);
6426 Aggr
: constant Node_Id
:= Array_Aggregate
(N
);
6427 Enumtype
: Entity_Id
;
6434 Err
: Boolean := False;
6435 -- Set True to avoid cascade errors and crashes on incorrect source code
6437 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Universal_Integer
));
6438 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(Universal_Integer
));
6439 -- Allowed range of universal integer (= allowed range of enum lit vals)
6443 -- Minimum and maximum values of entries
6446 -- Pointer to node for literal providing max value
6449 if Ignore_Rep_Clauses
then
6450 Kill_Rep_Clause
(N
);
6454 -- Ignore enumeration rep clauses by default in CodePeer mode,
6455 -- unless -gnatd.I is specified, as a work around for potential false
6456 -- positive messages.
6458 if CodePeer_Mode
and not Debug_Flag_Dot_II
then
6462 -- First some basic error checks
6465 Enumtype
:= Entity
(Ident
);
6467 if Enumtype
= Any_Type
6468 or else Rep_Item_Too_Early
(Enumtype
, N
)
6472 Enumtype
:= Underlying_Type
(Enumtype
);
6475 if not Is_Enumeration_Type
(Enumtype
) then
6477 ("enumeration type required, found}",
6478 Ident
, First_Subtype
(Enumtype
));
6482 -- Ignore rep clause on generic actual type. This will already have
6483 -- been flagged on the template as an error, and this is the safest
6484 -- way to ensure we don't get a junk cascaded message in the instance.
6486 if Is_Generic_Actual_Type
(Enumtype
) then
6489 -- Type must be in current scope
6491 elsif Scope
(Enumtype
) /= Current_Scope
then
6492 Error_Msg_N
("type must be declared in this scope", Ident
);
6495 -- Type must be a first subtype
6497 elsif not Is_First_Subtype
(Enumtype
) then
6498 Error_Msg_N
("cannot give enumeration rep clause for subtype", N
);
6501 -- Ignore duplicate rep clause
6503 elsif Has_Enumeration_Rep_Clause
(Enumtype
) then
6504 Error_Msg_N
("duplicate enumeration rep clause ignored", N
);
6507 -- Don't allow rep clause for standard [wide_[wide_]]character
6509 elsif Is_Standard_Character_Type
(Enumtype
) then
6510 Error_Msg_N
("enumeration rep clause not allowed for this type", N
);
6513 -- Check that the expression is a proper aggregate (no parentheses)
6515 elsif Paren_Count
(Aggr
) /= 0 then
6517 ("extra parentheses surrounding aggregate not allowed",
6521 -- All tests passed, so set rep clause in place
6524 Set_Has_Enumeration_Rep_Clause
(Enumtype
);
6525 Set_Has_Enumeration_Rep_Clause
(Base_Type
(Enumtype
));
6528 -- Now we process the aggregate. Note that we don't use the normal
6529 -- aggregate code for this purpose, because we don't want any of the
6530 -- normal expansion activities, and a number of special semantic
6531 -- rules apply (including the component type being any integer type)
6533 Elit
:= First_Literal
(Enumtype
);
6535 -- First the positional entries if any
6537 if Present
(Expressions
(Aggr
)) then
6538 Expr
:= First
(Expressions
(Aggr
));
6539 while Present
(Expr
) loop
6541 Error_Msg_N
("too many entries in aggregate", Expr
);
6545 Val
:= Static_Integer
(Expr
);
6547 -- Err signals that we found some incorrect entries processing
6548 -- the list. The final checks for completeness and ordering are
6549 -- skipped in this case.
6551 if Val
= No_Uint
then
6554 elsif Val
< Lo
or else Hi
< Val
then
6555 Error_Msg_N
("value outside permitted range", Expr
);
6559 Set_Enumeration_Rep
(Elit
, Val
);
6560 Set_Enumeration_Rep_Expr
(Elit
, Expr
);
6566 -- Now process the named entries if present
6568 if Present
(Component_Associations
(Aggr
)) then
6569 Assoc
:= First
(Component_Associations
(Aggr
));
6570 while Present
(Assoc
) loop
6571 Choice
:= First
(Choices
(Assoc
));
6573 if Present
(Next
(Choice
)) then
6575 ("multiple choice not allowed here", Next
(Choice
));
6579 if Nkind
(Choice
) = N_Others_Choice
then
6580 Error_Msg_N
("others choice not allowed here", Choice
);
6583 elsif Nkind
(Choice
) = N_Range
then
6585 -- ??? should allow zero/one element range here
6587 Error_Msg_N
("range not allowed here", Choice
);
6591 Analyze_And_Resolve
(Choice
, Enumtype
);
6593 if Error_Posted
(Choice
) then
6598 if Is_Entity_Name
(Choice
)
6599 and then Is_Type
(Entity
(Choice
))
6601 Error_Msg_N
("subtype name not allowed here", Choice
);
6604 -- ??? should allow static subtype with zero/one entry
6606 elsif Etype
(Choice
) = Base_Type
(Enumtype
) then
6607 if not Is_OK_Static_Expression
(Choice
) then
6608 Flag_Non_Static_Expr
6609 ("non-static expression used for choice!", Choice
);
6613 Elit
:= Expr_Value_E
(Choice
);
6615 if Present
(Enumeration_Rep_Expr
(Elit
)) then
6617 Sloc
(Enumeration_Rep_Expr
(Elit
));
6619 ("representation for& previously given#",
6624 Set_Enumeration_Rep_Expr
(Elit
, Expression
(Assoc
));
6626 Expr
:= Expression
(Assoc
);
6627 Val
:= Static_Integer
(Expr
);
6629 if Val
= No_Uint
then
6632 elsif Val
< Lo
or else Hi
< Val
then
6633 Error_Msg_N
("value outside permitted range", Expr
);
6637 Set_Enumeration_Rep
(Elit
, Val
);
6647 -- Aggregate is fully processed. Now we check that a full set of
6648 -- representations was given, and that they are in range and in order.
6649 -- These checks are only done if no other errors occurred.
6655 Elit
:= First_Literal
(Enumtype
);
6656 while Present
(Elit
) loop
6657 if No
(Enumeration_Rep_Expr
(Elit
)) then
6658 Error_Msg_NE
("missing representation for&!", N
, Elit
);
6661 Val
:= Enumeration_Rep
(Elit
);
6663 if Min
= No_Uint
then
6667 if Val
/= No_Uint
then
6668 if Max
/= No_Uint
and then Val
<= Max
then
6670 ("enumeration value for& not ordered!",
6671 Enumeration_Rep_Expr
(Elit
), Elit
);
6674 Max_Node
:= Enumeration_Rep_Expr
(Elit
);
6678 -- If there is at least one literal whose representation is not
6679 -- equal to the Pos value, then note that this enumeration type
6680 -- has a non-standard representation.
6682 if Val
/= Enumeration_Pos
(Elit
) then
6683 Set_Has_Non_Standard_Rep
(Base_Type
(Enumtype
));
6690 -- Now set proper size information
6693 Minsize
: Uint
:= UI_From_Int
(Minimum_Size
(Enumtype
));
6696 if Has_Size_Clause
(Enumtype
) then
6698 -- All OK, if size is OK now
6700 if RM_Size
(Enumtype
) >= Minsize
then
6704 -- Try if we can get by with biasing
6707 UI_From_Int
(Minimum_Size
(Enumtype
, Biased
=> True));
6709 -- Error message if even biasing does not work
6711 if RM_Size
(Enumtype
) < Minsize
then
6712 Error_Msg_Uint_1
:= RM_Size
(Enumtype
);
6713 Error_Msg_Uint_2
:= Max
;
6715 ("previously given size (^) is too small "
6716 & "for this value (^)", Max_Node
);
6718 -- If biasing worked, indicate that we now have biased rep
6722 (Enumtype
, Size_Clause
(Enumtype
), "size clause");
6727 Set_RM_Size
(Enumtype
, Minsize
);
6728 Set_Enum_Esize
(Enumtype
);
6731 Set_RM_Size
(Base_Type
(Enumtype
), RM_Size
(Enumtype
));
6732 Set_Esize
(Base_Type
(Enumtype
), Esize
(Enumtype
));
6733 Set_Alignment
(Base_Type
(Enumtype
), Alignment
(Enumtype
));
6737 -- We repeat the too late test in case it froze itself
6739 if Rep_Item_Too_Late
(Enumtype
, N
) then
6742 end Analyze_Enumeration_Representation_Clause
;
6744 ----------------------------
6745 -- Analyze_Free_Statement --
6746 ----------------------------
6748 procedure Analyze_Free_Statement
(N
: Node_Id
) is
6750 Analyze
(Expression
(N
));
6751 end Analyze_Free_Statement
;
6753 ---------------------------
6754 -- Analyze_Freeze_Entity --
6755 ---------------------------
6757 procedure Analyze_Freeze_Entity
(N
: Node_Id
) is
6759 Freeze_Entity_Checks
(N
);
6760 end Analyze_Freeze_Entity
;
6762 -----------------------------------
6763 -- Analyze_Freeze_Generic_Entity --
6764 -----------------------------------
6766 procedure Analyze_Freeze_Generic_Entity
(N
: Node_Id
) is
6767 E
: constant Entity_Id
:= Entity
(N
);
6770 if not Is_Frozen
(E
) and then Has_Delayed_Aspects
(E
) then
6771 Analyze_Aspects_At_Freeze_Point
(E
);
6774 Freeze_Entity_Checks
(N
);
6775 end Analyze_Freeze_Generic_Entity
;
6777 ------------------------------------------
6778 -- Analyze_Record_Representation_Clause --
6779 ------------------------------------------
6781 -- Note: we check as much as we can here, but we can't do any checks
6782 -- based on the position values (e.g. overlap checks) until freeze time
6783 -- because especially in Ada 2005 (machine scalar mode), the processing
6784 -- for non-standard bit order can substantially change the positions.
6785 -- See procedure Check_Record_Representation_Clause (called from Freeze)
6786 -- for the remainder of this processing.
6788 procedure Analyze_Record_Representation_Clause
(N
: Node_Id
) is
6789 Ident
: constant Node_Id
:= Identifier
(N
);
6794 Hbit
: Uint
:= Uint_0
;
6798 Rectype
: Entity_Id
;
6801 function Is_Inherited
(Comp
: Entity_Id
) return Boolean;
6802 -- True if Comp is an inherited component in a record extension
6808 function Is_Inherited
(Comp
: Entity_Id
) return Boolean is
6809 Comp_Base
: Entity_Id
;
6812 if Ekind
(Rectype
) = E_Record_Subtype
then
6813 Comp_Base
:= Original_Record_Component
(Comp
);
6818 return Comp_Base
/= Original_Record_Component
(Comp_Base
);
6823 Is_Record_Extension
: Boolean;
6824 -- True if Rectype is a record extension
6826 CR_Pragma
: Node_Id
:= Empty
;
6827 -- Points to N_Pragma node if Complete_Representation pragma present
6829 -- Start of processing for Analyze_Record_Representation_Clause
6832 if Ignore_Rep_Clauses
then
6833 Kill_Rep_Clause
(N
);
6838 Rectype
:= Entity
(Ident
);
6840 if Rectype
= Any_Type
or else Rep_Item_Too_Early
(Rectype
, N
) then
6843 Rectype
:= Underlying_Type
(Rectype
);
6846 -- First some basic error checks
6848 if not Is_Record_Type
(Rectype
) then
6850 ("record type required, found}", Ident
, First_Subtype
(Rectype
));
6853 elsif Scope
(Rectype
) /= Current_Scope
then
6854 Error_Msg_N
("type must be declared in this scope", N
);
6857 elsif not Is_First_Subtype
(Rectype
) then
6858 Error_Msg_N
("cannot give record rep clause for subtype", N
);
6861 elsif Has_Record_Rep_Clause
(Rectype
) then
6862 Error_Msg_N
("duplicate record rep clause ignored", N
);
6865 elsif Rep_Item_Too_Late
(Rectype
, N
) then
6869 -- We know we have a first subtype, now possibly go to the anonymous
6870 -- base type to determine whether Rectype is a record extension.
6872 Recdef
:= Type_Definition
(Declaration_Node
(Base_Type
(Rectype
)));
6873 Is_Record_Extension
:=
6874 Nkind
(Recdef
) = N_Derived_Type_Definition
6875 and then Present
(Record_Extension_Part
(Recdef
));
6877 if Present
(Mod_Clause
(N
)) then
6879 Loc
: constant Source_Ptr
:= Sloc
(N
);
6880 M
: constant Node_Id
:= Mod_Clause
(N
);
6881 P
: constant List_Id
:= Pragmas_Before
(M
);
6885 pragma Warnings
(Off
, Mod_Val
);
6888 Check_Restriction
(No_Obsolescent_Features
, Mod_Clause
(N
));
6890 if Warn_On_Obsolescent_Feature
then
6892 ("?j?mod clause is an obsolescent feature (RM J.8)", N
);
6894 ("\?j?use alignment attribute definition clause instead", N
);
6901 -- In ASIS_Mode mode, expansion is disabled, but we must convert
6902 -- the Mod clause into an alignment clause anyway, so that the
6903 -- back end can compute and back-annotate properly the size and
6904 -- alignment of types that may include this record.
6906 -- This seems dubious, this destroys the source tree in a manner
6907 -- not detectable by ASIS ???
6909 if Operating_Mode
= Check_Semantics
and then ASIS_Mode
then
6911 Make_Attribute_Definition_Clause
(Loc
,
6912 Name
=> New_Occurrence_Of
(Base_Type
(Rectype
), Loc
),
6913 Chars
=> Name_Alignment
,
6914 Expression
=> Relocate_Node
(Expression
(M
)));
6916 Set_From_At_Mod
(AtM_Nod
);
6917 Insert_After
(N
, AtM_Nod
);
6918 Mod_Val
:= Get_Alignment_Value
(Expression
(AtM_Nod
));
6919 Set_Mod_Clause
(N
, Empty
);
6922 -- Get the alignment value to perform error checking
6924 Mod_Val
:= Get_Alignment_Value
(Expression
(M
));
6929 -- For untagged types, clear any existing component clauses for the
6930 -- type. If the type is derived, this is what allows us to override
6931 -- a rep clause for the parent. For type extensions, the representation
6932 -- of the inherited components is inherited, so we want to keep previous
6933 -- component clauses for completeness.
6935 if not Is_Tagged_Type
(Rectype
) then
6936 Comp
:= First_Component_Or_Discriminant
(Rectype
);
6937 while Present
(Comp
) loop
6938 Set_Component_Clause
(Comp
, Empty
);
6939 Next_Component_Or_Discriminant
(Comp
);
6943 -- All done if no component clauses
6945 CC
:= First
(Component_Clauses
(N
));
6951 -- A representation like this applies to the base type
6953 Set_Has_Record_Rep_Clause
(Base_Type
(Rectype
));
6954 Set_Has_Non_Standard_Rep
(Base_Type
(Rectype
));
6955 Set_Has_Specified_Layout
(Base_Type
(Rectype
));
6957 -- Process the component clauses
6959 while Present
(CC
) loop
6963 if Nkind
(CC
) = N_Pragma
then
6966 -- The only pragma of interest is Complete_Representation
6968 if Pragma_Name
(CC
) = Name_Complete_Representation
then
6972 -- Processing for real component clause
6975 Posit
:= Static_Integer
(Position
(CC
));
6976 Fbit
:= Static_Integer
(First_Bit
(CC
));
6977 Lbit
:= Static_Integer
(Last_Bit
(CC
));
6980 and then Fbit
/= No_Uint
6981 and then Lbit
/= No_Uint
6984 Error_Msg_N
("position cannot be negative", Position
(CC
));
6987 Error_Msg_N
("first bit cannot be negative", First_Bit
(CC
));
6989 -- The Last_Bit specified in a component clause must not be
6990 -- less than the First_Bit minus one (RM-13.5.1(10)).
6992 elsif Lbit
< Fbit
- 1 then
6994 ("last bit cannot be less than first bit minus one",
6997 -- Values look OK, so find the corresponding record component
6998 -- Even though the syntax allows an attribute reference for
6999 -- implementation-defined components, GNAT does not allow the
7000 -- tag to get an explicit position.
7002 elsif Nkind
(Component_Name
(CC
)) = N_Attribute_Reference
then
7003 if Attribute_Name
(Component_Name
(CC
)) = Name_Tag
then
7004 Error_Msg_N
("position of tag cannot be specified", CC
);
7006 Error_Msg_N
("illegal component name", CC
);
7010 Comp
:= First_Entity
(Rectype
);
7011 while Present
(Comp
) loop
7012 exit when Chars
(Comp
) = Chars
(Component_Name
(CC
));
7018 -- Maybe component of base type that is absent from
7019 -- statically constrained first subtype.
7021 Comp
:= First_Entity
(Base_Type
(Rectype
));
7022 while Present
(Comp
) loop
7023 exit when Chars
(Comp
) = Chars
(Component_Name
(CC
));
7030 ("component clause is for non-existent field", CC
);
7032 -- Ada 2012 (AI05-0026): Any name that denotes a
7033 -- discriminant of an object of an unchecked union type
7034 -- shall not occur within a record_representation_clause.
7036 -- The general restriction of using record rep clauses on
7037 -- Unchecked_Union types has now been lifted. Since it is
7038 -- possible to introduce a record rep clause which mentions
7039 -- the discriminant of an Unchecked_Union in non-Ada 2012
7040 -- code, this check is applied to all versions of the
7043 elsif Ekind
(Comp
) = E_Discriminant
7044 and then Is_Unchecked_Union
(Rectype
)
7047 ("cannot reference discriminant of unchecked union",
7048 Component_Name
(CC
));
7050 elsif Is_Record_Extension
and then Is_Inherited
(Comp
) then
7052 ("component clause not allowed for inherited "
7053 & "component&", CC
, Comp
);
7055 elsif Present
(Component_Clause
(Comp
)) then
7057 -- Diagnose duplicate rep clause, or check consistency
7058 -- if this is an inherited component. In a double fault,
7059 -- there may be a duplicate inconsistent clause for an
7060 -- inherited component.
7062 if Scope
(Original_Record_Component
(Comp
)) = Rectype
7063 or else Parent
(Component_Clause
(Comp
)) = N
7065 Error_Msg_Sloc
:= Sloc
(Component_Clause
(Comp
));
7066 Error_Msg_N
("component clause previously given#", CC
);
7070 Rep1
: constant Node_Id
:= Component_Clause
(Comp
);
7072 if Intval
(Position
(Rep1
)) /=
7073 Intval
(Position
(CC
))
7074 or else Intval
(First_Bit
(Rep1
)) /=
7075 Intval
(First_Bit
(CC
))
7076 or else Intval
(Last_Bit
(Rep1
)) /=
7077 Intval
(Last_Bit
(CC
))
7080 ("component clause inconsistent with "
7081 & "representation of ancestor", CC
);
7083 elsif Warn_On_Redundant_Constructs
then
7085 ("?r?redundant confirming component clause "
7086 & "for component!", CC
);
7091 -- Normal case where this is the first component clause we
7092 -- have seen for this entity, so set it up properly.
7095 -- Make reference for field in record rep clause and set
7096 -- appropriate entity field in the field identifier.
7099 (Comp
, Component_Name
(CC
), Set_Ref
=> False);
7100 Set_Entity
(Component_Name
(CC
), Comp
);
7102 -- Update Fbit and Lbit to the actual bit number
7104 Fbit
:= Fbit
+ UI_From_Int
(SSU
) * Posit
;
7105 Lbit
:= Lbit
+ UI_From_Int
(SSU
) * Posit
;
7107 if Has_Size_Clause
(Rectype
)
7108 and then RM_Size
(Rectype
) <= Lbit
7111 ("bit number out of range of specified size",
7114 Set_Component_Clause
(Comp
, CC
);
7115 Set_Component_Bit_Offset
(Comp
, Fbit
);
7116 Set_Esize
(Comp
, 1 + (Lbit
- Fbit
));
7117 Set_Normalized_First_Bit
(Comp
, Fbit
mod SSU
);
7118 Set_Normalized_Position
(Comp
, Fbit
/ SSU
);
7120 if Warn_On_Overridden_Size
7121 and then Has_Size_Clause
(Etype
(Comp
))
7122 and then RM_Size
(Etype
(Comp
)) /= Esize
(Comp
)
7125 ("?S?component size overrides size clause for&",
7126 Component_Name
(CC
), Etype
(Comp
));
7129 -- This information is also set in the corresponding
7130 -- component of the base type, found by accessing the
7131 -- Original_Record_Component link if it is present.
7133 Ocomp
:= Original_Record_Component
(Comp
);
7140 (Component_Name
(CC
),
7146 (Comp
, First_Node
(CC
), "component clause", Biased
);
7148 if Present
(Ocomp
) then
7149 Set_Component_Clause
(Ocomp
, CC
);
7150 Set_Component_Bit_Offset
(Ocomp
, Fbit
);
7151 Set_Normalized_First_Bit
(Ocomp
, Fbit
mod SSU
);
7152 Set_Normalized_Position
(Ocomp
, Fbit
/ SSU
);
7153 Set_Esize
(Ocomp
, 1 + (Lbit
- Fbit
));
7155 Set_Normalized_Position_Max
7156 (Ocomp
, Normalized_Position
(Ocomp
));
7158 -- Note: we don't use Set_Biased here, because we
7159 -- already gave a warning above if needed, and we
7160 -- would get a duplicate for the same name here.
7162 Set_Has_Biased_Representation
7163 (Ocomp
, Has_Biased_Representation
(Comp
));
7166 if Esize
(Comp
) < 0 then
7167 Error_Msg_N
("component size is negative", CC
);
7178 -- Check missing components if Complete_Representation pragma appeared
7180 if Present
(CR_Pragma
) then
7181 Comp
:= First_Component_Or_Discriminant
(Rectype
);
7182 while Present
(Comp
) loop
7183 if No
(Component_Clause
(Comp
)) then
7185 ("missing component clause for &", CR_Pragma
, Comp
);
7188 Next_Component_Or_Discriminant
(Comp
);
7191 -- Give missing components warning if required
7193 elsif Warn_On_Unrepped_Components
then
7195 Num_Repped_Components
: Nat
:= 0;
7196 Num_Unrepped_Components
: Nat
:= 0;
7199 -- First count number of repped and unrepped components
7201 Comp
:= First_Component_Or_Discriminant
(Rectype
);
7202 while Present
(Comp
) loop
7203 if Present
(Component_Clause
(Comp
)) then
7204 Num_Repped_Components
:= Num_Repped_Components
+ 1;
7206 Num_Unrepped_Components
:= Num_Unrepped_Components
+ 1;
7209 Next_Component_Or_Discriminant
(Comp
);
7212 -- We are only interested in the case where there is at least one
7213 -- unrepped component, and at least half the components have rep
7214 -- clauses. We figure that if less than half have them, then the
7215 -- partial rep clause is really intentional. If the component
7216 -- type has no underlying type set at this point (as for a generic
7217 -- formal type), we don't know enough to give a warning on the
7220 if Num_Unrepped_Components
> 0
7221 and then Num_Unrepped_Components
< Num_Repped_Components
7223 Comp
:= First_Component_Or_Discriminant
(Rectype
);
7224 while Present
(Comp
) loop
7225 if No
(Component_Clause
(Comp
))
7226 and then Comes_From_Source
(Comp
)
7227 and then Present
(Underlying_Type
(Etype
(Comp
)))
7228 and then (Is_Scalar_Type
(Underlying_Type
(Etype
(Comp
)))
7229 or else Size_Known_At_Compile_Time
7230 (Underlying_Type
(Etype
(Comp
))))
7231 and then not Has_Warnings_Off
(Rectype
)
7233 -- Ignore discriminant in unchecked union, since it is
7234 -- not there, and cannot have a component clause.
7236 and then (not Is_Unchecked_Union
(Rectype
)
7237 or else Ekind
(Comp
) /= E_Discriminant
)
7239 Error_Msg_Sloc
:= Sloc
(Comp
);
7241 ("?C?no component clause given for & declared #",
7245 Next_Component_Or_Discriminant
(Comp
);
7250 end Analyze_Record_Representation_Clause
;
7252 -------------------------------------
7253 -- Build_Discrete_Static_Predicate --
7254 -------------------------------------
7256 procedure Build_Discrete_Static_Predicate
7261 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
7263 Non_Static
: exception;
7264 -- Raised if something non-static is found
7266 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
7268 BLo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Btyp
));
7269 BHi
: constant Uint
:= Expr_Value
(Type_High_Bound
(Btyp
));
7270 -- Low bound and high bound value of base type of Typ
7274 -- Bounds for constructing the static predicate. We use the bound of the
7275 -- subtype if it is static, otherwise the corresponding base type bound.
7276 -- Note: a non-static subtype can have a static predicate.
7281 -- One entry in a Rlist value, a single REnt (range entry) value denotes
7282 -- one range from Lo to Hi. To represent a single value range Lo = Hi =
7285 type RList
is array (Nat
range <>) of REnt
;
7286 -- A list of ranges. The ranges are sorted in increasing order, and are
7287 -- disjoint (there is a gap of at least one value between each range in
7288 -- the table). A value is in the set of ranges in Rlist if it lies
7289 -- within one of these ranges.
7291 False_Range
: constant RList
:=
7292 RList
'(1 .. 0 => REnt'(No_Uint
, No_Uint
));
7293 -- An empty set of ranges represents a range list that can never be
7294 -- satisfied, since there are no ranges in which the value could lie,
7295 -- so it does not lie in any of them. False_Range is a canonical value
7296 -- for this empty set, but general processing should test for an Rlist
7297 -- with length zero (see Is_False predicate), since other null ranges
7298 -- may appear which must be treated as False.
7300 True_Range
: constant RList
:= RList
'(1 => REnt'(BLo
, BHi
));
7301 -- Range representing True, value must be in the base range
7303 function "and" (Left
: RList
; Right
: RList
) return RList
;
7304 -- And's together two range lists, returning a range list. This is a set
7305 -- intersection operation.
7307 function "or" (Left
: RList
; Right
: RList
) return RList
;
7308 -- Or's together two range lists, returning a range list. This is a set
7311 function "not" (Right
: RList
) return RList
;
7312 -- Returns complement of a given range list, i.e. a range list
7313 -- representing all the values in TLo .. THi that are not in the input
7316 function Build_Val
(V
: Uint
) return Node_Id
;
7317 -- Return an analyzed N_Identifier node referencing this value, suitable
7318 -- for use as an entry in the Static_Discrte_Predicate list. This node
7319 -- is typed with the base type.
7321 function Build_Range
(Lo
: Uint
; Hi
: Uint
) return Node_Id
;
7322 -- Return an analyzed N_Range node referencing this range, suitable for
7323 -- use as an entry in the Static_Discrete_Predicate list. This node is
7324 -- typed with the base type.
7326 function Get_RList
(Exp
: Node_Id
) return RList
;
7327 -- This is a recursive routine that converts the given expression into a
7328 -- list of ranges, suitable for use in building the static predicate.
7330 function Is_False
(R
: RList
) return Boolean;
7331 pragma Inline
(Is_False
);
7332 -- Returns True if the given range list is empty, and thus represents a
7333 -- False list of ranges that can never be satisfied.
7335 function Is_True
(R
: RList
) return Boolean;
7336 -- Returns True if R trivially represents the True predicate by having a
7337 -- single range from BLo to BHi.
7339 function Is_Type_Ref
(N
: Node_Id
) return Boolean;
7340 pragma Inline
(Is_Type_Ref
);
7341 -- Returns if True if N is a reference to the type for the predicate in
7342 -- the expression (i.e. if it is an identifier whose Chars field matches
7343 -- the Nam given in the call). N must not be parenthesized, if the type
7344 -- name appears in parens, this routine will return False.
7346 function Lo_Val
(N
: Node_Id
) return Uint
;
7347 -- Given an entry from a Static_Discrete_Predicate list that is either
7348 -- a static expression or static range, gets either the expression value
7349 -- or the low bound of the range.
7351 function Hi_Val
(N
: Node_Id
) return Uint
;
7352 -- Given an entry from a Static_Discrete_Predicate list that is either
7353 -- a static expression or static range, gets either the expression value
7354 -- or the high bound of the range.
7356 function Membership_Entry
(N
: Node_Id
) return RList
;
7357 -- Given a single membership entry (range, value, or subtype), returns
7358 -- the corresponding range list. Raises Static_Error if not static.
7360 function Membership_Entries
(N
: Node_Id
) return RList
;
7361 -- Given an element on an alternatives list of a membership operation,
7362 -- returns the range list corresponding to this entry and all following
7363 -- entries (i.e. returns the "or" of this list of values).
7365 function Stat_Pred
(Typ
: Entity_Id
) return RList
;
7366 -- Given a type, if it has a static predicate, then return the predicate
7367 -- as a range list, otherwise raise Non_Static.
7373 function "and" (Left
: RList
; Right
: RList
) return RList
is
7375 -- First range of result
7377 SLeft
: Nat
:= Left
'First;
7378 -- Start of rest of left entries
7380 SRight
: Nat
:= Right
'First;
7381 -- Start of rest of right entries
7384 -- If either range is True, return the other
7386 if Is_True
(Left
) then
7388 elsif Is_True
(Right
) then
7392 -- If either range is False, return False
7394 if Is_False
(Left
) or else Is_False
(Right
) then
7398 -- Loop to remove entries at start that are disjoint, and thus just
7399 -- get discarded from the result entirely.
7402 -- If no operands left in either operand, result is false
7404 if SLeft
> Left
'Last or else SRight
> Right
'Last then
7407 -- Discard first left operand entry if disjoint with right
7409 elsif Left
(SLeft
).Hi
< Right
(SRight
).Lo
then
7412 -- Discard first right operand entry if disjoint with left
7414 elsif Right
(SRight
).Hi
< Left
(SLeft
).Lo
then
7415 SRight
:= SRight
+ 1;
7417 -- Otherwise we have an overlapping entry
7424 -- Now we have two non-null operands, and first entries overlap. The
7425 -- first entry in the result will be the overlapping part of these
7428 FEnt
:= REnt
'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo),
7429 Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi));
7431 -- Now we can remove the entry that ended at a lower value, since its
7432 -- contribution is entirely contained in Fent.
7434 if Left (SLeft).Hi <= Right (SRight).Hi then
7437 SRight := SRight + 1;
7440 -- Compute result by concatenating this first entry with the "and" of
7441 -- the remaining parts of the left and right operands. Note that if
7442 -- either of these is empty, "and" will yield empty, so that we will
7443 -- end up with just Fent, which is what we want in that case.
7446 FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
7453 function "not" (Right : RList) return RList is
7455 -- Return True if False range
7457 if Is_False (Right) then
7461 -- Return False if True range
7463 if Is_True (Right) then
7467 -- Here if not trivial case
7470 Result : RList (1 .. Right'Length + 1);
7471 -- May need one more entry for gap at beginning and end
7474 -- Number of entries stored in Result
7479 if Right (Right'First).Lo > TLo then
7481 Result (Count) := REnt'(TLo
, Right
(Right
'First).Lo
- 1);
7484 -- Gaps between ranges
7486 for J
in Right
'First .. Right
'Last - 1 loop
7488 Result
(Count
) := REnt
'(Right (J).Hi + 1, Right (J + 1).Lo - 1);
7493 if Right (Right'Last).Hi < THi then
7495 Result (Count) := REnt'(Right
(Right
'Last).Hi
+ 1, THi
);
7498 return Result
(1 .. Count
);
7506 function "or" (Left
: RList
; Right
: RList
) return RList
is
7508 -- First range of result
7510 SLeft
: Nat
:= Left
'First;
7511 -- Start of rest of left entries
7513 SRight
: Nat
:= Right
'First;
7514 -- Start of rest of right entries
7517 -- If either range is True, return True
7519 if Is_True
(Left
) or else Is_True
(Right
) then
7523 -- If either range is False (empty), return the other
7525 if Is_False
(Left
) then
7527 elsif Is_False
(Right
) then
7531 -- Initialize result first entry from left or right operand depending
7532 -- on which starts with the lower range.
7534 if Left
(SLeft
).Lo
< Right
(SRight
).Lo
then
7535 FEnt
:= Left
(SLeft
);
7538 FEnt
:= Right
(SRight
);
7539 SRight
:= SRight
+ 1;
7542 -- This loop eats ranges from left and right operands that are
7543 -- contiguous with the first range we are gathering.
7546 -- Eat first entry in left operand if contiguous or overlapped by
7547 -- gathered first operand of result.
7549 if SLeft
<= Left
'Last
7550 and then Left
(SLeft
).Lo
<= FEnt
.Hi
+ 1
7552 FEnt
.Hi
:= UI_Max
(FEnt
.Hi
, Left
(SLeft
).Hi
);
7555 -- Eat first entry in right operand if contiguous or overlapped by
7556 -- gathered right operand of result.
7558 elsif SRight
<= Right
'Last
7559 and then Right
(SRight
).Lo
<= FEnt
.Hi
+ 1
7561 FEnt
.Hi
:= UI_Max
(FEnt
.Hi
, Right
(SRight
).Hi
);
7562 SRight
:= SRight
+ 1;
7564 -- All done if no more entries to eat
7571 -- Obtain result as the first entry we just computed, concatenated
7572 -- to the "or" of the remaining results (if one operand is empty,
7573 -- this will just concatenate with the other
7576 FEnt
& (Left
(SLeft
.. Left
'Last) or Right
(SRight
.. Right
'Last));
7583 function Build_Range
(Lo
: Uint
; Hi
: Uint
) return Node_Id
is
7588 Low_Bound
=> Build_Val
(Lo
),
7589 High_Bound
=> Build_Val
(Hi
));
7590 Set_Etype
(Result
, Btyp
);
7591 Set_Analyzed
(Result
);
7599 function Build_Val
(V
: Uint
) return Node_Id
is
7603 if Is_Enumeration_Type
(Typ
) then
7604 Result
:= Get_Enum_Lit_From_Pos
(Typ
, V
, Loc
);
7606 Result
:= Make_Integer_Literal
(Loc
, V
);
7609 Set_Etype
(Result
, Btyp
);
7610 Set_Is_Static_Expression
(Result
);
7611 Set_Analyzed
(Result
);
7619 function Get_RList
(Exp
: Node_Id
) return RList
is
7624 -- Static expression can only be true or false
7626 if Is_OK_Static_Expression
(Exp
) then
7627 if Expr_Value
(Exp
) = 0 then
7634 -- Otherwise test node type
7645 return Get_RList
(Left_Opnd
(Exp
))
7647 Get_RList
(Right_Opnd
(Exp
));
7654 return Get_RList
(Left_Opnd
(Exp
))
7656 Get_RList
(Right_Opnd
(Exp
));
7661 return not Get_RList
(Right_Opnd
(Exp
));
7663 -- Comparisons of type with static value
7665 when N_Op_Compare
=>
7667 -- Type is left operand
7669 if Is_Type_Ref
(Left_Opnd
(Exp
))
7670 and then Is_OK_Static_Expression
(Right_Opnd
(Exp
))
7672 Val
:= Expr_Value
(Right_Opnd
(Exp
));
7674 -- Typ is right operand
7676 elsif Is_Type_Ref
(Right_Opnd
(Exp
))
7677 and then Is_OK_Static_Expression
(Left_Opnd
(Exp
))
7679 Val
:= Expr_Value
(Left_Opnd
(Exp
));
7681 -- Invert sense of comparison
7684 when N_Op_Gt
=> Op
:= N_Op_Lt
;
7685 when N_Op_Lt
=> Op
:= N_Op_Gt
;
7686 when N_Op_Ge
=> Op
:= N_Op_Le
;
7687 when N_Op_Le
=> Op
:= N_Op_Ge
;
7688 when others => null;
7691 -- Other cases are non-static
7697 -- Construct range according to comparison operation
7701 return RList
'(1 => REnt'(Val
, Val
));
7704 return RList
'(1 => REnt'(Val
, BHi
));
7707 return RList
'(1 => REnt'(Val
+ 1, BHi
));
7710 return RList
'(1 => REnt'(BLo
, Val
));
7713 return RList
'(1 => REnt'(BLo
, Val
- 1));
7716 return RList
'(REnt'(BLo
, Val
- 1), REnt
'(Val + 1, BHi));
7719 raise Program_Error;
7725 if not Is_Type_Ref (Left_Opnd (Exp)) then
7729 if Present (Right_Opnd (Exp)) then
7730 return Membership_Entry (Right_Opnd (Exp));
7732 return Membership_Entries (First (Alternatives (Exp)));
7735 -- Negative membership (NOT IN)
7738 if not Is_Type_Ref (Left_Opnd (Exp)) then
7742 if Present (Right_Opnd (Exp)) then
7743 return not Membership_Entry (Right_Opnd (Exp));
7745 return not Membership_Entries (First (Alternatives (Exp)));
7748 -- Function call, may be call to static predicate
7750 when N_Function_Call =>
7751 if Is_Entity_Name (Name (Exp)) then
7753 Ent : constant Entity_Id := Entity (Name (Exp));
7755 if Is_Predicate_Function (Ent)
7757 Is_Predicate_Function_M (Ent)
7759 return Stat_Pred (Etype (First_Formal (Ent)));
7764 -- Other function call cases are non-static
7768 -- Qualified expression, dig out the expression
7770 when N_Qualified_Expression =>
7771 return Get_RList (Expression (Exp));
7773 when N_Case_Expression =>
7780 if not Is_Entity_Name (Expression (Expr))
7781 or else Etype (Expression (Expr)) /= Typ
7784 ("expression must denaote subtype", Expression (Expr));
7788 -- Collect discrete choices in all True alternatives
7790 Choices := New_List;
7791 Alt := First (Alternatives (Exp));
7792 while Present (Alt) loop
7793 Dep := Expression (Alt);
7795 if not Is_OK_Static_Expression (Dep) then
7798 elsif Is_True (Expr_Value (Dep)) then
7799 Append_List_To (Choices,
7800 New_Copy_List (Discrete_Choices (Alt)));
7806 return Membership_Entries (First (Choices));
7809 -- Expression with actions: if no actions, dig out expression
7811 when N_Expression_With_Actions =>
7812 if Is_Empty_List (Actions (Exp)) then
7813 return Get_RList (Expression (Exp));
7821 return (Get_RList (Left_Opnd (Exp))
7822 and not Get_RList (Right_Opnd (Exp)))
7823 or (Get_RList (Right_Opnd (Exp))
7824 and not Get_RList (Left_Opnd (Exp)));
7826 -- Any other node type is non-static
7837 function Hi_Val (N : Node_Id) return Uint is
7839 if Is_OK_Static_Expression (N) then
7840 return Expr_Value (N);
7842 pragma Assert (Nkind (N) = N_Range);
7843 return Expr_Value (High_Bound (N));
7851 function Is_False (R : RList) return Boolean is
7853 return R'Length = 0;
7860 function Is_True (R : RList) return Boolean is
7863 and then R (R'First).Lo = BLo
7864 and then R (R'First).Hi = BHi;
7871 function Is_Type_Ref (N : Node_Id) return Boolean is
7873 return Nkind (N) = N_Identifier
7874 and then Chars (N) = Nam
7875 and then Paren_Count (N) = 0;
7882 function Lo_Val (N : Node_Id) return Uint is
7884 if Is_OK_Static_Expression (N) then
7885 return Expr_Value (N);
7887 pragma Assert (Nkind (N) = N_Range);
7888 return Expr_Value (Low_Bound (N));
7892 ------------------------
7893 -- Membership_Entries --
7894 ------------------------
7896 function Membership_Entries (N : Node_Id) return RList is
7898 if No (Next (N)) then
7899 return Membership_Entry (N);
7901 return Membership_Entry (N) or Membership_Entries (Next (N));
7903 end Membership_Entries;
7905 ----------------------
7906 -- Membership_Entry --
7907 ----------------------
7909 function Membership_Entry (N : Node_Id) return RList is
7917 if Nkind (N) = N_Range then
7918 if not Is_OK_Static_Expression (Low_Bound (N))
7920 not Is_OK_Static_Expression (High_Bound (N))
7924 SLo := Expr_Value (Low_Bound (N));
7925 SHi := Expr_Value (High_Bound (N));
7926 return RList'(1 => REnt
'(SLo, SHi));
7929 -- Static expression case
7931 elsif Is_OK_Static_Expression (N) then
7932 Val := Expr_Value (N);
7933 return RList'(1 => REnt
'(Val, Val));
7935 -- Identifier (other than static expression) case
7937 else pragma Assert (Nkind (N) = N_Identifier);
7941 if Is_Type (Entity (N)) then
7943 -- If type has predicates, process them
7945 if Has_Predicates (Entity (N)) then
7946 return Stat_Pred (Entity (N));
7948 -- For static subtype without predicates, get range
7950 elsif Is_OK_Static_Subtype (Entity (N)) then
7951 SLo := Expr_Value (Type_Low_Bound (Entity (N)));
7952 SHi := Expr_Value (Type_High_Bound (Entity (N)));
7953 return RList'(1 => REnt
'(SLo, SHi));
7955 -- Any other type makes us non-static
7961 -- Any other kind of identifier in predicate (e.g. a non-static
7962 -- expression value) means this is not a static predicate.
7968 end Membership_Entry;
7974 function Stat_Pred (Typ : Entity_Id) return RList is
7976 -- Not static if type does not have static predicates
7978 if not Has_Static_Predicate (Typ) then
7982 -- Otherwise we convert the predicate list to a range list
7985 Spred : constant List_Id := Static_Discrete_Predicate (Typ);
7986 Result : RList (1 .. List_Length (Spred));
7990 P := First (Static_Discrete_Predicate (Typ));
7991 for J in Result'Range loop
7992 Result (J) := REnt'(Lo_Val
(P
), Hi_Val
(P
));
8000 -- Start of processing for Build_Discrete_Static_Predicate
8003 -- Establish bounds for the predicate
8005 if Compile_Time_Known_Value
(Type_Low_Bound
(Typ
)) then
8006 TLo
:= Expr_Value
(Type_Low_Bound
(Typ
));
8011 if Compile_Time_Known_Value
(Type_High_Bound
(Typ
)) then
8012 THi
:= Expr_Value
(Type_High_Bound
(Typ
));
8017 -- Analyze the expression to see if it is a static predicate
8020 Ranges
: constant RList
:= Get_RList
(Expr
);
8021 -- Range list from expression if it is static
8026 -- Convert range list into a form for the static predicate. In the
8027 -- Ranges array, we just have raw ranges, these must be converted
8028 -- to properly typed and analyzed static expressions or range nodes.
8030 -- Note: here we limit ranges to the ranges of the subtype, so that
8031 -- a predicate is always false for values outside the subtype. That
8032 -- seems fine, such values are invalid anyway, and considering them
8033 -- to fail the predicate seems allowed and friendly, and furthermore
8034 -- simplifies processing for case statements and loops.
8038 for J
in Ranges
'Range loop
8040 Lo
: Uint
:= Ranges
(J
).Lo
;
8041 Hi
: Uint
:= Ranges
(J
).Hi
;
8044 -- Ignore completely out of range entry
8046 if Hi
< TLo
or else Lo
> THi
then
8049 -- Otherwise process entry
8052 -- Adjust out of range value to subtype range
8062 -- Convert range into required form
8064 Append_To
(Plist
, Build_Range
(Lo
, Hi
));
8069 -- Processing was successful and all entries were static, so now we
8070 -- can store the result as the predicate list.
8072 Set_Static_Discrete_Predicate
(Typ
, Plist
);
8074 -- The processing for static predicates put the expression into
8075 -- canonical form as a series of ranges. It also eliminated
8076 -- duplicates and collapsed and combined ranges. We might as well
8077 -- replace the alternatives list of the right operand of the
8078 -- membership test with the static predicate list, which will
8079 -- usually be more efficient.
8082 New_Alts
: constant List_Id
:= New_List
;
8087 Old_Node
:= First
(Plist
);
8088 while Present
(Old_Node
) loop
8089 New_Node
:= New_Copy
(Old_Node
);
8091 if Nkind
(New_Node
) = N_Range
then
8092 Set_Low_Bound
(New_Node
, New_Copy
(Low_Bound
(Old_Node
)));
8093 Set_High_Bound
(New_Node
, New_Copy
(High_Bound
(Old_Node
)));
8096 Append_To
(New_Alts
, New_Node
);
8100 -- If empty list, replace by False
8102 if Is_Empty_List
(New_Alts
) then
8103 Rewrite
(Expr
, New_Occurrence_Of
(Standard_False
, Loc
));
8105 -- Else replace by set membership test
8110 Left_Opnd
=> Make_Identifier
(Loc
, Nam
),
8111 Right_Opnd
=> Empty
,
8112 Alternatives
=> New_Alts
));
8114 -- Resolve new expression in function context
8116 Install_Formals
(Predicate_Function
(Typ
));
8117 Push_Scope
(Predicate_Function
(Typ
));
8118 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
8124 -- If non-static, return doing nothing
8129 end Build_Discrete_Static_Predicate
;
8131 --------------------------------
8132 -- Build_Export_Import_Pragma --
8133 --------------------------------
8135 function Build_Export_Import_Pragma
8137 Id
: Entity_Id
) return Node_Id
8139 Asp_Id
: constant Aspect_Id
:= Get_Aspect_Id
(Asp
);
8140 Expr
: constant Node_Id
:= Expression
(Asp
);
8141 Loc
: constant Source_Ptr
:= Sloc
(Asp
);
8152 Create_Pragma
: Boolean := False;
8153 -- This flag is set when the aspect form is such that it warrants the
8154 -- creation of a corresponding pragma.
8157 if Present
(Expr
) then
8158 if Error_Posted
(Expr
) then
8161 elsif Is_True
(Expr_Value
(Expr
)) then
8162 Create_Pragma
:= True;
8165 -- Otherwise the aspect defaults to True
8168 Create_Pragma
:= True;
8171 -- Nothing to do when the expression is False or is erroneous
8173 if not Create_Pragma
then
8177 -- Obtain all interfacing aspects that apply to the related entity
8179 Get_Interfacing_Aspects
8183 Expo_Asp
=> Dummy_1
,
8189 -- Handle the convention argument
8191 if Present
(Conv
) then
8192 Conv_Arg
:= New_Copy_Tree
(Expression
(Conv
));
8194 -- Assume convention "Ada' when aspect Convention is missing
8197 Conv_Arg
:= Make_Identifier
(Loc
, Name_Ada
);
8201 Make_Pragma_Argument_Association
(Loc
,
8202 Chars
=> Name_Convention
,
8203 Expression
=> Conv_Arg
));
8205 -- Handle the entity argument
8208 Make_Pragma_Argument_Association
(Loc
,
8209 Chars
=> Name_Entity
,
8210 Expression
=> New_Occurrence_Of
(Id
, Loc
)));
8212 -- Handle the External_Name argument
8214 if Present
(EN
) then
8216 Make_Pragma_Argument_Association
(Loc
,
8217 Chars
=> Name_External_Name
,
8218 Expression
=> New_Copy_Tree
(Expression
(EN
))));
8221 -- Handle the Link_Name argument
8223 if Present
(LN
) then
8225 Make_Pragma_Argument_Association
(Loc
,
8226 Chars
=> Name_Link_Name
,
8227 Expression
=> New_Copy_Tree
(Expression
(LN
))));
8231 -- pragma Export/Import
8232 -- (Convention => <Conv>/Ada,
8234 -- [External_Name => <EN>,]
8235 -- [Link_Name => <LN>]);
8239 Pragma_Identifier
=>
8240 Make_Identifier
(Loc
, Chars
(Identifier
(Asp
))),
8241 Pragma_Argument_Associations
=> Args
);
8243 -- Decorate the relevant aspect and the pragma
8245 Set_Aspect_Rep_Item
(Asp
, Prag
);
8247 Set_Corresponding_Aspect
(Prag
, Asp
);
8248 Set_From_Aspect_Specification
(Prag
);
8249 Set_Parent
(Prag
, Asp
);
8251 if Asp_Id
= Aspect_Import
and then Is_Subprogram
(Id
) then
8252 Set_Import_Pragma
(Id
, Prag
);
8256 end Build_Export_Import_Pragma
;
8258 -------------------------------
8259 -- Build_Predicate_Functions --
8260 -------------------------------
8262 -- The procedures that are constructed here have the form:
8264 -- function typPredicate (Ixxx : typ) return Boolean is
8267 -- typ1Predicate (typ1 (Ixxx))
8268 -- and then typ2Predicate (typ2 (Ixxx))
8270 -- exp1 and then exp2 and then ...
8271 -- end typPredicate;
8273 -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that
8274 -- this is the point at which these expressions get analyzed, providing the
8275 -- required delay, and typ1, typ2, are entities from which predicates are
8276 -- inherited. Note that we do NOT generate Check pragmas, that's because we
8277 -- use this function even if checks are off, e.g. for membership tests.
8279 -- Note that the inherited predicates are evaluated first, as required by
8282 -- Note that Sem_Eval.Real_Or_String_Static_Predicate_Matches depends on
8283 -- the form of this return expression.
8285 -- If the expression has at least one Raise_Expression, then we also build
8286 -- the typPredicateM version of the function, in which any occurrence of a
8287 -- Raise_Expression is converted to "return False".
8289 -- WARNING: This routine manages Ghost regions. Return statements must be
8290 -- replaced by gotos which jump to the end of the routine and restore the
8293 procedure Build_Predicate_Functions
(Typ
: Entity_Id
; N
: Node_Id
) is
8294 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8297 -- This is the expression for the result of the function. It is
8298 -- is build by connecting the component predicates with AND THEN.
8301 -- This is the corresponding return expression for the Predicate_M
8302 -- function. It differs in that raise expressions are marked for
8303 -- special expansion (see Process_REs).
8305 Object_Name
: Name_Id
;
8306 -- Name for argument of Predicate procedure. Note that we use the same
8307 -- name for both predicate functions. That way the reference within the
8308 -- predicate expression is the same in both functions.
8310 Object_Entity
: Entity_Id
;
8311 -- Entity for argument of Predicate procedure
8313 Object_Entity_M
: Entity_Id
;
8314 -- Entity for argument of separate Predicate procedure when exceptions
8315 -- are present in expression.
8318 -- The function declaration
8323 Raise_Expression_Present
: Boolean := False;
8324 -- Set True if Expr has at least one Raise_Expression
8326 procedure Add_Condition
(Cond
: Node_Id
);
8327 -- Append Cond to Expr using "and then" (or just copy Cond to Expr if
8330 procedure Add_Predicates
;
8331 -- Appends expressions for any Predicate pragmas in the rep item chain
8332 -- Typ to Expr. Note that we look only at items for this exact entity.
8333 -- Inheritance of predicates for the parent type is done by calling the
8334 -- Predicate_Function of the parent type, using Add_Call above.
8336 procedure Add_Call
(T
: Entity_Id
);
8337 -- Includes a call to the predicate function for type T in Expr if T
8338 -- has predicates and Predicate_Function (T) is non-empty.
8340 function Process_RE
(N
: Node_Id
) return Traverse_Result
;
8341 -- Used in Process REs, tests if node N is a raise expression, and if
8342 -- so, marks it to be converted to return False.
8344 procedure Process_REs
is new Traverse_Proc
(Process_RE
);
8345 -- Marks any raise expressions in Expr_M to return False
8347 function Test_RE
(N
: Node_Id
) return Traverse_Result
;
8348 -- Used in Test_REs, tests one node for being a raise expression, and if
8349 -- so sets Raise_Expression_Present True.
8351 procedure Test_REs
is new Traverse_Proc
(Test_RE
);
8352 -- Tests to see if Expr contains any raise expressions
8358 procedure Add_Call
(T
: Entity_Id
) is
8362 if Present
(T
) and then Present
(Predicate_Function
(T
)) then
8363 Set_Has_Predicates
(Typ
);
8365 -- Build the call to the predicate function of T. The type may be
8366 -- derived, so use an unchecked conversion for the actual.
8372 Unchecked_Convert_To
(T
,
8373 Make_Identifier
(Loc
, Object_Name
)));
8375 -- "and"-in the call to evolving expression
8377 Add_Condition
(Exp
);
8379 -- Output info message on inheritance if required. Note we do not
8380 -- give this information for generic actual types, since it is
8381 -- unwelcome noise in that case in instantiations. We also
8382 -- generally suppress the message in instantiations, and also
8383 -- if it involves internal names.
8385 if Opt
.List_Inherited_Aspects
8386 and then not Is_Generic_Actual_Type
(Typ
)
8387 and then Instantiation_Depth
(Sloc
(Typ
)) = 0
8388 and then not Is_Internal_Name
(Chars
(T
))
8389 and then not Is_Internal_Name
(Chars
(Typ
))
8391 Error_Msg_Sloc
:= Sloc
(Predicate_Function
(T
));
8392 Error_Msg_Node_2
:= T
;
8393 Error_Msg_N
("info: & inherits predicate from & #?L?", Typ
);
8402 procedure Add_Condition
(Cond
: Node_Id
) is
8404 -- This is the first predicate expression
8409 -- Otherwise concatenate to the existing predicate expressions by
8410 -- using "and then".
8415 Left_Opnd
=> Relocate_Node
(Expr
),
8416 Right_Opnd
=> Cond
);
8420 --------------------
8421 -- Add_Predicates --
8422 --------------------
8424 procedure Add_Predicates
is
8425 procedure Add_Predicate
(Prag
: Node_Id
);
8426 -- Concatenate the expression of predicate pragma Prag to Expr by
8427 -- using a short circuit "and then" operator.
8433 procedure Add_Predicate
(Prag
: Node_Id
) is
8434 procedure Replace_Type_Reference
(N
: Node_Id
);
8435 -- Replace a single occurrence N of the subtype name with a
8436 -- reference to the formal of the predicate function. N can be an
8437 -- identifier referencing the subtype, or a selected component,
8438 -- representing an appropriately qualified occurrence of the
8441 procedure Replace_Type_References
is
8442 new Replace_Type_References_Generic
(Replace_Type_Reference
);
8443 -- Traverse an expression changing every occurrence of an
8444 -- identifier whose name matches the name of the subtype with a
8445 -- reference to the formal parameter of the predicate function.
8447 ----------------------------
8448 -- Replace_Type_Reference --
8449 ----------------------------
8451 procedure Replace_Type_Reference
(N
: Node_Id
) is
8453 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Object_Name
));
8454 -- Use the Sloc of the usage name, not the defining name
8457 Set_Entity
(N
, Object_Entity
);
8459 -- We want to treat the node as if it comes from source, so
8460 -- that ASIS will not ignore it.
8462 Set_Comes_From_Source
(N
, True);
8463 end Replace_Type_Reference
;
8467 Asp
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
8471 -- Start of processing for Add_Predicate
8474 -- Mark corresponding SCO as enabled
8476 Set_SCO_Pragma_Enabled
(Sloc
(Prag
));
8478 -- Extract the arguments of the pragma. The expression itself
8479 -- is copied for use in the predicate function, to preserve the
8480 -- original version for ASIS use.
8482 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
8483 Arg2
:= Next
(Arg1
);
8485 Arg1
:= Get_Pragma_Arg
(Arg1
);
8486 Arg2
:= New_Copy_Tree
(Get_Pragma_Arg
(Arg2
));
8488 -- When the predicate pragma applies to the current type or its
8489 -- full view, replace all occurrences of the subtype name with
8490 -- references to the formal parameter of the predicate function.
8492 if Entity
(Arg1
) = Typ
8493 or else Full_View
(Entity
(Arg1
)) = Typ
8495 Replace_Type_References
(Arg2
, Typ
);
8497 -- If the predicate pragma comes from an aspect, replace the
8498 -- saved expression because we need the subtype references
8499 -- replaced for the calls to Preanalyze_Spec_Expression in
8500 -- Check_Aspect_At_xxx routines.
8502 if Present
(Asp
) then
8503 Set_Entity
(Identifier
(Asp
), New_Copy_Tree
(Arg2
));
8506 -- "and"-in the Arg2 condition to evolving expression
8508 Add_Condition
(Relocate_Node
(Arg2
));
8516 -- Start of processing for Add_Predicates
8519 Ritem
:= First_Rep_Item
(Typ
);
8521 -- If the type is private, check whether full view has inherited
8524 if Is_Private_Type
(Typ
) and then No
(Ritem
) then
8525 Ritem
:= First_Rep_Item
(Full_View
(Typ
));
8528 while Present
(Ritem
) loop
8529 if Nkind
(Ritem
) = N_Pragma
8530 and then Pragma_Name
(Ritem
) = Name_Predicate
8532 Add_Predicate
(Ritem
);
8534 -- If the type is declared in an inner package it may be frozen
8535 -- outside of the package, and the generated pragma has not been
8536 -- analyzed yet, so capture the expression for the predicate
8537 -- function at this point.
8539 elsif Nkind
(Ritem
) = N_Aspect_Specification
8540 and then Present
(Aspect_Rep_Item
(Ritem
))
8541 and then Scope
(Typ
) /= Current_Scope
8544 Prag
: constant Node_Id
:= Aspect_Rep_Item
(Ritem
);
8547 if Nkind
(Prag
) = N_Pragma
8548 and then Pragma_Name
(Prag
) = Name_Predicate
8550 Add_Predicate
(Prag
);
8555 Next_Rep_Item
(Ritem
);
8563 function Process_RE
(N
: Node_Id
) return Traverse_Result
is
8565 if Nkind
(N
) = N_Raise_Expression
then
8566 Set_Convert_To_Return_False
(N
);
8577 function Test_RE
(N
: Node_Id
) return Traverse_Result
is
8579 if Nkind
(N
) = N_Raise_Expression
then
8580 Raise_Expression_Present
:= True;
8589 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
8590 -- Save the Ghost mode to restore on exit
8592 -- Start of processing for Build_Predicate_Functions
8595 -- Return if already built or if type does not have predicates
8597 SId
:= Predicate_Function
(Typ
);
8598 if not Has_Predicates
(Typ
)
8599 or else (Present
(SId
) and then Has_Completion
(SId
))
8604 -- The related type may be subject to pragma Ghost. Set the mode now to
8605 -- ensure that the predicate functions are properly marked as Ghost.
8607 Set_Ghost_Mode
(Typ
);
8609 -- Prepare to construct predicate expression
8613 if Present
(SId
) then
8614 FDecl
:= Unit_Declaration_Node
(SId
);
8617 FDecl
:= Build_Predicate_Function_Declaration
(Typ
);
8618 SId
:= Defining_Entity
(FDecl
);
8621 -- Recover name of formal parameter of function that replaces references
8622 -- to the type in predicate expressions.
8626 (First
(Parameter_Specifications
(Specification
(FDecl
))));
8628 Object_Name
:= Chars
(Object_Entity
);
8629 Object_Entity_M
:= Make_Defining_Identifier
(Loc
, Chars
=> Object_Name
);
8631 -- Add predicates for ancestor if present. These must come before the
8632 -- ones for the current type, as required by AI12-0071-1.
8637 Atyp
:= Nearest_Ancestor
(Typ
);
8639 -- The type may be private but the full view may inherit predicates
8641 if No
(Atyp
) and then Is_Private_Type
(Typ
) then
8642 Atyp
:= Nearest_Ancestor
(Full_View
(Typ
));
8645 if Present
(Atyp
) then
8650 -- Add Predicates for the current type
8654 -- Case where predicates are present
8656 if Present
(Expr
) then
8658 -- Test for raise expression present
8662 -- If raise expression is present, capture a copy of Expr for use
8663 -- in building the predicateM function version later on. For this
8664 -- copy we replace references to Object_Entity by Object_Entity_M.
8666 if Raise_Expression_Present
then
8668 Map
: constant Elist_Id
:= New_Elmt_List
;
8669 New_V
: Entity_Id
:= Empty
;
8671 -- The unanalyzed expression will be copied and appear in
8672 -- both functions. Normally expressions do not declare new
8673 -- entities, but quantified expressions do, so we need to
8674 -- create new entities for their bound variables, to prevent
8675 -- multiple definitions in gigi.
8677 function Reset_Loop_Variable
(N
: Node_Id
)
8678 return Traverse_Result
;
8680 procedure Collect_Loop_Variables
is
8681 new Traverse_Proc
(Reset_Loop_Variable
);
8683 ------------------------
8684 -- Reset_Loop_Variable --
8685 ------------------------
8687 function Reset_Loop_Variable
(N
: Node_Id
)
8688 return Traverse_Result
8691 if Nkind
(N
) = N_Iterator_Specification
then
8692 New_V
:= Make_Defining_Identifier
8693 (Sloc
(N
), Chars
(Defining_Identifier
(N
)));
8695 Set_Defining_Identifier
(N
, New_V
);
8699 end Reset_Loop_Variable
;
8702 Append_Elmt
(Object_Entity
, Map
);
8703 Append_Elmt
(Object_Entity_M
, Map
);
8704 Expr_M
:= New_Copy_Tree
(Expr
, Map
=> Map
);
8705 Collect_Loop_Variables
(Expr_M
);
8709 -- Build the main predicate function
8712 SIdB
: constant Entity_Id
:=
8713 Make_Defining_Identifier
(Loc
,
8714 Chars
=> New_External_Name
(Chars
(Typ
), "Predicate"));
8715 -- The entity for the function body
8721 Set_Ekind
(SIdB
, E_Function
);
8722 Set_Is_Predicate_Function
(SIdB
);
8724 -- The predicate function is shared between views of a type
8726 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
8727 Set_Predicate_Function
(Full_View
(Typ
), SId
);
8730 -- Build function body
8733 Make_Function_Specification
(Loc
,
8734 Defining_Unit_Name
=> SIdB
,
8735 Parameter_Specifications
=> New_List
(
8736 Make_Parameter_Specification
(Loc
,
8737 Defining_Identifier
=>
8738 Make_Defining_Identifier
(Loc
, Object_Name
),
8740 New_Occurrence_Of
(Typ
, Loc
))),
8741 Result_Definition
=>
8742 New_Occurrence_Of
(Standard_Boolean
, Loc
));
8745 Make_Subprogram_Body
(Loc
,
8746 Specification
=> Spec
,
8747 Declarations
=> Empty_List
,
8748 Handled_Statement_Sequence
=>
8749 Make_Handled_Sequence_Of_Statements
(Loc
,
8750 Statements
=> New_List
(
8751 Make_Simple_Return_Statement
(Loc
,
8752 Expression
=> Expr
))));
8754 -- If declaration has not been analyzed yet, Insert declaration
8755 -- before freeze node. Insert body itself after freeze node.
8757 if not Analyzed
(FDecl
) then
8758 Insert_Before_And_Analyze
(N
, FDecl
);
8761 Insert_After_And_Analyze
(N
, FBody
);
8763 -- Static predicate functions are always side-effect free, and
8764 -- in most cases dynamic predicate functions are as well. Mark
8765 -- them as such whenever possible, so redundant predicate checks
8766 -- can be optimized. If there is a variable reference within the
8767 -- expression, the function is not pure.
8769 if Expander_Active
then
8771 Side_Effect_Free
(Expr
, Variable_Ref
=> True));
8772 Set_Is_Inlined
(SId
);
8776 -- Test for raise expressions present and if so build M version
8778 if Raise_Expression_Present
then
8780 SId
: constant Entity_Id
:=
8781 Make_Defining_Identifier
(Loc
,
8782 Chars
=> New_External_Name
(Chars
(Typ
), "PredicateM"));
8783 -- The entity for the function spec
8785 SIdB
: constant Entity_Id
:=
8786 Make_Defining_Identifier
(Loc
,
8787 Chars
=> New_External_Name
(Chars
(Typ
), "PredicateM"));
8788 -- The entity for the function body
8796 -- Mark any raise expressions for special expansion
8798 Process_REs
(Expr_M
);
8800 -- Build function declaration
8802 Set_Ekind
(SId
, E_Function
);
8803 Set_Is_Predicate_Function_M
(SId
);
8804 Set_Predicate_Function_M
(Typ
, SId
);
8806 -- The predicate function is shared between views of a type
8808 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
8809 Set_Predicate_Function_M
(Full_View
(Typ
), SId
);
8813 Make_Function_Specification
(Loc
,
8814 Defining_Unit_Name
=> SId
,
8815 Parameter_Specifications
=> New_List
(
8816 Make_Parameter_Specification
(Loc
,
8817 Defining_Identifier
=> Object_Entity_M
,
8818 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
8819 Result_Definition
=>
8820 New_Occurrence_Of
(Standard_Boolean
, Loc
));
8823 Make_Subprogram_Declaration
(Loc
,
8824 Specification
=> Spec
);
8826 -- Build function body
8829 Make_Function_Specification
(Loc
,
8830 Defining_Unit_Name
=> SIdB
,
8831 Parameter_Specifications
=> New_List
(
8832 Make_Parameter_Specification
(Loc
,
8833 Defining_Identifier
=>
8834 Make_Defining_Identifier
(Loc
, Object_Name
),
8836 New_Occurrence_Of
(Typ
, Loc
))),
8837 Result_Definition
=>
8838 New_Occurrence_Of
(Standard_Boolean
, Loc
));
8840 -- Build the body, we declare the boolean expression before
8841 -- doing the return, because we are not really confident of
8842 -- what happens if a return appears within a return.
8845 Make_Defining_Identifier
(Loc
,
8846 Chars
=> New_Internal_Name
('B'));
8849 Make_Subprogram_Body
(Loc
,
8850 Specification
=> Spec
,
8852 Declarations
=> New_List
(
8853 Make_Object_Declaration
(Loc
,
8854 Defining_Identifier
=> BTemp
,
8855 Constant_Present
=> True,
8856 Object_Definition
=>
8857 New_Occurrence_Of
(Standard_Boolean
, Loc
),
8858 Expression
=> Expr_M
)),
8860 Handled_Statement_Sequence
=>
8861 Make_Handled_Sequence_Of_Statements
(Loc
,
8862 Statements
=> New_List
(
8863 Make_Simple_Return_Statement
(Loc
,
8864 Expression
=> New_Occurrence_Of
(BTemp
, Loc
)))));
8866 -- Insert declaration before freeze node and body after
8868 Insert_Before_And_Analyze
(N
, FDecl
);
8869 Insert_After_And_Analyze
(N
, FBody
);
8873 -- See if we have a static predicate. Note that the answer may be
8874 -- yes even if we have an explicit Dynamic_Predicate present.
8881 if not Is_Scalar_Type
(Typ
) and then not Is_String_Type
(Typ
) then
8884 PS
:= Is_Predicate_Static
(Expr
, Object_Name
);
8887 -- Case where we have a predicate-static aspect
8891 -- We don't set Has_Static_Predicate_Aspect, since we can have
8892 -- any of the three cases (Predicate, Dynamic_Predicate, or
8893 -- Static_Predicate) generating a predicate with an expression
8894 -- that is predicate-static. We just indicate that we have a
8895 -- predicate that can be treated as static.
8897 Set_Has_Static_Predicate
(Typ
);
8899 -- For discrete subtype, build the static predicate list
8901 if Is_Discrete_Type
(Typ
) then
8902 Build_Discrete_Static_Predicate
(Typ
, Expr
, Object_Name
);
8904 -- If we don't get a static predicate list, it means that we
8905 -- have a case where this is not possible, most typically in
8906 -- the case where we inherit a dynamic predicate. We do not
8907 -- consider this an error, we just leave the predicate as
8908 -- dynamic. But if we do succeed in building the list, then
8909 -- we mark the predicate as static.
8911 if No
(Static_Discrete_Predicate
(Typ
)) then
8912 Set_Has_Static_Predicate
(Typ
, False);
8915 -- For real or string subtype, save predicate expression
8917 elsif Is_Real_Type
(Typ
) or else Is_String_Type
(Typ
) then
8918 Set_Static_Real_Or_String_Predicate
(Typ
, Expr
);
8921 -- Case of dynamic predicate (expression is not predicate-static)
8924 -- Again, we don't set Has_Dynamic_Predicate_Aspect, since that
8925 -- is only set if we have an explicit Dynamic_Predicate aspect
8926 -- given. Here we may simply have a Predicate aspect where the
8927 -- expression happens not to be predicate-static.
8929 -- Emit an error when the predicate is categorized as static
8930 -- but its expression is not predicate-static.
8932 -- First a little fiddling to get a nice location for the
8933 -- message. If the expression is of the form (A and then B),
8934 -- where A is an inherited predicate, then use the right
8935 -- operand for the Sloc. This avoids getting confused by a call
8936 -- to an inherited predicate with a less convenient source
8940 while Nkind
(EN
) = N_And_Then
8941 and then Nkind
(Left_Opnd
(EN
)) = N_Function_Call
8942 and then Is_Predicate_Function
8943 (Entity
(Name
(Left_Opnd
(EN
))))
8945 EN
:= Right_Opnd
(EN
);
8948 -- Now post appropriate message
8950 if Has_Static_Predicate_Aspect
(Typ
) then
8951 if Is_Scalar_Type
(Typ
) or else Is_String_Type
(Typ
) then
8953 ("expression is not predicate-static (RM 3.2.4(16-22))",
8957 ("static predicate requires scalar or string type", EN
);
8964 Restore_Ghost_Mode
(Saved_GM
);
8965 end Build_Predicate_Functions
;
8967 ------------------------------------------
8968 -- Build_Predicate_Function_Declaration --
8969 ------------------------------------------
8971 -- WARNING: This routine manages Ghost regions. Return statements must be
8972 -- replaced by gotos which jump to the end of the routine and restore the
8975 function Build_Predicate_Function_Declaration
8976 (Typ
: Entity_Id
) return Node_Id
8978 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8980 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
8981 -- Save the Ghost mode to restore on exit
8983 Func_Decl
: Node_Id
;
8984 Func_Id
: Entity_Id
;
8988 -- The related type may be subject to pragma Ghost. Set the mode now to
8989 -- ensure that the predicate functions are properly marked as Ghost.
8991 Set_Ghost_Mode
(Typ
);
8994 Make_Defining_Identifier
(Loc
,
8995 Chars
=> New_External_Name
(Chars
(Typ
), "Predicate"));
8997 -- The predicate function requires debug info when the predicates are
8998 -- subject to Source Coverage Obligations.
9000 if Opt
.Generate_SCO
then
9001 Set_Debug_Info_Needed
(Func_Id
);
9005 Make_Function_Specification
(Loc
,
9006 Defining_Unit_Name
=> Func_Id
,
9007 Parameter_Specifications
=> New_List
(
9008 Make_Parameter_Specification
(Loc
,
9009 Defining_Identifier
=> Make_Temporary
(Loc
, 'I'),
9010 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
9011 Result_Definition
=>
9012 New_Occurrence_Of
(Standard_Boolean
, Loc
));
9014 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Specification
=> Spec
);
9016 Set_Ekind
(Func_Id
, E_Function
);
9017 Set_Etype
(Func_Id
, Standard_Boolean
);
9018 Set_Is_Internal
(Func_Id
);
9019 Set_Is_Predicate_Function
(Func_Id
);
9020 Set_Predicate_Function
(Typ
, Func_Id
);
9022 Insert_After
(Parent
(Typ
), Func_Decl
);
9023 Analyze
(Func_Decl
);
9025 Restore_Ghost_Mode
(Saved_GM
);
9028 end Build_Predicate_Function_Declaration
;
9030 -----------------------------------------
9031 -- Check_Aspect_At_End_Of_Declarations --
9032 -----------------------------------------
9034 procedure Check_Aspect_At_End_Of_Declarations
(ASN
: Node_Id
) is
9035 Ent
: constant Entity_Id
:= Entity
(ASN
);
9036 Ident
: constant Node_Id
:= Identifier
(ASN
);
9037 A_Id
: constant Aspect_Id
:= Get_Aspect_Id
(Chars
(Ident
));
9039 End_Decl_Expr
: constant Node_Id
:= Entity
(Ident
);
9040 -- Expression to be analyzed at end of declarations
9042 Freeze_Expr
: constant Node_Id
:= Expression
(ASN
);
9043 -- Expression from call to Check_Aspect_At_Freeze_Point.
9045 T
: constant Entity_Id
:= Etype
(Original_Node
(Freeze_Expr
));
9046 -- Type required for preanalyze call. We use the original expression to
9047 -- get the proper type, to prevent cascaded errors when the expression
9048 -- is constant-folded.
9051 -- Set False if error
9053 -- On entry to this procedure, Entity (Ident) contains a copy of the
9054 -- original expression from the aspect, saved for this purpose, and
9055 -- but Expression (Ident) is a preanalyzed copy of the expression,
9056 -- preanalyzed just after the freeze point.
9058 procedure Check_Overloaded_Name
;
9059 -- For aspects whose expression is simply a name, this routine checks if
9060 -- the name is overloaded or not. If so, it verifies there is an
9061 -- interpretation that matches the entity obtained at the freeze point,
9062 -- otherwise the compiler complains.
9064 ---------------------------
9065 -- Check_Overloaded_Name --
9066 ---------------------------
9068 procedure Check_Overloaded_Name
is
9070 if not Is_Overloaded
(End_Decl_Expr
) then
9071 Err
:= not Is_Entity_Name
(End_Decl_Expr
)
9072 or else Entity
(End_Decl_Expr
) /= Entity
(Freeze_Expr
);
9078 Index
: Interp_Index
;
9082 Get_First_Interp
(End_Decl_Expr
, Index
, It
);
9083 while Present
(It
.Typ
) loop
9084 if It
.Nam
= Entity
(Freeze_Expr
) then
9089 Get_Next_Interp
(Index
, It
);
9093 end Check_Overloaded_Name
;
9095 -- Start of processing for Check_Aspect_At_End_Of_Declarations
9098 -- In an instance we do not perform the consistency check between freeze
9099 -- point and end of declarations, because it was done already in the
9100 -- analysis of the generic. Furthermore, the delayed analysis of an
9101 -- aspect of the instance may produce spurious errors when the generic
9102 -- is a child unit that references entities in the parent (which might
9103 -- not be in scope at the freeze point of the instance).
9108 -- The enclosing scope may have been rewritten during expansion (.e.g. a
9109 -- task body is rewritten as a procedure) after this conformance check
9110 -- has been performed, so do not perform it again (it may not easily be
9111 -- done if full visibility of local entities is not available).
9113 elsif not Comes_From_Source
(Current_Scope
) then
9116 -- Case of aspects Dimension, Dimension_System and Synchronization
9118 elsif A_Id
= Aspect_Synchronization
then
9121 -- Case of stream attributes, just have to compare entities. However,
9122 -- the expression is just a name (possibly overloaded), and there may
9123 -- be stream operations declared for unrelated types, so we just need
9124 -- to verify that one of these interpretations is the one available at
9125 -- at the freeze point.
9127 elsif A_Id
= Aspect_Input
or else
9128 A_Id
= Aspect_Output
or else
9129 A_Id
= Aspect_Read
or else
9132 Analyze
(End_Decl_Expr
);
9133 Check_Overloaded_Name
;
9135 elsif A_Id
= Aspect_Variable_Indexing
or else
9136 A_Id
= Aspect_Constant_Indexing
or else
9137 A_Id
= Aspect_Default_Iterator
or else
9138 A_Id
= Aspect_Iterator_Element
9140 -- Make type unfrozen before analysis, to prevent spurious errors
9141 -- about late attributes.
9143 Set_Is_Frozen
(Ent
, False);
9144 Analyze
(End_Decl_Expr
);
9145 Set_Is_Frozen
(Ent
, True);
9147 -- If the end of declarations comes before any other freeze
9148 -- point, the Freeze_Expr is not analyzed: no check needed.
9150 if Analyzed
(Freeze_Expr
) and then not In_Instance
then
9151 Check_Overloaded_Name
;
9159 -- Indicate that the expression comes from an aspect specification,
9160 -- which is used in subsequent analysis even if expansion is off.
9162 Set_Parent
(End_Decl_Expr
, ASN
);
9164 -- In a generic context the aspect expressions have not been
9165 -- preanalyzed, so do it now. There are no conformance checks
9166 -- to perform in this case.
9169 Check_Aspect_At_Freeze_Point
(ASN
);
9172 -- The default values attributes may be defined in the private part,
9173 -- and the analysis of the expression may take place when only the
9174 -- partial view is visible. The expression must be scalar, so use
9175 -- the full view to resolve.
9177 elsif (A_Id
= Aspect_Default_Value
9179 A_Id
= Aspect_Default_Component_Value
)
9180 and then Is_Private_Type
(T
)
9182 Preanalyze_Spec_Expression
(End_Decl_Expr
, Full_View
(T
));
9185 Preanalyze_Spec_Expression
(End_Decl_Expr
, T
);
9188 Err
:= not Fully_Conformant_Expressions
(End_Decl_Expr
, Freeze_Expr
);
9191 -- Output error message if error. Force error on aspect specification
9192 -- even if there is an error on the expression itself.
9196 ("!visibility of aspect for& changes after freeze point",
9199 ("info: & is frozen here, aspects evaluated at this point??",
9200 Freeze_Node
(Ent
), Ent
);
9202 end Check_Aspect_At_End_Of_Declarations
;
9204 ----------------------------------
9205 -- Check_Aspect_At_Freeze_Point --
9206 ----------------------------------
9208 procedure Check_Aspect_At_Freeze_Point
(ASN
: Node_Id
) is
9209 Ident
: constant Node_Id
:= Identifier
(ASN
);
9210 -- Identifier (use Entity field to save expression)
9212 A_Id
: constant Aspect_Id
:= Get_Aspect_Id
(Chars
(Ident
));
9214 T
: Entity_Id
:= Empty
;
9215 -- Type required for preanalyze call
9218 -- On entry to this procedure, Entity (Ident) contains a copy of the
9219 -- original expression from the aspect, saved for this purpose.
9221 -- On exit from this procedure Entity (Ident) is unchanged, still
9222 -- containing that copy, but Expression (Ident) is a preanalyzed copy
9223 -- of the expression, preanalyzed just after the freeze point.
9225 -- Make a copy of the expression to be preanalyzed
9227 Set_Expression
(ASN
, New_Copy_Tree
(Entity
(Ident
)));
9229 -- Find type for preanalyze call
9233 -- No_Aspect should be impossible
9236 raise Program_Error
;
9238 -- Aspects taking an optional boolean argument
9240 when Boolean_Aspects
9241 | Library_Unit_Aspects
9243 T
:= Standard_Boolean
;
9245 -- Aspects corresponding to attribute definition clauses
9247 when Aspect_Address
=>
9248 T
:= RTE
(RE_Address
);
9250 when Aspect_Attach_Handler
=>
9251 T
:= RTE
(RE_Interrupt_ID
);
9253 when Aspect_Bit_Order
9254 | Aspect_Scalar_Storage_Order
9256 T
:= RTE
(RE_Bit_Order
);
9258 when Aspect_Convention
=>
9262 T
:= RTE
(RE_CPU_Range
);
9264 -- Default_Component_Value is resolved with the component type
9266 when Aspect_Default_Component_Value
=>
9267 T
:= Component_Type
(Entity
(ASN
));
9269 when Aspect_Default_Storage_Pool
=>
9270 T
:= Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
));
9272 -- Default_Value is resolved with the type entity in question
9274 when Aspect_Default_Value
=>
9277 when Aspect_Dispatching_Domain
=>
9278 T
:= RTE
(RE_Dispatching_Domain
);
9280 when Aspect_External_Tag
=>
9281 T
:= Standard_String
;
9283 when Aspect_External_Name
=>
9284 T
:= Standard_String
;
9286 when Aspect_Link_Name
=>
9287 T
:= Standard_String
;
9289 when Aspect_Interrupt_Priority
9292 T
:= Standard_Integer
;
9294 when Aspect_Relative_Deadline
=>
9295 T
:= RTE
(RE_Time_Span
);
9297 when Aspect_Secondary_Stack_Size
=>
9298 T
:= Standard_Integer
;
9300 when Aspect_Small
=>
9302 -- Note that the expression can be of any real type (not just a
9303 -- real universal literal) as long as it is a static constant.
9307 -- For a simple storage pool, we have to retrieve the type of the
9308 -- pool object associated with the aspect's corresponding attribute
9309 -- definition clause.
9311 when Aspect_Simple_Storage_Pool
=>
9312 T
:= Etype
(Expression
(Aspect_Rep_Item
(ASN
)));
9314 when Aspect_Storage_Pool
=>
9315 T
:= Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
));
9317 when Aspect_Alignment
9318 | Aspect_Component_Size
9319 | Aspect_Machine_Radix
9320 | Aspect_Object_Size
9322 | Aspect_Storage_Size
9323 | Aspect_Stream_Size
9328 when Aspect_Linker_Section
=>
9329 T
:= Standard_String
;
9331 when Aspect_Synchronization
=>
9334 -- Special case, the expression of these aspects is just an entity
9335 -- that does not need any resolution, so just analyze.
9345 Analyze
(Expression
(ASN
));
9348 -- Same for Iterator aspects, where the expression is a function
9349 -- name. Legality rules are checked separately.
9351 when Aspect_Constant_Indexing
9352 | Aspect_Default_Iterator
9353 | Aspect_Iterator_Element
9354 | Aspect_Variable_Indexing
9356 Analyze
(Expression
(ASN
));
9359 -- Ditto for Iterable, legality checks in Validate_Iterable_Aspect.
9361 when Aspect_Iterable
=>
9365 Cursor
: constant Entity_Id
:= Get_Cursor_Type
(ASN
, T
);
9370 if Cursor
= Any_Type
then
9374 Assoc
:= First
(Component_Associations
(Expression
(ASN
)));
9375 while Present
(Assoc
) loop
9376 Expr
:= Expression
(Assoc
);
9379 if not Error_Posted
(Expr
) then
9380 Resolve_Iterable_Operation
9381 (Expr
, Cursor
, T
, Chars
(First
(Choices
(Assoc
))));
9390 -- Invariant/Predicate take boolean expressions
9392 when Aspect_Dynamic_Predicate
9395 | Aspect_Static_Predicate
9396 | Aspect_Type_Invariant
9398 T
:= Standard_Boolean
;
9400 when Aspect_Predicate_Failure
=>
9401 T
:= Standard_String
;
9403 -- Here is the list of aspects that don't require delay analysis
9405 when Aspect_Abstract_State
9407 | Aspect_Async_Readers
9408 | Aspect_Async_Writers
9409 | Aspect_Constant_After_Elaboration
9410 | Aspect_Contract_Cases
9411 | Aspect_Default_Initial_Condition
9414 | Aspect_Dimension_System
9415 | Aspect_Effective_Reads
9416 | Aspect_Effective_Writes
9417 | Aspect_Extensions_Visible
9420 | Aspect_Implicit_Dereference
9421 | Aspect_Initial_Condition
9422 | Aspect_Initializes
9423 | Aspect_Max_Queue_Length
9424 | Aspect_Obsolescent
9427 | Aspect_Postcondition
9429 | Aspect_Precondition
9430 | Aspect_Refined_Depends
9431 | Aspect_Refined_Global
9432 | Aspect_Refined_Post
9433 | Aspect_Refined_State
9436 | Aspect_Unimplemented
9437 | Aspect_Volatile_Function
9439 raise Program_Error
;
9443 -- Do the preanalyze call
9445 Preanalyze_Spec_Expression
(Expression
(ASN
), T
);
9446 end Check_Aspect_At_Freeze_Point
;
9448 -----------------------------------
9449 -- Check_Constant_Address_Clause --
9450 -----------------------------------
9452 procedure Check_Constant_Address_Clause
9456 procedure Check_At_Constant_Address
(Nod
: Node_Id
);
9457 -- Checks that the given node N represents a name whose 'Address is
9458 -- constant (in the same sense as OK_Constant_Address_Clause, i.e. the
9459 -- address value is the same at the point of declaration of U_Ent and at
9460 -- the time of elaboration of the address clause.
9462 procedure Check_Expr_Constants
(Nod
: Node_Id
);
9463 -- Checks that Nod meets the requirements for a constant address clause
9464 -- in the sense of the enclosing procedure.
9466 procedure Check_List_Constants
(Lst
: List_Id
);
9467 -- Check that all elements of list Lst meet the requirements for a
9468 -- constant address clause in the sense of the enclosing procedure.
9470 -------------------------------
9471 -- Check_At_Constant_Address --
9472 -------------------------------
9474 procedure Check_At_Constant_Address
(Nod
: Node_Id
) is
9476 if Is_Entity_Name
(Nod
) then
9477 if Present
(Address_Clause
(Entity
((Nod
)))) then
9479 ("invalid address clause for initialized object &!",
9482 ("address for& cannot depend on another address clause! "
9483 & "(RM 13.1(22))!", Nod
, U_Ent
);
9485 elsif In_Same_Source_Unit
(Entity
(Nod
), U_Ent
)
9486 and then Sloc
(U_Ent
) < Sloc
(Entity
(Nod
))
9489 ("invalid address clause for initialized object &!",
9491 Error_Msg_Node_2
:= U_Ent
;
9493 ("\& must be defined before & (RM 13.1(22))!",
9497 elsif Nkind
(Nod
) = N_Selected_Component
then
9499 T
: constant Entity_Id
:= Etype
(Prefix
(Nod
));
9502 if (Is_Record_Type
(T
)
9503 and then Has_Discriminants
(T
))
9506 and then Is_Record_Type
(Designated_Type
(T
))
9507 and then Has_Discriminants
(Designated_Type
(T
)))
9510 ("invalid address clause for initialized object &!",
9513 ("\address cannot depend on component of discriminated "
9514 & "record (RM 13.1(22))!", Nod
);
9516 Check_At_Constant_Address
(Prefix
(Nod
));
9520 elsif Nkind
(Nod
) = N_Indexed_Component
then
9521 Check_At_Constant_Address
(Prefix
(Nod
));
9522 Check_List_Constants
(Expressions
(Nod
));
9525 Check_Expr_Constants
(Nod
);
9527 end Check_At_Constant_Address
;
9529 --------------------------
9530 -- Check_Expr_Constants --
9531 --------------------------
9533 procedure Check_Expr_Constants
(Nod
: Node_Id
) is
9534 Loc_U_Ent
: constant Source_Ptr
:= Sloc
(U_Ent
);
9535 Ent
: Entity_Id
:= Empty
;
9538 if Nkind
(Nod
) in N_Has_Etype
9539 and then Etype
(Nod
) = Any_Type
9550 when N_Expanded_Name
9553 Ent
:= Entity
(Nod
);
9555 -- We need to look at the original node if it is different
9556 -- from the node, since we may have rewritten things and
9557 -- substituted an identifier representing the rewrite.
9559 if Original_Node
(Nod
) /= Nod
then
9560 Check_Expr_Constants
(Original_Node
(Nod
));
9562 -- If the node is an object declaration without initial
9563 -- value, some code has been expanded, and the expression
9564 -- is not constant, even if the constituents might be
9565 -- acceptable, as in A'Address + offset.
9567 if Ekind
(Ent
) = E_Variable
9569 Nkind
(Declaration_Node
(Ent
)) = N_Object_Declaration
9571 No
(Expression
(Declaration_Node
(Ent
)))
9574 ("invalid address clause for initialized object &!",
9577 -- If entity is constant, it may be the result of expanding
9578 -- a check. We must verify that its declaration appears
9579 -- before the object in question, else we also reject the
9582 elsif Ekind
(Ent
) = E_Constant
9583 and then In_Same_Source_Unit
(Ent
, U_Ent
)
9584 and then Sloc
(Ent
) > Loc_U_Ent
9587 ("invalid address clause for initialized object &!",
9594 -- Otherwise look at the identifier and see if it is OK
9596 if Ekind_In
(Ent
, E_Named_Integer
, E_Named_Real
)
9597 or else Is_Type
(Ent
)
9601 elsif Ekind_In
(Ent
, E_Constant
, E_In_Parameter
) then
9603 -- This is the case where we must have Ent defined before
9604 -- U_Ent. Clearly if they are in different units this
9605 -- requirement is met since the unit containing Ent is
9606 -- already processed.
9608 if not In_Same_Source_Unit
(Ent
, U_Ent
) then
9611 -- Otherwise location of Ent must be before the location
9612 -- of U_Ent, that's what prior defined means.
9614 elsif Sloc
(Ent
) < Loc_U_Ent
then
9619 ("invalid address clause for initialized object &!",
9621 Error_Msg_Node_2
:= U_Ent
;
9623 ("\& must be defined before & (RM 13.1(22))!",
9627 elsif Nkind
(Original_Node
(Nod
)) = N_Function_Call
then
9628 Check_Expr_Constants
(Original_Node
(Nod
));
9632 ("invalid address clause for initialized object &!",
9635 if Comes_From_Source
(Ent
) then
9637 ("\reference to variable& not allowed"
9638 & " (RM 13.1(22))!", Nod
, Ent
);
9641 ("non-static expression not allowed"
9642 & " (RM 13.1(22))!", Nod
);
9646 when N_Integer_Literal
=>
9648 -- If this is a rewritten unchecked conversion, in a system
9649 -- where Address is an integer type, always use the base type
9650 -- for a literal value. This is user-friendly and prevents
9651 -- order-of-elaboration issues with instances of unchecked
9654 if Nkind
(Original_Node
(Nod
)) = N_Function_Call
then
9655 Set_Etype
(Nod
, Base_Type
(Etype
(Nod
)));
9658 when N_Character_Literal
9665 Check_Expr_Constants
(Low_Bound
(Nod
));
9666 Check_Expr_Constants
(High_Bound
(Nod
));
9668 when N_Explicit_Dereference
=>
9669 Check_Expr_Constants
(Prefix
(Nod
));
9671 when N_Indexed_Component
=>
9672 Check_Expr_Constants
(Prefix
(Nod
));
9673 Check_List_Constants
(Expressions
(Nod
));
9676 Check_Expr_Constants
(Prefix
(Nod
));
9677 Check_Expr_Constants
(Discrete_Range
(Nod
));
9679 when N_Selected_Component
=>
9680 Check_Expr_Constants
(Prefix
(Nod
));
9682 when N_Attribute_Reference
=>
9683 if Nam_In
(Attribute_Name
(Nod
), Name_Address
,
9685 Name_Unchecked_Access
,
9686 Name_Unrestricted_Access
)
9688 Check_At_Constant_Address
(Prefix
(Nod
));
9691 Check_Expr_Constants
(Prefix
(Nod
));
9692 Check_List_Constants
(Expressions
(Nod
));
9696 Check_List_Constants
(Component_Associations
(Nod
));
9697 Check_List_Constants
(Expressions
(Nod
));
9699 when N_Component_Association
=>
9700 Check_Expr_Constants
(Expression
(Nod
));
9702 when N_Extension_Aggregate
=>
9703 Check_Expr_Constants
(Ancestor_Part
(Nod
));
9704 Check_List_Constants
(Component_Associations
(Nod
));
9705 Check_List_Constants
(Expressions
(Nod
));
9714 Check_Expr_Constants
(Left_Opnd
(Nod
));
9715 Check_Expr_Constants
(Right_Opnd
(Nod
));
9718 Check_Expr_Constants
(Right_Opnd
(Nod
));
9721 | N_Qualified_Expression
9723 | N_Unchecked_Type_Conversion
9725 Check_Expr_Constants
(Expression
(Nod
));
9727 when N_Function_Call
=>
9728 if not Is_Pure
(Entity
(Name
(Nod
))) then
9730 ("invalid address clause for initialized object &!",
9734 ("\function & is not pure (RM 13.1(22))!",
9735 Nod
, Entity
(Name
(Nod
)));
9738 Check_List_Constants
(Parameter_Associations
(Nod
));
9741 when N_Parameter_Association
=>
9742 Check_Expr_Constants
(Explicit_Actual_Parameter
(Nod
));
9746 ("invalid address clause for initialized object &!",
9749 ("\must be constant defined before& (RM 13.1(22))!",
9752 end Check_Expr_Constants
;
9754 --------------------------
9755 -- Check_List_Constants --
9756 --------------------------
9758 procedure Check_List_Constants
(Lst
: List_Id
) is
9762 if Present
(Lst
) then
9763 Nod1
:= First
(Lst
);
9764 while Present
(Nod1
) loop
9765 Check_Expr_Constants
(Nod1
);
9769 end Check_List_Constants
;
9771 -- Start of processing for Check_Constant_Address_Clause
9774 -- If rep_clauses are to be ignored, no need for legality checks. In
9775 -- particular, no need to pester user about rep clauses that violate the
9776 -- rule on constant addresses, given that these clauses will be removed
9777 -- by Freeze before they reach the back end. Similarly in CodePeer mode,
9778 -- we want to relax these checks.
9780 if not Ignore_Rep_Clauses
and not CodePeer_Mode
then
9781 Check_Expr_Constants
(Expr
);
9783 end Check_Constant_Address_Clause
;
9785 ---------------------------
9786 -- Check_Pool_Size_Clash --
9787 ---------------------------
9789 procedure Check_Pool_Size_Clash
(Ent
: Entity_Id
; SP
, SS
: Node_Id
) is
9793 -- We need to find out which one came first. Note that in the case of
9794 -- aspects mixed with pragmas there are cases where the processing order
9795 -- is reversed, which is why we do the check here.
9797 if Sloc
(SP
) < Sloc
(SS
) then
9798 Error_Msg_Sloc
:= Sloc
(SP
);
9800 Error_Msg_NE
("Storage_Pool previously given for&#", Post
, Ent
);
9803 Error_Msg_Sloc
:= Sloc
(SS
);
9805 Error_Msg_NE
("Storage_Size previously given for&#", Post
, Ent
);
9809 ("\cannot have Storage_Size and Storage_Pool (RM 13.11(3))", Post
);
9810 end Check_Pool_Size_Clash
;
9812 ----------------------------------------
9813 -- Check_Record_Representation_Clause --
9814 ----------------------------------------
9816 procedure Check_Record_Representation_Clause
(N
: Node_Id
) is
9817 Loc
: constant Source_Ptr
:= Sloc
(N
);
9818 Ident
: constant Node_Id
:= Identifier
(N
);
9819 Rectype
: Entity_Id
;
9824 Hbit
: Uint
:= Uint_0
;
9828 Max_Bit_So_Far
: Uint
;
9829 -- Records the maximum bit position so far. If all field positions
9830 -- are monotonically increasing, then we can skip the circuit for
9831 -- checking for overlap, since no overlap is possible.
9833 Tagged_Parent
: Entity_Id
:= Empty
;
9834 -- This is set in the case of an extension for which we have either a
9835 -- size clause or Is_Fully_Repped_Tagged_Type True (indicating that all
9836 -- components are positioned by record representation clauses) on the
9837 -- parent type. In this case we check for overlap between components of
9838 -- this tagged type and the parent component. Tagged_Parent will point
9839 -- to this parent type. For all other cases, Tagged_Parent is Empty.
9841 Parent_Last_Bit
: Uint
;
9842 -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the
9843 -- last bit position for any field in the parent type. We only need to
9844 -- check overlap for fields starting below this point.
9846 Overlap_Check_Required
: Boolean;
9847 -- Used to keep track of whether or not an overlap check is required
9849 Overlap_Detected
: Boolean := False;
9850 -- Set True if an overlap is detected
9852 Ccount
: Natural := 0;
9853 -- Number of component clauses in record rep clause
9855 procedure Check_Component_Overlap
(C1_Ent
, C2_Ent
: Entity_Id
);
9856 -- Given two entities for record components or discriminants, checks
9857 -- if they have overlapping component clauses and issues errors if so.
9859 procedure Find_Component
;
9860 -- Finds component entity corresponding to current component clause (in
9861 -- CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin
9862 -- start/stop bits for the field. If there is no matching component or
9863 -- if the matching component does not have a component clause, then
9864 -- that's an error and Comp is set to Empty, but no error message is
9865 -- issued, since the message was already given. Comp is also set to
9866 -- Empty if the current "component clause" is in fact a pragma.
9868 -----------------------------
9869 -- Check_Component_Overlap --
9870 -----------------------------
9872 procedure Check_Component_Overlap
(C1_Ent
, C2_Ent
: Entity_Id
) is
9873 CC1
: constant Node_Id
:= Component_Clause
(C1_Ent
);
9874 CC2
: constant Node_Id
:= Component_Clause
(C2_Ent
);
9877 if Present
(CC1
) and then Present
(CC2
) then
9879 -- Exclude odd case where we have two tag components in the same
9880 -- record, both at location zero. This seems a bit strange, but
9881 -- it seems to happen in some circumstances, perhaps on an error.
9883 if Nam_In
(Chars
(C1_Ent
), Name_uTag
, Name_uTag
) then
9887 -- Here we check if the two fields overlap
9890 S1
: constant Uint
:= Component_Bit_Offset
(C1_Ent
);
9891 S2
: constant Uint
:= Component_Bit_Offset
(C2_Ent
);
9892 E1
: constant Uint
:= S1
+ Esize
(C1_Ent
);
9893 E2
: constant Uint
:= S2
+ Esize
(C2_Ent
);
9896 if E2
<= S1
or else E1
<= S2
then
9899 Error_Msg_Node_2
:= Component_Name
(CC2
);
9900 Error_Msg_Sloc
:= Sloc
(Error_Msg_Node_2
);
9901 Error_Msg_Node_1
:= Component_Name
(CC1
);
9903 ("component& overlaps & #", Component_Name
(CC1
));
9904 Overlap_Detected
:= True;
9908 end Check_Component_Overlap
;
9910 --------------------
9911 -- Find_Component --
9912 --------------------
9914 procedure Find_Component
is
9916 procedure Search_Component
(R
: Entity_Id
);
9917 -- Search components of R for a match. If found, Comp is set
9919 ----------------------
9920 -- Search_Component --
9921 ----------------------
9923 procedure Search_Component
(R
: Entity_Id
) is
9925 Comp
:= First_Component_Or_Discriminant
(R
);
9926 while Present
(Comp
) loop
9928 -- Ignore error of attribute name for component name (we
9929 -- already gave an error message for this, so no need to
9932 if Nkind
(Component_Name
(CC
)) = N_Attribute_Reference
then
9935 exit when Chars
(Comp
) = Chars
(Component_Name
(CC
));
9938 Next_Component_Or_Discriminant
(Comp
);
9940 end Search_Component
;
9942 -- Start of processing for Find_Component
9945 -- Return with Comp set to Empty if we have a pragma
9947 if Nkind
(CC
) = N_Pragma
then
9952 -- Search current record for matching component
9954 Search_Component
(Rectype
);
9956 -- If not found, maybe component of base type discriminant that is
9957 -- absent from statically constrained first subtype.
9960 Search_Component
(Base_Type
(Rectype
));
9963 -- If no component, or the component does not reference the component
9964 -- clause in question, then there was some previous error for which
9965 -- we already gave a message, so just return with Comp Empty.
9967 if No
(Comp
) or else Component_Clause
(Comp
) /= CC
then
9968 Check_Error_Detected
;
9971 -- Normal case where we have a component clause
9974 Fbit
:= Component_Bit_Offset
(Comp
);
9975 Lbit
:= Fbit
+ Esize
(Comp
) - 1;
9979 -- Start of processing for Check_Record_Representation_Clause
9983 Rectype
:= Entity
(Ident
);
9985 if Rectype
= Any_Type
then
9989 Rectype
:= Underlying_Type
(Rectype
);
9991 -- See if we have a fully repped derived tagged type
9994 PS
: constant Entity_Id
:= Parent_Subtype
(Rectype
);
9997 if Present
(PS
) and then Known_Static_RM_Size
(PS
) then
9998 Tagged_Parent
:= PS
;
9999 Parent_Last_Bit
:= RM_Size
(PS
) - 1;
10001 elsif Present
(PS
) and then Is_Fully_Repped_Tagged_Type
(PS
) then
10002 Tagged_Parent
:= PS
;
10004 -- Find maximum bit of any component of the parent type
10006 Parent_Last_Bit
:= UI_From_Int
(System_Address_Size
- 1);
10007 Pcomp
:= First_Entity
(Tagged_Parent
);
10008 while Present
(Pcomp
) loop
10009 if Ekind_In
(Pcomp
, E_Discriminant
, E_Component
) then
10010 if Component_Bit_Offset
(Pcomp
) /= No_Uint
10011 and then Known_Static_Esize
(Pcomp
)
10016 Component_Bit_Offset
(Pcomp
) + Esize
(Pcomp
) - 1);
10020 -- Skip anonymous types generated for constrained array
10021 -- or record components.
10026 Next_Entity
(Pcomp
);
10031 -- All done if no component clauses
10033 CC
:= First
(Component_Clauses
(N
));
10039 -- If a tag is present, then create a component clause that places it
10040 -- at the start of the record (otherwise gigi may place it after other
10041 -- fields that have rep clauses).
10043 Fent
:= First_Entity
(Rectype
);
10045 if Nkind
(Fent
) = N_Defining_Identifier
10046 and then Chars
(Fent
) = Name_uTag
10048 Set_Component_Bit_Offset
(Fent
, Uint_0
);
10049 Set_Normalized_Position
(Fent
, Uint_0
);
10050 Set_Normalized_First_Bit
(Fent
, Uint_0
);
10051 Set_Normalized_Position_Max
(Fent
, Uint_0
);
10052 Init_Esize
(Fent
, System_Address_Size
);
10054 Set_Component_Clause
(Fent
,
10055 Make_Component_Clause
(Loc
,
10056 Component_Name
=> Make_Identifier
(Loc
, Name_uTag
),
10058 Position
=> Make_Integer_Literal
(Loc
, Uint_0
),
10059 First_Bit
=> Make_Integer_Literal
(Loc
, Uint_0
),
10061 Make_Integer_Literal
(Loc
,
10062 UI_From_Int
(System_Address_Size
))));
10064 Ccount
:= Ccount
+ 1;
10067 Max_Bit_So_Far
:= Uint_Minus_1
;
10068 Overlap_Check_Required
:= False;
10070 -- Process the component clauses
10072 while Present
(CC
) loop
10075 if Present
(Comp
) then
10076 Ccount
:= Ccount
+ 1;
10078 -- We need a full overlap check if record positions non-monotonic
10080 if Fbit
<= Max_Bit_So_Far
then
10081 Overlap_Check_Required
:= True;
10084 Max_Bit_So_Far
:= Lbit
;
10086 -- Check bit position out of range of specified size
10088 if Has_Size_Clause
(Rectype
)
10089 and then RM_Size
(Rectype
) <= Lbit
10092 ("bit number out of range of specified size",
10095 -- Check for overlap with tag or parent component
10098 if Is_Tagged_Type
(Rectype
)
10099 and then Fbit
< System_Address_Size
10102 ("component overlaps tag field of&",
10103 Component_Name
(CC
), Rectype
);
10104 Overlap_Detected
:= True;
10106 elsif Present
(Tagged_Parent
)
10107 and then Fbit
<= Parent_Last_Bit
10110 ("component overlaps parent field of&",
10111 Component_Name
(CC
), Rectype
);
10112 Overlap_Detected
:= True;
10115 if Hbit
< Lbit
then
10124 -- Now that we have processed all the component clauses, check for
10125 -- overlap. We have to leave this till last, since the components can
10126 -- appear in any arbitrary order in the representation clause.
10128 -- We do not need this check if all specified ranges were monotonic,
10129 -- as recorded by Overlap_Check_Required being False at this stage.
10131 -- This first section checks if there are any overlapping entries at
10132 -- all. It does this by sorting all entries and then seeing if there are
10133 -- any overlaps. If there are none, then that is decisive, but if there
10134 -- are overlaps, they may still be OK (they may result from fields in
10135 -- different variants).
10137 if Overlap_Check_Required
then
10138 Overlap_Check1
: declare
10140 OC_Fbit
: array (0 .. Ccount
) of Uint
;
10141 -- First-bit values for component clauses, the value is the offset
10142 -- of the first bit of the field from start of record. The zero
10143 -- entry is for use in sorting.
10145 OC_Lbit
: array (0 .. Ccount
) of Uint
;
10146 -- Last-bit values for component clauses, the value is the offset
10147 -- of the last bit of the field from start of record. The zero
10148 -- entry is for use in sorting.
10150 OC_Count
: Natural := 0;
10151 -- Count of entries in OC_Fbit and OC_Lbit
10153 function OC_Lt
(Op1
, Op2
: Natural) return Boolean;
10154 -- Compare routine for Sort
10156 procedure OC_Move
(From
: Natural; To
: Natural);
10157 -- Move routine for Sort
10159 package Sorting
is new GNAT
.Heap_Sort_G
(OC_Move
, OC_Lt
);
10165 function OC_Lt
(Op1
, Op2
: Natural) return Boolean is
10167 return OC_Fbit
(Op1
) < OC_Fbit
(Op2
);
10174 procedure OC_Move
(From
: Natural; To
: Natural) is
10176 OC_Fbit
(To
) := OC_Fbit
(From
);
10177 OC_Lbit
(To
) := OC_Lbit
(From
);
10180 -- Start of processing for Overlap_Check
10183 CC
:= First
(Component_Clauses
(N
));
10184 while Present
(CC
) loop
10186 -- Exclude component clause already marked in error
10188 if not Error_Posted
(CC
) then
10191 if Present
(Comp
) then
10192 OC_Count
:= OC_Count
+ 1;
10193 OC_Fbit
(OC_Count
) := Fbit
;
10194 OC_Lbit
(OC_Count
) := Lbit
;
10201 Sorting
.Sort
(OC_Count
);
10203 Overlap_Check_Required
:= False;
10204 for J
in 1 .. OC_Count
- 1 loop
10205 if OC_Lbit
(J
) >= OC_Fbit
(J
+ 1) then
10206 Overlap_Check_Required
:= True;
10210 end Overlap_Check1
;
10213 -- If Overlap_Check_Required is still True, then we have to do the full
10214 -- scale overlap check, since we have at least two fields that do
10215 -- overlap, and we need to know if that is OK since they are in
10216 -- different variant, or whether we have a definite problem.
10218 if Overlap_Check_Required
then
10219 Overlap_Check2
: declare
10220 C1_Ent
, C2_Ent
: Entity_Id
;
10221 -- Entities of components being checked for overlap
10224 -- Component_List node whose Component_Items are being checked
10227 -- Component declaration for component being checked
10230 C1_Ent
:= First_Entity
(Base_Type
(Rectype
));
10232 -- Loop through all components in record. For each component check
10233 -- for overlap with any of the preceding elements on the component
10234 -- list containing the component and also, if the component is in
10235 -- a variant, check against components outside the case structure.
10236 -- This latter test is repeated recursively up the variant tree.
10238 Main_Component_Loop
: while Present
(C1_Ent
) loop
10239 if not Ekind_In
(C1_Ent
, E_Component
, E_Discriminant
) then
10240 goto Continue_Main_Component_Loop
;
10243 -- Skip overlap check if entity has no declaration node. This
10244 -- happens with discriminants in constrained derived types.
10245 -- Possibly we are missing some checks as a result, but that
10246 -- does not seem terribly serious.
10248 if No
(Declaration_Node
(C1_Ent
)) then
10249 goto Continue_Main_Component_Loop
;
10252 Clist
:= Parent
(List_Containing
(Declaration_Node
(C1_Ent
)));
10254 -- Loop through component lists that need checking. Check the
10255 -- current component list and all lists in variants above us.
10257 Component_List_Loop
: loop
10259 -- If derived type definition, go to full declaration
10260 -- If at outer level, check discriminants if there are any.
10262 if Nkind
(Clist
) = N_Derived_Type_Definition
then
10263 Clist
:= Parent
(Clist
);
10266 -- Outer level of record definition, check discriminants
10268 if Nkind_In
(Clist
, N_Full_Type_Declaration
,
10269 N_Private_Type_Declaration
)
10271 if Has_Discriminants
(Defining_Identifier
(Clist
)) then
10273 First_Discriminant
(Defining_Identifier
(Clist
));
10274 while Present
(C2_Ent
) loop
10275 exit when C1_Ent
= C2_Ent
;
10276 Check_Component_Overlap
(C1_Ent
, C2_Ent
);
10277 Next_Discriminant
(C2_Ent
);
10281 -- Record extension case
10283 elsif Nkind
(Clist
) = N_Derived_Type_Definition
then
10286 -- Otherwise check one component list
10289 Citem
:= First
(Component_Items
(Clist
));
10290 while Present
(Citem
) loop
10291 if Nkind
(Citem
) = N_Component_Declaration
then
10292 C2_Ent
:= Defining_Identifier
(Citem
);
10293 exit when C1_Ent
= C2_Ent
;
10294 Check_Component_Overlap
(C1_Ent
, C2_Ent
);
10301 -- Check for variants above us (the parent of the Clist can
10302 -- be a variant, in which case its parent is a variant part,
10303 -- and the parent of the variant part is a component list
10304 -- whose components must all be checked against the current
10305 -- component for overlap).
10307 if Nkind
(Parent
(Clist
)) = N_Variant
then
10308 Clist
:= Parent
(Parent
(Parent
(Clist
)));
10310 -- Check for possible discriminant part in record, this
10311 -- is treated essentially as another level in the
10312 -- recursion. For this case the parent of the component
10313 -- list is the record definition, and its parent is the
10314 -- full type declaration containing the discriminant
10317 elsif Nkind
(Parent
(Clist
)) = N_Record_Definition
then
10318 Clist
:= Parent
(Parent
((Clist
)));
10320 -- If neither of these two cases, we are at the top of
10324 exit Component_List_Loop
;
10326 end loop Component_List_Loop
;
10328 <<Continue_Main_Component_Loop
>>
10329 Next_Entity
(C1_Ent
);
10331 end loop Main_Component_Loop
;
10332 end Overlap_Check2
;
10335 -- The following circuit deals with warning on record holes (gaps). We
10336 -- skip this check if overlap was detected, since it makes sense for the
10337 -- programmer to fix this illegality before worrying about warnings.
10339 if not Overlap_Detected
and Warn_On_Record_Holes
then
10340 Record_Hole_Check
: declare
10341 Decl
: constant Node_Id
:= Declaration_Node
(Base_Type
(Rectype
));
10342 -- Full declaration of record type
10344 procedure Check_Component_List
10348 -- Check component list CL for holes. The starting bit should be
10349 -- Sbit. which is zero for the main record component list and set
10350 -- appropriately for recursive calls for variants. DS is set to
10351 -- a list of discriminant specifications to be included in the
10352 -- consideration of components. It is No_List if none to consider.
10354 --------------------------
10355 -- Check_Component_List --
10356 --------------------------
10358 procedure Check_Component_List
10366 Compl
:= Integer (List_Length
(Component_Items
(CL
)));
10368 if DS
/= No_List
then
10369 Compl
:= Compl
+ Integer (List_Length
(DS
));
10373 Comps
: array (Natural range 0 .. Compl
) of Entity_Id
;
10374 -- Gather components (zero entry is for sort routine)
10376 Ncomps
: Natural := 0;
10377 -- Number of entries stored in Comps (starting at Comps (1))
10380 -- One component item or discriminant specification
10383 -- Starting bit for next component
10386 -- Component entity
10391 function Lt
(Op1
, Op2
: Natural) return Boolean;
10392 -- Compare routine for Sort
10394 procedure Move
(From
: Natural; To
: Natural);
10395 -- Move routine for Sort
10397 package Sorting
is new GNAT
.Heap_Sort_G
(Move
, Lt
);
10403 function Lt
(Op1
, Op2
: Natural) return Boolean is
10405 return Component_Bit_Offset
(Comps
(Op1
))
10407 Component_Bit_Offset
(Comps
(Op2
));
10414 procedure Move
(From
: Natural; To
: Natural) is
10416 Comps
(To
) := Comps
(From
);
10420 -- Gather discriminants into Comp
10422 if DS
/= No_List
then
10423 Citem
:= First
(DS
);
10424 while Present
(Citem
) loop
10425 if Nkind
(Citem
) = N_Discriminant_Specification
then
10427 Ent
: constant Entity_Id
:=
10428 Defining_Identifier
(Citem
);
10430 if Ekind
(Ent
) = E_Discriminant
then
10431 Ncomps
:= Ncomps
+ 1;
10432 Comps
(Ncomps
) := Ent
;
10441 -- Gather component entities into Comp
10443 Citem
:= First
(Component_Items
(CL
));
10444 while Present
(Citem
) loop
10445 if Nkind
(Citem
) = N_Component_Declaration
then
10446 Ncomps
:= Ncomps
+ 1;
10447 Comps
(Ncomps
) := Defining_Identifier
(Citem
);
10453 -- Now sort the component entities based on the first bit.
10454 -- Note we already know there are no overlapping components.
10456 Sorting
.Sort
(Ncomps
);
10458 -- Loop through entries checking for holes
10461 for J
in 1 .. Ncomps
loop
10465 CBO
: constant Uint
:= Component_Bit_Offset
(CEnt
);
10468 -- Skip components with unknown offsets
10470 if CBO
/= No_Uint
and then CBO
>= 0 then
10471 Error_Msg_Uint_1
:= CBO
- Nbit
;
10473 if Error_Msg_Uint_1
> 0 then
10475 ("?H?^-bit gap before component&",
10476 Component_Name
(Component_Clause
(CEnt
)),
10480 Nbit
:= CBO
+ Esize
(CEnt
);
10485 -- Process variant parts recursively if present
10487 if Present
(Variant_Part
(CL
)) then
10488 Variant
:= First
(Variants
(Variant_Part
(CL
)));
10489 while Present
(Variant
) loop
10490 Check_Component_List
10491 (Component_List
(Variant
), Nbit
, No_List
);
10496 end Check_Component_List
;
10498 -- Start of processing for Record_Hole_Check
10505 if Is_Tagged_Type
(Rectype
) then
10506 Sbit
:= UI_From_Int
(System_Address_Size
);
10511 if Nkind
(Decl
) = N_Full_Type_Declaration
10512 and then Nkind
(Type_Definition
(Decl
)) = N_Record_Definition
10514 Check_Component_List
10515 (Component_List
(Type_Definition
(Decl
)),
10517 Discriminant_Specifications
(Decl
));
10520 end Record_Hole_Check
;
10523 -- For records that have component clauses for all components, and whose
10524 -- size is less than or equal to 32, we need to know the size in the
10525 -- front end to activate possible packed array processing where the
10526 -- component type is a record.
10528 -- At this stage Hbit + 1 represents the first unused bit from all the
10529 -- component clauses processed, so if the component clauses are
10530 -- complete, then this is the length of the record.
10532 -- For records longer than System.Storage_Unit, and for those where not
10533 -- all components have component clauses, the back end determines the
10534 -- length (it may for example be appropriate to round up the size
10535 -- to some convenient boundary, based on alignment considerations, etc).
10537 if Unknown_RM_Size
(Rectype
) and then Hbit
+ 1 <= 32 then
10539 -- Nothing to do if at least one component has no component clause
10541 Comp
:= First_Component_Or_Discriminant
(Rectype
);
10542 while Present
(Comp
) loop
10543 exit when No
(Component_Clause
(Comp
));
10544 Next_Component_Or_Discriminant
(Comp
);
10547 -- If we fall out of loop, all components have component clauses
10548 -- and so we can set the size to the maximum value.
10551 Set_RM_Size
(Rectype
, Hbit
+ 1);
10554 end Check_Record_Representation_Clause
;
10560 procedure Check_Size
10564 Biased
: out Boolean)
10566 procedure Size_Too_Small_Error
(Min_Siz
: Uint
);
10567 -- Emit an error concerning illegal size Siz. Min_Siz denotes the
10570 --------------------------
10571 -- Size_Too_Small_Error --
10572 --------------------------
10574 procedure Size_Too_Small_Error
(Min_Siz
: Uint
) is
10576 -- This error is suppressed in ASIS mode to allow for different ASIS
10577 -- back ends or ASIS-based tools to query the illegal clause.
10579 if not ASIS_Mode
then
10580 Error_Msg_Uint_1
:= Min_Siz
;
10581 Error_Msg_NE
("size for& too small, minimum allowed is ^", N
, T
);
10583 end Size_Too_Small_Error
;
10587 UT
: constant Entity_Id
:= Underlying_Type
(T
);
10590 -- Start of processing for Check_Size
10595 -- Reject patently improper size values
10597 if Is_Elementary_Type
(T
)
10598 and then Siz
> UI_From_Int
(Int
'Last)
10600 Error_Msg_N
("Size value too large for elementary type", N
);
10602 if Nkind
(Original_Node
(N
)) = N_Op_Expon
then
10604 ("\maybe '* was meant, rather than '*'*", Original_Node
(N
));
10608 -- Dismiss generic types
10610 if Is_Generic_Type
(T
)
10612 Is_Generic_Type
(UT
)
10614 Is_Generic_Type
(Root_Type
(UT
))
10618 -- Guard against previous errors
10620 elsif No
(UT
) or else UT
= Any_Type
then
10621 Check_Error_Detected
;
10624 -- Check case of bit packed array
10626 elsif Is_Array_Type
(UT
)
10627 and then Known_Static_Component_Size
(UT
)
10628 and then Is_Bit_Packed_Array
(UT
)
10636 Asiz
:= Component_Size
(UT
);
10637 Indx
:= First_Index
(UT
);
10639 Ityp
:= Etype
(Indx
);
10641 -- If non-static bound, then we are not in the business of
10642 -- trying to check the length, and indeed an error will be
10643 -- issued elsewhere, since sizes of non-static array types
10644 -- cannot be set implicitly or explicitly.
10646 if not Is_OK_Static_Subtype
(Ityp
) then
10650 -- Otherwise accumulate next dimension
10652 Asiz
:= Asiz
* (Expr_Value
(Type_High_Bound
(Ityp
)) -
10653 Expr_Value
(Type_Low_Bound
(Ityp
)) +
10657 exit when No
(Indx
);
10660 if Asiz
<= Siz
then
10664 Size_Too_Small_Error
(Asiz
);
10665 Set_Esize
(T
, Asiz
);
10666 Set_RM_Size
(T
, Asiz
);
10670 -- All other composite types are ignored
10672 elsif Is_Composite_Type
(UT
) then
10675 -- For fixed-point types, don't check minimum if type is not frozen,
10676 -- since we don't know all the characteristics of the type that can
10677 -- affect the size (e.g. a specified small) till freeze time.
10679 elsif Is_Fixed_Point_Type
(UT
) and then not Is_Frozen
(UT
) then
10682 -- Cases for which a minimum check is required
10685 -- Ignore if specified size is correct for the type
10687 if Known_Esize
(UT
) and then Siz
= Esize
(UT
) then
10691 -- Otherwise get minimum size
10693 M
:= UI_From_Int
(Minimum_Size
(UT
));
10697 -- Size is less than minimum size, but one possibility remains
10698 -- that we can manage with the new size if we bias the type.
10700 M
:= UI_From_Int
(Minimum_Size
(UT
, Biased
=> True));
10703 Size_Too_Small_Error
(M
);
10705 Set_RM_Size
(T
, M
);
10713 --------------------------
10714 -- Freeze_Entity_Checks --
10715 --------------------------
10717 procedure Freeze_Entity_Checks
(N
: Node_Id
) is
10718 procedure Hide_Non_Overridden_Subprograms
(Typ
: Entity_Id
);
10719 -- Inspect the primitive operations of type Typ and hide all pairs of
10720 -- implicitly declared non-overridden non-fully conformant homographs
10721 -- (Ada RM 8.3 12.3/2).
10723 -------------------------------------
10724 -- Hide_Non_Overridden_Subprograms --
10725 -------------------------------------
10727 procedure Hide_Non_Overridden_Subprograms
(Typ
: Entity_Id
) is
10728 procedure Hide_Matching_Homographs
10729 (Subp_Id
: Entity_Id
;
10730 Start_Elmt
: Elmt_Id
);
10731 -- Inspect a list of primitive operations starting with Start_Elmt
10732 -- and find matching implicitly declared non-overridden non-fully
10733 -- conformant homographs of Subp_Id. If found, all matches along
10734 -- with Subp_Id are hidden from all visibility.
10736 function Is_Non_Overridden_Or_Null_Procedure
10737 (Subp_Id
: Entity_Id
) return Boolean;
10738 -- Determine whether subprogram Subp_Id is implicitly declared non-
10739 -- overridden subprogram or an implicitly declared null procedure.
10741 ------------------------------
10742 -- Hide_Matching_Homographs --
10743 ------------------------------
10745 procedure Hide_Matching_Homographs
10746 (Subp_Id
: Entity_Id
;
10747 Start_Elmt
: Elmt_Id
)
10750 Prim_Elmt
: Elmt_Id
;
10753 Prim_Elmt
:= Start_Elmt
;
10754 while Present
(Prim_Elmt
) loop
10755 Prim
:= Node
(Prim_Elmt
);
10757 -- The current primitive is implicitly declared non-overridden
10758 -- non-fully conformant homograph of Subp_Id. Both subprograms
10759 -- must be hidden from visibility.
10761 if Chars
(Prim
) = Chars
(Subp_Id
)
10762 and then Is_Non_Overridden_Or_Null_Procedure
(Prim
)
10763 and then not Fully_Conformant
(Prim
, Subp_Id
)
10765 Set_Is_Hidden_Non_Overridden_Subpgm
(Prim
);
10766 Set_Is_Immediately_Visible
(Prim
, False);
10767 Set_Is_Potentially_Use_Visible
(Prim
, False);
10769 Set_Is_Hidden_Non_Overridden_Subpgm
(Subp_Id
);
10770 Set_Is_Immediately_Visible
(Subp_Id
, False);
10771 Set_Is_Potentially_Use_Visible
(Subp_Id
, False);
10774 Next_Elmt
(Prim_Elmt
);
10776 end Hide_Matching_Homographs
;
10778 -----------------------------------------
10779 -- Is_Non_Overridden_Or_Null_Procedure --
10780 -----------------------------------------
10782 function Is_Non_Overridden_Or_Null_Procedure
10783 (Subp_Id
: Entity_Id
) return Boolean
10785 Alias_Id
: Entity_Id
;
10788 -- The subprogram is inherited (implicitly declared), it does not
10789 -- override and does not cover a primitive of an interface.
10791 if Ekind_In
(Subp_Id
, E_Function
, E_Procedure
)
10792 and then Present
(Alias
(Subp_Id
))
10793 and then No
(Interface_Alias
(Subp_Id
))
10794 and then No
(Overridden_Operation
(Subp_Id
))
10796 Alias_Id
:= Alias
(Subp_Id
);
10798 if Requires_Overriding
(Alias_Id
) then
10801 elsif Nkind
(Parent
(Alias_Id
)) = N_Procedure_Specification
10802 and then Null_Present
(Parent
(Alias_Id
))
10809 end Is_Non_Overridden_Or_Null_Procedure
;
10813 Prim_Ops
: constant Elist_Id
:= Direct_Primitive_Operations
(Typ
);
10815 Prim_Elmt
: Elmt_Id
;
10817 -- Start of processing for Hide_Non_Overridden_Subprograms
10820 -- Inspect the list of primitives looking for non-overridden
10823 if Present
(Prim_Ops
) then
10824 Prim_Elmt
:= First_Elmt
(Prim_Ops
);
10825 while Present
(Prim_Elmt
) loop
10826 Prim
:= Node
(Prim_Elmt
);
10827 Next_Elmt
(Prim_Elmt
);
10829 if Is_Non_Overridden_Or_Null_Procedure
(Prim
) then
10830 Hide_Matching_Homographs
10832 Start_Elmt
=> Prim_Elmt
);
10836 end Hide_Non_Overridden_Subprograms
;
10840 E
: constant Entity_Id
:= Entity
(N
);
10842 Non_Generic_Case
: constant Boolean := Nkind
(N
) = N_Freeze_Entity
;
10843 -- True in non-generic case. Some of the processing here is skipped
10844 -- for the generic case since it is not needed. Basically in the
10845 -- generic case, we only need to do stuff that might generate error
10846 -- messages or warnings.
10848 -- Start of processing for Freeze_Entity_Checks
10851 -- Remember that we are processing a freezing entity. Required to
10852 -- ensure correct decoration of internal entities associated with
10853 -- interfaces (see New_Overloaded_Entity).
10855 Inside_Freezing_Actions
:= Inside_Freezing_Actions
+ 1;
10857 -- For tagged types covering interfaces add internal entities that link
10858 -- the primitives of the interfaces with the primitives that cover them.
10859 -- Note: These entities were originally generated only when generating
10860 -- code because their main purpose was to provide support to initialize
10861 -- the secondary dispatch tables. They are now generated also when
10862 -- compiling with no code generation to provide ASIS the relationship
10863 -- between interface primitives and tagged type primitives. They are
10864 -- also used to locate primitives covering interfaces when processing
10865 -- generics (see Derive_Subprograms).
10867 -- This is not needed in the generic case
10869 if Ada_Version
>= Ada_2005
10870 and then Non_Generic_Case
10871 and then Ekind
(E
) = E_Record_Type
10872 and then Is_Tagged_Type
(E
)
10873 and then not Is_Interface
(E
)
10874 and then Has_Interfaces
(E
)
10876 -- This would be a good common place to call the routine that checks
10877 -- overriding of interface primitives (and thus factorize calls to
10878 -- Check_Abstract_Overriding located at different contexts in the
10879 -- compiler). However, this is not possible because it causes
10880 -- spurious errors in case of late overriding.
10882 Add_Internal_Interface_Entities
(E
);
10885 -- After all forms of overriding have been resolved, a tagged type may
10886 -- be left with a set of implicitly declared and possibly erroneous
10887 -- abstract subprograms, null procedures and subprograms that require
10888 -- overriding. If this set contains fully conformant homographs, then
10889 -- one is chosen arbitrarily (already done during resolution), otherwise
10890 -- all remaining non-fully conformant homographs are hidden from
10891 -- visibility (Ada RM 8.3 12.3/2).
10893 if Is_Tagged_Type
(E
) then
10894 Hide_Non_Overridden_Subprograms
(E
);
10899 if Ekind
(E
) = E_Record_Type
10900 and then Is_CPP_Class
(E
)
10901 and then Is_Tagged_Type
(E
)
10902 and then Tagged_Type_Expansion
10904 if CPP_Num_Prims
(E
) = 0 then
10906 -- If the CPP type has user defined components then it must import
10907 -- primitives from C++. This is required because if the C++ class
10908 -- has no primitives then the C++ compiler does not added the _tag
10909 -- component to the type.
10911 if First_Entity
(E
) /= Last_Entity
(E
) then
10913 ("'C'P'P type must import at least one primitive from C++??",
10918 -- Check that all its primitives are abstract or imported from C++.
10919 -- Check also availability of the C++ constructor.
10922 Has_Constructors
: constant Boolean := Has_CPP_Constructors
(E
);
10924 Error_Reported
: Boolean := False;
10928 Elmt
:= First_Elmt
(Primitive_Operations
(E
));
10929 while Present
(Elmt
) loop
10930 Prim
:= Node
(Elmt
);
10932 if Comes_From_Source
(Prim
) then
10933 if Is_Abstract_Subprogram
(Prim
) then
10936 elsif not Is_Imported
(Prim
)
10937 or else Convention
(Prim
) /= Convention_CPP
10940 ("primitives of 'C'P'P types must be imported from C++ "
10941 & "or abstract??", Prim
);
10943 elsif not Has_Constructors
10944 and then not Error_Reported
10946 Error_Msg_Name_1
:= Chars
(E
);
10948 ("??'C'P'P constructor required for type %", Prim
);
10949 Error_Reported
:= True;
10958 -- Check Ada derivation of CPP type
10960 if Expander_Active
-- why? losing errors in -gnatc mode???
10961 and then Present
(Etype
(E
)) -- defend against errors
10962 and then Tagged_Type_Expansion
10963 and then Ekind
(E
) = E_Record_Type
10964 and then Etype
(E
) /= E
10965 and then Is_CPP_Class
(Etype
(E
))
10966 and then CPP_Num_Prims
(Etype
(E
)) > 0
10967 and then not Is_CPP_Class
(E
)
10968 and then not Has_CPP_Constructors
(Etype
(E
))
10970 -- If the parent has C++ primitives but it has no constructor then
10971 -- check that all the primitives are overridden in this derivation;
10972 -- otherwise the constructor of the parent is needed to build the
10980 Elmt
:= First_Elmt
(Primitive_Operations
(E
));
10981 while Present
(Elmt
) loop
10982 Prim
:= Node
(Elmt
);
10984 if not Is_Abstract_Subprogram
(Prim
)
10985 and then No
(Interface_Alias
(Prim
))
10986 and then Find_Dispatching_Type
(Ultimate_Alias
(Prim
)) /= E
10988 Error_Msg_Name_1
:= Chars
(Etype
(E
));
10990 ("'C'P'P constructor required for parent type %", E
);
10999 Inside_Freezing_Actions
:= Inside_Freezing_Actions
- 1;
11001 -- If we have a type with predicates, build predicate function. This is
11002 -- not needed in the generic case, nor within TSS subprograms and other
11003 -- predefined primitives.
11006 and then Non_Generic_Case
11007 and then not Within_Internal_Subprogram
11008 and then Has_Predicates
(E
)
11010 Build_Predicate_Functions
(E
, N
);
11013 -- If type has delayed aspects, this is where we do the preanalysis at
11014 -- the freeze point, as part of the consistent visibility check. Note
11015 -- that this must be done after calling Build_Predicate_Functions or
11016 -- Build_Invariant_Procedure since these subprograms fix occurrences of
11017 -- the subtype name in the saved expression so that they will not cause
11018 -- trouble in the preanalysis.
11020 -- This is also not needed in the generic case
11022 if Non_Generic_Case
11023 and then Has_Delayed_Aspects
(E
)
11024 and then Scope
(E
) = Current_Scope
11026 -- Retrieve the visibility to the discriminants in order to properly
11027 -- analyze the aspects.
11029 Push_Scope_And_Install_Discriminants
(E
);
11035 -- Look for aspect specification entries for this entity
11037 Ritem
:= First_Rep_Item
(E
);
11038 while Present
(Ritem
) loop
11039 if Nkind
(Ritem
) = N_Aspect_Specification
11040 and then Entity
(Ritem
) = E
11041 and then Is_Delayed_Aspect
(Ritem
)
11043 Check_Aspect_At_Freeze_Point
(Ritem
);
11046 Next_Rep_Item
(Ritem
);
11050 Uninstall_Discriminants_And_Pop_Scope
(E
);
11053 -- For a record type, deal with variant parts. This has to be delayed
11054 -- to this point, because of the issue of statically predicated
11055 -- subtypes, which we have to ensure are frozen before checking
11056 -- choices, since we need to have the static choice list set.
11058 if Is_Record_Type
(E
) then
11059 Check_Variant_Part
: declare
11060 D
: constant Node_Id
:= Declaration_Node
(E
);
11065 Others_Present
: Boolean;
11066 pragma Warnings
(Off
, Others_Present
);
11067 -- Indicates others present, not used in this case
11069 procedure Non_Static_Choice_Error
(Choice
: Node_Id
);
11070 -- Error routine invoked by the generic instantiation below when
11071 -- the variant part has a non static choice.
11073 procedure Process_Declarations
(Variant
: Node_Id
);
11074 -- Processes declarations associated with a variant. We analyzed
11075 -- the declarations earlier (in Sem_Ch3.Analyze_Variant_Part),
11076 -- but we still need the recursive call to Check_Choices for any
11077 -- nested variant to get its choices properly processed. This is
11078 -- also where we expand out the choices if expansion is active.
11080 package Variant_Choices_Processing
is new
11081 Generic_Check_Choices
11082 (Process_Empty_Choice
=> No_OP
,
11083 Process_Non_Static_Choice
=> Non_Static_Choice_Error
,
11084 Process_Associated_Node
=> Process_Declarations
);
11085 use Variant_Choices_Processing
;
11087 -----------------------------
11088 -- Non_Static_Choice_Error --
11089 -----------------------------
11091 procedure Non_Static_Choice_Error
(Choice
: Node_Id
) is
11093 Flag_Non_Static_Expr
11094 ("choice given in variant part is not static!", Choice
);
11095 end Non_Static_Choice_Error
;
11097 --------------------------
11098 -- Process_Declarations --
11099 --------------------------
11101 procedure Process_Declarations
(Variant
: Node_Id
) is
11102 CL
: constant Node_Id
:= Component_List
(Variant
);
11106 -- Check for static predicate present in this variant
11108 if Has_SP_Choice
(Variant
) then
11110 -- Here we expand. You might expect to find this call in
11111 -- Expand_N_Variant_Part, but that is called when we first
11112 -- see the variant part, and we cannot do this expansion
11113 -- earlier than the freeze point, since for statically
11114 -- predicated subtypes, the predicate is not known till
11115 -- the freeze point.
11117 -- Furthermore, we do this expansion even if the expander
11118 -- is not active, because other semantic processing, e.g.
11119 -- for aggregates, requires the expanded list of choices.
11121 -- If the expander is not active, then we can't just clobber
11122 -- the list since it would invalidate the ASIS -gnatct tree.
11123 -- So we have to rewrite the variant part with a Rewrite
11124 -- call that replaces it with a copy and clobber the copy.
11126 if not Expander_Active
then
11128 NewV
: constant Node_Id
:= New_Copy
(Variant
);
11130 Set_Discrete_Choices
11131 (NewV
, New_Copy_List
(Discrete_Choices
(Variant
)));
11132 Rewrite
(Variant
, NewV
);
11136 Expand_Static_Predicates_In_Choices
(Variant
);
11139 -- We don't need to worry about the declarations in the variant
11140 -- (since they were analyzed by Analyze_Choices when we first
11141 -- encountered the variant), but we do need to take care of
11142 -- expansion of any nested variants.
11144 if not Null_Present
(CL
) then
11145 VP
:= Variant_Part
(CL
);
11147 if Present
(VP
) then
11149 (VP
, Variants
(VP
), Etype
(Name
(VP
)), Others_Present
);
11152 end Process_Declarations
;
11154 -- Start of processing for Check_Variant_Part
11157 -- Find component list
11161 if Nkind
(D
) = N_Full_Type_Declaration
then
11162 T
:= Type_Definition
(D
);
11164 if Nkind
(T
) = N_Record_Definition
then
11165 C
:= Component_List
(T
);
11167 elsif Nkind
(T
) = N_Derived_Type_Definition
11168 and then Present
(Record_Extension_Part
(T
))
11170 C
:= Component_List
(Record_Extension_Part
(T
));
11174 -- Case of variant part present
11176 if Present
(C
) and then Present
(Variant_Part
(C
)) then
11177 VP
:= Variant_Part
(C
);
11182 (VP
, Variants
(VP
), Etype
(Name
(VP
)), Others_Present
);
11184 -- If the last variant does not contain the Others choice,
11185 -- replace it with an N_Others_Choice node since Gigi always
11186 -- wants an Others. Note that we do not bother to call Analyze
11187 -- on the modified variant part, since its only effect would be
11188 -- to compute the Others_Discrete_Choices node laboriously, and
11189 -- of course we already know the list of choices corresponding
11190 -- to the others choice (it's the list we're replacing).
11192 -- We only want to do this if the expander is active, since
11193 -- we do not want to clobber the ASIS tree.
11195 if Expander_Active
then
11197 Last_Var
: constant Node_Id
:=
11198 Last_Non_Pragma
(Variants
(VP
));
11200 Others_Node
: Node_Id
;
11203 if Nkind
(First
(Discrete_Choices
(Last_Var
))) /=
11206 Others_Node
:= Make_Others_Choice
(Sloc
(Last_Var
));
11207 Set_Others_Discrete_Choices
11208 (Others_Node
, Discrete_Choices
(Last_Var
));
11209 Set_Discrete_Choices
11210 (Last_Var
, New_List
(Others_Node
));
11215 end Check_Variant_Part
;
11217 end Freeze_Entity_Checks
;
11219 -------------------------
11220 -- Get_Alignment_Value --
11221 -------------------------
11223 function Get_Alignment_Value
(Expr
: Node_Id
) return Uint
is
11224 Align
: constant Uint
:= Static_Integer
(Expr
);
11227 if Align
= No_Uint
then
11230 elsif Align
<= 0 then
11232 -- This error is suppressed in ASIS mode to allow for different ASIS
11233 -- back ends or ASIS-based tools to query the illegal clause.
11235 if not ASIS_Mode
then
11236 Error_Msg_N
("alignment value must be positive", Expr
);
11242 for J
in Int
range 0 .. 64 loop
11244 M
: constant Uint
:= Uint_2
** J
;
11247 exit when M
= Align
;
11251 -- This error is suppressed in ASIS mode to allow for
11252 -- different ASIS back ends or ASIS-based tools to query the
11255 if not ASIS_Mode
then
11256 Error_Msg_N
("alignment value must be power of 2", Expr
);
11266 end Get_Alignment_Value
;
11268 -------------------------------------
11269 -- Inherit_Aspects_At_Freeze_Point --
11270 -------------------------------------
11272 procedure Inherit_Aspects_At_Freeze_Point
(Typ
: Entity_Id
) is
11273 function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11274 (Rep_Item
: Node_Id
) return Boolean;
11275 -- This routine checks if Rep_Item is either a pragma or an aspect
11276 -- specification node whose correponding pragma (if any) is present in
11277 -- the Rep Item chain of the entity it has been specified to.
11279 --------------------------------------------------
11280 -- Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item --
11281 --------------------------------------------------
11283 function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11284 (Rep_Item
: Node_Id
) return Boolean
11288 Nkind
(Rep_Item
) = N_Pragma
11289 or else Present_In_Rep_Item
11290 (Entity
(Rep_Item
), Aspect_Rep_Item
(Rep_Item
));
11291 end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
;
11293 -- Start of processing for Inherit_Aspects_At_Freeze_Point
11296 -- A representation item is either subtype-specific (Size and Alignment
11297 -- clauses) or type-related (all others). Subtype-specific aspects may
11298 -- differ for different subtypes of the same type (RM 13.1.8).
11300 -- A derived type inherits each type-related representation aspect of
11301 -- its parent type that was directly specified before the declaration of
11302 -- the derived type (RM 13.1.15).
11304 -- A derived subtype inherits each subtype-specific representation
11305 -- aspect of its parent subtype that was directly specified before the
11306 -- declaration of the derived type (RM 13.1.15).
11308 -- The general processing involves inheriting a representation aspect
11309 -- from a parent type whenever the first rep item (aspect specification,
11310 -- attribute definition clause, pragma) corresponding to the given
11311 -- representation aspect in the rep item chain of Typ, if any, isn't
11312 -- directly specified to Typ but to one of its parents.
11314 -- ??? Note that, for now, just a limited number of representation
11315 -- aspects have been inherited here so far. Many of them are
11316 -- still inherited in Sem_Ch3. This will be fixed soon. Here is
11317 -- a non- exhaustive list of aspects that likely also need to
11318 -- be moved to this routine: Alignment, Component_Alignment,
11319 -- Component_Size, Machine_Radix, Object_Size, Pack, Predicates,
11320 -- Preelaborable_Initialization, RM_Size and Small.
11322 -- In addition, Convention must be propagated from base type to subtype,
11323 -- because the subtype may have been declared on an incomplete view.
11325 if Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
then
11331 if not Has_Rep_Item
(Typ
, Name_Ada_05
, Name_Ada_2005
, False)
11332 and then Has_Rep_Item
(Typ
, Name_Ada_05
, Name_Ada_2005
)
11333 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11334 (Get_Rep_Item
(Typ
, Name_Ada_05
, Name_Ada_2005
))
11336 Set_Is_Ada_2005_Only
(Typ
);
11341 if not Has_Rep_Item
(Typ
, Name_Ada_12
, Name_Ada_2012
, False)
11342 and then Has_Rep_Item
(Typ
, Name_Ada_12
, Name_Ada_2012
)
11343 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11344 (Get_Rep_Item
(Typ
, Name_Ada_12
, Name_Ada_2012
))
11346 Set_Is_Ada_2012_Only
(Typ
);
11351 if not Has_Rep_Item
(Typ
, Name_Atomic
, Name_Shared
, False)
11352 and then Has_Rep_Pragma
(Typ
, Name_Atomic
, Name_Shared
)
11353 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11354 (Get_Rep_Item
(Typ
, Name_Atomic
, Name_Shared
))
11356 Set_Is_Atomic
(Typ
);
11357 Set_Is_Volatile
(Typ
);
11358 Set_Treat_As_Volatile
(Typ
);
11363 if Is_Record_Type
(Typ
)
11364 and then Typ
/= Base_Type
(Typ
) and then Is_Frozen
(Base_Type
(Typ
))
11366 Set_Convention
(Typ
, Convention
(Base_Type
(Typ
)));
11369 -- Default_Component_Value
11371 -- Verify that there is no rep_item declared for the type, and there
11372 -- is one coming from an ancestor.
11374 if Is_Array_Type
(Typ
)
11375 and then Is_Base_Type
(Typ
)
11376 and then not Has_Rep_Item
(Typ
, Name_Default_Component_Value
, False)
11377 and then Has_Rep_Item
(Typ
, Name_Default_Component_Value
)
11379 Set_Default_Aspect_Component_Value
(Typ
,
11380 Default_Aspect_Component_Value
11381 (Entity
(Get_Rep_Item
(Typ
, Name_Default_Component_Value
))));
11386 if Is_Scalar_Type
(Typ
)
11387 and then Is_Base_Type
(Typ
)
11388 and then not Has_Rep_Item
(Typ
, Name_Default_Value
, False)
11389 and then Has_Rep_Item
(Typ
, Name_Default_Value
)
11391 Set_Has_Default_Aspect
(Typ
);
11392 Set_Default_Aspect_Value
(Typ
,
11393 Default_Aspect_Value
11394 (Entity
(Get_Rep_Item
(Typ
, Name_Default_Value
))));
11399 if not Has_Rep_Item
(Typ
, Name_Discard_Names
, False)
11400 and then Has_Rep_Item
(Typ
, Name_Discard_Names
)
11401 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11402 (Get_Rep_Item
(Typ
, Name_Discard_Names
))
11404 Set_Discard_Names
(Typ
);
11409 if not Has_Rep_Item
(Typ
, Name_Volatile
, False)
11410 and then Has_Rep_Item
(Typ
, Name_Volatile
)
11411 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11412 (Get_Rep_Item
(Typ
, Name_Volatile
))
11414 Set_Is_Volatile
(Typ
);
11415 Set_Treat_As_Volatile
(Typ
);
11418 -- Volatile_Full_Access
11420 if not Has_Rep_Item
(Typ
, Name_Volatile_Full_Access
, False)
11421 and then Has_Rep_Pragma
(Typ
, Name_Volatile_Full_Access
)
11422 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11423 (Get_Rep_Item
(Typ
, Name_Volatile_Full_Access
))
11425 Set_Is_Volatile_Full_Access
(Typ
);
11426 Set_Is_Volatile
(Typ
);
11427 Set_Treat_As_Volatile
(Typ
);
11430 -- Inheritance for derived types only
11432 if Is_Derived_Type
(Typ
) then
11434 Bas_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
11435 Imp_Bas_Typ
: constant Entity_Id
:= Implementation_Base_Type
(Typ
);
11438 -- Atomic_Components
11440 if not Has_Rep_Item
(Typ
, Name_Atomic_Components
, False)
11441 and then Has_Rep_Item
(Typ
, Name_Atomic_Components
)
11442 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11443 (Get_Rep_Item
(Typ
, Name_Atomic_Components
))
11445 Set_Has_Atomic_Components
(Imp_Bas_Typ
);
11448 -- Volatile_Components
11450 if not Has_Rep_Item
(Typ
, Name_Volatile_Components
, False)
11451 and then Has_Rep_Item
(Typ
, Name_Volatile_Components
)
11452 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11453 (Get_Rep_Item
(Typ
, Name_Volatile_Components
))
11455 Set_Has_Volatile_Components
(Imp_Bas_Typ
);
11458 -- Finalize_Storage_Only
11460 if not Has_Rep_Pragma
(Typ
, Name_Finalize_Storage_Only
, False)
11461 and then Has_Rep_Pragma
(Typ
, Name_Finalize_Storage_Only
)
11463 Set_Finalize_Storage_Only
(Bas_Typ
);
11466 -- Universal_Aliasing
11468 if not Has_Rep_Item
(Typ
, Name_Universal_Aliasing
, False)
11469 and then Has_Rep_Item
(Typ
, Name_Universal_Aliasing
)
11470 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
11471 (Get_Rep_Item
(Typ
, Name_Universal_Aliasing
))
11473 Set_Universal_Aliasing
(Imp_Bas_Typ
);
11478 if Is_Record_Type
(Typ
) then
11479 if not Has_Rep_Item
(Typ
, Name_Bit_Order
, False)
11480 and then Has_Rep_Item
(Typ
, Name_Bit_Order
)
11482 Set_Reverse_Bit_Order
(Bas_Typ
,
11483 Reverse_Bit_Order
(Entity
(Name
11484 (Get_Rep_Item
(Typ
, Name_Bit_Order
)))));
11488 -- Scalar_Storage_Order
11490 -- Note: the aspect is specified on a first subtype, but recorded
11491 -- in a flag of the base type!
11493 if (Is_Record_Type
(Typ
) or else Is_Array_Type
(Typ
))
11494 and then Typ
= Bas_Typ
11496 -- For a type extension, always inherit from parent; otherwise
11497 -- inherit if no default applies. Note: we do not check for
11498 -- an explicit rep item on the parent type when inheriting,
11499 -- because the parent SSO may itself have been set by default.
11501 if not Has_Rep_Item
(First_Subtype
(Typ
),
11502 Name_Scalar_Storage_Order
, False)
11503 and then (Is_Tagged_Type
(Bas_Typ
)
11504 or else not (SSO_Set_Low_By_Default
(Bas_Typ
)
11506 SSO_Set_High_By_Default
(Bas_Typ
)))
11508 Set_Reverse_Storage_Order
(Bas_Typ
,
11509 Reverse_Storage_Order
11510 (Implementation_Base_Type
(Etype
(Bas_Typ
))));
11512 -- Clear default SSO indications, since the inherited aspect
11513 -- which was set explicitly overrides the default.
11515 Set_SSO_Set_Low_By_Default
(Bas_Typ
, False);
11516 Set_SSO_Set_High_By_Default
(Bas_Typ
, False);
11521 end Inherit_Aspects_At_Freeze_Point
;
11527 procedure Initialize
is
11529 Address_Clause_Checks
.Init
;
11530 Compile_Time_Warnings_Errors
.Init
;
11531 Unchecked_Conversions
.Init
;
11533 -- ??? Might be needed in the future for some non GCC back-ends
11534 -- if AAMP_On_Target then
11535 -- Independence_Checks.Init;
11539 ---------------------------
11540 -- Install_Discriminants --
11541 ---------------------------
11543 procedure Install_Discriminants
(E
: Entity_Id
) is
11547 Disc
:= First_Discriminant
(E
);
11548 while Present
(Disc
) loop
11549 Prev
:= Current_Entity
(Disc
);
11550 Set_Current_Entity
(Disc
);
11551 Set_Is_Immediately_Visible
(Disc
);
11552 Set_Homonym
(Disc
, Prev
);
11553 Next_Discriminant
(Disc
);
11555 end Install_Discriminants
;
11557 -------------------------
11558 -- Is_Operational_Item --
11559 -------------------------
11561 function Is_Operational_Item
(N
: Node_Id
) return Boolean is
11563 if Nkind
(N
) /= N_Attribute_Definition_Clause
then
11568 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Chars
(N
));
11571 -- List of operational items is given in AARM 13.1(8.mm/1).
11572 -- It is clearly incomplete, as it does not include iterator
11573 -- aspects, among others.
11575 return Id
= Attribute_Constant_Indexing
11576 or else Id
= Attribute_Default_Iterator
11577 or else Id
= Attribute_Implicit_Dereference
11578 or else Id
= Attribute_Input
11579 or else Id
= Attribute_Iterator_Element
11580 or else Id
= Attribute_Iterable
11581 or else Id
= Attribute_Output
11582 or else Id
= Attribute_Read
11583 or else Id
= Attribute_Variable_Indexing
11584 or else Id
= Attribute_Write
11585 or else Id
= Attribute_External_Tag
;
11588 end Is_Operational_Item
;
11590 -------------------------
11591 -- Is_Predicate_Static --
11592 -------------------------
11594 -- Note: the basic legality of the expression has already been checked, so
11595 -- we don't need to worry about cases or ranges on strings for example.
11597 function Is_Predicate_Static
11599 Nam
: Name_Id
) return Boolean
11601 function All_Static_Case_Alternatives
(L
: List_Id
) return Boolean;
11602 -- Given a list of case expression alternatives, returns True if all
11603 -- the alternatives are static (have all static choices, and a static
11606 function All_Static_Choices
(L
: List_Id
) return Boolean;
11607 -- Returns true if all elements of the list are OK static choices
11608 -- as defined below for Is_Static_Choice. Used for case expression
11609 -- alternatives and for the right operand of a membership test. An
11610 -- others_choice is static if the corresponding expression is static.
11611 -- The staticness of the bounds is checked separately.
11613 function Is_Static_Choice
(N
: Node_Id
) return Boolean;
11614 -- Returns True if N represents a static choice (static subtype, or
11615 -- static subtype indication, or static expression, or static range).
11617 -- Note that this is a bit more inclusive than we actually need
11618 -- (in particular membership tests do not allow the use of subtype
11619 -- indications). But that doesn't matter, we have already checked
11620 -- that the construct is legal to get this far.
11622 function Is_Type_Ref
(N
: Node_Id
) return Boolean;
11623 pragma Inline
(Is_Type_Ref
);
11624 -- Returns True if N is a reference to the type for the predicate in the
11625 -- expression (i.e. if it is an identifier whose Chars field matches the
11626 -- Nam given in the call). N must not be parenthesized, if the type name
11627 -- appears in parens, this routine will return False.
11629 -- The routine also returns True for function calls generated during the
11630 -- expansion of comparison operators on strings, which are intended to
11631 -- be legal in static predicates, and are converted into calls to array
11632 -- comparison routines in the body of the corresponding predicate
11635 ----------------------------------
11636 -- All_Static_Case_Alternatives --
11637 ----------------------------------
11639 function All_Static_Case_Alternatives
(L
: List_Id
) return Boolean is
11644 while Present
(N
) loop
11645 if not (All_Static_Choices
(Discrete_Choices
(N
))
11646 and then Is_OK_Static_Expression
(Expression
(N
)))
11655 end All_Static_Case_Alternatives
;
11657 ------------------------
11658 -- All_Static_Choices --
11659 ------------------------
11661 function All_Static_Choices
(L
: List_Id
) return Boolean is
11666 while Present
(N
) loop
11667 if not Is_Static_Choice
(N
) then
11675 end All_Static_Choices
;
11677 ----------------------
11678 -- Is_Static_Choice --
11679 ----------------------
11681 function Is_Static_Choice
(N
: Node_Id
) return Boolean is
11683 return Nkind
(N
) = N_Others_Choice
11684 or else Is_OK_Static_Expression
(N
)
11685 or else (Is_Entity_Name
(N
) and then Is_Type
(Entity
(N
))
11686 and then Is_OK_Static_Subtype
(Entity
(N
)))
11687 or else (Nkind
(N
) = N_Subtype_Indication
11688 and then Is_OK_Static_Subtype
(Entity
(N
)))
11689 or else (Nkind
(N
) = N_Range
and then Is_OK_Static_Range
(N
));
11690 end Is_Static_Choice
;
11696 function Is_Type_Ref
(N
: Node_Id
) return Boolean is
11698 return (Nkind
(N
) = N_Identifier
11699 and then Chars
(N
) = Nam
11700 and then Paren_Count
(N
) = 0)
11701 or else Nkind
(N
) = N_Function_Call
;
11704 -- Start of processing for Is_Predicate_Static
11707 -- Predicate_Static means one of the following holds. Numbers are the
11708 -- corresponding paragraph numbers in (RM 3.2.4(16-22)).
11710 -- 16: A static expression
11712 if Is_OK_Static_Expression
(Expr
) then
11715 -- 17: A membership test whose simple_expression is the current
11716 -- instance, and whose membership_choice_list meets the requirements
11717 -- for a static membership test.
11719 elsif Nkind
(Expr
) in N_Membership_Test
11720 and then ((Present
(Right_Opnd
(Expr
))
11721 and then Is_Static_Choice
(Right_Opnd
(Expr
)))
11723 (Present
(Alternatives
(Expr
))
11724 and then All_Static_Choices
(Alternatives
(Expr
))))
11728 -- 18. A case_expression whose selecting_expression is the current
11729 -- instance, and whose dependent expressions are static expressions.
11731 elsif Nkind
(Expr
) = N_Case_Expression
11732 and then Is_Type_Ref
(Expression
(Expr
))
11733 and then All_Static_Case_Alternatives
(Alternatives
(Expr
))
11737 -- 19. A call to a predefined equality or ordering operator, where one
11738 -- operand is the current instance, and the other is a static
11741 -- Note: the RM is clearly wrong here in not excluding string types.
11742 -- Without this exclusion, we would allow expressions like X > "ABC"
11743 -- to be considered as predicate-static, which is clearly not intended,
11744 -- since the idea is for predicate-static to be a subset of normal
11745 -- static expressions (and "DEF" > "ABC" is not a static expression).
11747 -- However, we do allow internally generated (not from source) equality
11748 -- and inequality operations to be valid on strings (this helps deal
11749 -- with cases where we transform A in "ABC" to A = "ABC).
11751 -- In fact, it appears that the intent of the ARG is to extend static
11752 -- predicates to strings, and that the extension should probably apply
11753 -- to static expressions themselves. The code below accepts comparison
11754 -- operators that apply to static strings.
11756 elsif Nkind
(Expr
) in N_Op_Compare
11757 and then ((Is_Type_Ref
(Left_Opnd
(Expr
))
11758 and then Is_OK_Static_Expression
(Right_Opnd
(Expr
)))
11760 (Is_Type_Ref
(Right_Opnd
(Expr
))
11761 and then Is_OK_Static_Expression
(Left_Opnd
(Expr
))))
11765 -- 20. A call to a predefined boolean logical operator, where each
11766 -- operand is predicate-static.
11768 elsif (Nkind_In
(Expr
, N_Op_And
, N_Op_Or
, N_Op_Xor
)
11769 and then Is_Predicate_Static
(Left_Opnd
(Expr
), Nam
)
11770 and then Is_Predicate_Static
(Right_Opnd
(Expr
), Nam
))
11772 (Nkind
(Expr
) = N_Op_Not
11773 and then Is_Predicate_Static
(Right_Opnd
(Expr
), Nam
))
11777 -- 21. A short-circuit control form where both operands are
11778 -- predicate-static.
11780 elsif Nkind
(Expr
) in N_Short_Circuit
11781 and then Is_Predicate_Static
(Left_Opnd
(Expr
), Nam
)
11782 and then Is_Predicate_Static
(Right_Opnd
(Expr
), Nam
)
11786 -- 22. A parenthesized predicate-static expression. This does not
11787 -- require any special test, since we just ignore paren levels in
11788 -- all the cases above.
11790 -- One more test that is an implementation artifact caused by the fact
11791 -- that we are analyzing not the original expression, but the generated
11792 -- expression in the body of the predicate function. This can include
11793 -- references to inherited predicates, so that the expression we are
11794 -- processing looks like:
11796 -- xxPredicate (typ (Inns)) and then expression
11798 -- Where the call is to a Predicate function for an inherited predicate.
11799 -- We simply ignore such a call, which could be to either a dynamic or
11800 -- a static predicate. Note that if the parent predicate is dynamic then
11801 -- eventually this type will be marked as dynamic, but you are allowed
11802 -- to specify a static predicate for a subtype which is inheriting a
11803 -- dynamic predicate, so the static predicate validation here ignores
11804 -- the inherited predicate even if it is dynamic.
11805 -- In all cases, a static predicate can only apply to a scalar type.
11807 elsif Nkind
(Expr
) = N_Function_Call
11808 and then Is_Predicate_Function
(Entity
(Name
(Expr
)))
11809 and then Is_Scalar_Type
(Etype
(First_Entity
(Entity
(Name
(Expr
)))))
11813 -- That's an exhaustive list of tests, all other cases are not
11814 -- predicate-static, so we return False.
11819 end Is_Predicate_Static
;
11821 ---------------------
11822 -- Kill_Rep_Clause --
11823 ---------------------
11825 procedure Kill_Rep_Clause
(N
: Node_Id
) is
11827 pragma Assert
(Ignore_Rep_Clauses
);
11829 -- Note: we use Replace rather than Rewrite, because we don't want
11830 -- ASIS to be able to use Original_Node to dig out the (undecorated)
11831 -- rep clause that is being replaced.
11833 Replace
(N
, Make_Null_Statement
(Sloc
(N
)));
11835 -- The null statement must be marked as not coming from source. This is
11836 -- so that ASIS ignores it, and also the back end does not expect bogus
11837 -- "from source" null statements in weird places (e.g. in declarative
11838 -- regions where such null statements are not allowed).
11840 Set_Comes_From_Source
(N
, False);
11841 end Kill_Rep_Clause
;
11847 function Minimum_Size
11849 Biased
: Boolean := False) return Nat
11851 Lo
: Uint
:= No_Uint
;
11852 Hi
: Uint
:= No_Uint
;
11853 LoR
: Ureal
:= No_Ureal
;
11854 HiR
: Ureal
:= No_Ureal
;
11855 LoSet
: Boolean := False;
11856 HiSet
: Boolean := False;
11859 Ancest
: Entity_Id
;
11860 R_Typ
: constant Entity_Id
:= Root_Type
(T
);
11863 -- If bad type, return 0
11865 if T
= Any_Type
then
11868 -- For generic types, just return zero. There cannot be any legitimate
11869 -- need to know such a size, but this routine may be called with a
11870 -- generic type as part of normal processing.
11872 elsif Is_Generic_Type
(R_Typ
) or else R_Typ
= Any_Type
then
11875 -- Access types (cannot have size smaller than System.Address)
11877 elsif Is_Access_Type
(T
) then
11878 return System_Address_Size
;
11880 -- Floating-point types
11882 elsif Is_Floating_Point_Type
(T
) then
11883 return UI_To_Int
(Esize
(R_Typ
));
11887 elsif Is_Discrete_Type
(T
) then
11889 -- The following loop is looking for the nearest compile time known
11890 -- bounds following the ancestor subtype chain. The idea is to find
11891 -- the most restrictive known bounds information.
11895 if Ancest
= Any_Type
or else Etype
(Ancest
) = Any_Type
then
11900 if Compile_Time_Known_Value
(Type_Low_Bound
(Ancest
)) then
11901 Lo
:= Expr_Rep_Value
(Type_Low_Bound
(Ancest
));
11908 if Compile_Time_Known_Value
(Type_High_Bound
(Ancest
)) then
11909 Hi
:= Expr_Rep_Value
(Type_High_Bound
(Ancest
));
11915 Ancest
:= Ancestor_Subtype
(Ancest
);
11917 if No
(Ancest
) then
11918 Ancest
:= Base_Type
(T
);
11920 if Is_Generic_Type
(Ancest
) then
11926 -- Fixed-point types. We can't simply use Expr_Value to get the
11927 -- Corresponding_Integer_Value values of the bounds, since these do not
11928 -- get set till the type is frozen, and this routine can be called
11929 -- before the type is frozen. Similarly the test for bounds being static
11930 -- needs to include the case where we have unanalyzed real literals for
11931 -- the same reason.
11933 elsif Is_Fixed_Point_Type
(T
) then
11935 -- The following loop is looking for the nearest compile time known
11936 -- bounds following the ancestor subtype chain. The idea is to find
11937 -- the most restrictive known bounds information.
11941 if Ancest
= Any_Type
or else Etype
(Ancest
) = Any_Type
then
11945 -- Note: In the following two tests for LoSet and HiSet, it may
11946 -- seem redundant to test for N_Real_Literal here since normally
11947 -- one would assume that the test for the value being known at
11948 -- compile time includes this case. However, there is a glitch.
11949 -- If the real literal comes from folding a non-static expression,
11950 -- then we don't consider any non- static expression to be known
11951 -- at compile time if we are in configurable run time mode (needed
11952 -- in some cases to give a clearer definition of what is and what
11953 -- is not accepted). So the test is indeed needed. Without it, we
11954 -- would set neither Lo_Set nor Hi_Set and get an infinite loop.
11957 if Nkind
(Type_Low_Bound
(Ancest
)) = N_Real_Literal
11958 or else Compile_Time_Known_Value
(Type_Low_Bound
(Ancest
))
11960 LoR
:= Expr_Value_R
(Type_Low_Bound
(Ancest
));
11967 if Nkind
(Type_High_Bound
(Ancest
)) = N_Real_Literal
11968 or else Compile_Time_Known_Value
(Type_High_Bound
(Ancest
))
11970 HiR
:= Expr_Value_R
(Type_High_Bound
(Ancest
));
11976 Ancest
:= Ancestor_Subtype
(Ancest
);
11978 if No
(Ancest
) then
11979 Ancest
:= Base_Type
(T
);
11981 if Is_Generic_Type
(Ancest
) then
11987 Lo
:= UR_To_Uint
(LoR
/ Small_Value
(T
));
11988 Hi
:= UR_To_Uint
(HiR
/ Small_Value
(T
));
11990 -- No other types allowed
11993 raise Program_Error
;
11996 -- Fall through with Hi and Lo set. Deal with biased case
11999 and then not Is_Fixed_Point_Type
(T
)
12000 and then not (Is_Enumeration_Type
(T
)
12001 and then Has_Non_Standard_Rep
(T
)))
12002 or else Has_Biased_Representation
(T
)
12008 -- Null range case, size is always zero. We only do this in the discrete
12009 -- type case, since that's the odd case that came up. Probably we should
12010 -- also do this in the fixed-point case, but doing so causes peculiar
12011 -- gigi failures, and it is not worth worrying about this incredibly
12012 -- marginal case (explicit null-range fixed-point type declarations)???
12014 if Lo
> Hi
and then Is_Discrete_Type
(T
) then
12017 -- Signed case. Note that we consider types like range 1 .. -1 to be
12018 -- signed for the purpose of computing the size, since the bounds have
12019 -- to be accommodated in the base type.
12021 elsif Lo
< 0 or else Hi
< 0 then
12025 -- S = size, B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
12026 -- Note that we accommodate the case where the bounds cross. This
12027 -- can happen either because of the way the bounds are declared
12028 -- or because of the algorithm in Freeze_Fixed_Point_Type.
12042 -- If both bounds are positive, make sure that both are represen-
12043 -- table in the case where the bounds are crossed. This can happen
12044 -- either because of the way the bounds are declared, or because of
12045 -- the algorithm in Freeze_Fixed_Point_Type.
12051 -- S = size, (can accommodate 0 .. (2**size - 1))
12054 while Hi
>= Uint_2
** S
loop
12062 ---------------------------
12063 -- New_Stream_Subprogram --
12064 ---------------------------
12066 procedure New_Stream_Subprogram
12070 Nam
: TSS_Name_Type
)
12072 Loc
: constant Source_Ptr
:= Sloc
(N
);
12073 Sname
: constant Name_Id
:= Make_TSS_Name
(Base_Type
(Ent
), Nam
);
12074 Subp_Id
: Entity_Id
;
12075 Subp_Decl
: Node_Id
;
12079 Defer_Declaration
: constant Boolean :=
12080 Is_Tagged_Type
(Ent
) or else Is_Private_Type
(Ent
);
12081 -- For a tagged type, there is a declaration for each stream attribute
12082 -- at the freeze point, and we must generate only a completion of this
12083 -- declaration. We do the same for private types, because the full view
12084 -- might be tagged. Otherwise we generate a declaration at the point of
12085 -- the attribute definition clause. If the attribute definition comes
12086 -- from an aspect specification the declaration is part of the freeze
12087 -- actions of the type.
12089 function Build_Spec
return Node_Id
;
12090 -- Used for declaration and renaming declaration, so that this is
12091 -- treated as a renaming_as_body.
12097 function Build_Spec
return Node_Id
is
12098 Out_P
: constant Boolean := (Nam
= TSS_Stream_Read
);
12101 T_Ref
: constant Node_Id
:= New_Occurrence_Of
(Etyp
, Loc
);
12104 Subp_Id
:= Make_Defining_Identifier
(Loc
, Sname
);
12106 -- S : access Root_Stream_Type'Class
12108 Formals
:= New_List
(
12109 Make_Parameter_Specification
(Loc
,
12110 Defining_Identifier
=>
12111 Make_Defining_Identifier
(Loc
, Name_S
),
12113 Make_Access_Definition
(Loc
,
12115 New_Occurrence_Of
(
12116 Designated_Type
(Etype
(F
)), Loc
))));
12118 if Nam
= TSS_Stream_Input
then
12120 Make_Function_Specification
(Loc
,
12121 Defining_Unit_Name
=> Subp_Id
,
12122 Parameter_Specifications
=> Formals
,
12123 Result_Definition
=> T_Ref
);
12127 Append_To
(Formals
,
12128 Make_Parameter_Specification
(Loc
,
12129 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
12130 Out_Present
=> Out_P
,
12131 Parameter_Type
=> T_Ref
));
12134 Make_Procedure_Specification
(Loc
,
12135 Defining_Unit_Name
=> Subp_Id
,
12136 Parameter_Specifications
=> Formals
);
12142 -- Start of processing for New_Stream_Subprogram
12145 F
:= First_Formal
(Subp
);
12147 if Ekind
(Subp
) = E_Procedure
then
12148 Etyp
:= Etype
(Next_Formal
(F
));
12150 Etyp
:= Etype
(Subp
);
12153 -- Prepare subprogram declaration and insert it as an action on the
12154 -- clause node. The visibility for this entity is used to test for
12155 -- visibility of the attribute definition clause (in the sense of
12156 -- 8.3(23) as amended by AI-195).
12158 if not Defer_Declaration
then
12160 Make_Subprogram_Declaration
(Loc
,
12161 Specification
=> Build_Spec
);
12163 -- For a tagged type, there is always a visible declaration for each
12164 -- stream TSS (it is a predefined primitive operation), and the
12165 -- completion of this declaration occurs at the freeze point, which is
12166 -- not always visible at places where the attribute definition clause is
12167 -- visible. So, we create a dummy entity here for the purpose of
12168 -- tracking the visibility of the attribute definition clause itself.
12172 Make_Defining_Identifier
(Loc
, New_External_Name
(Sname
, 'V'));
12174 Make_Object_Declaration
(Loc
,
12175 Defining_Identifier
=> Subp_Id
,
12176 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
));
12179 if not Defer_Declaration
12180 and then From_Aspect_Specification
(N
)
12181 and then Has_Delayed_Freeze
(Ent
)
12183 Append_Freeze_Action
(Ent
, Subp_Decl
);
12186 Insert_Action
(N
, Subp_Decl
);
12187 Set_Entity
(N
, Subp_Id
);
12191 Make_Subprogram_Renaming_Declaration
(Loc
,
12192 Specification
=> Build_Spec
,
12193 Name
=> New_Occurrence_Of
(Subp
, Loc
));
12195 if Defer_Declaration
then
12196 Set_TSS
(Base_Type
(Ent
), Subp_Id
);
12199 if From_Aspect_Specification
(N
) then
12200 Append_Freeze_Action
(Ent
, Subp_Decl
);
12202 Insert_Action
(N
, Subp_Decl
);
12205 Copy_TSS
(Subp_Id
, Base_Type
(Ent
));
12207 end New_Stream_Subprogram
;
12209 ------------------------------------------
12210 -- Push_Scope_And_Install_Discriminants --
12211 ------------------------------------------
12213 procedure Push_Scope_And_Install_Discriminants
(E
: Entity_Id
) is
12215 if Has_Discriminants
(E
) then
12218 -- Make the discriminants visible for type declarations and protected
12219 -- type declarations, not for subtype declarations (RM 13.1.1 (12/3))
12221 if Nkind
(Parent
(E
)) /= N_Subtype_Declaration
then
12222 Install_Discriminants
(E
);
12225 end Push_Scope_And_Install_Discriminants
;
12227 ------------------------
12228 -- Rep_Item_Too_Early --
12229 ------------------------
12231 function Rep_Item_Too_Early
(T
: Entity_Id
; N
: Node_Id
) return Boolean is
12233 -- Cannot apply non-operational rep items to generic types
12235 if Is_Operational_Item
(N
) then
12239 and then Is_Generic_Type
(Root_Type
(T
))
12240 and then (Nkind
(N
) /= N_Pragma
12241 or else Get_Pragma_Id
(N
) /= Pragma_Convention
)
12243 Error_Msg_N
("representation item not allowed for generic type", N
);
12247 -- Otherwise check for incomplete type
12249 if Is_Incomplete_Or_Private_Type
(T
)
12250 and then No
(Underlying_Type
(T
))
12252 (Nkind
(N
) /= N_Pragma
12253 or else Get_Pragma_Id
(N
) /= Pragma_Import
)
12256 ("representation item must be after full type declaration", N
);
12259 -- If the type has incomplete components, a representation clause is
12260 -- illegal but stream attributes and Convention pragmas are correct.
12262 elsif Has_Private_Component
(T
) then
12263 if Nkind
(N
) = N_Pragma
then
12268 ("representation item must appear after type is fully defined",
12275 end Rep_Item_Too_Early
;
12277 -----------------------
12278 -- Rep_Item_Too_Late --
12279 -----------------------
12281 function Rep_Item_Too_Late
12284 FOnly
: Boolean := False) return Boolean
12287 Parent_Type
: Entity_Id
;
12289 procedure No_Type_Rep_Item
;
12290 -- Output message indicating that no type-related aspects can be
12291 -- specified due to some property of the parent type.
12293 procedure Too_Late
;
12294 -- Output message for an aspect being specified too late
12296 -- Note that neither of the above errors is considered a serious one,
12297 -- since the effect is simply that we ignore the representation clause
12299 -- Is this really true? In any case if we make this change we must
12300 -- document the requirement in the spec of Rep_Item_Too_Late that
12301 -- if True is returned, then the rep item must be completely ignored???
12303 ----------------------
12304 -- No_Type_Rep_Item --
12305 ----------------------
12307 procedure No_Type_Rep_Item
is
12309 Error_Msg_N
("|type-related representation item not permitted!", N
);
12310 end No_Type_Rep_Item
;
12316 procedure Too_Late
is
12318 -- Other compilers seem more relaxed about rep items appearing too
12319 -- late. Since analysis tools typically don't care about rep items
12320 -- anyway, no reason to be too strict about this.
12322 if not Relaxed_RM_Semantics
then
12323 Error_Msg_N
("|representation item appears too late!", N
);
12327 -- Start of processing for Rep_Item_Too_Late
12330 -- First make sure entity is not frozen (RM 13.1(9))
12334 -- Exclude imported types, which may be frozen if they appear in a
12335 -- representation clause for a local type.
12337 and then not From_Limited_With
(T
)
12339 -- Exclude generated entities (not coming from source). The common
12340 -- case is when we generate a renaming which prematurely freezes the
12341 -- renamed internal entity, but we still want to be able to set copies
12342 -- of attribute values such as Size/Alignment.
12344 and then Comes_From_Source
(T
)
12346 -- A self-referential aspect is illegal if it forces freezing the
12347 -- entity before the corresponding pragma has been analyzed.
12349 if Nkind_In
(N
, N_Attribute_Definition_Clause
, N_Pragma
)
12350 and then From_Aspect_Specification
(N
)
12353 ("aspect specification causes premature freezing of&", N
, T
);
12354 Set_Has_Delayed_Freeze
(T
, False);
12359 S
:= First_Subtype
(T
);
12361 if Present
(Freeze_Node
(S
)) then
12362 if not Relaxed_RM_Semantics
then
12364 ("??no more representation items for }", Freeze_Node
(S
), S
);
12370 -- Check for case of untagged derived type whose parent either has
12371 -- primitive operations, or is a by reference type (RM 13.1(10)). In
12372 -- this case we do not output a Too_Late message, since there is no
12373 -- earlier point where the rep item could be placed to make it legal.
12377 and then Is_Derived_Type
(T
)
12378 and then not Is_Tagged_Type
(T
)
12380 Parent_Type
:= Etype
(Base_Type
(T
));
12382 if Has_Primitive_Operations
(Parent_Type
) then
12385 if not Relaxed_RM_Semantics
then
12387 ("\parent type & has primitive operations!", N
, Parent_Type
);
12392 elsif Is_By_Reference_Type
(Parent_Type
) then
12395 if not Relaxed_RM_Semantics
then
12397 ("\parent type & is a by reference type!", N
, Parent_Type
);
12404 -- No error, but one more warning to consider. The RM (surprisingly)
12405 -- allows this pattern:
12408 -- primitive operations for S
12409 -- type R is new S;
12410 -- rep clause for S
12412 -- Meaning that calls on the primitive operations of S for values of
12413 -- type R may require possibly expensive implicit conversion operations.
12414 -- This is not an error, but is worth a warning.
12416 if not Relaxed_RM_Semantics
and then Is_Type
(T
) then
12418 DTL
: constant Entity_Id
:= Derived_Type_Link
(Base_Type
(T
));
12422 and then Has_Primitive_Operations
(Base_Type
(T
))
12424 -- For now, do not generate this warning for the case of aspect
12425 -- specification using Ada 2012 syntax, since we get wrong
12426 -- messages we do not understand. The whole business of derived
12427 -- types and rep items seems a bit confused when aspects are
12428 -- used, since the aspects are not evaluated till freeze time.
12430 and then not From_Aspect_Specification
(N
)
12432 Error_Msg_Sloc
:= Sloc
(DTL
);
12434 ("representation item for& appears after derived type "
12435 & "declaration#??", N
);
12437 ("\may result in implicit conversions for primitive "
12438 & "operations of&??", N
, T
);
12440 ("\to change representations when called with arguments "
12441 & "of type&??", N
, DTL
);
12446 -- No error, link item into head of chain of rep items for the entity,
12447 -- but avoid chaining if we have an overloadable entity, and the pragma
12448 -- is one that can apply to multiple overloaded entities.
12450 if Is_Overloadable
(T
) and then Nkind
(N
) = N_Pragma
then
12452 Pname
: constant Name_Id
:= Pragma_Name
(N
);
12454 if Nam_In
(Pname
, Name_Convention
, Name_Import
, Name_Export
,
12455 Name_External
, Name_Interface
)
12462 Record_Rep_Item
(T
, N
);
12464 end Rep_Item_Too_Late
;
12466 -------------------------------------
12467 -- Replace_Type_References_Generic --
12468 -------------------------------------
12470 procedure Replace_Type_References_Generic
(N
: Node_Id
; T
: Entity_Id
) is
12471 TName
: constant Name_Id
:= Chars
(T
);
12473 function Replace_Type_Ref
(N
: Node_Id
) return Traverse_Result
;
12474 -- Processes a single node in the traversal procedure below, checking
12475 -- if node N should be replaced, and if so, doing the replacement.
12477 function Visible_Component
(Comp
: Name_Id
) return Entity_Id
;
12478 -- Given an identifier in the expression, check whether there is a
12479 -- discriminant or component of the type that is directy visible, and
12480 -- rewrite it as the corresponding selected component of the formal of
12481 -- the subprogram. The entity is located by a sequential search, which
12482 -- seems acceptable given the typical size of component lists and check
12483 -- expressions. Possible optimization ???
12485 ----------------------
12486 -- Replace_Type_Ref --
12487 ----------------------
12489 function Replace_Type_Ref
(N
: Node_Id
) return Traverse_Result
is
12490 Loc
: constant Source_Ptr
:= Sloc
(N
);
12492 procedure Add_Prefix
(Ref
: Node_Id
; Comp
: Entity_Id
);
12493 -- Add the proper prefix to a reference to a component of the type
12494 -- when it is not already a selected component.
12500 procedure Add_Prefix
(Ref
: Node_Id
; Comp
: Entity_Id
) is
12503 Make_Selected_Component
(Loc
,
12504 Prefix
=> New_Occurrence_Of
(T
, Loc
),
12505 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
)));
12506 Replace_Type_Reference
(Prefix
(Ref
));
12515 -- Start of processing for Replace_Type_Ref
12518 if Nkind
(N
) = N_Identifier
then
12520 -- If not the type name, check whether it is a reference to some
12521 -- other type, which must be frozen before the predicate function
12522 -- is analyzed, i.e. before the freeze node of the type to which
12523 -- the predicate applies.
12525 if Chars
(N
) /= TName
then
12526 if Present
(Current_Entity
(N
))
12527 and then Is_Type
(Current_Entity
(N
))
12529 Freeze_Before
(Freeze_Node
(T
), Current_Entity
(N
));
12532 -- The components of the type are directly visible and can
12533 -- be referenced without a prefix.
12535 if Nkind
(Parent
(N
)) = N_Selected_Component
then
12538 -- In expression C (I), C may be a directly visible function
12539 -- or a visible component that has an array type. Disambiguate
12540 -- by examining the component type.
12542 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
12543 and then N
= Prefix
(Parent
(N
))
12545 Comp
:= Visible_Component
(Chars
(N
));
12547 if Present
(Comp
) and then Is_Array_Type
(Etype
(Comp
)) then
12548 Add_Prefix
(N
, Comp
);
12552 Comp
:= Visible_Component
(Chars
(N
));
12554 if Present
(Comp
) then
12555 Add_Prefix
(N
, Comp
);
12561 -- Otherwise do the replacement and we are done with this node
12564 Replace_Type_Reference
(N
);
12568 -- Case of selected component (which is what a qualification looks
12569 -- like in the unanalyzed tree, which is what we have.
12571 elsif Nkind
(N
) = N_Selected_Component
then
12573 -- If selector name is not our type, keeping going (we might still
12574 -- have an occurrence of the type in the prefix).
12576 if Nkind
(Selector_Name
(N
)) /= N_Identifier
12577 or else Chars
(Selector_Name
(N
)) /= TName
12581 -- Selector name is our type, check qualification
12584 -- Loop through scopes and prefixes, doing comparison
12586 Scop
:= Current_Scope
;
12587 Pref
:= Prefix
(N
);
12589 -- Continue if no more scopes or scope with no name
12591 if No
(Scop
) or else Nkind
(Scop
) not in N_Has_Chars
then
12595 -- Do replace if prefix is an identifier matching the scope
12596 -- that we are currently looking at.
12598 if Nkind
(Pref
) = N_Identifier
12599 and then Chars
(Pref
) = Chars
(Scop
)
12601 Replace_Type_Reference
(N
);
12605 -- Go check scope above us if prefix is itself of the form
12606 -- of a selected component, whose selector matches the scope
12607 -- we are currently looking at.
12609 if Nkind
(Pref
) = N_Selected_Component
12610 and then Nkind
(Selector_Name
(Pref
)) = N_Identifier
12611 and then Chars
(Selector_Name
(Pref
)) = Chars
(Scop
)
12613 Scop
:= Scope
(Scop
);
12614 Pref
:= Prefix
(Pref
);
12616 -- For anything else, we don't have a match, so keep on
12617 -- going, there are still some weird cases where we may
12618 -- still have a replacement within the prefix.
12626 -- Continue for any other node kind
12631 end Replace_Type_Ref
;
12633 procedure Replace_Type_Refs
is new Traverse_Proc
(Replace_Type_Ref
);
12635 -----------------------
12636 -- Visible_Component --
12637 -----------------------
12639 function Visible_Component
(Comp
: Name_Id
) return Entity_Id
is
12643 -- Types with nameable components are records and discriminated
12646 if Ekind
(T
) = E_Record_Type
12647 or else (Is_Private_Type
(T
) and then Has_Discriminants
(T
))
12649 E
:= First_Entity
(T
);
12650 while Present
(E
) loop
12651 if Comes_From_Source
(E
) and then Chars
(E
) = Comp
then
12659 -- Nothing by that name, or the type has no components
12662 end Visible_Component
;
12664 -- Start of processing for Replace_Type_References_Generic
12667 Replace_Type_Refs
(N
);
12668 end Replace_Type_References_Generic
;
12670 --------------------------------
12671 -- Resolve_Aspect_Expressions --
12672 --------------------------------
12674 procedure Resolve_Aspect_Expressions
(E
: Entity_Id
) is
12675 function Resolve_Name
(N
: Node_Id
) return Traverse_Result
;
12676 -- Verify that all identifiers in the expression, with the exception
12677 -- of references to the current entity, denote visible entities. This
12678 -- is done only to detect visibility errors, as the expression will be
12679 -- properly analyzed/expanded during analysis of the predicate function
12680 -- body. We omit quantified expressions from this test, given that they
12681 -- introduce a local identifier that would require proper expansion to
12682 -- handle properly.
12684 -- In ASIS_Mode we preserve the entity in the source because there is
12685 -- no subsequent expansion to decorate the tree.
12691 function Resolve_Name
(N
: Node_Id
) return Traverse_Result
is
12692 Dummy
: Traverse_Result
;
12695 if Nkind
(N
) = N_Selected_Component
then
12696 if Nkind
(Prefix
(N
)) = N_Identifier
12697 and then Chars
(Prefix
(N
)) /= Chars
(E
)
12699 Find_Selected_Component
(N
);
12704 elsif Nkind
(N
) = N_Identifier
and then Chars
(N
) /= Chars
(E
) then
12705 Find_Direct_Name
(N
);
12707 -- In ASIS mode we must analyze overloaded identifiers to ensure
12708 -- their correct decoration because expansion is disabled (and
12709 -- the expansion of freeze nodes takes care of resolving aspect
12713 if Is_Overloaded
(N
) then
12714 Analyze
(Parent
(N
));
12717 Set_Entity
(N
, Empty
);
12720 -- The name is component association needs no resolution.
12722 elsif Nkind
(N
) = N_Component_Association
then
12723 Dummy
:= Resolve_Name
(Expression
(N
));
12726 elsif Nkind
(N
) = N_Quantified_Expression
then
12733 procedure Resolve_Aspect_Expression
is new Traverse_Proc
(Resolve_Name
);
12737 ASN
: Node_Id
:= First_Rep_Item
(E
);
12739 -- Start of processing for Resolve_Aspect_Expressions
12742 -- Need to make sure discriminants, if any, are directly visible
12744 Push_Scope_And_Install_Discriminants
(E
);
12746 while Present
(ASN
) loop
12747 if Nkind
(ASN
) = N_Aspect_Specification
and then Entity
(ASN
) = E
then
12749 A_Id
: constant Aspect_Id
:= Get_Aspect_Id
(ASN
);
12750 Expr
: constant Node_Id
:= Expression
(ASN
);
12755 -- For now we only deal with aspects that do not generate
12756 -- subprograms, or that may mention current instances of
12757 -- types. These will require special handling (???TBD).
12759 when Aspect_Invariant
12761 | Aspect_Predicate_Failure
12765 when Aspect_Dynamic_Predicate
12766 | Aspect_Static_Predicate
12768 -- Build predicate function specification and preanalyze
12769 -- expression after type replacement. The function
12770 -- declaration must be analyzed in the scope of the
12771 -- type, but the expression must see components.
12773 if No
(Predicate_Function
(E
)) then
12774 Uninstall_Discriminants_And_Pop_Scope
(E
);
12776 FDecl
: constant Node_Id
:=
12777 Build_Predicate_Function_Declaration
(E
);
12778 pragma Unreferenced
(FDecl
);
12781 Push_Scope_And_Install_Discriminants
(E
);
12782 Resolve_Aspect_Expression
(Expr
);
12786 when Pre_Post_Aspects
=>
12789 when Aspect_Iterable
=>
12790 if Nkind
(Expr
) = N_Aggregate
then
12795 Assoc
:= First
(Component_Associations
(Expr
));
12796 while Present
(Assoc
) loop
12797 Find_Direct_Name
(Expression
(Assoc
));
12803 -- The expression for Default_Value is a static expression
12804 -- of the type, but this expression does not freeze the
12805 -- type, so it can still appear in a representation clause
12806 -- before the actual freeze point.
12808 when Aspect_Default_Value
=>
12809 Set_Must_Not_Freeze
(Expr
);
12810 Preanalyze_Spec_Expression
(Expr
, E
);
12813 if Present
(Expr
) then
12814 case Aspect_Argument
(A_Id
) is
12816 | Optional_Expression
12818 Analyze_And_Resolve
(Expr
);
12823 if Nkind
(Expr
) = N_Identifier
then
12824 Find_Direct_Name
(Expr
);
12826 elsif Nkind
(Expr
) = N_Selected_Component
then
12827 Find_Selected_Component
(Expr
);
12835 ASN
:= Next_Rep_Item
(ASN
);
12838 Uninstall_Discriminants_And_Pop_Scope
(E
);
12839 end Resolve_Aspect_Expressions
;
12841 -------------------------
12842 -- Same_Representation --
12843 -------------------------
12845 function Same_Representation
(Typ1
, Typ2
: Entity_Id
) return Boolean is
12846 T1
: constant Entity_Id
:= Underlying_Type
(Typ1
);
12847 T2
: constant Entity_Id
:= Underlying_Type
(Typ2
);
12850 -- A quick check, if base types are the same, then we definitely have
12851 -- the same representation, because the subtype specific representation
12852 -- attributes (Size and Alignment) do not affect representation from
12853 -- the point of view of this test.
12855 if Base_Type
(T1
) = Base_Type
(T2
) then
12858 elsif Is_Private_Type
(Base_Type
(T2
))
12859 and then Base_Type
(T1
) = Full_View
(Base_Type
(T2
))
12864 -- Tagged types always have the same representation, because it is not
12865 -- possible to specify different representations for common fields.
12867 if Is_Tagged_Type
(T1
) then
12871 -- Representations are definitely different if conventions differ
12873 if Convention
(T1
) /= Convention
(T2
) then
12877 -- Representations are different if component alignments or scalar
12878 -- storage orders differ.
12880 if (Is_Record_Type
(T1
) or else Is_Array_Type
(T1
))
12882 (Is_Record_Type
(T2
) or else Is_Array_Type
(T2
))
12884 (Component_Alignment
(T1
) /= Component_Alignment
(T2
)
12885 or else Reverse_Storage_Order
(T1
) /= Reverse_Storage_Order
(T2
))
12890 -- For arrays, the only real issue is component size. If we know the
12891 -- component size for both arrays, and it is the same, then that's
12892 -- good enough to know we don't have a change of representation.
12894 if Is_Array_Type
(T1
) then
12895 if Known_Component_Size
(T1
)
12896 and then Known_Component_Size
(T2
)
12897 and then Component_Size
(T1
) = Component_Size
(T2
)
12903 -- For records, representations are different if reorderings differ
12905 if Is_Record_Type
(T1
)
12906 and then Is_Record_Type
(T2
)
12907 and then No_Reordering
(T1
) /= No_Reordering
(T2
)
12912 -- Types definitely have same representation if neither has non-standard
12913 -- representation since default representations are always consistent.
12914 -- If only one has non-standard representation, and the other does not,
12915 -- then we consider that they do not have the same representation. They
12916 -- might, but there is no way of telling early enough.
12918 if Has_Non_Standard_Rep
(T1
) then
12919 if not Has_Non_Standard_Rep
(T2
) then
12923 return not Has_Non_Standard_Rep
(T2
);
12926 -- Here the two types both have non-standard representation, and we need
12927 -- to determine if they have the same non-standard representation.
12929 -- For arrays, we simply need to test if the component sizes are the
12930 -- same. Pragma Pack is reflected in modified component sizes, so this
12931 -- check also deals with pragma Pack.
12933 if Is_Array_Type
(T1
) then
12934 return Component_Size
(T1
) = Component_Size
(T2
);
12936 -- Case of record types
12938 elsif Is_Record_Type
(T1
) then
12940 -- Packed status must conform
12942 if Is_Packed
(T1
) /= Is_Packed
(T2
) then
12945 -- Otherwise we must check components. Typ2 maybe a constrained
12946 -- subtype with fewer components, so we compare the components
12947 -- of the base types.
12950 Record_Case
: declare
12951 CD1
, CD2
: Entity_Id
;
12953 function Same_Rep
return Boolean;
12954 -- CD1 and CD2 are either components or discriminants. This
12955 -- function tests whether they have the same representation.
12961 function Same_Rep
return Boolean is
12963 if No
(Component_Clause
(CD1
)) then
12964 return No
(Component_Clause
(CD2
));
12966 -- Note: at this point, component clauses have been
12967 -- normalized to the default bit order, so that the
12968 -- comparison of Component_Bit_Offsets is meaningful.
12971 Present
(Component_Clause
(CD2
))
12973 Component_Bit_Offset
(CD1
) = Component_Bit_Offset
(CD2
)
12975 Esize
(CD1
) = Esize
(CD2
);
12979 -- Start of processing for Record_Case
12982 if Has_Discriminants
(T1
) then
12984 -- The number of discriminants may be different if the
12985 -- derived type has fewer (constrained by values). The
12986 -- invisible discriminants retain the representation of
12987 -- the original, so the discrepancy does not per se
12988 -- indicate a different representation.
12990 CD1
:= First_Discriminant
(T1
);
12991 CD2
:= First_Discriminant
(T2
);
12992 while Present
(CD1
) and then Present
(CD2
) loop
12993 if not Same_Rep
then
12996 Next_Discriminant
(CD1
);
12997 Next_Discriminant
(CD2
);
13002 CD1
:= First_Component
(Underlying_Type
(Base_Type
(T1
)));
13003 CD2
:= First_Component
(Underlying_Type
(Base_Type
(T2
)));
13004 while Present
(CD1
) loop
13005 if not Same_Rep
then
13008 Next_Component
(CD1
);
13009 Next_Component
(CD2
);
13017 -- For enumeration types, we must check each literal to see if the
13018 -- representation is the same. Note that we do not permit enumeration
13019 -- representation clauses for Character and Wide_Character, so these
13020 -- cases were already dealt with.
13022 elsif Is_Enumeration_Type
(T1
) then
13023 Enumeration_Case
: declare
13024 L1
, L2
: Entity_Id
;
13027 L1
:= First_Literal
(T1
);
13028 L2
:= First_Literal
(T2
);
13029 while Present
(L1
) loop
13030 if Enumeration_Rep
(L1
) /= Enumeration_Rep
(L2
) then
13039 end Enumeration_Case
;
13041 -- Any other types have the same representation for these purposes
13046 end Same_Representation
;
13048 --------------------------------
13049 -- Resolve_Iterable_Operation --
13050 --------------------------------
13052 procedure Resolve_Iterable_Operation
13054 Cursor
: Entity_Id
;
13063 if not Is_Overloaded
(N
) then
13064 if not Is_Entity_Name
(N
)
13065 or else Ekind
(Entity
(N
)) /= E_Function
13066 or else Scope
(Entity
(N
)) /= Scope
(Typ
)
13067 or else No
(First_Formal
(Entity
(N
)))
13068 or else Etype
(First_Formal
(Entity
(N
))) /= Typ
13070 Error_Msg_N
("iterable primitive must be local function name "
13071 & "whose first formal is an iterable type", N
);
13076 F1
:= First_Formal
(Ent
);
13077 if Nam
= Name_First
then
13079 -- First (Container) => Cursor
13081 if Etype
(Ent
) /= Cursor
then
13082 Error_Msg_N
("primitive for First must yield a curosr", N
);
13085 elsif Nam
= Name_Next
then
13087 -- Next (Container, Cursor) => Cursor
13089 F2
:= Next_Formal
(F1
);
13091 if Etype
(F2
) /= Cursor
13092 or else Etype
(Ent
) /= Cursor
13093 or else Present
(Next_Formal
(F2
))
13095 Error_Msg_N
("no match for Next iterable primitive", N
);
13098 elsif Nam
= Name_Has_Element
then
13100 -- Has_Element (Container, Cursor) => Boolean
13102 F2
:= Next_Formal
(F1
);
13103 if Etype
(F2
) /= Cursor
13104 or else Etype
(Ent
) /= Standard_Boolean
13105 or else Present
(Next_Formal
(F2
))
13107 Error_Msg_N
("no match for Has_Element iterable primitive", N
);
13110 elsif Nam
= Name_Element
then
13111 F2
:= Next_Formal
(F1
);
13114 or else Etype
(F2
) /= Cursor
13115 or else Present
(Next_Formal
(F2
))
13117 Error_Msg_N
("no match for Element iterable primitive", N
);
13122 raise Program_Error
;
13126 -- Overloaded case: find subprogram with proper signature.
13127 -- Caller will report error if no match is found.
13134 Get_First_Interp
(N
, I
, It
);
13135 while Present
(It
.Typ
) loop
13136 if Ekind
(It
.Nam
) = E_Function
13137 and then Scope
(It
.Nam
) = Scope
(Typ
)
13138 and then Etype
(First_Formal
(It
.Nam
)) = Typ
13140 F1
:= First_Formal
(It
.Nam
);
13142 if Nam
= Name_First
then
13143 if Etype
(It
.Nam
) = Cursor
13144 and then No
(Next_Formal
(F1
))
13146 Set_Entity
(N
, It
.Nam
);
13150 elsif Nam
= Name_Next
then
13151 F2
:= Next_Formal
(F1
);
13154 and then No
(Next_Formal
(F2
))
13155 and then Etype
(F2
) = Cursor
13156 and then Etype
(It
.Nam
) = Cursor
13158 Set_Entity
(N
, It
.Nam
);
13162 elsif Nam
= Name_Has_Element
then
13163 F2
:= Next_Formal
(F1
);
13166 and then No
(Next_Formal
(F2
))
13167 and then Etype
(F2
) = Cursor
13168 and then Etype
(It
.Nam
) = Standard_Boolean
13170 Set_Entity
(N
, It
.Nam
);
13171 F2
:= Next_Formal
(F1
);
13175 elsif Nam
= Name_Element
then
13176 F2
:= Next_Formal
(F1
);
13179 and then No
(Next_Formal
(F2
))
13180 and then Etype
(F2
) = Cursor
13182 Set_Entity
(N
, It
.Nam
);
13188 Get_Next_Interp
(I
, It
);
13192 end Resolve_Iterable_Operation
;
13198 procedure Set_Biased
13202 Biased
: Boolean := True)
13206 Set_Has_Biased_Representation
(E
);
13208 if Warn_On_Biased_Representation
then
13210 ("?B?" & Msg
& " forces biased representation for&", N
, E
);
13215 --------------------
13216 -- Set_Enum_Esize --
13217 --------------------
13219 procedure Set_Enum_Esize
(T
: Entity_Id
) is
13225 Init_Alignment
(T
);
13227 -- Find the minimum standard size (8,16,32,64) that fits
13229 Lo
:= Enumeration_Rep
(Entity
(Type_Low_Bound
(T
)));
13230 Hi
:= Enumeration_Rep
(Entity
(Type_High_Bound
(T
)));
13233 if Lo
>= -Uint_2
**07 and then Hi
< Uint_2
**07 then
13234 Sz
:= Standard_Character_Size
; -- May be > 8 on some targets
13236 elsif Lo
>= -Uint_2
**15 and then Hi
< Uint_2
**15 then
13239 elsif Lo
>= -Uint_2
**31 and then Hi
< Uint_2
**31 then
13242 else pragma Assert
(Lo
>= -Uint_2
**63 and then Hi
< Uint_2
**63);
13247 if Hi
< Uint_2
**08 then
13248 Sz
:= Standard_Character_Size
; -- May be > 8 on some targets
13250 elsif Hi
< Uint_2
**16 then
13253 elsif Hi
< Uint_2
**32 then
13256 else pragma Assert
(Hi
< Uint_2
**63);
13261 -- That minimum is the proper size unless we have a foreign convention
13262 -- and the size required is 32 or less, in which case we bump the size
13263 -- up to 32. This is required for C and C++ and seems reasonable for
13264 -- all other foreign conventions.
13266 if Has_Foreign_Convention
(T
)
13267 and then Esize
(T
) < Standard_Integer_Size
13269 -- Don't do this if Short_Enums on target
13271 and then not Target_Short_Enums
13273 Init_Esize
(T
, Standard_Integer_Size
);
13275 Init_Esize
(T
, Sz
);
13277 end Set_Enum_Esize
;
13279 -----------------------------
13280 -- Uninstall_Discriminants --
13281 -----------------------------
13283 procedure Uninstall_Discriminants
(E
: Entity_Id
) is
13289 -- Discriminants have been made visible for type declarations and
13290 -- protected type declarations, not for subtype declarations.
13292 if Nkind
(Parent
(E
)) /= N_Subtype_Declaration
then
13293 Disc
:= First_Discriminant
(E
);
13294 while Present
(Disc
) loop
13295 if Disc
/= Current_Entity
(Disc
) then
13296 Prev
:= Current_Entity
(Disc
);
13297 while Present
(Prev
)
13298 and then Present
(Homonym
(Prev
))
13299 and then Homonym
(Prev
) /= Disc
13301 Prev
:= Homonym
(Prev
);
13307 Set_Is_Immediately_Visible
(Disc
, False);
13309 Outer
:= Homonym
(Disc
);
13310 while Present
(Outer
) and then Scope
(Outer
) = E
loop
13311 Outer
:= Homonym
(Outer
);
13314 -- Reset homonym link of other entities, but do not modify link
13315 -- between entities in current scope, so that the back end can
13316 -- have a proper count of local overloadings.
13319 Set_Name_Entity_Id
(Chars
(Disc
), Outer
);
13321 elsif Scope
(Prev
) /= Scope
(Disc
) then
13322 Set_Homonym
(Prev
, Outer
);
13325 Next_Discriminant
(Disc
);
13328 end Uninstall_Discriminants
;
13330 -------------------------------------------
13331 -- Uninstall_Discriminants_And_Pop_Scope --
13332 -------------------------------------------
13334 procedure Uninstall_Discriminants_And_Pop_Scope
(E
: Entity_Id
) is
13336 if Has_Discriminants
(E
) then
13337 Uninstall_Discriminants
(E
);
13340 end Uninstall_Discriminants_And_Pop_Scope
;
13342 ------------------------------
13343 -- Validate_Address_Clauses --
13344 ------------------------------
13346 procedure Validate_Address_Clauses
is
13347 function Offset_Value
(Expr
: Node_Id
) return Uint
;
13348 -- Given an Address attribute reference, return the value in bits of its
13349 -- offset from the first bit of the underlying entity, or 0 if it is not
13350 -- known at compile time.
13356 function Offset_Value
(Expr
: Node_Id
) return Uint
is
13357 N
: Node_Id
:= Prefix
(Expr
);
13359 Val
: Uint
:= Uint_0
;
13362 -- Climb the prefix chain and compute the cumulative offset
13365 if Is_Entity_Name
(N
) then
13368 elsif Nkind
(N
) = N_Selected_Component
then
13369 Off
:= Component_Bit_Offset
(Entity
(Selector_Name
(N
)));
13370 if Off
/= No_Uint
and then Off
>= Uint_0
then
13377 elsif Nkind
(N
) = N_Indexed_Component
then
13378 Off
:= Indexed_Component_Bit_Offset
(N
);
13379 if Off
/= No_Uint
then
13392 -- Start of processing for Validate_Address_Clauses
13395 for J
in Address_Clause_Checks
.First
.. Address_Clause_Checks
.Last
loop
13397 ACCR
: Address_Clause_Check_Record
13398 renames Address_Clause_Checks
.Table
(J
);
13402 X_Alignment
: Uint
;
13403 Y_Alignment
: Uint
:= Uint_0
;
13406 Y_Size
: Uint
:= Uint_0
;
13411 -- Skip processing of this entry if warning already posted
13413 if not Address_Warning_Posted
(ACCR
.N
) then
13414 Expr
:= Original_Node
(Expression
(ACCR
.N
));
13416 -- Get alignments, sizes and offset, if any
13418 X_Alignment
:= Alignment
(ACCR
.X
);
13419 X_Size
:= Esize
(ACCR
.X
);
13421 if Present
(ACCR
.Y
) then
13422 Y_Alignment
:= Alignment
(ACCR
.Y
);
13423 Y_Size
:= Esize
(ACCR
.Y
);
13427 and then Nkind
(Expr
) = N_Attribute_Reference
13428 and then Attribute_Name
(Expr
) = Name_Address
13430 X_Offs
:= Offset_Value
(Expr
);
13435 -- Check for known value not multiple of alignment
13437 if No
(ACCR
.Y
) then
13438 if not Alignment_Checks_Suppressed
(ACCR
.X
)
13439 and then X_Alignment
/= 0
13440 and then ACCR
.A
mod X_Alignment
/= 0
13443 ("??specified address for& is inconsistent with "
13444 & "alignment", ACCR
.N
, ACCR
.X
);
13446 ("\??program execution may be erroneous (RM 13.3(27))",
13449 Error_Msg_Uint_1
:= X_Alignment
;
13450 Error_Msg_NE
("\??alignment of & is ^", ACCR
.N
, ACCR
.X
);
13453 -- Check for large object overlaying smaller one
13455 elsif Y_Size
> Uint_0
13456 and then X_Size
> Uint_0
13457 and then X_Offs
+ X_Size
> Y_Size
13459 Error_Msg_NE
("??& overlays smaller object", ACCR
.N
, ACCR
.X
);
13461 ("\??program execution may be erroneous", ACCR
.N
);
13463 Error_Msg_Uint_1
:= X_Size
;
13464 Error_Msg_NE
("\??size of & is ^", ACCR
.N
, ACCR
.X
);
13466 Error_Msg_Uint_1
:= Y_Size
;
13467 Error_Msg_NE
("\??size of & is ^", ACCR
.N
, ACCR
.Y
);
13469 if Y_Size
>= X_Size
then
13470 Error_Msg_Uint_1
:= X_Offs
;
13471 Error_Msg_NE
("\??but offset of & is ^", ACCR
.N
, ACCR
.X
);
13474 -- Check for inadequate alignment, both of the base object
13475 -- and of the offset, if any. We only do this check if the
13476 -- run-time Alignment_Check is active. No point in warning
13477 -- if this check has been suppressed (or is suppressed by
13478 -- default in the non-strict alignment machine case).
13480 -- Note: we do not check the alignment if we gave a size
13481 -- warning, since it would likely be redundant.
13483 elsif not Alignment_Checks_Suppressed
(ACCR
.X
)
13484 and then Y_Alignment
/= Uint_0
13486 (Y_Alignment
< X_Alignment
13489 and then Nkind
(Expr
) = N_Attribute_Reference
13490 and then Attribute_Name
(Expr
) = Name_Address
13491 and then Has_Compatible_Alignment
13492 (ACCR
.X
, Prefix
(Expr
), True) /=
13496 ("??specified address for& may be inconsistent with "
13497 & "alignment", ACCR
.N
, ACCR
.X
);
13499 ("\??program execution may be erroneous (RM 13.3(27))",
13502 Error_Msg_Uint_1
:= X_Alignment
;
13503 Error_Msg_NE
("\??alignment of & is ^", ACCR
.N
, ACCR
.X
);
13505 Error_Msg_Uint_1
:= Y_Alignment
;
13506 Error_Msg_NE
("\??alignment of & is ^", ACCR
.N
, ACCR
.Y
);
13508 if Y_Alignment
>= X_Alignment
then
13510 ("\??but offset is not multiple of alignment", ACCR
.N
);
13516 end Validate_Address_Clauses
;
13518 -----------------------------------------
13519 -- Validate_Compile_Time_Warning_Error --
13520 -----------------------------------------
13522 procedure Validate_Compile_Time_Warning_Error
(N
: Node_Id
) is
13524 Compile_Time_Warnings_Errors
.Append
13525 (New_Val
=> CTWE_Entry
'(Eloc => Sloc (N),
13526 Scope => Current_Scope,
13528 end Validate_Compile_Time_Warning_Error;
13530 ------------------------------------------
13531 -- Validate_Compile_Time_Warning_Errors --
13532 ------------------------------------------
13534 procedure Validate_Compile_Time_Warning_Errors is
13535 procedure Set_Scope (S : Entity_Id);
13536 -- Install all enclosing scopes of S along with S itself
13538 procedure Unset_Scope (S : Entity_Id);
13539 -- Uninstall all enclosing scopes of S along with S itself
13545 procedure Set_Scope (S : Entity_Id) is
13547 if S /= Standard_Standard then
13548 Set_Scope (Scope (S));
13558 procedure Unset_Scope (S : Entity_Id) is
13560 if S /= Standard_Standard then
13561 Unset_Scope (Scope (S));
13567 -- Start of processing for Validate_Compile_Time_Warning_Errors
13570 Expander_Mode_Save_And_Set (False);
13571 In_Compile_Time_Warning_Or_Error := True;
13573 for N in Compile_Time_Warnings_Errors.First ..
13574 Compile_Time_Warnings_Errors.Last
13577 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
13580 Set_Scope (T.Scope);
13581 Reset_Analyzed_Flags (T.Prag);
13582 Process_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
13583 Unset_Scope (T.Scope);
13587 In_Compile_Time_Warning_Or_Error := False;
13588 Expander_Mode_Restore;
13589 end Validate_Compile_Time_Warning_Errors;
13591 ---------------------------
13592 -- Validate_Independence --
13593 ---------------------------
13595 procedure Validate_Independence is
13596 SU : constant Uint := UI_From_Int (System_Storage_Unit);
13604 procedure Check_Array_Type (Atyp : Entity_Id);
13605 -- Checks if the array type Atyp has independent components, and
13606 -- if not, outputs an appropriate set of error messages.
13608 procedure No_Independence;
13609 -- Output message that independence cannot be guaranteed
13611 function OK_Component (C : Entity_Id) return Boolean;
13612 -- Checks one component to see if it is independently accessible, and
13613 -- if so yields True, otherwise yields False if independent access
13614 -- cannot be guaranteed. This is a conservative routine, it only
13615 -- returns True if it knows for sure, it returns False if it knows
13616 -- there is a problem, or it cannot be sure there is no problem.
13618 procedure Reason_Bad_Component (C : Entity_Id);
13619 -- Outputs continuation message if a reason can be determined for
13620 -- the component C being bad.
13622 ----------------------
13623 -- Check_Array_Type --
13624 ----------------------
13626 procedure Check_Array_Type (Atyp : Entity_Id) is
13627 Ctyp : constant Entity_Id := Component_Type (Atyp);
13630 -- OK if no alignment clause, no pack, and no component size
13632 if not Has_Component_Size_Clause (Atyp)
13633 and then not Has_Alignment_Clause (Atyp)
13634 and then not Is_Packed (Atyp)
13639 -- Case of component size is greater than or equal to 64 and the
13640 -- alignment of the array is at least as large as the alignment
13641 -- of the component. We are definitely OK in this situation.
13643 if Known_Component_Size (Atyp)
13644 and then Component_Size (Atyp) >= 64
13645 and then Known_Alignment (Atyp)
13646 and then Known_Alignment (Ctyp)
13647 and then Alignment (Atyp) >= Alignment (Ctyp)
13652 -- Check actual component size
13654 if not Known_Component_Size (Atyp)
13655 or else not (Addressable (Component_Size (Atyp))
13656 and then Component_Size (Atyp) < 64)
13657 or else Component_Size (Atyp) mod Esize (Ctyp) /= 0
13661 -- Bad component size, check reason
13663 if Has_Component_Size_Clause (Atyp) then
13664 P := Get_Attribute_Definition_Clause
13665 (Atyp, Attribute_Component_Size);
13667 if Present (P) then
13668 Error_Msg_Sloc := Sloc (P);
13669 Error_Msg_N ("\because of Component_Size clause#", N);
13674 if Is_Packed (Atyp) then
13675 P := Get_Rep_Pragma (Atyp, Name_Pack);
13677 if Present (P) then
13678 Error_Msg_Sloc := Sloc (P);
13679 Error_Msg_N ("\because of pragma Pack#", N);
13684 -- No reason found, just return
13689 -- Array type is OK independence-wise
13692 end Check_Array_Type;
13694 ---------------------
13695 -- No_Independence --
13696 ---------------------
13698 procedure No_Independence is
13700 if Pragma_Name (N) = Name_Independent then
13701 Error_Msg_NE ("independence cannot be guaranteed for&", N, E);
13704 ("independent components cannot be guaranteed for&", N, E);
13706 end No_Independence;
13712 function OK_Component (C : Entity_Id) return Boolean is
13713 Rec : constant Entity_Id := Scope (C);
13714 Ctyp : constant Entity_Id := Etype (C);
13717 -- OK if no component clause, no Pack, and no alignment clause
13719 if No (Component_Clause (C))
13720 and then not Is_Packed (Rec)
13721 and then not Has_Alignment_Clause (Rec)
13726 -- Here we look at the actual component layout. A component is
13727 -- addressable if its size is a multiple of the Esize of the
13728 -- component type, and its starting position in the record has
13729 -- appropriate alignment, and the record itself has appropriate
13730 -- alignment to guarantee the component alignment.
13732 -- Make sure sizes are static, always assume the worst for any
13733 -- cases where we cannot check static values.
13735 if not (Known_Static_Esize (C)
13737 Known_Static_Esize (Ctyp))
13742 -- Size of component must be addressable or greater than 64 bits
13743 -- and a multiple of bytes.
13745 if not Addressable (Esize (C)) and then Esize (C) < Uint_64 then
13749 -- Check size is proper multiple
13751 if Esize (C) mod Esize (Ctyp) /= 0 then
13755 -- Check alignment of component is OK
13757 if not Known_Component_Bit_Offset (C)
13758 or else Component_Bit_Offset (C) < Uint_0
13759 or else Component_Bit_Offset (C) mod Esize (Ctyp) /= 0
13764 -- Check alignment of record type is OK
13766 if not Known_Alignment (Rec)
13767 or else (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0
13772 -- All tests passed, component is addressable
13777 --------------------------
13778 -- Reason_Bad_Component --
13779 --------------------------
13781 procedure Reason_Bad_Component (C : Entity_Id) is
13782 Rec : constant Entity_Id := Scope (C);
13783 Ctyp : constant Entity_Id := Etype (C);
13786 -- If component clause present assume that's the problem
13788 if Present (Component_Clause (C)) then
13789 Error_Msg_Sloc := Sloc (Component_Clause (C));
13790 Error_Msg_N ("\because of Component_Clause#", N);
13794 -- If pragma Pack clause present, assume that's the problem
13796 if Is_Packed (Rec) then
13797 P := Get_Rep_Pragma (Rec, Name_Pack);
13799 if Present (P) then
13800 Error_Msg_Sloc := Sloc (P);
13801 Error_Msg_N ("\because of pragma Pack#", N);
13806 -- See if record has bad alignment clause
13808 if Has_Alignment_Clause (Rec)
13809 and then Known_Alignment (Rec)
13810 and then (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0
13812 P := Get_Attribute_Definition_Clause (Rec, Attribute_Alignment);
13814 if Present (P) then
13815 Error_Msg_Sloc := Sloc (P);
13816 Error_Msg_N ("\because of Alignment clause#", N);
13820 -- Couldn't find a reason, so return without a message
13823 end Reason_Bad_Component;
13825 -- Start of processing for Validate_Independence
13828 for J in Independence_Checks.First .. Independence_Checks.Last loop
13829 N := Independence_Checks.Table (J).N;
13830 E := Independence_Checks.Table (J).E;
13831 IC := Pragma_Name (N) = Name_Independent_Components;
13833 -- Deal with component case
13835 if Ekind (E) = E_Discriminant or else Ekind (E) = E_Component then
13836 if not OK_Component (E) then
13838 Reason_Bad_Component (E);
13843 -- Deal with record with Independent_Components
13845 if IC and then Is_Record_Type (E) then
13846 Comp := First_Component_Or_Discriminant (E);
13847 while Present (Comp) loop
13848 if not OK_Component (Comp) then
13850 Reason_Bad_Component (Comp);
13854 Next_Component_Or_Discriminant (Comp);
13858 -- Deal with address clause case
13860 if Is_Object (E) then
13861 Addr := Address_Clause (E);
13863 if Present (Addr) then
13865 Error_Msg_Sloc := Sloc (Addr);
13866 Error_Msg_N ("\because of Address clause#", N);
13871 -- Deal with independent components for array type
13873 if IC and then Is_Array_Type (E) then
13874 Check_Array_Type (E);
13877 -- Deal with independent components for array object
13879 if IC and then Is_Object (E) and then Is_Array_Type (Etype (E)) then
13880 Check_Array_Type (Etype (E));
13885 end Validate_Independence;
13887 ------------------------------
13888 -- Validate_Iterable_Aspect --
13889 ------------------------------
13891 procedure Validate_Iterable_Aspect (Typ : Entity_Id; ASN : Node_Id) is
13896 Cursor : constant Entity_Id := Get_Cursor_Type (ASN, Typ);
13898 First_Id : Entity_Id;
13899 Next_Id : Entity_Id;
13900 Has_Element_Id : Entity_Id;
13901 Element_Id : Entity_Id;
13904 -- If previous error aspect is unusable
13906 if Cursor = Any_Type then
13912 Has_Element_Id := Empty;
13913 Element_Id := Empty;
13915 -- Each expression must resolve to a function with the proper signature
13917 Assoc := First (Component_Associations (Expression (ASN)));
13918 while Present (Assoc) loop
13919 Expr := Expression (Assoc);
13922 Prim := First (Choices (Assoc));
13924 if Nkind (Prim) /= N_Identifier or else Present (Next (Prim)) then
13925 Error_Msg_N ("illegal name in association", Prim);
13927 elsif Chars (Prim) = Name_First then
13928 Resolve_Iterable_Operation (Expr, Cursor, Typ, Name_First);
13929 First_Id := Entity (Expr);
13931 elsif Chars (Prim) = Name_Next then
13932 Resolve_Iterable_Operation (Expr, Cursor, Typ, Name_Next);
13933 Next_Id := Entity (Expr);
13935 elsif Chars (Prim) = Name_Has_Element then
13936 Resolve_Iterable_Operation (Expr, Cursor, Typ, Name_Has_Element);
13937 Has_Element_Id := Entity (Expr);
13939 elsif Chars (Prim) = Name_Element then
13940 Resolve_Iterable_Operation (Expr, Cursor, Typ, Name_Element);
13941 Element_Id := Entity (Expr);
13944 Error_Msg_N ("invalid name for iterable function", Prim);
13950 if No (First_Id) then
13951 Error_Msg_N ("match for First primitive not found", ASN);
13953 elsif No (Next_Id) then
13954 Error_Msg_N ("match for Next primitive not found", ASN);
13956 elsif No (Has_Element_Id) then
13957 Error_Msg_N ("match for Has_Element primitive not found", ASN);
13959 elsif No (Element_Id) then
13962 end Validate_Iterable_Aspect;
13964 -----------------------------------
13965 -- Validate_Unchecked_Conversion --
13966 -----------------------------------
13968 procedure Validate_Unchecked_Conversion
13970 Act_Unit : Entity_Id)
13972 Source : Entity_Id;
13973 Target : Entity_Id;
13977 -- Obtain source and target types. Note that we call Ancestor_Subtype
13978 -- here because the processing for generic instantiation always makes
13979 -- subtypes, and we want the original frozen actual types.
13981 -- If we are dealing with private types, then do the check on their
13982 -- fully declared counterparts if the full declarations have been
13983 -- encountered (they don't have to be visible, but they must exist).
13985 Source := Ancestor_Subtype (Etype (First_Formal (Act_Unit)));
13987 if Is_Private_Type (Source)
13988 and then Present (Underlying_Type (Source))
13990 Source := Underlying_Type (Source);
13993 Target := Ancestor_Subtype (Etype (Act_Unit));
13995 -- If either type is generic, the instantiation happens within a generic
13996 -- unit, and there is nothing to check. The proper check will happen
13997 -- when the enclosing generic is instantiated.
13999 if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then
14003 if Is_Private_Type (Target)
14004 and then Present (Underlying_Type (Target))
14006 Target := Underlying_Type (Target);
14009 -- Source may be unconstrained array, but not target, except in relaxed
14012 if Is_Array_Type (Target)
14013 and then not Is_Constrained (Target)
14014 and then not Relaxed_RM_Semantics
14017 ("unchecked conversion to unconstrained array not allowed", N);
14021 -- Warn if conversion between two different convention pointers
14023 if Is_Access_Type (Target)
14024 and then Is_Access_Type (Source)
14025 and then Convention (Target) /= Convention (Source)
14026 and then Warn_On_Unchecked_Conversion
14028 -- Give warnings for subprogram pointers only on most targets
14030 if Is_Access_Subprogram_Type (Target)
14031 or else Is_Access_Subprogram_Type (Source)
14034 ("?z?conversion between pointers with different conventions!",
14039 -- Warn if one of the operands is Ada.Calendar.Time. Do not emit a
14040 -- warning when compiling GNAT-related sources.
14042 if Warn_On_Unchecked_Conversion
14043 and then not In_Predefined_Unit (N)
14044 and then RTU_Loaded (Ada_Calendar)
14045 and then (Chars (Source) = Name_Time
14047 Chars (Target) = Name_Time)
14049 -- If Ada.Calendar is loaded and the name of one of the operands is
14050 -- Time, there is a good chance that this is Ada.Calendar.Time.
14053 Calendar_Time : constant Entity_Id := Full_View (RTE (RO_CA_Time));
14055 pragma Assert (Present (Calendar_Time));
14057 if Source = Calendar_Time or else Target = Calendar_Time then
14059 ("?z?representation of 'Time values may change between
"
14060 & "'G'N'A
'T versions
", N);
14065 -- Make entry in unchecked conversion table for later processing by
14066 -- Validate_Unchecked_Conversions, which will check sizes and alignments
14067 -- (using values set by the back end where possible). This is only done
14068 -- if the appropriate warning is active.
14070 if Warn_On_Unchecked_Conversion then
14071 Unchecked_Conversions.Append
14072 (New_Val => UC_Entry'(Eloc => Sloc (N),
14075 Act_Unit => Act_Unit));
14077 -- If both sizes are known statically now, then back-end annotation
14078 -- is not required to do a proper check but if either size is not
14079 -- known statically, then we need the annotation.
14081 if Known_Static_RM_Size (Source)
14083 Known_Static_RM_Size (Target)
14087 Back_Annotate_Rep_Info := True;
14091 -- If unchecked conversion to access type, and access type is declared
14092 -- in the same unit as the unchecked conversion, then set the flag
14093 -- No_Strict_Aliasing (no strict aliasing is implicit here)
14095 if Is_Access_Type (Target) and then
14096 In_Same_Source_Unit (Target, N)
14098 Set_No_Strict_Aliasing (Implementation_Base_Type (Target));
14101 -- Generate N_Validate_Unchecked_Conversion node for back end in case
14102 -- the back end needs to perform special validation checks.
14104 -- Shouldn't this be in Exp_Ch13, since the check only gets done if we
14105 -- have full expansion and the back end is called ???
14108 Make_Validate_Unchecked_Conversion (Sloc (N));
14109 Set_Source_Type (Vnode, Source);
14110 Set_Target_Type (Vnode, Target);
14112 -- If the unchecked conversion node is in a list, just insert before it.
14113 -- If not we have some strange case, not worth bothering about.
14115 if Is_List_Member (N) then
14116 Insert_After (N, Vnode);
14118 end Validate_Unchecked_Conversion;
14120 ------------------------------------
14121 -- Validate_Unchecked_Conversions --
14122 ------------------------------------
14124 procedure Validate_Unchecked_Conversions is
14126 for N in Unchecked_Conversions.First .. Unchecked_Conversions.Last loop
14128 T : UC_Entry renames Unchecked_Conversions.Table (N);
14130 Act_Unit : constant Entity_Id := T.Act_Unit;
14131 Eloc : constant Source_Ptr := T.Eloc;
14132 Source : constant Entity_Id := T.Source;
14133 Target : constant Entity_Id := T.Target;
14139 -- Skip if function marked as warnings off
14141 if Warnings_Off (Act_Unit) then
14145 -- This validation check, which warns if we have unequal sizes for
14146 -- unchecked conversion, and thus potentially implementation
14147 -- dependent semantics, is one of the few occasions on which we
14148 -- use the official RM size instead of Esize. See description in
14149 -- Einfo "Handling
of Type'Size Values
" for details.
14151 if Serious_Errors_Detected = 0
14152 and then Known_Static_RM_Size (Source)
14153 and then Known_Static_RM_Size (Target)
14155 -- Don't do the check if warnings off for either type, note the
14156 -- deliberate use of OR here instead of OR ELSE to get the flag
14157 -- Warnings_Off_Used set for both types if appropriate.
14159 and then not (Has_Warnings_Off (Source)
14161 Has_Warnings_Off (Target))
14163 Source_Siz := RM_Size (Source);
14164 Target_Siz := RM_Size (Target);
14166 if Source_Siz /= Target_Siz then
14168 ("?z?types
for unchecked conversion have different sizes
!",
14171 if All_Errors_Mode then
14172 Error_Msg_Name_1 := Chars (Source);
14173 Error_Msg_Uint_1 := Source_Siz;
14174 Error_Msg_Name_2 := Chars (Target);
14175 Error_Msg_Uint_2 := Target_Siz;
14176 Error_Msg ("\size
of % is ^
, size
of % is ^?z?
", Eloc);
14178 Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz);
14180 if Is_Discrete_Type (Source)
14182 Is_Discrete_Type (Target)
14184 if Source_Siz > Target_Siz then
14186 ("\?z?^ high order bits
of source will
"
14187 & "be ignored
!", Eloc);
14189 elsif Is_Unsigned_Type (Source) then
14191 ("\?z?source will be extended
with ^ high order
"
14192 & "zero bits
!", Eloc);
14196 ("\?z?source will be extended
with ^ high order
"
14197 & "sign bits
!", Eloc);
14200 elsif Source_Siz < Target_Siz then
14201 if Is_Discrete_Type (Target) then
14202 if Bytes_Big_Endian then
14204 ("\?z?target value will include ^ undefined
"
14205 & "low order bits
!", Eloc);
14208 ("\?z?target value will include ^ undefined
"
14209 & "high order bits
!", Eloc);
14214 ("\?z?^ trailing bits
of target value will be
"
14215 & "undefined
!", Eloc);
14218 else pragma Assert (Source_Siz > Target_Siz);
14219 if Is_Discrete_Type (Source) then
14220 if Bytes_Big_Endian then
14222 ("\?z?^ low order bits
of source will be
"
14223 & "ignored
!", Eloc);
14226 ("\?z?^ high order bits
of source will be
"
14227 & "ignored
!", Eloc);
14232 ("\?z?^ trailing bits
of source will be
"
14233 & "ignored
!", Eloc);
14240 -- If both types are access types, we need to check the alignment.
14241 -- If the alignment of both is specified, we can do it here.
14243 if Serious_Errors_Detected = 0
14244 and then Is_Access_Type (Source)
14245 and then Is_Access_Type (Target)
14246 and then Target_Strict_Alignment
14247 and then Present (Designated_Type (Source))
14248 and then Present (Designated_Type (Target))
14251 D_Source : constant Entity_Id := Designated_Type (Source);
14252 D_Target : constant Entity_Id := Designated_Type (Target);
14255 if Known_Alignment (D_Source)
14257 Known_Alignment (D_Target)
14260 Source_Align : constant Uint := Alignment (D_Source);
14261 Target_Align : constant Uint := Alignment (D_Target);
14264 if Source_Align < Target_Align
14265 and then not Is_Tagged_Type (D_Source)
14267 -- Suppress warning if warnings suppressed on either
14268 -- type or either designated type. Note the use of
14269 -- OR here instead of OR ELSE. That is intentional,
14270 -- we would like to set flag Warnings_Off_Used in
14271 -- all types for which warnings are suppressed.
14273 and then not (Has_Warnings_Off (D_Source)
14275 Has_Warnings_Off (D_Target)
14277 Has_Warnings_Off (Source)
14279 Has_Warnings_Off (Target))
14281 Error_Msg_Uint_1 := Target_Align;
14282 Error_Msg_Uint_2 := Source_Align;
14283 Error_Msg_Node_1 := D_Target;
14284 Error_Msg_Node_2 := D_Source;
14286 ("?z?alignment
of & (^
) is stricter than
"
14287 & "alignment
of & (^
)!", Eloc);
14289 ("\?z?resulting
access value may have invalid
"
14290 & "alignment
!", Eloc);
14301 end Validate_Unchecked_Conversions;