1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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 Accessibility
; use Accessibility
;
27 with Aspects
; use Aspects
;
28 with Atree
; use Atree
;
29 with Checks
; use Checks
;
30 with Contracts
; use Contracts
;
31 with Debug
; use Debug
;
32 with Einfo
; use Einfo
;
33 with Einfo
.Entities
; use Einfo
.Entities
;
34 with Einfo
.Utils
; use Einfo
.Utils
;
35 with Elists
; use Elists
;
36 with Errout
; use Errout
;
37 with Exp_Ch3
; use Exp_Ch3
;
38 with Exp_Disp
; use Exp_Disp
;
39 with Exp_Tss
; use Exp_Tss
;
40 with Exp_Util
; use Exp_Util
;
41 with Expander
; use Expander
;
42 with Freeze
; use Freeze
;
43 with Ghost
; use Ghost
;
45 with Lib
.Xref
; use Lib
.Xref
;
46 with Namet
; use Namet
;
47 with Nlists
; use Nlists
;
48 with Nmake
; use Nmake
;
50 with Par_SCO
; use Par_SCO
;
51 with Restrict
; use Restrict
;
52 with Rident
; use Rident
;
53 with Rtsfind
; use Rtsfind
;
55 with Sem_Aux
; use Sem_Aux
;
56 with Sem_Case
; use Sem_Case
;
57 with Sem_Cat
; use Sem_Cat
;
58 with Sem_Ch3
; use Sem_Ch3
;
59 with Sem_Ch6
; use Sem_Ch6
;
60 with Sem_Ch7
; use Sem_Ch7
;
61 with Sem_Ch8
; use Sem_Ch8
;
62 with Sem_Dim
; use Sem_Dim
;
63 with Sem_Eval
; use Sem_Eval
;
64 with Sem_Prag
; use Sem_Prag
;
65 with Sem_Res
; use Sem_Res
;
66 with Sem_Type
; use Sem_Type
;
67 with Sem_Util
; use Sem_Util
;
68 with Sem_Warn
; use Sem_Warn
;
69 with Sinfo
; use Sinfo
;
70 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
71 with Sinfo
.Utils
; use Sinfo
.Utils
;
72 with Sinput
; use Sinput
;
73 with Snames
; use Snames
;
74 with Stand
; use Stand
;
75 with System
.Case_Util
; use System
.Case_Util
;
77 with Targparm
; use Targparm
;
78 with Ttypes
; use Ttypes
;
79 with Tbuild
; use Tbuild
;
80 with Urealp
; use Urealp
;
81 with Warnsw
; use Warnsw
;
83 with GNAT
.Heap_Sort_G
;
85 package body Sem_Ch13
is
87 SSU
: constant Pos
:= System_Storage_Unit
;
88 -- Convenient short hand for commonly used constant
90 -----------------------
91 -- Local Subprograms --
92 -----------------------
94 procedure Adjust_Record_For_Reverse_Bit_Order_Ada_95
(R
: Entity_Id
);
95 -- Helper routine providing the original (pre-AI95-0133) behavior for
96 -- Adjust_Record_For_Reverse_Bit_Order.
98 procedure Alignment_Check_For_Size_Change
(Typ
: Entity_Id
; Size
: Uint
);
99 -- This routine is called after setting one of the sizes of type entity
100 -- Typ to Size. The purpose is to deal with the situation of a derived
101 -- type whose inherited alignment is no longer appropriate for the new
102 -- size value. In this case, we reset the Alignment to unknown.
104 function All_Static_Choices
(L
: List_Id
) return Boolean;
105 -- Returns true if all elements of the list are OK static choices
106 -- as defined below for Is_Static_Choice. Used for case expression
107 -- alternatives and for the right operand of a membership test. An
108 -- others_choice is static if the corresponding expression is static.
109 -- The staticness of the bounds is checked separately.
111 procedure Analyze_User_Aspect_Aspect_Specification
(N
: Node_Id
);
112 -- Analyze a User_Aspect aspect specification. Called from outside
113 -- this package (in addition to locally), but the call from aspect.adb
114 -- is via an access-to-subprogram value.
116 procedure Build_Discrete_Static_Predicate
120 -- Given a predicated type Typ, where Typ is a discrete static subtype,
121 -- whose predicate expression is Expr, tests if Expr is a static predicate,
122 -- and if so, builds the predicate range list. Nam is the name of the one
123 -- argument to the predicate function. Occurrences of the type name in the
124 -- predicate expression have been replaced by identifier references to this
125 -- name, which is unique, so any identifier with Chars matching Nam must be
126 -- a reference to the type. If the predicate is non-static, this procedure
127 -- returns doing nothing. If the predicate is static, then the predicate
128 -- list is stored in Static_Discrete_Predicate (Typ), and the Expr is
129 -- rewritten as a canonicalized membership operation.
131 function Build_Export_Import_Pragma
133 Id
: Entity_Id
) return Node_Id
;
134 -- Create the corresponding pragma for aspect Export or Import denoted by
135 -- Asp. Id is the related entity subject to the aspect. Return Empty when
136 -- the expression of aspect Asp evaluates to False or is erroneous.
138 function Build_Predicate_Function_Declaration
139 (Typ
: Entity_Id
) return Node_Id
;
140 -- Build the declaration for a predicate function. The declaration is built
141 -- at the same time as the body but inserted before, as explained below.
143 procedure Build_Predicate_Function
(Typ
: Entity_Id
; N
: Node_Id
);
144 -- If Typ has predicates (indicated by Has_Predicates being set for Typ),
145 -- then either there are pragma Predicate entries on the rep chain for the
146 -- type (note that Predicate aspects are converted to pragma Predicate), or
147 -- there are inherited aspects from a parent type, or ancestor subtypes.
148 -- This procedure builds body for the Predicate function that tests these
149 -- predicates. N is the freeze node for the type. The spec of the function
150 -- is inserted before the freeze node, and the body of the function is
151 -- inserted after the freeze node.
153 procedure Check_Pool_Size_Clash
(Ent
: Entity_Id
; SP
, SS
: Node_Id
);
154 -- Called if both Storage_Pool and Storage_Size attribute definition
155 -- clauses (SP and SS) are present for entity Ent. Issue error message.
157 procedure Freeze_Entity_Checks
(N
: Node_Id
);
158 -- Called from Analyze_Freeze_Entity and Analyze_Generic_Freeze Entity
159 -- to generate appropriate semantic checks that are delayed until this
160 -- point (they had to be delayed this long for cases of delayed aspects,
161 -- e.g. analysis of statically predicated subtypes in choices, for which
162 -- we have to be sure the subtypes in question are frozen before checking).
164 function Get_Alignment_Value
(Expr
: Node_Id
) return Uint
;
165 -- Given the expression for an alignment value, returns the corresponding
166 -- Uint value. If the value is inappropriate, then error messages are
167 -- posted as required, and a value of No_Uint is returned.
169 function Is_Operational_Item
(N
: Node_Id
) return Boolean;
170 -- A specification for a stream attribute is allowed before the full type
171 -- is declared, as explained in AI-00137 and the corrigendum. Attributes
172 -- that do not specify a representation characteristic are operational
175 function Is_Static_Choice
(N
: Node_Id
) return Boolean;
176 -- Returns True if N represents a static choice (static subtype, or
177 -- static subtype indication, or static expression, or static range).
179 -- Note that this is a bit more inclusive than we actually need
180 -- (in particular membership tests do not allow the use of subtype
181 -- indications). But that doesn't matter, we have already checked
182 -- that the construct is legal to get this far.
184 function Is_Type_Related_Rep_Item
(N
: Node_Id
) return Boolean;
185 -- Returns True for a representation clause/pragma that specifies a
186 -- type-related representation (as opposed to operational) aspect.
188 function Is_Predicate_Static
191 Warn
: Boolean := True) return Boolean;
192 -- Given predicate expression Expr, tests if Expr is predicate-static in
193 -- the sense of the rules in (RM 3.2.4 (15-24)). Occurrences of the type
194 -- name in the predicate expression have been replaced by references to
195 -- an identifier whose Chars field is Nam. This name is unique, so any
196 -- identifier with Chars matching Nam must be a reference to the type.
197 -- Returns True if the expression is predicate-static and False otherwise,
198 -- but is not in the business of setting flags or issuing error messages.
200 -- Only scalar types can have static predicates, so False is always
201 -- returned for non-scalar types.
203 -- Note: the RM seems to suggest that string types can also have static
204 -- predicates. But that really makes little sense as very few useful
205 -- predicates can be constructed for strings. Remember that:
209 -- is not a static expression. So even though the clearly faulty RM wording
210 -- allows the following:
212 -- subtype S is String with Static_Predicate => S < "DEF"
214 -- We can't allow this, otherwise we have predicate-static applying to a
215 -- larger class than static expressions, which was never intended.
217 -- The Warn parameter is True iff this is not a recursive call. This
218 -- parameter is used to avoid generating warnings for subexpressions and
219 -- for cases where the predicate expression (as originally written by
220 -- the user, before any transformations) is a Boolean literal.
222 procedure New_Put_Image_Subprogram
226 -- Similar to New_Stream_Subprogram, but for the Put_Image attribute
228 procedure New_Stream_Subprogram
232 Nam
: TSS_Name_Type
);
233 -- Create a subprogram renaming of a given stream attribute to the
234 -- designated subprogram and then in the tagged case, provide this as a
235 -- primitive operation, or in the untagged case make an appropriate TSS
236 -- entry. This is more properly an expansion activity than just semantics,
237 -- but the presence of user-defined stream functions for limited types
238 -- is a legality check, which is why this takes place here rather than in
239 -- exp_ch13, where it was previously. Nam indicates the name of the TSS
240 -- function to be generated.
242 -- To avoid elaboration anomalies with freeze nodes, for untagged types
243 -- we generate both a subprogram declaration and a subprogram renaming
244 -- declaration, so that the attribute specification is handled as a
245 -- renaming_as_body. For tagged types, the specification is one of the
248 procedure No_Type_Rep_Item
(N
: Node_Id
);
249 -- Output message indicating that no type-related aspects can be
250 -- specified due to some property of the parent type.
252 procedure Register_Address_Clause_Check
258 -- Register a check for the address clause N. The rest of the parameters
259 -- are in keeping with the components of Address_Clause_Check_Record below.
261 procedure Validate_Aspect_Aggregate
(N
: Node_Id
);
262 -- Check legality of operations given in the Ada 2022 Aggregate aspect for
265 procedure Resolve_Aspect_Aggregate
268 -- Resolve each one of the operations specified in the specification of
271 procedure Validate_Aspect_Local_Restrictions
(E
: Entity_Id
; N
: Node_Id
);
272 -- Check legality of a Local_Restrictions aspect specification
274 procedure Validate_Aspect_Stable_Properties
275 (E
: Entity_Id
; N
: Node_Id
; Class_Present
: Boolean);
276 -- Check legality of functions given in the Ada 2022 Stable_Properties
277 -- (or Stable_Properties'Class) aspect.
279 procedure Validate_Storage_Model_Type_Aspect
280 (Typ
: Entity_Id
; ASN
: Node_Id
);
281 -- Check legality and completeness of the aggregate associations given in
282 -- the Storage_Model_Type aspect associated with Typ.
284 procedure Resolve_Storage_Model_Type_Argument
287 Addr_Type
: in out Entity_Id
;
289 -- Resolve argument N to be of the proper kind (when a type or constant)
290 -- or to have the proper profile (when a subprogram).
292 procedure Resolve_Aspect_Stable_Properties
293 (Typ_Or_Subp
: Entity_Id
;
295 Class_Present
: Boolean);
296 -- Resolve each one of the functions specified in the specification of
297 -- aspect Stable_Properties (or Stable_Properties'Class).
299 procedure Resolve_Iterable_Operation
304 -- If the name of a primitive operation for an Iterable aspect is
305 -- overloaded, resolve according to required signature.
311 Biased
: Boolean := True);
312 -- If Biased is True, sets Has_Biased_Representation flag for E, and
313 -- outputs a warning message at node N if Warn_On_Biased_Representation is
314 -- is True. This warning inserts the string Msg to describe the construct
317 -----------------------------------------------------------
318 -- Visibility of Discriminants in Aspect Specifications --
319 -----------------------------------------------------------
321 -- The discriminants of a type are visible when analyzing the aspect
322 -- specifications of a type declaration or protected type declaration,
323 -- but not when analyzing those of a subtype declaration. The following
324 -- routines enforce this distinction.
326 procedure Push_Type
(E
: Entity_Id
);
327 -- Push scope E and make visible the discriminants of type entity E if E
328 -- has discriminants and is not a subtype.
330 procedure Pop_Type
(E
: Entity_Id
);
331 -- Remove visibility to the discriminants of type entity E and pop the
332 -- scope stack if E has discriminants and is not a subtype.
334 ----------------------------------------------
335 -- Table for Validate_Unchecked_Conversions --
336 ----------------------------------------------
338 -- The following table collects unchecked conversions for validation.
339 -- Entries are made by Validate_Unchecked_Conversion and then the call
340 -- to Validate_Unchecked_Conversions does the actual error checking and
341 -- posting of warnings. The reason for this delayed processing is to take
342 -- advantage of back-annotations of size and alignment values performed by
345 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
346 -- that by the time Validate_Unchecked_Conversions is called, Sprint will
347 -- already have modified all Sloc values if the -gnatD option is set.
349 type UC_Entry
is record
350 Eloc
: Source_Ptr
; -- node used for posting warnings
351 Source
: Entity_Id
; -- source type for unchecked conversion
352 Target
: Entity_Id
; -- target type for unchecked conversion
353 Act_Unit
: Entity_Id
; -- actual function instantiated
356 package Unchecked_Conversions
is new Table
.Table
(
357 Table_Component_Type
=> UC_Entry
,
358 Table_Index_Type
=> Int
,
359 Table_Low_Bound
=> 1,
361 Table_Increment
=> 200,
362 Table_Name
=> "Unchecked_Conversions");
364 ----------------------------------------
365 -- Table for Validate_Address_Clauses --
366 ----------------------------------------
368 -- If an address clause has the form
370 -- for X'Address use Expr
372 -- where Expr has a value known at compile time or is of the form Y'Address
373 -- or recursively is a reference to a constant initialized with either of
374 -- these forms, and the value of Expr is not a multiple of X's alignment,
375 -- or if Y has a smaller alignment than X, then that merits a warning about
376 -- possible bad alignment. The following table collects address clauses of
377 -- this kind. We put these in a table so that they can be checked after the
378 -- back end has completed annotation of the alignments of objects, since we
379 -- can catch more cases that way.
381 type Address_Clause_Check_Record
is record
383 -- The address clause
386 -- The entity of the object subject to the address clause
389 -- The value of the address in the first case
392 -- The entity of the object being overlaid in the second case
395 -- Whether the address is offset within Y in the second case
397 Alignment_Checks_Suppressed
: Boolean;
398 -- Whether alignment checks are suppressed by an active scope suppress
399 -- setting. We need to save the value in order to be able to reuse it
400 -- after the back end has been run.
403 package Address_Clause_Checks
is new Table
.Table
(
404 Table_Component_Type
=> Address_Clause_Check_Record
,
405 Table_Index_Type
=> Int
,
406 Table_Low_Bound
=> 1,
408 Table_Increment
=> 200,
409 Table_Name
=> "Address_Clause_Checks");
411 function Alignment_Checks_Suppressed
412 (ACCR
: Address_Clause_Check_Record
) return Boolean;
413 -- Return whether the alignment check generated for the address clause
416 ---------------------------------
417 -- Alignment_Checks_Suppressed --
418 ---------------------------------
420 function Alignment_Checks_Suppressed
421 (ACCR
: Address_Clause_Check_Record
) return Boolean
424 if Checks_May_Be_Suppressed
(ACCR
.X
) then
425 return Is_Check_Suppressed
(ACCR
.X
, Alignment_Check
);
427 return ACCR
.Alignment_Checks_Suppressed
;
429 end Alignment_Checks_Suppressed
;
431 -----------------------------------------
432 -- Adjust_Record_For_Reverse_Bit_Order --
433 -----------------------------------------
435 procedure Adjust_Record_For_Reverse_Bit_Order
(R
: Entity_Id
) is
436 Max_Machine_Scalar_Size
: constant Uint
:=
437 UI_From_Int
(if Reverse_Bit_Order_Threshold
>= 0
438 then Reverse_Bit_Order_Threshold
439 else System_Max_Integer_Size
);
440 -- We use this as the maximum machine scalar size
442 SSU
: constant Uint
:= UI_From_Int
(System_Storage_Unit
);
449 -- The processing done here used to depend on the Ada version, but the
450 -- behavior has been changed by AI95-0133. However this AI is a Binding
451 -- Interpretation, so we now implement it even in Ada 95 mode. But the
452 -- original behavior from unamended Ada 95 is available for the sake of
453 -- compatibility under the debugging switch -gnatd.p in Ada 95 mode.
455 if Ada_Version
< Ada_2005
and then Debug_Flag_Dot_P
then
456 Adjust_Record_For_Reverse_Bit_Order_Ada_95
(R
);
460 -- For Ada 2005, we do machine scalar processing, as fully described In
461 -- AI-133. This involves gathering all components which start at the
462 -- same byte offset and processing them together. Same approach is still
463 -- valid in later versions including Ada 2012.
465 -- Note that component clauses found on record types may be inherited,
466 -- in which case the layout of the component with such a clause still
467 -- has to be done at this point. Therefore, the processing done here
468 -- must exclusively rely on the Component_Clause of the component.
470 -- This first loop through components does two things. First it deals
471 -- with the case of components with component clauses whose length is
472 -- greater than the maximum machine scalar size (either accepting them
473 -- or rejecting as needed). Second, it counts the number of components
474 -- with component clauses whose length does not exceed this maximum for
478 Comp
:= First_Component_Or_Discriminant
(R
);
479 while Present
(Comp
) loop
480 CC
:= Component_Clause
(Comp
);
484 Fbit
: constant Uint
:= Static_Integer
(First_Bit
(CC
));
485 Lbit
: constant Uint
:= Static_Integer
(Last_Bit
(CC
));
488 -- Case of component with last bit >= max machine scalar
490 if Lbit
>= Max_Machine_Scalar_Size
then
492 -- This is allowed only if first bit is zero, and last bit
493 -- + 1 is a multiple of storage unit size.
495 if Fbit
= 0 and then (Lbit
+ 1) mod SSU
= 0 then
497 -- This is the case to give a warning if enabled
499 if Warn_On_Reverse_Bit_Order
then
501 ("info: multi-byte field specified with "
502 & "non-standard Bit_Order?.v?", CC
);
504 if Bytes_Big_Endian
then
506 ("\bytes are not reversed "
507 & "(component is big-endian)?.v?", CC
);
510 ("\bytes are not reversed "
511 & "(component is little-endian)?.v?", CC
);
515 -- Give error message for RM 13.5.1(10) violation
519 ("machine scalar rules not followed for&",
520 First_Bit
(CC
), Comp
);
522 Error_Msg_Uint_1
:= Lbit
+ 1;
523 Error_Msg_Uint_2
:= Max_Machine_Scalar_Size
;
525 ("\last bit + 1 (^) exceeds maximum machine scalar "
526 & "size (^)", First_Bit
(CC
));
528 if (Lbit
+ 1) mod SSU
/= 0 then
529 Error_Msg_Uint_1
:= SSU
;
531 ("\and is not a multiple of Storage_Unit (^) "
532 & "(RM 13.5.1(10))", First_Bit
(CC
));
535 Error_Msg_Uint_1
:= Fbit
;
537 ("\and first bit (^) is non-zero "
538 & "(RM 13.4.1(10))", First_Bit
(CC
));
542 -- OK case of machine scalar related component clause. For now,
546 Num_CC
:= Num_CC
+ 1;
551 Next_Component_Or_Discriminant
(Comp
);
554 -- We need to sort the component clauses on the basis of the Position
555 -- values in the clause, so we can group clauses with the same Position
556 -- together to determine the relevant machine scalar size.
559 Comps
: array (0 .. Num_CC
) of Entity_Id
;
560 -- Array to collect component and discriminant entities. The data
561 -- starts at index 1, the 0'th entry is for the sort routine.
563 function CP_Lt
(Op1
, Op2
: Natural) return Boolean;
564 -- Compare routine for Sort
566 procedure CP_Move
(From
: Natural; To
: Natural);
567 -- Move routine for Sort
569 package Sorting
is new GNAT
.Heap_Sort_G
(CP_Move
, CP_Lt
);
572 -- Maximum last bit value of any component in this set
575 -- Corresponding machine scalar size
579 -- Start and stop positions in the component list of the set of
580 -- components with the same starting position (that constitute
581 -- components in a single machine scalar).
587 function CP_Lt
(Op1
, Op2
: Natural) return Boolean is
590 Position
(Component_Clause
(Comps
(Op1
))) <
591 Position
(Component_Clause
(Comps
(Op2
)));
598 procedure CP_Move
(From
: Natural; To
: Natural) is
600 Comps
(To
) := Comps
(From
);
603 -- Start of processing for Sort_CC
606 -- Collect the machine scalar relevant component clauses
609 Comp
:= First_Component_Or_Discriminant
(R
);
610 while Present
(Comp
) loop
612 CC
: constant Node_Id
:= Component_Clause
(Comp
);
615 -- Collect only component clauses whose last bit is less than
616 -- machine scalar size. Any component clause whose last bit
617 -- exceeds this value does not take part in machine scalar
618 -- layout considerations. The test for Error_Posted makes sure
619 -- we exclude component clauses for which we already posted an
623 and then not Error_Posted
(Last_Bit
(CC
))
624 and then Static_Integer
(Last_Bit
(CC
)) <
625 Max_Machine_Scalar_Size
627 Num_CC
:= Num_CC
+ 1;
628 Comps
(Num_CC
) := Comp
;
632 Next_Component_Or_Discriminant
(Comp
);
635 -- Sort by ascending position number
637 Sorting
.Sort
(Num_CC
);
639 -- We now have all the components whose size does not exceed the max
640 -- machine scalar value, sorted by starting position. In this loop we
641 -- gather groups of clauses starting at the same position, to process
642 -- them in accordance with AI-133.
645 while Stop
< Num_CC
loop
650 (Last_Bit
(Component_Clause
(Comps
(Start
))));
651 while Stop
< Num_CC
loop
653 (Position
(Component_Clause
(Comps
(Stop
+ 1)))) =
655 (Position
(Component_Clause
(Comps
(Stop
))))
663 (Component_Clause
(Comps
(Stop
)))));
669 -- Now we have a group of component clauses from Start to Stop
670 -- whose positions are identical, and MaxL is the maximum last
671 -- bit value of any of these components.
673 -- We need to determine the corresponding machine scalar size.
674 -- This loop assumes that machine scalar sizes are even, and that
675 -- each possible machine scalar has twice as many bits as the next
678 MSS
:= Max_Machine_Scalar_Size
;
680 and then (MSS
/ 2) >= SSU
681 and then (MSS
/ 2) > MaxL
686 -- Here is where we fix up the Component_Bit_Offset value to
687 -- account for the reverse bit order. Some examples of what needs
688 -- to be done for the case of a machine scalar size of 8 are:
690 -- First_Bit .. Last_Bit Component_Bit_Offset
702 -- The rule is that the first bit is obtained by subtracting the
703 -- old ending bit from machine scalar size - 1.
705 for C
in Start
.. Stop
loop
707 Comp
: constant Entity_Id
:= Comps
(C
);
708 CC
: constant Node_Id
:= Component_Clause
(Comp
);
710 FB
: constant Uint
:= Static_Integer
(First_Bit
(CC
));
711 LB
: constant Uint
:= Static_Integer
(Last_Bit
(CC
));
712 NFB
: constant Uint
:= MSS
- 1 - LB
;
713 NLB
: constant Uint
:= NFB
+ LB
- FB
;
714 Pos
: constant Uint
:= Static_Integer
(Position
(CC
));
717 -- Do not warn for the artificial clause built for the tag
718 -- in Check_Record_Representation_Clause if it is inherited.
720 if Warn_On_Reverse_Bit_Order
721 and then Chars
(Comp
) /= Name_uTag
723 Error_Msg_Uint_1
:= MSS
;
725 ("info: reverse bit order in machine scalar of "
726 & "length^?.v?", First_Bit
(CC
));
727 Error_Msg_Uint_1
:= NFB
;
728 Error_Msg_Uint_2
:= NLB
;
730 if Bytes_Big_Endian
then
732 ("\big-endian range for component & is ^ .. ^?.v?",
733 First_Bit
(CC
), Comp
);
736 ("\little-endian range for component " &
738 First_Bit
(CC
), Comp
);
742 Set_Component_Bit_Offset
(Comp
, Pos
* SSU
+ NFB
);
743 Set_Esize
(Comp
, 1 + (NLB
- NFB
));
744 Set_Normalized_First_Bit
(Comp
, NFB
mod SSU
);
745 Set_Normalized_Position
(Comp
, Pos
+ NFB
/ SSU
);
750 end Adjust_Record_For_Reverse_Bit_Order
;
752 ------------------------------------------------
753 -- Adjust_Record_For_Reverse_Bit_Order_Ada_95 --
754 ------------------------------------------------
756 procedure Adjust_Record_For_Reverse_Bit_Order_Ada_95
(R
: Entity_Id
) is
761 -- For Ada 95, we just renumber bits within a storage unit. We do the
762 -- same for Ada 83 mode, since we recognize the Bit_Order attribute in
763 -- Ada 83, and are free to add this extension.
765 Comp
:= First_Component_Or_Discriminant
(R
);
766 while Present
(Comp
) loop
767 CC
:= Component_Clause
(Comp
);
769 -- If component clause is present, then deal with the non-default
770 -- bit order case for Ada 95 mode.
772 -- We only do this processing for the base type, and in fact that
773 -- is important, since otherwise if there are record subtypes, we
774 -- could reverse the bits once for each subtype, which is wrong.
776 if Present
(CC
) and then Ekind
(R
) = E_Record_Type
then
778 CFB
: constant Uint
:= Component_Bit_Offset
(Comp
);
779 CSZ
: constant Uint
:= Esize
(Comp
);
780 CLC
: constant Node_Id
:= Component_Clause
(Comp
);
781 Pos
: constant Node_Id
:= Position
(CLC
);
782 FB
: constant Node_Id
:= First_Bit
(CLC
);
784 Storage_Unit_Offset
: constant Uint
:=
785 CFB
/ System_Storage_Unit
;
787 Start_Bit
: constant Uint
:=
788 CFB
mod System_Storage_Unit
;
791 -- Cases where field goes over storage unit boundary
793 if Start_Bit
+ CSZ
> System_Storage_Unit
then
795 -- Allow multi-byte field but generate warning
797 if Start_Bit
mod System_Storage_Unit
= 0
798 and then CSZ
mod System_Storage_Unit
= 0
801 ("info: multi-byte field specified with non-standard "
802 & "Bit_Order?.v?", CLC
);
804 if Bytes_Big_Endian
then
806 ("\bytes are not reversed "
807 & "(component is big-endian)?.v?", CLC
);
810 ("\bytes are not reversed "
811 & "(component is little-endian)?.v?", CLC
);
814 -- Do not allow non-contiguous field
818 ("attempt to specify non-contiguous field not "
821 ("\caused by non-standard Bit_Order specified in "
822 & "legacy Ada 95 mode", CLC
);
825 -- Case where field fits in one storage unit
828 -- Give warning if suspicious component clause
830 if Intval
(FB
) >= System_Storage_Unit
831 and then Warn_On_Reverse_Bit_Order
834 ("info: Bit_Order clause does not affect byte "
835 & "ordering?.v?", Pos
);
837 Intval
(Pos
) + Intval
(FB
) /
840 ("info: position normalized to ^ before bit order "
841 & "interpreted?.v?", Pos
);
844 -- Here is where we fix up the Component_Bit_Offset value
845 -- to account for the reverse bit order. Some examples of
846 -- what needs to be done are:
848 -- First_Bit .. Last_Bit Component_Bit_Offset
860 -- The rule is that the first bit is obtained by subtracting
861 -- the old ending bit from storage_unit - 1.
863 Set_Component_Bit_Offset
(Comp
,
864 (Storage_Unit_Offset
* System_Storage_Unit
) +
865 (System_Storage_Unit
- 1) -
866 (Start_Bit
+ CSZ
- 1));
868 Set_Normalized_Position
(Comp
,
869 Component_Bit_Offset
(Comp
) / System_Storage_Unit
);
871 Set_Normalized_First_Bit
(Comp
,
872 Component_Bit_Offset
(Comp
) mod System_Storage_Unit
);
877 Next_Component_Or_Discriminant
(Comp
);
879 end Adjust_Record_For_Reverse_Bit_Order_Ada_95
;
881 -------------------------------------
882 -- Alignment_Check_For_Size_Change --
883 -------------------------------------
885 procedure Alignment_Check_For_Size_Change
(Typ
: Entity_Id
; Size
: Uint
) is
887 -- If the alignment is known, and not set by a rep clause, and is
888 -- inconsistent with the size being set, then reset it to unknown,
889 -- we assume in this case that the size overrides the inherited
890 -- alignment, and that the alignment must be recomputed.
892 if Known_Alignment
(Typ
)
893 and then not Has_Alignment_Clause
(Typ
)
894 and then Present
(Size
)
895 and then Size
mod (Alignment
(Typ
) * SSU
) /= 0
897 Reinit_Alignment
(Typ
);
899 end Alignment_Check_For_Size_Change
;
901 -----------------------------------
902 -- All_Membership_Choices_Static --
903 -----------------------------------
905 function All_Membership_Choices_Static
(Expr
: Node_Id
) return Boolean is
906 pragma Assert
(Nkind
(Expr
) in N_Membership_Test
);
909 (Present
(Right_Opnd
(Expr
))
911 Present
(Alternatives
(Expr
)));
913 if Present
(Right_Opnd
(Expr
)) then
914 return Is_Static_Choice
(Right_Opnd
(Expr
));
916 return All_Static_Choices
(Alternatives
(Expr
));
918 end All_Membership_Choices_Static
;
920 ------------------------
921 -- All_Static_Choices --
922 ------------------------
924 function All_Static_Choices
(L
: List_Id
) return Boolean is
929 while Present
(N
) loop
930 if not Is_Static_Choice
(N
) then
938 end All_Static_Choices
;
940 -------------------------------------
941 -- Analyze_Aspects_At_Freeze_Point --
942 -------------------------------------
944 procedure Analyze_Aspects_At_Freeze_Point
(E
: Entity_Id
) is
945 procedure Analyze_Aspect_Default_Value
(ASN
: Node_Id
);
946 -- This routine analyzes an Aspect_Default_[Component_]Value denoted by
947 -- the aspect specification node ASN.
949 procedure Check_Aspect_Too_Late
(N
: Node_Id
);
950 -- This procedure is similar to Rep_Item_Too_Late for representation
951 -- aspects that apply to type and that do not have a corresponding
953 -- Used to check in particular that the expression associated with
954 -- aspect node N for the given type (entity) of the aspect does not
955 -- appear too late according to the rules in RM 13.1(9) and 13.1(10).
957 procedure Make_Pragma_From_Boolean_Aspect
(ASN
: Node_Id
);
958 -- Given an aspect specification node ASN whose expression is an
959 -- optional Boolean, this routines creates the corresponding pragma
960 -- at the freezing point.
962 ----------------------------------
963 -- Analyze_Aspect_Default_Value --
964 ----------------------------------
966 procedure Analyze_Aspect_Default_Value
(ASN
: Node_Id
) is
967 Ent
: constant Entity_Id
:= Entity
(ASN
);
968 Expr
: constant Node_Id
:= Expression
(ASN
);
971 Set_Has_Default_Aspect
(Base_Type
(Ent
));
973 if Is_Scalar_Type
(Ent
) then
974 Set_Default_Aspect_Value
(Base_Type
(Ent
), Expr
);
976 Set_Default_Aspect_Component_Value
(Base_Type
(Ent
), Expr
);
979 Check_Aspect_Too_Late
(ASN
);
980 end Analyze_Aspect_Default_Value
;
982 ---------------------------
983 -- Check_Aspect_Too_Late --
984 ---------------------------
986 procedure Check_Aspect_Too_Late
(N
: Node_Id
) is
987 Typ
: constant Entity_Id
:= Entity
(N
);
988 Expr
: constant Node_Id
:= Expression
(N
);
990 function Find_Type_Reference
991 (Typ
: Entity_Id
; Expr
: Node_Id
) return Boolean;
992 -- Return True if a reference to type Typ is found in the expression
995 -------------------------
996 -- Find_Type_Reference --
997 -------------------------
999 function Find_Type_Reference
1000 (Typ
: Entity_Id
; Expr
: Node_Id
) return Boolean
1002 function Find_Type
(N
: Node_Id
) return Traverse_Result
;
1003 -- Set Found to True if N refers to Typ
1009 function Find_Type
(N
: Node_Id
) return Traverse_Result
is
1012 or else (Nkind
(N
) in N_Identifier | N_Expanded_Name
1013 and then Present
(Entity
(N
))
1014 and then Entity
(N
) = Typ
)
1022 function Search_Type_Reference
is new Traverse_Func
(Find_Type
);
1025 return Search_Type_Reference
(Expr
) = Abandon
;
1026 end Find_Type_Reference
;
1028 Parent_Type
: Entity_Id
;
1031 -- Ensure Expr is analyzed so that e.g. all types are properly
1032 -- resolved for Find_Type_Reference.
1036 -- A self-referential aspect is illegal if it forces freezing the
1037 -- entity before the corresponding aspect has been analyzed.
1039 if Find_Type_Reference
(Typ
, Expr
) then
1041 ("aspect specification causes premature freezing of&", N
, Typ
);
1044 -- For representation aspects, check for case of untagged derived
1045 -- type whose parent either has primitive operations (pre Ada 2022),
1046 -- or is a by-reference type (RM 13.1(10)).
1047 -- Strictly speaking the check also applies to Ada 2012 but it is
1048 -- really too constraining for existing code already, so relax it.
1049 -- ??? Confirming aspects should be allowed here.
1051 if Is_Representation_Aspect
(Get_Aspect_Id
(N
))
1052 and then Is_Derived_Type
(Typ
)
1053 and then not Is_Tagged_Type
(Typ
)
1055 Parent_Type
:= Etype
(Base_Type
(Typ
));
1057 if Ada_Version
<= Ada_2012
1058 and then Has_Primitive_Operations
(Parent_Type
)
1061 ("|representation aspect not permitted before Ada 2022: " &
1062 "use -gnat2022!", N
);
1064 ("\parent type & has primitive operations!", N
, Parent_Type
);
1066 elsif Is_By_Reference_Type
(Parent_Type
) then
1067 No_Type_Rep_Item
(N
);
1069 ("\parent type & is a by-reference type!", N
, Parent_Type
);
1072 end Check_Aspect_Too_Late
;
1074 -------------------------------------
1075 -- Make_Pragma_From_Boolean_Aspect --
1076 -------------------------------------
1078 procedure Make_Pragma_From_Boolean_Aspect
(ASN
: Node_Id
) is
1079 Ident
: constant Node_Id
:= Identifier
(ASN
);
1080 A_Name
: constant Name_Id
:= Chars
(Ident
);
1081 A_Id
: constant Aspect_Id
:= Get_Aspect_Id
(A_Name
);
1082 Ent
: constant Entity_Id
:= Entity
(ASN
);
1083 Expr
: constant Node_Id
:= Expression
(ASN
);
1084 Loc
: constant Source_Ptr
:= Sloc
(ASN
);
1086 procedure Check_False_Aspect_For_Derived_Type
;
1087 -- This procedure checks for the case of a false aspect for a derived
1088 -- type, which improperly tries to cancel an aspect inherited from
1091 -----------------------------------------
1092 -- Check_False_Aspect_For_Derived_Type --
1093 -----------------------------------------
1095 procedure Check_False_Aspect_For_Derived_Type
is
1099 -- We are only checking derived types
1101 if not Is_Derived_Type
(E
) then
1105 Par
:= Nearest_Ancestor
(E
);
1111 if not Is_Atomic
(Par
) then
1115 when Aspect_Atomic_Components
=>
1116 if not Has_Atomic_Components
(Par
) then
1120 when Aspect_Discard_Names
=>
1121 if not Discard_Names
(Par
) then
1126 if not Is_Packed
(Par
) then
1130 when Aspect_Unchecked_Union
=>
1131 if not Is_Unchecked_Union
(Par
) then
1135 when Aspect_Volatile
=>
1136 if not Is_Volatile
(Par
) then
1140 when Aspect_Volatile_Components
=>
1141 if not Has_Volatile_Components
(Par
) then
1145 when Aspect_Volatile_Full_Access
1146 | Aspect_Full_Access_Only
1148 if not Is_Volatile_Full_Access
(Par
) then
1156 -- Fall through means we are canceling an inherited aspect
1158 Error_Msg_Name_1
:= A_Name
;
1160 ("derived type& inherits aspect%, cannot cancel", Expr
, E
);
1161 end Check_False_Aspect_For_Derived_Type
;
1168 -- Start of processing for Make_Pragma_From_Boolean_Aspect
1171 if Present
(Expr
) and then Is_False
(Static_Boolean
(Expr
)) then
1172 Check_False_Aspect_For_Derived_Type
;
1175 -- There is no Full_Access_Only pragma so use VFA instead
1177 if A_Name
= Name_Full_Access_Only
then
1178 P_Name
:= Name_Volatile_Full_Access
;
1185 Pragma_Identifier
=>
1186 Make_Identifier
(Sloc
(Ident
), P_Name
),
1187 Pragma_Argument_Associations
=> New_List
(
1188 Make_Pragma_Argument_Association
(Sloc
(Ident
),
1189 Expression
=> New_Occurrence_Of
(Ent
, Sloc
(Ident
)))));
1191 Set_From_Aspect_Specification
(Prag
, True);
1192 Set_Corresponding_Aspect
(Prag
, ASN
);
1193 Set_Aspect_Rep_Item
(ASN
, Prag
);
1194 Set_Is_Delayed_Aspect
(Prag
);
1195 Set_Parent
(Prag
, ASN
);
1197 end Make_Pragma_From_Boolean_Aspect
;
1205 -- Start of processing for Analyze_Aspects_At_Freeze_Point
1208 -- Must be visible in current scope, but if this is a type from a nested
1209 -- package it may be frozen from an object declaration in the enclosing
1210 -- scope, so install the package declarations to complete the analysis
1211 -- of the aspects, if any. If the package itself is frozen the type will
1212 -- have been frozen as well.
1214 if not Scope_Within_Or_Same
(Current_Scope
, Scope
(E
)) then
1215 if Is_Type
(E
) and then From_Nested_Package
(E
) then
1217 Pack
: constant Entity_Id
:= Scope
(E
);
1221 Install_Visible_Declarations
(Pack
);
1222 Install_Private_Declarations
(Pack
);
1223 Analyze_Aspects_At_Freeze_Point
(E
);
1225 if Is_Private_Type
(E
)
1226 and then Present
(Full_View
(E
))
1228 Analyze_Aspects_At_Freeze_Point
(Full_View
(E
));
1231 End_Package_Scope
(Pack
);
1235 -- Aspects from other entities in different contexts are analyzed
1243 -- Look for aspect specification entries for this entity
1245 ASN
:= First_Rep_Item
(E
);
1246 while Present
(ASN
) loop
1247 if Nkind
(ASN
) = N_Aspect_Specification
then
1248 exit when Entity
(ASN
) /= E
;
1250 if Is_Delayed_Aspect
(ASN
) then
1251 A_Id
:= Get_Aspect_Id
(ASN
);
1255 -- For aspects whose expression is an optional Boolean, make
1256 -- the corresponding pragma at the freeze point.
1258 when Boolean_Aspects
1259 | Library_Unit_Aspects
1261 -- Aspects Export and Import require special handling.
1262 -- Both are by definition Boolean and may benefit from
1263 -- forward references, however their expressions are
1264 -- treated as static. In addition, the syntax of their
1265 -- corresponding pragmas requires extra "pieces" which
1266 -- may also contain forward references. To account for
1267 -- all of this, the corresponding pragma is created by
1268 -- Analyze_Aspect_Export_Import, but is not analyzed as
1269 -- the complete analysis must happen now.
1271 -- Aspect Full_Access_Only must be analyzed last so that
1272 -- aspects Volatile and Atomic, if any, are analyzed.
1274 -- Skip creation of pragma Preelaborable_Initialization
1275 -- in the case where the aspect has an expression,
1276 -- because the pragma is only needed for setting flag
1277 -- Known_To_Have_Preelab_Init, which is set by other
1278 -- means following resolution of the aspect expression.
1280 if A_Id
not in Aspect_Export
1281 | Aspect_Full_Access_Only
1283 and then (A_Id
/= Aspect_Preelaborable_Initialization
1284 or else No
(Expression
(ASN
)))
1286 Make_Pragma_From_Boolean_Aspect
(ASN
);
1289 -- Special handling for aspects that don't correspond to
1290 -- pragmas/attributes.
1292 when Aspect_Default_Value
1293 | Aspect_Default_Component_Value
1295 -- Do not inherit aspect for anonymous base type of a
1296 -- scalar or array type, because they apply to the first
1297 -- subtype of the type, and will be processed when that
1298 -- first subtype is frozen.
1300 if Is_Derived_Type
(E
)
1301 and then not Comes_From_Source
(E
)
1302 and then E
/= First_Subtype
(E
)
1306 Analyze_Aspect_Default_Value
(ASN
);
1309 -- Ditto for iterator aspects, because the corresponding
1310 -- attributes may not have been analyzed yet.
1312 when Aspect_Constant_Indexing
1313 | Aspect_Default_Iterator
1314 | Aspect_Iterator_Element
1315 | Aspect_Variable_Indexing
1317 Analyze
(Expression
(ASN
));
1319 if Etype
(Expression
(ASN
)) = Any_Type
then
1321 ("\aspect must be fully defined before & is frozen",
1325 when Aspect_Integer_Literal
1326 | Aspect_Real_Literal
1327 | Aspect_String_Literal
1329 Validate_Literal_Aspect
(E
, ASN
);
1331 when Aspect_Iterable
=>
1332 Validate_Iterable_Aspect
(E
, ASN
);
1334 when Aspect_Designated_Storage_Model
=>
1335 Analyze_And_Resolve
(Expression
(ASN
));
1337 if not Is_Entity_Name
(Expression
(ASN
))
1338 or else not Is_Object
(Entity
(Expression
(ASN
)))
1340 No
(Find_Aspect
(Etype
(Expression
(ASN
)),
1341 Aspect_Storage_Model_Type
))
1344 ("must specify name of stand-alone object of type "
1345 & "with aspect Storage_Model_Type",
1348 -- Set access type's Associated_Storage_Pool to denote
1349 -- the Storage_Model_Type object given for the aspect
1350 -- (even though that isn't actually an Ada storage pool).
1353 Set_Associated_Storage_Pool
1354 (E
, Entity
(Expression
(ASN
)));
1357 when Aspect_Storage_Model_Type
=>
1358 Validate_Storage_Model_Type_Aspect
(E
, ASN
);
1360 when Aspect_Aggregate
=>
1367 Ritem
:= Aspect_Rep_Item
(ASN
);
1369 if Present
(Ritem
) then
1375 Next_Rep_Item
(ASN
);
1378 -- Make a second pass for a Full_Access_Only entry
1380 ASN
:= First_Rep_Item
(E
);
1381 while Present
(ASN
) loop
1382 if Nkind
(ASN
) = N_Aspect_Specification
then
1383 exit when Entity
(ASN
) /= E
;
1385 if Get_Aspect_Id
(ASN
) = Aspect_Full_Access_Only
then
1386 Make_Pragma_From_Boolean_Aspect
(ASN
);
1387 Ritem
:= Aspect_Rep_Item
(ASN
);
1388 if Present
(Ritem
) then
1394 Next_Rep_Item
(ASN
);
1398 and then E
/= Base_Type
(E
)
1399 and then Is_First_Subtype
(E
)
1401 Inherit_Rep_Item_Chain
(Base_Type
(E
), E
);
1403 end Analyze_Aspects_At_Freeze_Point
;
1405 -----------------------------------
1406 -- Analyze_Aspect_Specifications --
1407 -----------------------------------
1409 procedure Analyze_Aspect_Specifications
(N
: Node_Id
; E
: Entity_Id
) is
1410 pragma Assert
(Present
(E
));
1412 procedure Decorate
(Asp
: Node_Id
; Prag
: Node_Id
);
1413 -- Establish linkages between an aspect and its corresponding pragma
1415 procedure Insert_Pragma
1417 Is_Instance
: Boolean := False);
1418 -- Subsidiary to the analysis of aspects
1420 -- Always_Terminates
1424 -- Constant_After_Elaboration
1427 -- Default_Initial_Condition
1428 -- Default_Storage_Pool
1432 -- Exceptional_Cases
1433 -- Extensions_Visible
1436 -- Initial_Condition
1438 -- Max_Entry_Queue_Depth
1439 -- Max_Entry_Queue_Length
1451 -- Secondary_Stack_Size
1452 -- Subprogram_Variant
1453 -- Volatile_Function
1455 -- Insert pragma Prag such that it mimics the placement of a source
1456 -- pragma of the same kind. Flag Is_Generic should be set when the
1457 -- context denotes a generic instance.
1459 function Relocate_Expression
(Source
: Node_Id
) return Node_Id
;
1460 -- Outside of a generic this function is equivalent to Relocate_Node.
1461 -- Inside a generic it is an identity function, because Relocate_Node
1462 -- would create a new node that is not associated with the generic
1463 -- template. This association is needed to save references to entities
1464 -- that are global to the generic (and might be not visible from where
1465 -- the generic is instantiated).
1467 -- Inside a generic the original tree is shared between aspect and
1468 -- a corresponding pragma (or an attribute definition clause). This
1469 -- parallels what is done in sem_prag.adb (see Get_Argument).
1475 procedure Decorate
(Asp
: Node_Id
; Prag
: Node_Id
) is
1477 Set_Aspect_Rep_Item
(Asp
, Prag
);
1478 Set_Corresponding_Aspect
(Prag
, Asp
);
1479 Set_From_Aspect_Specification
(Prag
);
1480 Set_Parent
(Prag
, Asp
);
1487 procedure Insert_Pragma
1489 Is_Instance
: Boolean := False)
1495 Inserted
: Boolean := False;
1498 -- When the aspect appears on an entry, package, protected unit,
1499 -- subprogram, or task unit body, insert the generated pragma at the
1500 -- top of the body declarations to emulate the behavior of a source
1503 -- package body Pack with Aspect is
1505 -- package body Pack is
1508 if Nkind
(N
) in N_Entry_Body
1514 Decls
:= Declarations
(N
);
1518 Set_Declarations
(N
, Decls
);
1521 Prepend_To
(Decls
, Prag
);
1523 -- When the aspect is associated with a [generic] package declaration
1524 -- insert the generated pragma at the top of the visible declarations
1525 -- to emulate the behavior of a source pragma.
1527 -- package Pack with Aspect is
1532 elsif Nkind
(N
) in N_Generic_Package_Declaration
1533 | N_Package_Declaration
1535 Decls
:= Visible_Declarations
(Specification
(N
));
1539 Set_Visible_Declarations
(Specification
(N
), Decls
);
1542 -- The visible declarations of a generic instance have the
1543 -- following structure:
1545 -- <renamings of generic formals>
1546 -- <renamings of internally-generated spec and body>
1547 -- <first source declaration>
1549 -- Insert the pragma before the first source declaration by
1550 -- skipping the instance "header" to ensure proper visibility of
1554 Decl
:= First
(Decls
);
1555 while Present
(Decl
) loop
1556 if Comes_From_Source
(Decl
) then
1557 Insert_Before
(Decl
, Prag
);
1565 -- The pragma is placed after the instance "header"
1567 if not Inserted
then
1568 Append_To
(Decls
, Prag
);
1571 -- Otherwise this is not a generic instance
1574 Prepend_To
(Decls
, Prag
);
1577 -- When the aspect is associated with a protected unit declaration,
1578 -- insert the generated pragma at the top of the visible declarations
1579 -- the emulate the behavior of a source pragma.
1581 -- protected [type] Prot with Aspect is
1583 -- protected [type] Prot is
1586 elsif Nkind
(N
) = N_Protected_Type_Declaration
then
1587 Def
:= Protected_Definition
(N
);
1591 Make_Protected_Definition
(Sloc
(N
),
1592 Visible_Declarations
=> New_List
,
1593 End_Label
=> Empty
);
1595 Set_Protected_Definition
(N
, Def
);
1598 Decls
:= Visible_Declarations
(Def
);
1602 Set_Visible_Declarations
(Def
, Decls
);
1605 Prepend_To
(Decls
, Prag
);
1607 -- When the aspect is associated with a task unit declaration, insert
1608 -- insert the generated pragma at the top of the visible declarations
1609 -- the emulate the behavior of a source pragma.
1611 -- task [type] Prot with Aspect is
1613 -- task [type] Prot is
1616 elsif Nkind
(N
) = N_Task_Type_Declaration
then
1617 Def
:= Task_Definition
(N
);
1621 Make_Task_Definition
(Sloc
(N
),
1622 Visible_Declarations
=> New_List
,
1623 End_Label
=> Empty
);
1625 Set_Task_Definition
(N
, Def
);
1628 Decls
:= Visible_Declarations
(Def
);
1632 Set_Visible_Declarations
(Def
, Decls
);
1635 Prepend_To
(Decls
, Prag
);
1637 -- When the context is a library unit, the pragma is added to the
1638 -- Pragmas_After list.
1640 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
1641 Aux
:= Aux_Decls_Node
(Parent
(N
));
1643 if No
(Pragmas_After
(Aux
)) then
1644 Set_Pragmas_After
(Aux
, New_List
);
1647 Prepend
(Prag
, Pragmas_After
(Aux
));
1649 -- Default, the pragma is inserted after the context
1652 Insert_After
(N
, Prag
);
1656 -------------------------
1657 -- Relocate_Expression --
1658 -------------------------
1660 function Relocate_Expression
(Source
: Node_Id
) return Node_Id
is
1662 if Inside_A_Generic
then
1665 return Atree
.Relocate_Node
(Source
);
1667 end Relocate_Expression
;
1672 Aitem
: Node_Id
:= Empty
;
1675 L
: constant List_Id
:= Aspect_Specifications
(N
);
1677 Ins_Node
: Node_Id
:= N
;
1678 -- Insert pragmas/attribute definition clause after this node when no
1679 -- delayed analysis is required.
1681 -- Start of processing for Analyze_Aspect_Specifications
1684 -- The general processing involves building an attribute definition
1685 -- clause or a pragma node that corresponds to the aspect. Then in order
1686 -- to delay the evaluation of this aspect to the freeze point, we attach
1687 -- the corresponding pragma/attribute definition clause to the aspect
1688 -- specification node, which is then placed in the Rep Item chain. In
1689 -- this case we mark the entity by setting the flag Has_Delayed_Aspects
1690 -- and we evaluate the rep item at the freeze point. When the aspect
1691 -- doesn't have a corresponding pragma/attribute definition clause, then
1692 -- its analysis is simply delayed at the freeze point.
1694 -- Some special cases don't require delay analysis, thus the aspect is
1695 -- analyzed right now.
1697 -- Note that there is a special handling for Pre, Post, Test_Case,
1698 -- Contract_Cases, Always_Terminates, Exceptional_Cases and
1699 -- Subprogram_Variant aspects. In these cases, we do not have to worry
1700 -- about delay issues, since the pragmas themselves deal with delay of
1701 -- visibility for the expression analysis. Thus, we just insert the
1702 -- pragma after the node N.
1708 -- Loop through aspects
1710 Aspect
:= First
(L
);
1711 Aspect_Loop
: while Present
(Aspect
) loop
1712 Analyze_One_Aspect
: declare
1714 Aspect_Exit
: exception;
1715 -- This exception is used to exit aspect processing completely. It
1716 -- is used when an error is detected, and no further processing is
1717 -- required. It is also used if an earlier error has left the tree
1718 -- in a state where the aspect should not be processed.
1720 Expr
: constant Node_Id
:= Expression
(Aspect
);
1721 Id
: constant Node_Id
:= Identifier
(Aspect
);
1722 Loc
: constant Source_Ptr
:= Sloc
(Aspect
);
1723 Nam
: constant Name_Id
:= Chars
(Id
);
1724 A_Id
: constant Aspect_Id
:= Get_Aspect_Id
(Nam
);
1727 Delay_Required
: Boolean;
1728 -- Set False if delay is not required
1730 Eloc
: Source_Ptr
:= No_Location
;
1731 -- Source location of expression, modified when we split PPC's. It
1732 -- is set below when Expr is present.
1734 procedure Analyze_Aspect_Convention
;
1735 -- Perform analysis of aspect Convention
1737 procedure Analyze_Aspect_Disable_Controlled
;
1738 -- Perform analysis of aspect Disable_Controlled
1740 procedure Analyze_Aspect_Export_Import
;
1741 -- Perform analysis of aspects Export or Import
1743 procedure Analyze_Aspect_External_Link_Name
;
1744 -- Perform analysis of aspects External_Name or Link_Name
1746 procedure Analyze_Aspect_Implicit_Dereference
;
1747 -- Perform analysis of the Implicit_Dereference aspects
1749 procedure Analyze_Aspect_Relaxed_Initialization
;
1750 -- Perform analysis of aspect Relaxed_Initialization
1752 procedure Analyze_Aspect_Yield
;
1753 -- Perform analysis of aspect Yield
1755 procedure Analyze_Aspect_Static
;
1756 -- Ada 2022 (AI12-0075): Perform analysis of aspect Static
1758 procedure Check_Expr_Is_OK_Static_Expression
1760 Typ
: Entity_Id
:= Empty
);
1761 -- Check the specified expression Expr to make sure that it is a
1762 -- static expression of the given type (i.e. it will be analyzed
1763 -- and resolved using this type, which can be any valid argument
1764 -- to Resolve, e.g. Any_Integer is OK). If not, give an error
1765 -- and raise Aspect_Exit. If Typ is left Empty, then any static
1766 -- expression is allowed. Includes checking that the expression
1767 -- does not raise Constraint_Error.
1769 function Directly_Specified
1770 (Id
: Entity_Id
; A
: Aspect_Id
) return Boolean;
1771 -- Returns True if the given aspect is directly (as opposed to
1772 -- via any form of inheritance) specified for the given entity.
1774 function Make_Aitem_Pragma
1775 (Pragma_Argument_Associations
: List_Id
;
1776 Pragma_Name
: Name_Id
) return Node_Id
;
1777 -- This is a wrapper for Make_Pragma used for converting aspects
1778 -- to pragmas. It takes care of Sloc (set from Loc) and building
1779 -- the pragma identifier from the given name. In addition the
1780 -- flags Class_Present and Split_PPC are set from the aspect
1781 -- node, as well as Is_Ignored. This routine also sets the
1782 -- From_Aspect_Specification in the resulting pragma node to
1783 -- True, and sets Corresponding_Aspect to point to the aspect.
1784 -- The resulting pragma is assigned to Aitem.
1786 -------------------------------
1787 -- Analyze_Aspect_Convention --
1788 -------------------------------
1790 procedure Analyze_Aspect_Convention
is
1799 -- Obtain all interfacing aspects that apply to the related
1802 Get_Interfacing_Aspects
1803 (Iface_Asp
=> Aspect
,
1804 Conv_Asp
=> Dummy_1
,
1811 -- The related entity is subject to aspect Export or Import.
1812 -- Do not process Convention now because it must be analysed
1813 -- as part of Export or Import.
1815 if Present
(Expo
) or else Present
(Imp
) then
1818 -- Otherwise Convention appears by itself
1821 -- The aspect specifies a particular convention
1823 if Present
(Expr
) then
1824 Conv
:= New_Copy_Tree
(Expr
);
1826 -- Otherwise assume convention Ada
1829 Conv
:= Make_Identifier
(Loc
, Name_Ada
);
1833 -- pragma Convention (<Conv>, <E>);
1835 Aitem
:= Make_Aitem_Pragma
1836 (Pragma_Name
=> Name_Convention
,
1837 Pragma_Argument_Associations
=> New_List
(
1838 Make_Pragma_Argument_Association
(Loc
,
1839 Expression
=> Conv
),
1840 Make_Pragma_Argument_Association
(Loc
,
1841 Expression
=> New_Occurrence_Of
(E
, Loc
))));
1843 Decorate
(Aspect
, Aitem
);
1844 Insert_Pragma
(Aitem
);
1846 end Analyze_Aspect_Convention
;
1848 ---------------------------------------
1849 -- Analyze_Aspect_Disable_Controlled --
1850 ---------------------------------------
1852 procedure Analyze_Aspect_Disable_Controlled
is
1854 -- The aspect applies only to controlled records
1856 if not (Ekind
(E
) = E_Record_Type
1857 and then Is_Controlled_Active
(E
))
1860 ("aspect % requires controlled record type", Aspect
);
1864 -- Preanalyze the expression (if any) when the aspect resides
1865 -- in a generic unit.
1867 if Inside_A_Generic
then
1868 if Present
(Expr
) then
1869 Preanalyze_And_Resolve
(Expr
, Any_Boolean
);
1872 -- Otherwise the aspect resides in a nongeneric context
1875 -- A controlled record type loses its controlled semantics
1876 -- when the expression statically evaluates to True.
1878 if Present
(Expr
) then
1879 Analyze_And_Resolve
(Expr
, Any_Boolean
);
1881 if Is_OK_Static_Expression
(Expr
) then
1882 if Is_True
(Static_Boolean
(Expr
)) then
1883 Set_Disable_Controlled
(E
);
1886 -- Otherwise the expression is not static
1890 ("expression of aspect % must be static", Aspect
);
1893 -- Otherwise the aspect appears without an expression and
1894 -- defaults to True.
1897 Set_Disable_Controlled
(E
);
1900 end Analyze_Aspect_Disable_Controlled
;
1902 ----------------------------------
1903 -- Analyze_Aspect_Export_Import --
1904 ----------------------------------
1906 procedure Analyze_Aspect_Export_Import
is
1914 -- Obtain all interfacing aspects that apply to the related
1917 Get_Interfacing_Aspects
1918 (Iface_Asp
=> Aspect
,
1919 Conv_Asp
=> Dummy_1
,
1926 -- The related entity cannot be subject to both aspects Export
1929 if Present
(Expo
) and then Present
(Imp
) then
1931 ("incompatible interfacing aspects given for &", E
);
1932 Error_Msg_Sloc
:= Sloc
(Expo
);
1933 Error_Msg_N
("\aspect Export #", E
);
1934 Error_Msg_Sloc
:= Sloc
(Imp
);
1935 Error_Msg_N
("\aspect Import #", E
);
1938 -- A variable is most likely modified from the outside. Take
1939 -- the optimistic approach to avoid spurious errors.
1941 if Ekind
(E
) = E_Variable
then
1942 Set_Never_Set_In_Source
(E
, False);
1945 -- Resolve the expression of an Import or Export here, and
1946 -- require it to be of type Boolean and static. This is not
1947 -- quite right, because in general this should be delayed,
1948 -- but that seems tricky for these, because normally Boolean
1949 -- aspects are replaced with pragmas at the freeze point in
1950 -- Make_Pragma_From_Boolean_Aspect.
1953 or else Is_True
(Static_Boolean
(Expr
))
1955 if A_Id
= Aspect_Import
then
1956 Set_Has_Completion
(E
);
1957 Set_Is_Imported
(E
);
1959 -- An imported object cannot be explicitly initialized
1961 if Nkind
(N
) = N_Object_Declaration
1962 and then Present
(Expression
(N
))
1965 ("imported entities cannot be initialized "
1966 & "(RM B.1(24))", Expression
(N
));
1970 pragma Assert
(A_Id
= Aspect_Export
);
1971 Set_Is_Exported
(E
);
1974 -- Create the proper form of pragma Export or Import taking
1975 -- into account Conversion, External_Name, and Link_Name.
1977 Aitem
:= Build_Export_Import_Pragma
(Aspect
, E
);
1979 -- Otherwise the expression is either False or erroneous. There
1980 -- is no corresponding pragma.
1985 end Analyze_Aspect_Export_Import
;
1987 ---------------------------------------
1988 -- Analyze_Aspect_External_Link_Name --
1989 ---------------------------------------
1991 procedure Analyze_Aspect_External_Link_Name
is
1999 -- Obtain all interfacing aspects that apply to the related
2002 Get_Interfacing_Aspects
2003 (Iface_Asp
=> Aspect
,
2004 Conv_Asp
=> Dummy_1
,
2011 -- Ensure that aspect External_Name applies to aspect Export or
2014 if A_Id
= Aspect_External_Name
then
2015 if No
(Expo
) and then No
(Imp
) then
2017 ("aspect External_Name requires aspect Import or "
2018 & "Export", Aspect
);
2021 -- Otherwise ensure that aspect Link_Name applies to aspect
2022 -- Export or Import.
2025 pragma Assert
(A_Id
= Aspect_Link_Name
);
2026 if No
(Expo
) and then No
(Imp
) then
2028 ("aspect Link_Name requires aspect Import or Export",
2032 end Analyze_Aspect_External_Link_Name
;
2034 -----------------------------------------
2035 -- Analyze_Aspect_Implicit_Dereference --
2036 -----------------------------------------
2038 procedure Analyze_Aspect_Implicit_Dereference
is
2040 if not Is_Type
(E
) or else not Has_Discriminants
(E
) then
2042 ("aspect must apply to a type with discriminants", Expr
);
2044 elsif not Is_Entity_Name
(Expr
) then
2046 ("aspect must name a discriminant of current type", Expr
);
2049 -- Discriminant type be an anonymous access type or an
2050 -- anonymous access to subprogram.
2052 -- Missing synchronized types???
2055 Disc
: Entity_Id
:= First_Discriminant
(E
);
2057 while Present
(Disc
) loop
2058 if Chars
(Expr
) = Chars
(Disc
)
2059 and then Ekind
(Etype
(Disc
)) in
2060 E_Anonymous_Access_Subprogram_Type |
2061 E_Anonymous_Access_Type
2063 Set_Has_Implicit_Dereference
(E
);
2064 Set_Has_Implicit_Dereference
(Disc
);
2068 Next_Discriminant
(Disc
);
2071 -- Error if no proper access discriminant
2073 if Present
(Disc
) then
2074 -- For a type extension, check whether parent has
2075 -- a reference discriminant, to verify that use is
2078 if Is_Derived_Type
(E
)
2079 and then Has_Discriminants
(Etype
(E
))
2082 Parent_Disc
: constant Entity_Id
:=
2083 Get_Reference_Discriminant
(Etype
(E
));
2085 if Present
(Parent_Disc
)
2086 and then Corresponding_Discriminant
(Disc
) /=
2090 ("reference discriminant does not match "
2091 & "discriminant of parent type", Expr
);
2098 ("not an access discriminant of&", Expr
, E
);
2103 end Analyze_Aspect_Implicit_Dereference
;
2105 -------------------------------------------
2106 -- Analyze_Aspect_Relaxed_Initialization --
2107 -------------------------------------------
2109 procedure Analyze_Aspect_Relaxed_Initialization
is
2110 procedure Analyze_Relaxed_Parameter
2111 (Subp_Id
: Entity_Id
;
2113 Seen
: in out Elist_Id
);
2114 -- Analyze parameter that appears in the expression of the
2115 -- aspect Relaxed_Initialization.
2117 -------------------------------
2118 -- Analyze_Relaxed_Parameter --
2119 -------------------------------
2121 procedure Analyze_Relaxed_Parameter
2122 (Subp_Id
: Entity_Id
;
2124 Seen
: in out Elist_Id
)
2127 -- Set name of the aspect for error messages
2128 Error_Msg_Name_1
:= Nam
;
2130 -- The relaxed parameter is a formal parameter
2132 if Nkind
(Param
) in N_Identifier | N_Expanded_Name
then
2136 Item
: constant Entity_Id
:= Entity
(Param
);
2138 -- It must be a formal of the analyzed subprogram
2140 if Scope
(Item
) = Subp_Id
then
2142 pragma Assert
(Is_Formal
(Item
));
2144 -- It must not have scalar or access type
2146 if Is_Elementary_Type
(Etype
(Item
)) then
2147 Error_Msg_N
("illegal aspect % item", Param
);
2149 ("\item must not have elementary type", Param
);
2152 -- Detect duplicated items
2154 if Contains
(Seen
, Item
) then
2155 Error_Msg_N
("duplicate aspect % item", Param
);
2157 Append_New_Elmt
(Item
, Seen
);
2160 Error_Msg_N
("illegal aspect % item", Param
);
2164 -- The relaxed parameter is the function's Result attribute
2166 elsif Is_Attribute_Result
(Param
) then
2170 Pref
: constant Node_Id
:= Prefix
(Param
);
2174 Nkind
(Pref
) in N_Identifier | N_Expanded_Name
2176 Entity
(Pref
) = Subp_Id
2178 -- Function result must not have scalar or access
2181 if Is_Elementary_Type
(Etype
(Pref
)) then
2182 Error_Msg_N
("illegal aspect % item", Param
);
2184 ("\function result must not have elementary"
2188 -- Detect duplicated items
2190 if Contains
(Seen
, Subp_Id
) then
2191 Error_Msg_N
("duplicate aspect % item", Param
);
2193 Append_New_Elmt
(Entity
(Pref
), Seen
);
2197 Error_Msg_N
("illegal aspect % item", Param
);
2201 Error_Msg_N
("illegal aspect % item", Param
);
2203 end Analyze_Relaxed_Parameter
;
2207 Seen
: Elist_Id
:= No_Elist
;
2208 -- Items that appear in the relaxed initialization aspect
2209 -- expression of a subprogram; for detecting duplicates.
2211 Restore_Scope
: Boolean;
2212 -- Will be set to True if we need to restore the scope table
2213 -- after analyzing the aspect expression.
2215 Prev_Id
: Entity_Id
;
2217 -- Start of processing for Analyze_Aspect_Relaxed_Initialization
2220 -- Set name of the aspect for error messages
2221 Error_Msg_Name_1
:= Nam
;
2223 -- Annotation of a type; no aspect expression is allowed.
2224 -- For a private type, the aspect must be attached to the
2227 -- ??? Once the exact rule for this aspect is ready, we will
2228 -- likely reject concurrent types, etc., so let's keep the code
2229 -- for types and variable separate.
2231 if Is_First_Subtype
(E
) then
2232 Prev_Id
:= Incomplete_Or_Partial_View
(E
);
2233 if Present
(Prev_Id
) then
2235 -- Aspect may appear on the full view of an incomplete
2236 -- type because the incomplete declaration cannot have
2239 if Ekind
(Prev_Id
) = E_Incomplete_Type
then
2242 Error_Msg_N
("aspect % must apply to partial view", N
);
2245 elsif Present
(Expr
) then
2246 Error_Msg_N
("illegal aspect % expression", Expr
);
2249 -- Annotation of a variable; no aspect expression is allowed
2251 elsif Ekind
(E
) = E_Variable
then
2252 if Present
(Expr
) then
2253 Error_Msg_N
("illegal aspect % expression", Expr
);
2256 -- Annotation of a constant; no aspect expression is allowed.
2257 -- For a deferred constant, the aspect must be attached to the
2260 elsif Ekind
(E
) = E_Constant
then
2261 if Present
(Incomplete_Or_Partial_View
(E
)) then
2263 ("aspect % must apply to deferred constant", N
);
2265 elsif Present
(Expr
) then
2266 Error_Msg_N
("illegal aspect % expression", Expr
);
2269 -- Annotation of a subprogram; aspect expression is required
2271 elsif Is_Subprogram_Or_Entry
(E
)
2272 or else Is_Generic_Subprogram
(E
)
2274 if Present
(Expr
) then
2276 -- If we analyze subprogram body that acts as its own
2277 -- spec, then the subprogram itself and its formals are
2278 -- already installed; otherwise, we need to install them,
2279 -- as they must be visible when analyzing the aspect
2282 if In_Open_Scopes
(E
) then
2283 Restore_Scope
:= False;
2285 Restore_Scope
:= True;
2288 -- Only formals of the subprogram itself can appear
2289 -- in Relaxed_Initialization aspect expression, not
2290 -- formals of the enclosing generic unit. (This is
2291 -- different than in Precondition or Depends aspects,
2292 -- where both kinds of formals are allowed.)
2294 Install_Formals
(E
);
2297 -- Aspect expression is either an aggregate with list of
2298 -- parameters (and possibly the Result attribute for a
2301 if Nkind
(Expr
) = N_Aggregate
then
2303 -- Component associations in the aggregate must be a
2304 -- parameter name followed by a static boolean
2307 if Present
(Component_Associations
(Expr
)) then
2310 First
(Component_Associations
(Expr
));
2312 while Present
(Assoc
) loop
2313 if List_Length
(Choices
(Assoc
)) = 1 then
2314 Analyze_Relaxed_Parameter
2315 (E
, First
(Choices
(Assoc
)), Seen
);
2317 if Inside_A_Generic
then
2318 Preanalyze_And_Resolve
2319 (Expression
(Assoc
), Any_Boolean
);
2322 (Expression
(Assoc
), Any_Boolean
);
2325 if not Is_OK_Static_Expression
2326 (Expression
(Assoc
))
2328 Error_Msg_Name_1
:= Nam
;
2330 ("expression of aspect % " &
2331 "must be static", Aspect
);
2335 Error_Msg_Name_1
:= Nam
;
2337 ("illegal aspect % expression", Expr
);
2344 -- Expressions of the aggregate are parameter names
2346 if Present
(Expressions
(Expr
)) then
2348 Param
: Node_Id
:= First
(Expressions
(Expr
));
2351 while Present
(Param
) loop
2352 Analyze_Relaxed_Parameter
(E
, Param
, Seen
);
2358 -- Mark the aggregate expression itself as analyzed;
2359 -- its subexpressions were marked when they themselves
2362 Set_Analyzed
(Expr
);
2364 -- Otherwise, it is a single name of a subprogram
2365 -- parameter (or possibly the Result attribute for
2369 Analyze_Relaxed_Parameter
(E
, Expr
, Seen
);
2372 if Restore_Scope
then
2376 Error_Msg_N
("missing expression for aspect %", N
);
2380 Error_Msg_N
("inappropriate entity for aspect %", E
);
2382 end Analyze_Aspect_Relaxed_Initialization
;
2384 ---------------------------
2385 -- Analyze_Aspect_Static --
2386 ---------------------------
2388 procedure Analyze_Aspect_Static
is
2389 function Has_Convention_Intrinsic
(L
: List_Id
) return Boolean;
2390 -- Return True if L contains a pragma argument association
2391 -- node representing a convention Intrinsic.
2393 ------------------------------
2394 -- Has_Convention_Intrinsic --
2395 ------------------------------
2397 function Has_Convention_Intrinsic
2398 (L
: List_Id
) return Boolean
2400 Arg
: Node_Id
:= First
(L
);
2402 while Present
(Arg
) loop
2403 if Nkind
(Arg
) = N_Pragma_Argument_Association
2404 and then Chars
(Arg
) = Name_Convention
2405 and then Chars
(Expression
(Arg
)) = Name_Intrinsic
2414 end Has_Convention_Intrinsic
;
2416 Is_Imported_Intrinsic
: Boolean;
2419 if Ada_Version
< Ada_2022
then
2420 Error_Msg_Ada_2022_Feature
("aspect %", Sloc
(Aspect
));
2424 Is_Imported_Intrinsic
:= Is_Imported
(E
)
2426 Has_Convention_Intrinsic
2427 (Pragma_Argument_Associations
(Import_Pragma
(E
)));
2429 -- The aspect applies only to expression functions that
2430 -- statisfy the requirements for a static expression function
2431 -- (such as having an expression that is predicate-static) as
2432 -- well as Intrinsic imported functions as a -gnatX extension.
2434 if not Is_Expression_Function
(E
)
2436 not (All_Extensions_Allowed
and then Is_Imported_Intrinsic
)
2438 if All_Extensions_Allowed
then
2440 ("aspect % requires intrinsic or expression function",
2443 elsif Is_Imported_Intrinsic
then
2444 Error_Msg_GNAT_Extension
2445 ("aspect % on intrinsic function", Sloc
(Aspect
),
2446 Is_Core_Extension
=> True);
2450 ("aspect % requires expression function", Aspect
);
2455 -- Ada 2022 (AI12-0075): Check that the function satisfies
2456 -- several requirements of static functions as specified in
2457 -- RM 6.8(5.1-5.8). Note that some of the requirements given
2458 -- there are checked elsewhere.
2461 -- The expression of the expression function must be a
2462 -- potentially static expression (RM 2022 6.8(3.2-3.4)).
2463 -- That's checked in Sem_Ch6.Analyze_Expression_Function.
2465 -- The function must not contain any calls to itself, which
2466 -- is checked in Sem_Res.Resolve_Call.
2468 -- Each formal must be of mode in and have a static subtype
2471 Formal
: Entity_Id
:= First_Formal
(E
);
2473 while Present
(Formal
) loop
2474 if Ekind
(Formal
) /= E_In_Parameter
then
2476 ("aspect % requires formals of mode IN",
2482 if not Is_Static_Subtype
(Etype
(Formal
)) then
2484 ("aspect % requires formals with static subtypes",
2490 Next_Formal
(Formal
);
2494 -- The function's result subtype must be a static subtype
2496 if not Is_Static_Subtype
(Etype
(E
)) then
2498 ("aspect % requires function with result of "
2499 & "a static subtype",
2505 -- Check that the function does not have any applicable
2506 -- precondition or postcondition expression.
2508 for Asp
in Pre_Post_Aspects
loop
2509 if Has_Aspect
(E
, Asp
) then
2510 Error_Msg_Name_1
:= Aspect_Names
(Asp
);
2512 ("aspect % is not allowed for a static "
2513 & "expression function",
2514 Find_Aspect
(E
, Asp
));
2520 -- ??? Must check that "for result type R, if the
2521 -- function is a boundary entity for type R (see 7.3.2),
2522 -- no type invariant applies to type R; if R has a
2523 -- component type C, a similar rule applies to C."
2526 -- When the expression is present, it must be static. If it
2527 -- evaluates to True, the expression function is treated as
2528 -- a static function. Otherwise the aspect appears without
2529 -- an expression and defaults to True.
2531 if Present
(Expr
) then
2532 -- Preanalyze the expression when the aspect resides in a
2533 -- generic unit. (Is this generic-related code necessary
2534 -- for this aspect? It's modeled on what's done for aspect
2535 -- Disable_Controlled. ???)
2537 if Inside_A_Generic
then
2538 Preanalyze_And_Resolve
(Expr
, Any_Boolean
);
2540 -- Otherwise the aspect resides in a nongeneric context
2543 Analyze_And_Resolve
(Expr
, Any_Boolean
);
2545 -- Error if the boolean expression is not static
2547 if not Is_OK_Static_Expression
(Expr
) then
2549 ("expression of aspect % must be static", Aspect
);
2553 end Analyze_Aspect_Static
;
2555 --------------------------
2556 -- Analyze_Aspect_Yield --
2557 --------------------------
2559 procedure Analyze_Aspect_Yield
is
2560 Expr_Value
: Boolean := False;
2563 -- Check valid entity for 'Yield
2565 if (Is_Subprogram
(E
)
2566 or else Is_Generic_Subprogram
(E
)
2567 or else Is_Entry
(E
))
2568 and then not Within_Protected_Type
(E
)
2572 elsif Within_Protected_Type
(E
) then
2574 ("aspect% not applicable to protected operation", Id
);
2579 ("aspect% only applicable to subprogram and entry "
2580 & "declarations", Id
);
2584 -- Evaluate its static expression (if available); otherwise it
2585 -- defaults to True.
2590 -- Otherwise it must have a static boolean expression
2593 if Inside_A_Generic
then
2594 Preanalyze_And_Resolve
(Expr
, Any_Boolean
);
2596 Analyze_And_Resolve
(Expr
, Any_Boolean
);
2599 if Is_OK_Static_Expression
(Expr
) then
2600 if Is_True
(Static_Boolean
(Expr
)) then
2605 ("expression of aspect % must be static", Aspect
);
2610 Set_Has_Yield_Aspect
(E
);
2613 -- If the Yield aspect is specified for a dispatching
2614 -- subprogram that inherits the aspect, the specified
2615 -- value shall be confirming.
2618 and then Is_Dispatching_Operation
(E
)
2619 and then Present
(Overridden_Operation
(E
))
2620 and then Has_Yield_Aspect
(Overridden_Operation
(E
))
2621 /= Is_True
(Static_Boolean
(Expr
))
2623 Error_Msg_N
("specification of inherited aspect% can only " &
2624 "confirm parent value", Id
);
2626 end Analyze_Aspect_Yield
;
2628 ----------------------------------------
2629 -- Check_Expr_Is_OK_Static_Expression --
2630 ----------------------------------------
2632 procedure Check_Expr_Is_OK_Static_Expression
2634 Typ
: Entity_Id
:= Empty
)
2637 if Present
(Typ
) then
2638 Analyze_And_Resolve
(Expr
, Typ
);
2640 Analyze_And_Resolve
(Expr
);
2643 -- An expression cannot be considered static if its resolution
2644 -- failed or if it's erroneous. Stop the analysis of the
2647 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
2650 elsif Is_OK_Static_Expression
(Expr
) then
2653 -- Finally, we have a real error
2656 Error_Msg_Name_1
:= Nam
;
2657 Flag_Non_Static_Expr
2658 ("entity for aspect% must be a static expression",
2662 end Check_Expr_Is_OK_Static_Expression
;
2664 ------------------------
2665 -- Directly_Specified --
2666 ------------------------
2668 function Directly_Specified
2669 (Id
: Entity_Id
; A
: Aspect_Id
) return Boolean
2671 Aspect_Spec
: constant Node_Id
:= Find_Aspect
(Id
, A
);
2673 return Present
(Aspect_Spec
) and then Entity
(Aspect_Spec
) = Id
;
2674 end Directly_Specified
;
2676 -----------------------
2677 -- Make_Aitem_Pragma --
2678 -----------------------
2680 function Make_Aitem_Pragma
2681 (Pragma_Argument_Associations
: List_Id
;
2682 Pragma_Name
: Name_Id
) return Node_Id
2684 Args
: List_Id
:= Pragma_Argument_Associations
;
2688 -- We should never get here if aspect was disabled
2690 pragma Assert
(not Is_Disabled
(Aspect
));
2692 -- Certain aspects allow for an optional name or expression. Do
2693 -- not generate a pragma with empty argument association list.
2695 if No
(Args
) or else No
(Expression
(First
(Args
))) then
2703 Pragma_Argument_Associations
=> Args
,
2704 Pragma_Identifier
=>
2705 Make_Identifier
(Sloc
(Id
), Pragma_Name
),
2706 Class_Present
=> Class_Present
(Aspect
),
2707 Split_PPC
=> Split_PPC
(Aspect
));
2709 -- Set additional semantic fields
2711 if Is_Ignored
(Aspect
) then
2712 Set_Is_Ignored
(Aitem
);
2713 elsif Is_Checked
(Aspect
) then
2714 Set_Is_Checked
(Aitem
);
2717 Set_Corresponding_Aspect
(Aitem
, Aspect
);
2718 Set_From_Aspect_Specification
(Aitem
);
2721 end Make_Aitem_Pragma
;
2723 -- Start of processing for Analyze_One_Aspect
2726 -- Skip aspect if already analyzed, to avoid looping in some cases
2728 if Analyzed
(Aspect
) then
2732 -- Skip looking at aspect if it is totally disabled. Just mark it
2733 -- as such for later reference in the tree. This also sets the
2734 -- Is_Ignored and Is_Checked flags appropriately.
2736 Check_Applicable_Policy
(Aspect
);
2738 if Is_Disabled
(Aspect
) then
2742 -- Set the source location of expression, used in the case of
2743 -- a failed precondition/postcondition or invariant. Note that
2744 -- the source location of the expression is not usually the best
2745 -- choice here. For example, it gets located on the last AND
2746 -- keyword in a chain of boolean expressiond AND'ed together.
2747 -- It is best to put the message on the first character of the
2748 -- assertion, which is the effect of the First_Node call here.
2750 if Present
(Expr
) then
2751 Eloc
:= Sloc
(First_Node
(Expr
));
2754 -- Check restriction No_Implementation_Aspect_Specifications
2756 if Implementation_Defined_Aspect
(A_Id
) then
2758 (No_Implementation_Aspect_Specifications
, Aspect
);
2761 -- Check restriction No_Specification_Of_Aspect
2763 Check_Restriction_No_Specification_Of_Aspect
(Aspect
);
2765 -- Mark aspect analyzed (actual analysis is delayed till later)
2767 if A_Id
/= Aspect_User_Aspect
then
2768 -- Analyzed flag is handled differently for a User_Aspect
2769 -- aspect specification because it can also be analyzed
2770 -- "on demand" from Aspects.Find_Aspect. So that analysis
2771 -- tests for the case where the aspect specification has
2772 -- already been analyzed (in which case it just returns)
2773 -- and takes care of calling Set_Analyzed.
2775 Set_Analyzed
(Aspect
);
2778 Set_Entity
(Aspect
, E
);
2780 -- Build the reference to E that will be used in the built pragmas
2782 Ent
:= New_Occurrence_Of
(E
, Sloc
(Id
));
2784 if A_Id
in Aspect_Attach_Handler | Aspect_Interrupt_Handler
then
2786 -- Treat the specification as a reference to the protected
2787 -- operation, which might otherwise appear unreferenced and
2788 -- generate spurious warnings.
2790 Generate_Reference
(E
, Id
);
2793 -- Check for duplicate aspect. Note that the Comes_From_Source
2794 -- test allows duplicate Pre/Post's that we generate internally
2795 -- to escape being flagged here.
2797 if No_Duplicates_Allowed
(A_Id
) then
2799 while Anod
/= Aspect
loop
2800 if Comes_From_Source
(Aspect
)
2801 and then Same_Aspect
(A_Id
, Get_Aspect_Id
(Anod
))
2803 Error_Msg_Name_1
:= Nam
;
2804 Error_Msg_Sloc
:= Sloc
(Anod
);
2806 -- Case of same aspect specified twice
2808 if Class_Present
(Anod
) = Class_Present
(Aspect
) then
2809 if not Class_Present
(Anod
) then
2811 ("aspect% for & previously given#",
2815 ("aspect `%''Class` for & previously given#",
2825 -- Check some general restrictions on language defined aspects
2827 if not Implementation_Defined_Aspect
(A_Id
)
2828 or else A_Id
in Aspect_Async_Readers
2829 | Aspect_Async_Writers
2830 | Aspect_Effective_Reads
2831 | Aspect_Effective_Writes
2832 | Aspect_Preelaborable_Initialization
2834 Error_Msg_Name_1
:= Nam
;
2836 -- Not allowed for renaming declarations. Examine the original
2837 -- node because a subprogram renaming may have been rewritten
2840 if Nkind
(Original_Node
(N
)) in N_Renaming_Declaration
then
2842 ("aspect % not allowed for renaming declaration",
2846 -- Not allowed for formal type declarations in previous
2847 -- versions of the language. Allowed for them only for
2848 -- shared variable control aspects.
2850 -- Original node is used in case expansion rewrote the node -
2851 -- as is the case with generic derived types.
2853 if Nkind
(Original_Node
(N
)) = N_Formal_Type_Declaration
then
2854 if Ada_Version
< Ada_2022
then
2856 ("aspect % not allowed for formal type declaration",
2859 elsif A_Id
not in Aspect_Atomic
2861 | Aspect_Independent
2862 | Aspect_Atomic_Components
2863 | Aspect_Independent_Components
2864 | Aspect_Volatile_Components
2865 | Aspect_Async_Readers
2866 | Aspect_Async_Writers
2867 | Aspect_Effective_Reads
2868 | Aspect_Effective_Writes
2869 | Aspect_Preelaborable_Initialization
2872 ("aspect % not allowed for formal type declaration",
2878 -- Copy expression for later processing by the procedures
2879 -- Check_Aspect_At_[Freeze_Point | End_Of_Declarations]
2881 -- The expression may be a subprogram name, and can
2882 -- be an operator name that appears as a string, but
2883 -- requires its own analysis procedure (see sem_ch6).
2885 if Nkind
(Expr
) = N_Operator_Symbol
then
2886 Set_Expression_Copy
(Aspect
, Expr
);
2888 Set_Expression_Copy
(Aspect
, New_Copy_Tree
(Expr
));
2891 -- Set Delay_Required as appropriate to aspect
2893 case Aspect_Delay
(A_Id
) is
2894 when Always_Delay
=>
2895 -- For Boolean aspects, do not delay if no expression
2897 if A_Id
in Boolean_Aspects | Library_Unit_Aspects
then
2898 Delay_Required
:= Present
(Expr
);
2900 Delay_Required
:= True;
2904 Delay_Required
:= False;
2908 -- For Boolean aspects, do not delay if no expression except
2909 -- for Full_Access_Only because we need to process it after
2910 -- Volatile and Atomic, which can be independently delayed.
2912 if A_Id
in Boolean_Aspects
2913 and then A_Id
/= Aspect_Full_Access_Only
2916 Delay_Required
:= False;
2918 -- For non-Boolean aspects, if the expression has the form
2919 -- of an integer literal, then do not delay, since we know
2920 -- the value cannot change. This optimization catches most
2921 -- rep clause cases.
2923 elsif A_Id
not in Boolean_Aspects
2924 and then Present
(Expr
)
2925 and then Nkind
(Expr
) = N_Integer_Literal
2927 Delay_Required
:= False;
2929 -- For Alignment and various Size aspects, do not delay for
2930 -- an attribute reference whose prefix is Standard, for
2931 -- example Standard'Maximum_Alignment or Standard'Word_Size.
2933 elsif A_Id
in Aspect_Alignment
2934 | Aspect_Component_Size
2935 | Aspect_Object_Size
2938 and then Present
(Expr
)
2939 and then Nkind
(Expr
) = N_Attribute_Reference
2940 and then Nkind
(Prefix
(Expr
)) = N_Identifier
2941 and then Chars
(Prefix
(Expr
)) = Name_Standard
2943 Delay_Required
:= False;
2945 -- All other cases are delayed
2948 Delay_Required
:= True;
2949 Set_Has_Delayed_Rep_Aspects
(E
);
2954 and then (A_Id
= Aspect_Stable_Properties
2955 or else A_Id
= Aspect_Designated_Storage_Model
2956 or else A_Id
= Aspect_Storage_Model_Type
2957 or else A_Id
= Aspect_Aggregate
)
2958 -- ??? It seems like we should do this for all aspects, not
2959 -- just these, but that causes as-yet-undiagnosed regressions.
2962 Set_Has_Delayed_Aspects
(E
);
2963 Set_Is_Delayed_Aspect
(Aspect
);
2966 -- Check 13.1(9.2/5): A representation aspect of a subtype or type
2967 -- shall not be specified (whether by a representation item or an
2968 -- aspect_specification) before the type is completely defined
2971 if Is_Representation_Aspect
(A_Id
)
2972 and then Rep_Item_Too_Early
(E
, N
)
2977 -- Processing based on specific aspect
2980 when Aspect_Unimplemented
=>
2981 null; -- ??? temp for now
2983 -- No_Aspect should be impossible
2986 raise Program_Error
;
2988 -- Case 1: Aspects corresponding to attribute definition
2994 | Aspect_Component_Size
2995 | Aspect_Constant_Indexing
2996 | Aspect_Default_Iterator
2997 | Aspect_Dispatching_Domain
2998 | Aspect_External_Tag
3001 | Aspect_Iterator_Element
3002 | Aspect_Machine_Radix
3003 | Aspect_Object_Size
3007 | Aspect_Scalar_Storage_Order
3008 | Aspect_Simple_Storage_Pool
3011 | Aspect_Storage_Pool
3012 | Aspect_Stream_Size
3014 | Aspect_Variable_Indexing
3017 -- Indexing aspects apply only to tagged type
3019 if A_Id
in Aspect_Constant_Indexing
3020 | Aspect_Variable_Indexing
3021 and then not (Is_Type
(E
)
3022 and then Is_Tagged_Type
(E
))
3025 ("indexing aspect can only apply to a tagged type",
3030 -- For the case of aspect Address, we don't consider that we
3031 -- know the entity is never set in the source, since it is
3032 -- is likely aliasing is occurring.
3034 -- Note: one might think that the analysis of the resulting
3035 -- attribute definition clause would take care of that, but
3036 -- that's not the case since it won't be from source.
3038 if A_Id
= Aspect_Address
then
3039 Set_Never_Set_In_Source
(E
, False);
3042 -- Correctness of the profile of a stream operation is
3043 -- verified at the freeze point, but we must detect the
3044 -- illegal specification of this aspect for a subtype now,
3045 -- to prevent malformed rep_item chains.
3047 if A_Id
in Aspect_Input
3052 if not Is_First_Subtype
(E
) then
3054 ("local name must be a first subtype", Aspect
);
3057 -- If stream aspect applies to the class-wide type,
3058 -- the generated attribute definition applies to the
3059 -- class-wide type as well.
3061 elsif Class_Present
(Aspect
) then
3063 Make_Attribute_Reference
(Loc
,
3065 Attribute_Name
=> Name_Class
);
3069 -- Construct the attribute_definition_clause. The expression
3070 -- in the aspect specification is simply shared with the
3071 -- constructed attribute, because it will be fully analyzed
3072 -- when the attribute is processed.
3075 Make_Attribute_Definition_Clause
(Loc
,
3078 Expression
=> Relocate_Expression
(Expr
));
3080 -- If the address is specified, then we treat the entity as
3081 -- referenced, to avoid spurious warnings. This is analogous
3082 -- to what is done with an attribute definition clause, but
3083 -- here we don't want to generate a reference because this
3084 -- is the point of definition of the entity.
3086 if A_Id
= Aspect_Address
then
3090 -- Case 2: Aspects corresponding to pragmas
3092 -- Case 2a: Aspects corresponding to pragmas with two
3093 -- arguments, where the first argument is a local name
3094 -- referring to the entity, and the second argument is the
3095 -- aspect definition expression.
3099 when Aspect_Linker_Section
=>
3100 Aitem
:= Make_Aitem_Pragma
3101 (Pragma_Argument_Associations
=> New_List
(
3102 Make_Pragma_Argument_Association
(Loc
,
3103 Expression
=> New_Occurrence_Of
(E
, Loc
)),
3104 Make_Pragma_Argument_Association
(Sloc
(Expr
),
3105 Expression
=> Relocate_Node
(Expr
))),
3106 Pragma_Name
=> Name_Linker_Section
);
3108 -- No need to delay the processing if the entity is already
3109 -- frozen. This should only happen for subprogram bodies.
3111 if Is_Frozen
(E
) then
3112 pragma Assert
(Nkind
(N
) = N_Subprogram_Body
);
3113 Delay_Required
:= False;
3118 -- Corresponds to pragma Implemented, construct the pragma
3120 when Aspect_Synchronization
=>
3121 Aitem
:= Make_Aitem_Pragma
3122 (Pragma_Argument_Associations
=> New_List
(
3123 Make_Pragma_Argument_Association
(Loc
,
3124 Expression
=> New_Occurrence_Of
(E
, Loc
)),
3125 Make_Pragma_Argument_Association
(Sloc
(Expr
),
3126 Expression
=> Relocate_Node
(Expr
))),
3127 Pragma_Name
=> Name_Implemented
);
3131 when Aspect_Attach_Handler
=>
3132 Aitem
:= Make_Aitem_Pragma
3133 (Pragma_Argument_Associations
=> New_List
(
3134 Make_Pragma_Argument_Association
(Sloc
(Ent
),
3136 Make_Pragma_Argument_Association
(Sloc
(Expr
),
3137 Expression
=> Relocate_Expression
(Expr
))),
3138 Pragma_Name
=> Name_Attach_Handler
);
3140 -- We need to insert this pragma into the tree to get proper
3141 -- processing and to look valid from a placement viewpoint.
3143 Insert_Pragma
(Aitem
);
3146 -- Dynamic_Predicate, Predicate, Static_Predicate
3148 when Aspect_Dynamic_Predicate
3149 | Aspect_Ghost_Predicate
3151 | Aspect_Static_Predicate
3153 -- These aspects apply only to subtypes
3155 if not Is_Type
(E
) then
3157 ("predicate can only be specified for a subtype",
3161 elsif Is_Incomplete_Type
(E
) then
3163 ("predicate cannot apply to incomplete view", Aspect
);
3165 elsif Is_Generic_Type
(E
) then
3167 ("predicate cannot apply to formal type", Aspect
);
3171 -- Construct the pragma (always a pragma Predicate, with
3172 -- flags recording whether it is static/dynamic). We also
3173 -- set flags recording this in the type itself.
3175 Aitem
:= Make_Aitem_Pragma
3176 (Pragma_Argument_Associations
=> New_List
(
3177 Make_Pragma_Argument_Association
(Sloc
(Ent
),
3179 Make_Pragma_Argument_Association
(Sloc
(Expr
),
3180 Expression
=> Relocate_Expression
(Expr
))),
3181 Pragma_Name
=> Name_Predicate
);
3183 -- Mark type has predicates, and remember what kind of
3184 -- aspect lead to this predicate (we need this to access
3185 -- the right set of check policies later on).
3187 Set_Has_Predicates
(E
);
3189 if A_Id
= Aspect_Dynamic_Predicate
then
3190 Set_Has_Dynamic_Predicate_Aspect
(E
);
3192 -- If the entity has a dynamic predicate, any inherited
3193 -- static predicate becomes dynamic as well, and the
3194 -- predicate function includes the conjunction of both.
3196 Set_Has_Static_Predicate_Aspect
(E
, False);
3198 elsif A_Id
= Aspect_Static_Predicate
then
3199 Set_Has_Static_Predicate_Aspect
(E
);
3200 elsif A_Id
= Aspect_Ghost_Predicate
then
3201 Set_Has_Ghost_Predicate_Aspect
(E
);
3204 -- If the type is private, indicate that its completion
3205 -- has a freeze node, because that is the one that will
3206 -- be visible at freeze time.
3208 if Is_Private_Type
(E
) and then Present
(Full_View
(E
)) then
3209 Set_Has_Predicates
(Full_View
(E
));
3211 if A_Id
= Aspect_Dynamic_Predicate
then
3212 Set_Has_Dynamic_Predicate_Aspect
(Full_View
(E
));
3213 elsif A_Id
= Aspect_Static_Predicate
then
3214 Set_Has_Static_Predicate_Aspect
(Full_View
(E
));
3215 elsif A_Id
= Aspect_Ghost_Predicate
then
3216 Set_Has_Ghost_Predicate_Aspect
(Full_View
(E
));
3219 Set_Has_Delayed_Aspects
(Full_View
(E
));
3220 Ensure_Freeze_Node
(Full_View
(E
));
3222 -- If there is an Underlying_Full_View, also create a
3223 -- freeze node for that one.
3225 if Is_Private_Type
(Full_View
(E
)) then
3227 U_Full
: constant Entity_Id
:=
3228 Underlying_Full_View
(Full_View
(E
));
3230 if Present
(U_Full
) then
3231 Set_Has_Delayed_Aspects
(U_Full
);
3232 Ensure_Freeze_Node
(U_Full
);
3238 -- Predicate_Failure
3240 when Aspect_Predicate_Failure
=>
3242 -- This aspect applies only to subtypes
3244 if not Is_Type
(E
) then
3246 ("predicate can only be specified for a subtype",
3250 elsif Is_Incomplete_Type
(E
) then
3252 ("predicate cannot apply to incomplete view", Aspect
);
3255 elsif not Has_Predicates
(E
) then
3257 ("Predicate_Failure requires previous predicate" &
3258 " specification", Aspect
);
3261 elsif not (Directly_Specified
(E
, Aspect_Dynamic_Predicate
)
3262 or else Directly_Specified
(E
, Aspect_Predicate
)
3263 or else Directly_Specified
(E
, Aspect_Ghost_Predicate
)
3264 or else Directly_Specified
(E
, Aspect_Static_Predicate
))
3267 ("Predicate_Failure requires accompanying" &
3268 " noninherited predicate specification", Aspect
);
3272 -- Construct the pragma
3274 Aitem
:= Make_Aitem_Pragma
3275 (Pragma_Argument_Associations
=> New_List
(
3276 Make_Pragma_Argument_Association
(Sloc
(Ent
),
3278 Make_Pragma_Argument_Association
(Sloc
(Expr
),
3279 Expression
=> Relocate_Node
(Expr
))),
3280 Pragma_Name
=> Name_Predicate_Failure
);
3282 -- Case 2b: Aspects corresponding to pragmas with two
3283 -- arguments, where the second argument is a local name
3284 -- referring to the entity, and the first argument is the
3285 -- aspect definition expression.
3289 when Aspect_Convention
=>
3290 Analyze_Aspect_Convention
;
3293 -- External_Name, Link_Name
3295 when Aspect_External_Name
3298 Analyze_Aspect_External_Link_Name
;
3301 -- CPU, Interrupt_Priority, Priority
3303 -- These three aspects can be specified for a subprogram spec
3304 -- or body, in which case we analyze the expression and export
3305 -- the value of the aspect.
3307 -- Previously, we generated an equivalent pragma for bodies
3308 -- (note that the specs cannot contain these pragmas). The
3309 -- pragma was inserted ahead of local declarations, rather than
3310 -- after the body. This leads to a certain duplication between
3311 -- the processing performed for the aspect and the pragma, but
3312 -- given the straightforward handling required it is simpler
3313 -- to duplicate than to translate the aspect in the spec into
3314 -- a pragma in the declarative part of the body.
3317 | Aspect_Interrupt_Priority
3320 -- Verify the expression is static when Static_Priorities is
3323 if not Is_OK_Static_Expression
(Expr
) then
3324 Check_Restriction
(Static_Priorities
, Expr
);
3327 if Nkind
(N
) in N_Subprogram_Body | N_Subprogram_Declaration
3329 -- Analyze the aspect expression
3331 Analyze_And_Resolve
(Expr
, Standard_Integer
);
3333 -- Interrupt_Priority aspect not allowed for main
3334 -- subprograms. RM D.1 does not forbid this explicitly,
3335 -- but RM J.15.11(6/3) does not permit pragma
3336 -- Interrupt_Priority for subprograms.
3338 if A_Id
= Aspect_Interrupt_Priority
then
3340 ("Interrupt_Priority aspect cannot apply to "
3341 & "subprogram", Expr
);
3343 -- The expression must be static
3345 elsif not Is_OK_Static_Expression
(Expr
) then
3346 Flag_Non_Static_Expr
3347 ("aspect requires static expression!", Expr
);
3349 -- Check whether this is the main subprogram. Issue a
3350 -- warning only if it is obviously not a main program
3351 -- (when it has parameters or when the subprogram is
3352 -- within a package).
3354 elsif Present
(Parameter_Specifications
3355 (Specification
(N
)))
3356 or else not Is_Compilation_Unit
(Defining_Entity
(N
))
3358 -- See RM D.1(14/3) and D.16(12/3)
3361 ("aspect applied to subprogram other than the "
3362 & "main subprogram has no effect??", Expr
);
3364 -- Otherwise check in range and export the value
3366 -- For the CPU aspect
3368 elsif A_Id
= Aspect_CPU
then
3369 if Is_In_Range
(Expr
, RTE
(RE_CPU_Range
)) then
3371 -- Value is correct so we export the value to make
3372 -- it available at execution time.
3375 (Main_Unit
, UI_To_Int
(Expr_Value
(Expr
)));
3379 ("main subprogram 'C'P'U is out of range", Expr
);
3382 -- For the Priority aspect
3384 elsif A_Id
= Aspect_Priority
then
3385 if Is_In_Range
(Expr
, RTE
(RE_Priority
)) then
3387 -- Value is correct so we export the value to make
3388 -- it available at execution time.
3391 (Main_Unit
, UI_To_Int
(Expr_Value
(Expr
)));
3393 -- Ignore pragma if Relaxed_RM_Semantics to support
3394 -- other targets/non GNAT compilers.
3396 elsif not Relaxed_RM_Semantics
then
3398 ("main subprogram priority is out of range",
3403 -- Load an arbitrary entity from System.Tasking.Stages
3404 -- or System.Tasking.Restricted.Stages (depending on
3405 -- the supported profile) to make sure that one of these
3406 -- packages is implicitly with'ed, since we need to have
3407 -- the tasking run time active for the pragma Priority to
3408 -- have any effect. Previously we with'ed the package
3409 -- System.Tasking, but this package does not trigger the
3410 -- required initialization of the run-time library.
3412 if Restricted_Profile
then
3413 Discard_Node
(RTE
(RE_Activate_Restricted_Tasks
));
3415 Discard_Node
(RTE
(RE_Activate_Tasks
));
3418 -- Handling for these aspects in subprograms is complete
3422 -- For task and protected types pass the aspect as an
3427 Make_Attribute_Definition_Clause
(Loc
,
3430 Expression
=> Relocate_Expression
(Expr
));
3433 -- Suppress/Unsuppress
3435 when Aspect_Suppress
3438 Aitem
:= Make_Aitem_Pragma
3439 (Pragma_Argument_Associations
=> New_List
(
3440 Make_Pragma_Argument_Association
(Loc
,
3441 Expression
=> Relocate_Node
(Expr
)),
3442 Make_Pragma_Argument_Association
(Sloc
(Expr
),
3443 Expression
=> New_Occurrence_Of
(E
, Loc
))),
3444 Pragma_Name
=> Nam
);
3446 Delay_Required
:= False;
3450 when Aspect_Warnings
=>
3451 Aitem
:= Make_Aitem_Pragma
3452 (Pragma_Argument_Associations
=> New_List
(
3453 Make_Pragma_Argument_Association
(Sloc
(Expr
),
3454 Expression
=> Relocate_Node
(Expr
)),
3455 Make_Pragma_Argument_Association
(Loc
,
3456 Expression
=> New_Occurrence_Of
(E
, Loc
))),
3457 Pragma_Name
=> Name_Warnings
);
3459 Decorate
(Aspect
, Aitem
);
3460 Insert_Pragma
(Aitem
);
3463 -- Case 2c: Aspects corresponding to pragmas with three
3466 -- Invariant aspects have a first argument that references the
3467 -- entity, a second argument that is the expression and a third
3468 -- argument that is an appropriate message.
3470 -- Invariant, Type_Invariant
3472 when Aspect_Invariant
3473 | Aspect_Type_Invariant
3475 -- Analysis of the pragma will verify placement legality:
3476 -- an invariant must apply to a private type, or appear in
3477 -- the private part of a spec and apply to a completion.
3479 Aitem
:= Make_Aitem_Pragma
3480 (Pragma_Argument_Associations
=> New_List
(
3481 Make_Pragma_Argument_Association
(Sloc
(Ent
),
3483 Make_Pragma_Argument_Association
(Sloc
(Expr
),
3484 Expression
=> Relocate_Node
(Expr
))),
3485 Pragma_Name
=> Name_Invariant
);
3487 -- Add message unless exception messages are suppressed
3489 if not Opt
.Exception_Locations_Suppressed
then
3490 Append_To
(Pragma_Argument_Associations
(Aitem
),
3491 Make_Pragma_Argument_Association
(Eloc
,
3492 Chars
=> Name_Message
,
3494 Make_String_Literal
(Eloc
,
3495 Strval
=> "failed invariant from "
3496 & Build_Location_String
(Eloc
))));
3499 -- For Invariant case, insert immediately after the entity
3500 -- declaration. We do not have to worry about delay issues
3501 -- since the pragma processing takes care of this.
3503 Delay_Required
:= False;
3505 -- Case 2d : Aspects that correspond to a pragma with one
3510 -- Aspect Abstract_State introduces implicit declarations for
3511 -- all state abstraction entities it defines. To emulate this
3512 -- behavior, insert the pragma at the beginning of the visible
3513 -- declarations of the related package so that it is analyzed
3516 when Aspect_Abstract_State
=> Abstract_State
: declare
3517 Context
: Node_Id
:= N
;
3520 -- When aspect Abstract_State appears on a generic package,
3521 -- it is propagated to the package instance. The context in
3522 -- this case is the instance spec.
3524 if Nkind
(Context
) = N_Package_Instantiation
then
3525 Context
:= Instance_Spec
(Context
);
3528 if Nkind
(Context
) in N_Generic_Package_Declaration
3529 | N_Package_Declaration
3531 Aitem
:= Make_Aitem_Pragma
3532 (Pragma_Argument_Associations
=> New_List
(
3533 Make_Pragma_Argument_Association
(Loc
,
3534 Expression
=> Relocate_Node
(Expr
))),
3535 Pragma_Name
=> Name_Abstract_State
);
3537 Decorate
(Aspect
, Aitem
);
3541 Is_Generic_Instance
(Defining_Entity
(Context
)));
3545 ("aspect & must apply to a package declaration",
3552 -- Aspect Async_Readers is never delayed because it is
3553 -- equivalent to a source pragma which appears after the
3554 -- related object declaration.
3556 when Aspect_Async_Readers
=>
3557 Aitem
:= Make_Aitem_Pragma
3558 (Pragma_Argument_Associations
=> New_List
(
3559 Make_Pragma_Argument_Association
(Loc
,
3560 Expression
=> Relocate_Node
(Expr
))),
3561 Pragma_Name
=> Name_Async_Readers
);
3563 Decorate
(Aspect
, Aitem
);
3564 Insert_Pragma
(Aitem
);
3567 -- Aspect Async_Writers is never delayed because it is
3568 -- equivalent to a source pragma which appears after the
3569 -- related object declaration.
3571 when Aspect_Async_Writers
=>
3572 Aitem
:= Make_Aitem_Pragma
3573 (Pragma_Argument_Associations
=> New_List
(
3574 Make_Pragma_Argument_Association
(Loc
,
3575 Expression
=> Relocate_Node
(Expr
))),
3576 Pragma_Name
=> Name_Async_Writers
);
3578 Decorate
(Aspect
, Aitem
);
3579 Insert_Pragma
(Aitem
);
3582 -- Aspect Constant_After_Elaboration is never delayed because
3583 -- it is equivalent to a source pragma which appears after the
3584 -- related object declaration.
3586 when Aspect_Constant_After_Elaboration
=>
3587 Aitem
:= Make_Aitem_Pragma
3588 (Pragma_Argument_Associations
=> New_List
(
3589 Make_Pragma_Argument_Association
(Loc
,
3590 Expression
=> Relocate_Node
(Expr
))),
3592 Name_Constant_After_Elaboration
);
3594 Decorate
(Aspect
, Aitem
);
3595 Insert_Pragma
(Aitem
);
3598 -- Aspect Default_Internal_Condition is never delayed because
3599 -- it is equivalent to a source pragma which appears after the
3600 -- related private type. To deal with forward references, the
3601 -- generated pragma is stored in the rep chain of the related
3602 -- private type as types do not carry contracts. The pragma is
3603 -- wrapped inside of a procedure at the freeze point of the
3604 -- private type's full view.
3606 -- A type entity argument is appended to facilitate inheriting
3607 -- the aspect from parent types (see Build_DIC_Procedure_Body),
3608 -- though that extra argument isn't documented for the pragma.
3610 when Aspect_Default_Initial_Condition
=>
3611 Aitem
:= Make_Aitem_Pragma
3612 (Pragma_Argument_Associations
=> New_List
(
3613 Make_Pragma_Argument_Association
(Loc
,
3614 Expression
=> Relocate_Node
(Expr
)),
3615 Make_Pragma_Argument_Association
(Sloc
(Ent
),
3616 Expression
=> Ent
)),
3618 Name_Default_Initial_Condition
);
3620 Decorate
(Aspect
, Aitem
);
3621 Insert_Pragma
(Aitem
);
3624 -- Default_Storage_Pool
3626 when Aspect_Default_Storage_Pool
=>
3627 Aitem
:= Make_Aitem_Pragma
3628 (Pragma_Argument_Associations
=> New_List
(
3629 Make_Pragma_Argument_Association
(Loc
,
3630 Expression
=> Relocate_Node
(Expr
))),
3632 Name_Default_Storage_Pool
);
3634 Decorate
(Aspect
, Aitem
);
3635 Insert_Pragma
(Aitem
);
3640 -- Aspect Depends is never delayed because it is equivalent to
3641 -- a source pragma which appears after the related subprogram.
3642 -- To deal with forward references, the generated pragma is
3643 -- stored in the contract of the related subprogram and later
3644 -- analyzed at the end of the declarative region. See routine
3645 -- Analyze_Depends_In_Decl_Part for details.
3647 when Aspect_Depends
=>
3648 Aitem
:= Make_Aitem_Pragma
3649 (Pragma_Argument_Associations
=> New_List
(
3650 Make_Pragma_Argument_Association
(Loc
,
3651 Expression
=> Relocate_Node
(Expr
))),
3652 Pragma_Name
=> Name_Depends
);
3654 Decorate
(Aspect
, Aitem
);
3655 Insert_Pragma
(Aitem
);
3658 -- Aspect Effective_Reads is never delayed because it is
3659 -- equivalent to a source pragma which appears after the
3660 -- related object declaration.
3662 when Aspect_Effective_Reads
=>
3663 Aitem
:= Make_Aitem_Pragma
3664 (Pragma_Argument_Associations
=> New_List
(
3665 Make_Pragma_Argument_Association
(Loc
,
3666 Expression
=> Relocate_Node
(Expr
))),
3667 Pragma_Name
=> Name_Effective_Reads
);
3669 Decorate
(Aspect
, Aitem
);
3670 Insert_Pragma
(Aitem
);
3673 -- Aspect Effective_Writes is never delayed because it is
3674 -- equivalent to a source pragma which appears after the
3675 -- related object declaration.
3677 when Aspect_Effective_Writes
=>
3678 Aitem
:= Make_Aitem_Pragma
3679 (Pragma_Argument_Associations
=> New_List
(
3680 Make_Pragma_Argument_Association
(Loc
,
3681 Expression
=> Relocate_Node
(Expr
))),
3682 Pragma_Name
=> Name_Effective_Writes
);
3684 Decorate
(Aspect
, Aitem
);
3685 Insert_Pragma
(Aitem
);
3688 -- Aspect Extensions_Visible is never delayed because it is
3689 -- equivalent to a source pragma which appears after the
3690 -- related subprogram.
3692 when Aspect_Extensions_Visible
=>
3693 Aitem
:= Make_Aitem_Pragma
3694 (Pragma_Argument_Associations
=> New_List
(
3695 Make_Pragma_Argument_Association
(Loc
,
3696 Expression
=> Relocate_Node
(Expr
))),
3697 Pragma_Name
=> Name_Extensions_Visible
);
3699 Decorate
(Aspect
, Aitem
);
3700 Insert_Pragma
(Aitem
);
3703 -- Aspect Ghost is never delayed because it is equivalent to a
3704 -- source pragma which appears at the top of [generic] package
3705 -- declarations or after an object, a [generic] subprogram, or
3706 -- a type declaration.
3708 when Aspect_Ghost
=>
3709 Aitem
:= Make_Aitem_Pragma
3710 (Pragma_Argument_Associations
=> New_List
(
3711 Make_Pragma_Argument_Association
(Loc
,
3712 Expression
=> Relocate_Node
(Expr
))),
3713 Pragma_Name
=> Name_Ghost
);
3715 Decorate
(Aspect
, Aitem
);
3716 Insert_Pragma
(Aitem
);
3721 -- Aspect Global is never delayed because it is equivalent to
3722 -- a source pragma which appears after the related subprogram.
3723 -- To deal with forward references, the generated pragma is
3724 -- stored in the contract of the related subprogram and later
3725 -- analyzed at the end of the declarative region. See routine
3726 -- Analyze_Global_In_Decl_Part for details.
3728 when Aspect_Global
=>
3729 Aitem
:= Make_Aitem_Pragma
3730 (Pragma_Argument_Associations
=> New_List
(
3731 Make_Pragma_Argument_Association
(Loc
,
3732 Expression
=> Relocate_Node
(Expr
))),
3733 Pragma_Name
=> Name_Global
);
3735 Decorate
(Aspect
, Aitem
);
3736 Insert_Pragma
(Aitem
);
3739 -- Initial_Condition
3741 -- Aspect Initial_Condition is never delayed because it is
3742 -- equivalent to a source pragma which appears after the
3743 -- related package. To deal with forward references, the
3744 -- generated pragma is stored in the contract of the related
3745 -- package and later analyzed at the end of the declarative
3746 -- region. See routine Analyze_Initial_Condition_In_Decl_Part
3749 when Aspect_Initial_Condition
=> Initial_Condition
: declare
3750 Context
: Node_Id
:= N
;
3753 -- When aspect Initial_Condition appears on a generic
3754 -- package, it is propagated to the package instance. The
3755 -- context in this case is the instance spec.
3757 if Nkind
(Context
) = N_Package_Instantiation
then
3758 Context
:= Instance_Spec
(Context
);
3761 if Nkind
(Context
) in N_Generic_Package_Declaration
3762 | N_Package_Declaration
3764 Aitem
:= Make_Aitem_Pragma
3765 (Pragma_Argument_Associations
=> New_List
(
3766 Make_Pragma_Argument_Association
(Loc
,
3767 Expression
=> Relocate_Node
(Expr
))),
3769 Name_Initial_Condition
);
3771 Decorate
(Aspect
, Aitem
);
3775 Is_Generic_Instance
(Defining_Entity
(Context
)));
3777 -- Otherwise the context is illegal
3781 ("aspect & must apply to a package declaration",
3786 end Initial_Condition
;
3790 -- Aspect Initializes is never delayed because it is equivalent
3791 -- to a source pragma appearing after the related package. To
3792 -- deal with forward references, the generated pragma is stored
3793 -- in the contract of the related package and later analyzed at
3794 -- the end of the declarative region. For details, see routine
3795 -- Analyze_Initializes_In_Decl_Part.
3797 when Aspect_Initializes
=> Initializes
: declare
3798 Context
: Node_Id
:= N
;
3801 -- When aspect Initializes appears on a generic package,
3802 -- it is propagated to the package instance. The context
3803 -- in this case is the instance spec.
3805 if Nkind
(Context
) = N_Package_Instantiation
then
3806 Context
:= Instance_Spec
(Context
);
3809 if Nkind
(Context
) in N_Generic_Package_Declaration
3810 | N_Package_Declaration
3812 Aitem
:= Make_Aitem_Pragma
3813 (Pragma_Argument_Associations
=> New_List
(
3814 Make_Pragma_Argument_Association
(Loc
,
3815 Expression
=> Relocate_Node
(Expr
))),
3816 Pragma_Name
=> Name_Initializes
);
3818 Decorate
(Aspect
, Aitem
);
3822 Is_Generic_Instance
(Defining_Entity
(Context
)));
3824 -- Otherwise the context is illegal
3828 ("aspect & must apply to a package declaration",
3835 -- Max_Entry_Queue_Depth
3837 when Aspect_Max_Entry_Queue_Depth
=>
3838 Aitem
:= Make_Aitem_Pragma
3839 (Pragma_Argument_Associations
=> New_List
(
3840 Make_Pragma_Argument_Association
(Loc
,
3841 Expression
=> Relocate_Node
(Expr
))),
3842 Pragma_Name
=> Name_Max_Entry_Queue_Depth
);
3844 Decorate
(Aspect
, Aitem
);
3845 Insert_Pragma
(Aitem
);
3848 -- Max_Entry_Queue_Length
3850 when Aspect_Max_Entry_Queue_Length
=>
3851 Aitem
:= Make_Aitem_Pragma
3852 (Pragma_Argument_Associations
=> New_List
(
3853 Make_Pragma_Argument_Association
(Loc
,
3854 Expression
=> Relocate_Node
(Expr
))),
3855 Pragma_Name
=> Name_Max_Entry_Queue_Length
);
3857 Decorate
(Aspect
, Aitem
);
3858 Insert_Pragma
(Aitem
);
3863 when Aspect_Max_Queue_Length
=>
3864 Aitem
:= Make_Aitem_Pragma
3865 (Pragma_Argument_Associations
=> New_List
(
3866 Make_Pragma_Argument_Association
(Loc
,
3867 Expression
=> Relocate_Node
(Expr
))),
3868 Pragma_Name
=> Name_Max_Queue_Length
);
3870 Decorate
(Aspect
, Aitem
);
3871 Insert_Pragma
(Aitem
);
3874 -- Aspect No_Caching is never delayed because it is equivalent
3875 -- to a source pragma which appears after the related object
3878 when Aspect_No_Caching
=>
3879 Aitem
:= Make_Aitem_Pragma
3880 (Pragma_Argument_Associations
=> New_List
(
3881 Make_Pragma_Argument_Association
(Loc
,
3882 Expression
=> Relocate_Node
(Expr
))),
3883 Pragma_Name
=> Name_No_Caching
);
3885 Decorate
(Aspect
, Aitem
);
3886 Insert_Pragma
(Aitem
);
3889 -- No_Controlled_Parts, No_Task_Parts
3891 when Aspect_No_Controlled_Parts | Aspect_No_Task_Parts
=>
3893 -- Check appropriate type argument
3895 if not Is_Type
(E
) then
3897 ("aspect % can only be applied to types", E
);
3900 -- Disallow subtypes
3902 if Nkind
(Declaration_Node
(E
)) = N_Subtype_Declaration
then
3904 ("aspect % cannot be applied to subtypes", E
);
3907 -- Resolve the expression to a boolean
3909 if Present
(Expr
) then
3910 Check_Expr_Is_OK_Static_Expression
(Expr
, Any_Boolean
);
3917 when Aspect_Obsolescent
=> declare
3925 Make_Pragma_Argument_Association
(Sloc
(Expr
),
3926 Expression
=> Relocate_Node
(Expr
)));
3929 Aitem
:= Make_Aitem_Pragma
3930 (Pragma_Argument_Associations
=> Args
,
3931 Pragma_Name
=> Name_Obsolescent
);
3936 when Aspect_Part_Of
=>
3937 if Nkind
(N
) in N_Object_Declaration
3938 | N_Package_Instantiation
3939 or else Is_Single_Concurrent_Type_Declaration
(N
)
3941 Aitem
:= Make_Aitem_Pragma
3942 (Pragma_Argument_Associations
=> New_List
(
3943 Make_Pragma_Argument_Association
(Loc
,
3944 Expression
=> Relocate_Node
(Expr
))),
3945 Pragma_Name
=> Name_Part_Of
);
3947 Decorate
(Aspect
, Aitem
);
3948 Insert_Pragma
(Aitem
);
3952 ("aspect & must apply to package instantiation, "
3953 & "object, single protected type or single task type",
3959 -- Aspect Side_Effects is never delayed because it is
3960 -- equivalent to a source pragma which appears after
3961 -- the related subprogram.
3963 when Aspect_Side_Effects
=>
3964 Aitem
:= Make_Aitem_Pragma
3965 (Pragma_Argument_Associations
=> New_List
(
3966 Make_Pragma_Argument_Association
(Loc
,
3967 Expression
=> Relocate_Node
(Expr
))),
3968 Pragma_Name
=> Name_Side_Effects
);
3970 Decorate
(Aspect
, Aitem
);
3971 Insert_Pragma
(Aitem
);
3976 when Aspect_SPARK_Mode
=>
3977 Aitem
:= Make_Aitem_Pragma
3978 (Pragma_Argument_Associations
=> New_List
(
3979 Make_Pragma_Argument_Association
(Loc
,
3980 Expression
=> Relocate_Node
(Expr
))),
3981 Pragma_Name
=> Name_SPARK_Mode
);
3983 Decorate
(Aspect
, Aitem
);
3984 Insert_Pragma
(Aitem
);
3989 -- Aspect Refined_Depends is never delayed because it is
3990 -- equivalent to a source pragma which appears in the
3991 -- declarations of the related subprogram body. To deal with
3992 -- forward references, the generated pragma is stored in the
3993 -- contract of the related subprogram body and later analyzed
3994 -- at the end of the declarative region. For details, see
3995 -- routine Analyze_Refined_Depends_In_Decl_Part.
3997 when Aspect_Refined_Depends
=>
3998 Aitem
:= Make_Aitem_Pragma
3999 (Pragma_Argument_Associations
=> New_List
(
4000 Make_Pragma_Argument_Association
(Loc
,
4001 Expression
=> Relocate_Node
(Expr
))),
4002 Pragma_Name
=> Name_Refined_Depends
);
4004 Decorate
(Aspect
, Aitem
);
4005 Insert_Pragma
(Aitem
);
4010 -- Aspect Refined_Global is never delayed because it is
4011 -- equivalent to a source pragma which appears in the
4012 -- declarations of the related subprogram body. To deal with
4013 -- forward references, the generated pragma is stored in the
4014 -- contract of the related subprogram body and later analyzed
4015 -- at the end of the declarative region. For details, see
4016 -- routine Analyze_Refined_Global_In_Decl_Part.
4018 when Aspect_Refined_Global
=>
4019 Aitem
:= Make_Aitem_Pragma
4020 (Pragma_Argument_Associations
=> New_List
(
4021 Make_Pragma_Argument_Association
(Loc
,
4022 Expression
=> Relocate_Node
(Expr
))),
4023 Pragma_Name
=> Name_Refined_Global
);
4025 Decorate
(Aspect
, Aitem
);
4026 Insert_Pragma
(Aitem
);
4031 when Aspect_Refined_Post
=>
4032 Aitem
:= Make_Aitem_Pragma
4033 (Pragma_Argument_Associations
=> New_List
(
4034 Make_Pragma_Argument_Association
(Loc
,
4035 Expression
=> Relocate_Node
(Expr
))),
4036 Pragma_Name
=> Name_Refined_Post
);
4038 Decorate
(Aspect
, Aitem
);
4039 Insert_Pragma
(Aitem
);
4044 when Aspect_Refined_State
=>
4046 -- The corresponding pragma for Refined_State is inserted in
4047 -- the declarations of the related package body. This action
4048 -- synchronizes both the source and from-aspect versions of
4051 if Nkind
(N
) = N_Package_Body
then
4052 Aitem
:= Make_Aitem_Pragma
4053 (Pragma_Argument_Associations
=> New_List
(
4054 Make_Pragma_Argument_Association
(Loc
,
4055 Expression
=> Relocate_Node
(Expr
))),
4056 Pragma_Name
=> Name_Refined_State
);
4058 Decorate
(Aspect
, Aitem
);
4059 Insert_Pragma
(Aitem
);
4061 -- Otherwise the context is illegal
4065 ("aspect & must apply to a package body", Aspect
, Id
);
4070 -- Relative_Deadline
4072 when Aspect_Relative_Deadline
=>
4073 Aitem
:= Make_Aitem_Pragma
4074 (Pragma_Argument_Associations
=> New_List
(
4075 Make_Pragma_Argument_Association
(Loc
,
4076 Expression
=> Relocate_Node
(Expr
))),
4077 Pragma_Name
=> Name_Relative_Deadline
);
4079 -- If the aspect applies to a task, the corresponding pragma
4080 -- must appear within its declarations, not after.
4082 if Nkind
(N
) = N_Task_Type_Declaration
then
4088 if No
(Task_Definition
(N
)) then
4089 Set_Task_Definition
(N
,
4090 Make_Task_Definition
(Loc
,
4091 Visible_Declarations
=> New_List
,
4092 End_Label
=> Empty
));
4095 Def
:= Task_Definition
(N
);
4096 V
:= Visible_Declarations
(Def
);
4097 if not Is_Empty_List
(V
) then
4098 Insert_Before
(First
(V
), Aitem
);
4101 Set_Visible_Declarations
(Def
, New_List
(Aitem
));
4108 -- Relaxed_Initialization
4110 when Aspect_Relaxed_Initialization
=>
4111 Analyze_Aspect_Relaxed_Initialization
;
4114 -- Secondary_Stack_Size
4116 -- Aspect Secondary_Stack_Size needs to be converted into a
4117 -- pragma for two reasons: the attribute is not analyzed until
4118 -- after the expansion of the task type declaration and the
4119 -- attribute does not have visibility on the discriminant.
4121 when Aspect_Secondary_Stack_Size
=>
4122 Aitem
:= Make_Aitem_Pragma
4123 (Pragma_Argument_Associations
=> New_List
(
4124 Make_Pragma_Argument_Association
(Loc
,
4125 Expression
=> Relocate_Node
(Expr
))),
4127 Name_Secondary_Stack_Size
);
4129 Decorate
(Aspect
, Aitem
);
4130 Insert_Pragma
(Aitem
);
4135 when Aspect_User_Aspect
=>
4136 Analyze_User_Aspect_Aspect_Specification
(Aspect
);
4139 -- Volatile_Function
4141 -- Aspect Volatile_Function is never delayed because it is
4142 -- equivalent to a source pragma which appears after the
4143 -- related subprogram.
4145 when Aspect_Volatile_Function
=>
4146 Aitem
:= Make_Aitem_Pragma
4147 (Pragma_Argument_Associations
=> New_List
(
4148 Make_Pragma_Argument_Association
(Loc
,
4149 Expression
=> Relocate_Node
(Expr
))),
4150 Pragma_Name
=> Name_Volatile_Function
);
4152 Decorate
(Aspect
, Aitem
);
4153 Insert_Pragma
(Aitem
);
4156 -- Case 2e: Annotate aspect
4158 when Aspect_Annotate | Aspect_GNAT_Annotate
=>
4165 -- The argument can be a single identifier
4167 if Nkind
(Expr
) = N_Identifier
then
4169 -- One level of parens is allowed
4171 if Paren_Count
(Expr
) > 1 then
4172 Error_Msg_F
("extra parentheses ignored", Expr
);
4175 Set_Paren_Count
(Expr
, 0);
4177 -- Add the single item to the list
4179 Args
:= New_List
(Expr
);
4181 -- Otherwise we must have an aggregate
4183 elsif Nkind
(Expr
) = N_Aggregate
then
4185 -- Must be positional
4187 if Present
(Component_Associations
(Expr
)) then
4189 ("purely positional aggregate required", Expr
);
4193 -- Must not be parenthesized
4195 if Paren_Count
(Expr
) /= 0 then
4196 Error_Msg_F
-- CODEFIX
4197 ("redundant parentheses", Expr
);
4200 -- List of arguments is list of aggregate expressions
4202 Args
:= Expressions
(Expr
);
4204 -- Anything else is illegal
4207 Error_Msg_F
("wrong form for Annotate aspect", Expr
);
4211 -- Prepare pragma arguments
4214 Arg
:= First
(Args
);
4215 while Present
(Arg
) loop
4217 Make_Pragma_Argument_Association
(Sloc
(Arg
),
4218 Expression
=> Relocate_Node
(Arg
)));
4223 Make_Pragma_Argument_Association
(Sloc
(Ent
),
4224 Chars
=> Name_Entity
,
4225 Expression
=> Ent
));
4227 Aitem
:= Make_Aitem_Pragma
4228 (Pragma_Argument_Associations
=> Pargs
,
4229 Pragma_Name
=> Name_Annotate
);
4232 -- Case 3 : Aspects that don't correspond to pragma/attribute
4233 -- definition clause.
4235 -- Case 3a: The aspects listed below don't correspond to
4236 -- pragmas/attributes but do require delayed analysis.
4238 when Aspect_Default_Value | Aspect_Default_Component_Value
=>
4239 Error_Msg_Name_1
:= Nam
;
4241 if not Is_Type
(E
) then
4242 Error_Msg_N
("aspect% can only apply to a type", Id
);
4245 elsif not Is_First_Subtype
(E
) then
4246 Error_Msg_N
("aspect% cannot apply to subtype", Id
);
4249 elsif A_Id
= Aspect_Default_Value
4250 and then not Is_Scalar_Type
(E
)
4253 ("aspect% can only be applied to scalar type", Id
);
4256 elsif A_Id
= Aspect_Default_Component_Value
then
4257 if not Is_Array_Type
(E
) then
4259 ("aspect% can only be applied to array type", Id
);
4262 elsif not Is_Scalar_Type
(Component_Type
(E
)) then
4263 Error_Msg_N
("aspect% requires scalar components", Id
);
4270 when Aspect_Aggregate
=>
4271 -- We will be checking that the aspect is not specified on a
4272 -- non-array type in Check_Aspect_At_Freeze_Point
4274 Validate_Aspect_Aggregate
(Expr
);
4275 Record_Rep_Item
(E
, Aspect
);
4278 when Aspect_Local_Restrictions
=>
4279 Validate_Aspect_Local_Restrictions
(E
, Expr
);
4280 Record_Rep_Item
(E
, Aspect
);
4283 when Aspect_Stable_Properties
=>
4284 Validate_Aspect_Stable_Properties
4285 (E
, Expr
, Class_Present
=> Class_Present
(Aspect
));
4286 Record_Rep_Item
(E
, Aspect
);
4289 when Aspect_Designated_Storage_Model
=>
4290 if not All_Extensions_Allowed
then
4291 Error_Msg_GNAT_Extension
("aspect %", Sloc
(Aspect
));
4293 elsif not Is_Type
(E
)
4294 or else Ekind
(E
) /= E_Access_Type
4297 ("can only be specified for pool-specific access type",
4301 Record_Rep_Item
(E
, Aspect
);
4304 when Aspect_Storage_Model_Type
=>
4305 if not All_Extensions_Allowed
then
4306 Error_Msg_GNAT_Extension
("aspect %", Sloc
(Aspect
));
4308 elsif not Is_Type
(E
)
4309 or else not Is_Immutably_Limited_Type
(E
)
4312 ("can only be specified for immutably limited type",
4316 Record_Rep_Item
(E
, Aspect
);
4319 when Aspect_Integer_Literal
4320 | Aspect_Real_Literal
4321 | Aspect_String_Literal
4324 if not Is_First_Subtype
(E
) then
4326 ("may only be specified for a first subtype", Aspect
);
4330 if Ada_Version
< Ada_2022
then
4332 (No_Implementation_Aspect_Specifications
, N
);
4337 -- Case 3b: The aspects listed below don't correspond to
4338 -- pragmas/attributes and don't need delayed analysis.
4340 -- Implicit_Dereference
4342 -- For Implicit_Dereference, External_Name and Link_Name, only
4343 -- the legality checks are done during the analysis, thus no
4344 -- delay is required.
4346 when Aspect_Implicit_Dereference
=>
4347 Analyze_Aspect_Implicit_Dereference
;
4352 when Aspect_Dimension
=>
4353 Analyze_Aspect_Dimension
(N
, Id
, Expr
);
4358 when Aspect_Dimension_System
=>
4359 Analyze_Aspect_Dimension_System
(N
, Id
, Expr
);
4362 -- Case 4: Aspects requiring special handling
4364 -- Pre/Post/Test_Case/Contract_Cases/Always_Terminates/
4365 -- Exceptional_Cases and Subprogram_Variant whose corresponding
4366 -- pragmas take care of the delay.
4370 -- Aspects Pre/Post generate Precondition/Postcondition pragmas
4371 -- with a first argument that is the expression, and a second
4372 -- argument that is an informative message if the test fails.
4373 -- This is inserted right after the declaration, to get the
4374 -- required pragma placement. The processing for the pragmas
4375 -- takes care of the required delay.
4377 when Pre_Post_Aspects
=> Pre_Post
: declare
4381 if A_Id
in Aspect_Pre | Aspect_Precondition
then
4382 Pname
:= Name_Precondition
;
4384 Pname
:= Name_Postcondition
;
4387 -- Check that the class-wide predicate cannot be applied to
4388 -- an operation of a synchronized type. AI12-0182 forbids
4389 -- these altogether, while earlier language semantics made
4390 -- them legal on tagged synchronized types.
4392 -- Other legality checks are performed when analyzing the
4393 -- contract of the operation.
4395 if Class_Present
(Aspect
)
4396 and then Is_Concurrent_Type
(Current_Scope
)
4397 and then Ekind
(E
) in E_Entry | E_Function | E_Procedure
4399 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Aspect
);
4401 ("aspect % can only be specified for a primitive "
4402 & "operation of a tagged type", Aspect
);
4407 -- Remember class-wide conditions; they will be merged
4408 -- with inherited conditions.
4410 if Class_Present
(Aspect
)
4411 and then A_Id
in Aspect_Pre | Aspect_Post
4412 and then Is_Subprogram
(E
)
4413 and then not Is_Ignored_Ghost_Entity
(E
)
4415 if A_Id
= Aspect_Pre
then
4416 if Is_Ignored
(Aspect
) then
4417 Set_Ignored_Class_Preconditions
(E
,
4418 New_Copy_Tree
(Expr
));
4420 Set_Class_Preconditions
(E
, New_Copy_Tree
(Expr
));
4423 -- Postconditions may split into separate aspects, and we
4424 -- remember the expression before such split (i.e. when
4425 -- the first postcondition is processed).
4427 elsif No
(Class_Postconditions
(E
))
4428 and then No
(Ignored_Class_Postconditions
(E
))
4430 if Is_Ignored
(Aspect
) then
4431 Set_Ignored_Class_Postconditions
(E
,
4432 New_Copy_Tree
(Expr
));
4434 Set_Class_Postconditions
(E
, New_Copy_Tree
(Expr
));
4439 -- If the expressions is of the form A and then B, then
4440 -- we generate separate Pre/Post aspects for the separate
4441 -- clauses. Since we allow multiple pragmas, there is no
4442 -- problem in allowing multiple Pre/Post aspects internally.
4443 -- These should be treated in reverse order (B first and
4444 -- A second) since they are later inserted just after N in
4445 -- the order they are treated. This way, the pragma for A
4446 -- ends up preceding the pragma for B, which may have an
4447 -- importance for the error raised (either constraint error
4448 -- or precondition error).
4450 -- We do not do this for Pre'Class, since we have to put
4451 -- these conditions together in a complex OR expression.
4453 -- We don't do this in GNATprove mode, because it brings no
4454 -- benefit for proof and causes annoyance for flow analysis,
4455 -- which prefers to be as close to the original source code
4456 -- as possible. Also we don't do this when analyzing generic
4457 -- units since it causes spurious visibility errors in the
4458 -- preanalysis of instantiations.
4460 if not GNATprove_Mode
4461 and then (Pname
= Name_Postcondition
4462 or else not Class_Present
(Aspect
))
4463 and then not Inside_A_Generic
4465 while Nkind
(Expr
) = N_And_Then
loop
4466 Insert_After
(Aspect
,
4467 Make_Aspect_Specification
(Sloc
(Left_Opnd
(Expr
)),
4468 Identifier
=> Identifier
(Aspect
),
4469 Expression
=> Relocate_Node
(Left_Opnd
(Expr
)),
4470 Class_Present
=> Class_Present
(Aspect
),
4471 Split_PPC
=> True));
4472 Rewrite
(Expr
, Relocate_Node
(Right_Opnd
(Expr
)));
4473 Eloc
:= Sloc
(Expr
);
4477 -- Build the precondition/postcondition pragma
4479 Aitem
:= Make_Aitem_Pragma
4480 (Pragma_Argument_Associations
=> New_List
(
4481 Make_Pragma_Argument_Association
(Eloc
,
4482 Chars
=> Name_Check
,
4483 Expression
=> Relocate_Expression
(Expr
))),
4484 Pragma_Name
=> Pname
);
4486 -- Add message unless exception messages are suppressed
4488 if not Opt
.Exception_Locations_Suppressed
then
4489 Append_To
(Pragma_Argument_Associations
(Aitem
),
4490 Make_Pragma_Argument_Association
(Eloc
,
4491 Chars
=> Name_Message
,
4493 Make_String_Literal
(Eloc
,
4495 & Get_Name_String
(Pname
)
4497 & Build_Location_String
(Eloc
))));
4500 Set_Is_Delayed_Aspect
(Aspect
);
4502 -- For Pre/Post cases, insert immediately after the entity
4503 -- declaration, since that is the required pragma placement.
4504 -- Note that for these aspects, we do not have to worry
4505 -- about delay issues, since the pragmas themselves deal
4506 -- with delay of visibility for the expression analysis.
4508 Insert_Pragma
(Aitem
);
4515 when Aspect_Test_Case
=> Test_Case
: declare
4517 Comp_Expr
: Node_Id
;
4518 Comp_Assn
: Node_Id
;
4523 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4524 Error_Msg_Name_1
:= Nam
;
4525 Error_Msg_N
("incorrect placement of aspect %", E
);
4529 if Nkind
(Expr
) /= N_Aggregate
4530 or else Null_Record_Present
(Expr
)
4532 Error_Msg_Name_1
:= Nam
;
4534 ("wrong syntax for aspect % for &", Id
, E
);
4538 -- Check that the expression is a proper aggregate (no
4541 if Paren_Count
(Expr
) /= 0 then
4542 Error_Msg_F
-- CODEFIX
4543 ("redundant parentheses", Expr
);
4547 -- Create the list of arguments for building the Test_Case
4550 Comp_Expr
:= First
(Expressions
(Expr
));
4551 while Present
(Comp_Expr
) loop
4553 Make_Pragma_Argument_Association
(Sloc
(Comp_Expr
),
4554 Expression
=> Relocate_Node
(Comp_Expr
)));
4558 Comp_Assn
:= First
(Component_Associations
(Expr
));
4559 while Present
(Comp_Assn
) loop
4560 if List_Length
(Choices
(Comp_Assn
)) /= 1
4562 Nkind
(First
(Choices
(Comp_Assn
))) /= N_Identifier
4564 Error_Msg_Name_1
:= Nam
;
4566 ("wrong syntax for aspect % for &", Id
, E
);
4571 Make_Pragma_Argument_Association
(Sloc
(Comp_Assn
),
4572 Chars
=> Chars
(First
(Choices
(Comp_Assn
))),
4574 Relocate_Node
(Expression
(Comp_Assn
))));
4578 -- Build the test-case pragma
4580 Aitem
:= Make_Aitem_Pragma
4581 (Pragma_Argument_Associations
=> Args
,
4582 Pragma_Name
=> Name_Test_Case
);
4587 when Aspect_Contract_Cases
=>
4588 Aitem
:= Make_Aitem_Pragma
4589 (Pragma_Argument_Associations
=> New_List
(
4590 Make_Pragma_Argument_Association
(Loc
,
4591 Expression
=> Relocate_Node
(Expr
))),
4592 Pragma_Name
=> Name_Contract_Cases
);
4594 Decorate
(Aspect
, Aitem
);
4595 Insert_Pragma
(Aitem
);
4598 -- Always_Terminates
4600 when Aspect_Always_Terminates
=>
4601 Aitem
:= Make_Aitem_Pragma
4602 (Pragma_Argument_Associations
=> New_List
(
4603 Make_Pragma_Argument_Association
(Loc
,
4604 Expression
=> Relocate_Node
(Expr
))),
4605 Pragma_Name
=> Name_Always_Terminates
);
4607 Decorate
(Aspect
, Aitem
);
4608 Insert_Pragma
(Aitem
);
4611 -- Exceptional_Cases
4613 when Aspect_Exceptional_Cases
=>
4614 Aitem
:= Make_Aitem_Pragma
4615 (Pragma_Argument_Associations
=> New_List
(
4616 Make_Pragma_Argument_Association
(Loc
,
4617 Expression
=> Relocate_Node
(Expr
))),
4618 Pragma_Name
=> Name_Exceptional_Cases
);
4620 Decorate
(Aspect
, Aitem
);
4621 Insert_Pragma
(Aitem
);
4624 -- Subprogram_Variant
4626 when Aspect_Subprogram_Variant
=>
4627 Aitem
:= Make_Aitem_Pragma
4628 (Pragma_Argument_Associations
=> New_List
(
4629 Make_Pragma_Argument_Association
(Loc
,
4630 Expression
=> Relocate_Node
(Expr
))),
4631 Pragma_Name
=> Name_Subprogram_Variant
);
4633 Decorate
(Aspect
, Aitem
);
4634 Insert_Pragma
(Aitem
);
4637 -- Case 5: Special handling for aspects with an optional
4638 -- boolean argument.
4640 -- In the delayed case, the corresponding pragma cannot be
4641 -- generated yet because the evaluation of the boolean needs
4642 -- to be delayed till the freeze point.
4644 when Boolean_Aspects
4645 | Library_Unit_Aspects
4647 Set_Is_Boolean_Aspect
(Aspect
);
4649 -- Lock_Free aspect only apply to protected objects
4651 if A_Id
= Aspect_Lock_Free
then
4652 if Ekind
(E
) /= E_Protected_Type
then
4653 Error_Msg_Name_1
:= Nam
;
4655 ("aspect % only applies to a protected type " &
4660 -- Set the Uses_Lock_Free flag to True if there is no
4661 -- expression or if the expression is True. The
4662 -- evaluation of this aspect should be delayed to the
4663 -- freeze point if we wanted to handle the corner case
4664 -- of "true" or "false" being redefined.
4667 or else Is_True
(Static_Boolean
(Expr
))
4669 Set_Uses_Lock_Free
(E
);
4672 Record_Rep_Item
(E
, Aspect
);
4677 elsif A_Id
in Aspect_Export | Aspect_Import
then
4678 Analyze_Aspect_Export_Import
;
4680 -- Disable_Controlled
4682 elsif A_Id
= Aspect_Disable_Controlled
then
4683 Analyze_Aspect_Disable_Controlled
;
4686 -- Ada 2022 (AI12-0129): Exclusive_Functions
4688 elsif A_Id
= Aspect_Exclusive_Functions
then
4689 if Ekind
(E
) /= E_Protected_Type
then
4690 Error_Msg_Name_1
:= Nam
;
4692 ("aspect % only applies to a protected type " &
4699 -- Ada 2022 (AI12-0363): Full_Access_Only
4701 elsif A_Id
= Aspect_Full_Access_Only
then
4702 Error_Msg_Ada_2022_Feature
("aspect %", Sloc
(Aspect
));
4704 -- Ada 2022 (AI12-0075): static expression functions
4706 elsif A_Id
= Aspect_Static
then
4707 Analyze_Aspect_Static
;
4710 -- Ada 2022 (AI12-0279)
4712 elsif A_Id
= Aspect_Yield
then
4713 Analyze_Aspect_Yield
;
4717 -- Library unit aspects require special handling in the case
4718 -- of a package declaration, the pragma needs to be inserted
4719 -- in the list of declarations for the associated package.
4720 -- There is no issue of visibility delay for these aspects.
4722 if A_Id
in Library_Unit_Aspects
4724 Nkind
(N
) in N_Package_Declaration
4725 | N_Generic_Package_Declaration
4726 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4728 -- Aspect is legal on a local instantiation of a library-
4729 -- level generic unit.
4731 and then not Is_Generic_Instance
(Defining_Entity
(N
))
4734 ("incorrect context for library unit aspect&", Id
);
4738 -- Cases where we do not delay
4740 if not Delay_Required
then
4742 -- Exclude aspects Export and Import because their pragma
4743 -- syntax does not map directly to a Boolean aspect.
4745 if A_Id
not in Aspect_Export | Aspect_Import
then
4746 Aitem
:= Make_Aitem_Pragma
4747 (Pragma_Argument_Associations
=> New_List
(
4748 Make_Pragma_Argument_Association
(Sloc
(Ent
),
4749 Expression
=> Ent
)),
4750 Pragma_Name
=> Nam
);
4753 -- In general cases, the corresponding pragma/attribute
4754 -- definition clause will be inserted later at the freezing
4755 -- point, and we do not need to build it now.
4763 -- This is special because for access types we need to generate
4764 -- an attribute definition clause. This also works for single
4765 -- task declarations, but it does not work for task type
4766 -- declarations, because we have the case where the expression
4767 -- references a discriminant of the task type. That can't use
4768 -- an attribute definition clause because we would not have
4769 -- visibility on the discriminant. For that case we must
4770 -- generate a pragma in the task definition.
4772 when Aspect_Storage_Size
=>
4776 if Ekind
(E
) = E_Task_Type
then
4778 Decl
: constant Node_Id
:= Declaration_Node
(E
);
4781 pragma Assert
(Nkind
(Decl
) = N_Task_Type_Declaration
);
4783 -- If no task definition, create one
4785 if No
(Task_Definition
(Decl
)) then
4786 Set_Task_Definition
(Decl
,
4787 Make_Task_Definition
(Loc
,
4788 Visible_Declarations
=> Empty_List
,
4789 End_Label
=> Empty
));
4792 -- Create a pragma and put it at the start of the task
4793 -- definition for the task type declaration.
4795 Aitem
:= Make_Aitem_Pragma
4796 (Pragma_Argument_Associations
=> New_List
(
4797 Make_Pragma_Argument_Association
(Loc
,
4798 Expression
=> Relocate_Node
(Expr
))),
4799 Pragma_Name
=> Name_Storage_Size
);
4803 Visible_Declarations
(Task_Definition
(Decl
)));
4807 -- All other cases, generate attribute definition
4811 Make_Attribute_Definition_Clause
(Loc
,
4813 Chars
=> Name_Storage_Size
,
4814 Expression
=> Relocate_Node
(Expr
));
4818 -- Attach the corresponding pragma/attribute definition clause to
4819 -- the aspect specification node.
4821 if Present
(Aitem
) then
4822 Set_From_Aspect_Specification
(Aitem
);
4825 -- For an aspect that applies to a type, indicate whether it
4826 -- appears on a partial view of the type.
4828 if Is_Type
(E
) and then Is_Private_Type
(E
) then
4829 Set_Aspect_On_Partial_View
(Aspect
);
4832 -- In the context of a compilation unit, we directly put the
4833 -- pragma in the Pragmas_After list of the N_Compilation_Unit_Aux
4834 -- node (no delay is required here) except for aspects on a
4835 -- subprogram body (see below) and a generic package, for which we
4836 -- need to introduce the pragma before building the generic copy
4837 -- (see sem_ch12), and for package instantiations, where the
4838 -- library unit pragmas are better handled early.
4840 if Nkind
(Parent
(N
)) = N_Compilation_Unit
4841 and then (Present
(Aitem
) or else Is_Boolean_Aspect
(Aspect
))
4844 Aux
: constant Node_Id
:= Aux_Decls_Node
(Parent
(N
));
4847 pragma Assert
(Nkind
(Aux
) = N_Compilation_Unit_Aux
);
4849 -- For a Boolean aspect, create the corresponding pragma if
4850 -- no expression or if the value is True.
4852 if Is_Boolean_Aspect
(Aspect
) and then No
(Aitem
) then
4853 if Is_True
(Static_Boolean
(Expr
)) then
4854 Aitem
:= Make_Aitem_Pragma
4855 (Pragma_Argument_Associations
=> New_List
(
4856 Make_Pragma_Argument_Association
(Sloc
(Ent
),
4857 Expression
=> Ent
)),
4858 Pragma_Name
=> Nam
);
4860 Set_From_Aspect_Specification
(Aitem
, True);
4861 Set_Corresponding_Aspect
(Aitem
, Aspect
);
4868 -- If the aspect is on a subprogram body (relevant aspect
4869 -- is Inline), add the pragma in front of the declarations.
4871 if Nkind
(N
) = N_Subprogram_Body
then
4872 if No
(Declarations
(N
)) then
4873 Set_Declarations
(N
, New_List
);
4876 Prepend
(Aitem
, Declarations
(N
));
4878 elsif Nkind
(N
) = N_Generic_Package_Declaration
then
4879 if No
(Visible_Declarations
(Specification
(N
))) then
4880 Set_Visible_Declarations
(Specification
(N
), New_List
);
4884 Visible_Declarations
(Specification
(N
)));
4886 elsif Nkind
(N
) = N_Package_Instantiation
then
4888 Spec
: constant Node_Id
:=
4889 Specification
(Instance_Spec
(N
));
4891 if No
(Visible_Declarations
(Spec
)) then
4892 Set_Visible_Declarations
(Spec
, New_List
);
4895 Prepend
(Aitem
, Visible_Declarations
(Spec
));
4899 if No
(Pragmas_After
(Aux
)) then
4900 Set_Pragmas_After
(Aux
, New_List
);
4903 Append
(Aitem
, Pragmas_After
(Aux
));
4910 -- The evaluation of the aspect is delayed to the freezing point.
4911 -- The pragma or attribute clause if there is one is then attached
4912 -- to the aspect specification which is put in the rep item list.
4914 if Delay_Required
then
4915 if Present
(Aitem
) then
4916 Set_Is_Delayed_Aspect
(Aitem
);
4917 Set_Aspect_Rep_Item
(Aspect
, Aitem
);
4918 Set_Parent
(Aitem
, Aspect
);
4921 Set_Is_Delayed_Aspect
(Aspect
);
4923 -- In the case of Default_Value, link the aspect to base type
4924 -- as well, even though it appears on a first subtype. This is
4925 -- mandated by the semantics of the aspect. Do not establish
4926 -- the link when processing the base type itself as this leads
4927 -- to a rep item circularity.
4929 if A_Id
= Aspect_Default_Value
and then Base_Type
(E
) /= E
then
4930 Set_Has_Delayed_Aspects
(Base_Type
(E
));
4931 Record_Rep_Item
(Base_Type
(E
), Aspect
);
4934 Set_Has_Delayed_Aspects
(E
);
4935 Record_Rep_Item
(E
, Aspect
);
4937 -- When delay is not required and the context is a package or a
4938 -- subprogram body, insert the pragma in the body declarations.
4940 elsif Nkind
(N
) in N_Package_Body | N_Subprogram_Body
then
4941 if No
(Declarations
(N
)) then
4942 Set_Declarations
(N
, New_List
);
4945 -- The pragma is added before source declarations
4947 Prepend_To
(Declarations
(N
), Aitem
);
4949 -- When delay is not required and the context is not a compilation
4950 -- unit, we simply insert the pragma/attribute definition clause
4953 elsif Present
(Aitem
) then
4954 Insert_After
(Ins_Node
, Aitem
);
4960 -- If a nonoverridable aspect is explicitly specified for a
4961 -- derived type, then check consistency with the parent type.
4963 if A_Id
in Nonoverridable_Aspect_Id
4964 and then Nkind
(N
) = N_Full_Type_Declaration
4965 and then Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
4966 and then not In_Instance_Body
4969 Parent_Type
: constant Entity_Id
:= Etype
(E
);
4970 Inherited_Aspect
: constant Node_Id
:=
4971 Find_Aspect
(Parent_Type
, A_Id
);
4973 if Present
(Inherited_Aspect
)
4974 and then not Is_Confirming
4975 (A_Id
, Inherited_Aspect
, Aspect
)
4977 Error_Msg_Name_1
:= Aspect_Names
(A_Id
);
4978 Error_Msg_Sloc
:= Sloc
(Inherited_Aspect
);
4981 ("overriding aspect specification for "
4982 & "nonoverridable aspect % does not confirm "
4983 & "aspect specification inherited from #",
4989 when Aspect_Exit
=> null;
4990 end Analyze_One_Aspect
;
4993 end loop Aspect_Loop
;
4995 if Has_Delayed_Aspects
(E
) then
4996 Ensure_Freeze_Node
(E
);
4998 end Analyze_Aspect_Specifications
;
5000 ------------------------------------------------
5001 -- Analyze_Aspects_On_Subprogram_Body_Or_Stub --
5002 ------------------------------------------------
5004 procedure Analyze_Aspects_On_Subprogram_Body_Or_Stub
(N
: Node_Id
) is
5005 Body_Id
: constant Entity_Id
:= Defining_Entity
(N
);
5007 procedure Diagnose_Misplaced_Aspects
(Spec_Id
: Entity_Id
);
5008 -- Body [stub] N has aspects, but they are not properly placed. Emit an
5009 -- error message depending on the aspects involved. Spec_Id denotes the
5010 -- entity of the corresponding spec.
5012 --------------------------------
5013 -- Diagnose_Misplaced_Aspects --
5014 --------------------------------
5016 procedure Diagnose_Misplaced_Aspects
(Spec_Id
: Entity_Id
) is
5017 procedure Misplaced_Aspect_Error
5020 -- Emit an error message concerning misplaced aspect Asp. Ref_Nam is
5021 -- the name of the refined version of the aspect.
5023 ----------------------------
5024 -- Misplaced_Aspect_Error --
5025 ----------------------------
5027 procedure Misplaced_Aspect_Error
5031 Asp_Nam
: constant Name_Id
:= Chars
(Identifier
(Asp
));
5032 Asp_Id
: constant Aspect_Id
:= Get_Aspect_Id
(Asp_Nam
);
5035 -- The corresponding spec already contains the aspect in question
5036 -- and the one appearing on the body must be the refined form:
5038 -- procedure P with Global ...;
5039 -- procedure P with Global ... is ... end P;
5043 if Has_Aspect
(Spec_Id
, Asp_Id
) then
5044 Error_Msg_Name_1
:= Asp_Nam
;
5046 -- Subunits cannot carry aspects that apply to a subprogram
5049 if Nkind
(Parent
(N
)) = N_Subunit
then
5050 Error_Msg_N
("aspect % cannot apply to a subunit", Asp
);
5052 -- Otherwise suggest the refined form
5055 Error_Msg_Name_2
:= Ref_Nam
;
5056 Error_Msg_N
("aspect % should be %", Asp
);
5059 -- Otherwise the aspect must appear on the spec, not on the body
5062 -- procedure P with Global ... is ... end P;
5066 ("aspect specification must appear on initial declaration",
5069 end Misplaced_Aspect_Error
;
5076 -- Start of processing for Diagnose_Misplaced_Aspects
5079 -- Iterate over the aspect specifications and emit specific errors
5080 -- where applicable.
5082 Asp
:= First
(Aspect_Specifications
(N
));
5083 while Present
(Asp
) loop
5084 Asp_Nam
:= Chars
(Identifier
(Asp
));
5086 -- Do not emit errors on aspects that can appear on a subprogram
5087 -- body. This scenario occurs when the aspect specification list
5088 -- contains both misplaced and properly placed aspects.
5090 if Aspect_On_Body_Or_Stub_OK
(Get_Aspect_Id
(Asp_Nam
)) then
5093 -- Special diagnostics for SPARK aspects
5095 elsif Asp_Nam
= Name_Depends
then
5096 Misplaced_Aspect_Error
(Asp
, Name_Refined_Depends
);
5098 elsif Asp_Nam
= Name_Global
then
5099 Misplaced_Aspect_Error
(Asp
, Name_Refined_Global
);
5101 elsif Asp_Nam
= Name_Post
then
5102 Misplaced_Aspect_Error
(Asp
, Name_Refined_Post
);
5104 -- Otherwise a language-defined aspect is misplaced
5108 ("aspect specification must appear on initial declaration",
5114 end Diagnose_Misplaced_Aspects
;
5118 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(N
);
5120 -- Start of processing for Analyze_Aspects_On_Subprogram_Body_Or_Stub
5123 -- Language-defined aspects cannot be associated with a subprogram body
5124 -- [stub] if the subprogram has a spec. Certain implementation defined
5125 -- aspects are allowed to break this rule (for all applicable cases, see
5126 -- table Aspects.Aspect_On_Body_Or_Stub_OK).
5128 if Spec_Id
/= Body_Id
5129 and then Has_Aspects
(N
)
5130 and then not Aspects_On_Body_Or_Stub_OK
(N
)
5132 Diagnose_Misplaced_Aspects
(Spec_Id
);
5134 Analyze_Aspect_Specifications
(N
, Body_Id
);
5136 end Analyze_Aspects_On_Subprogram_Body_Or_Stub
;
5138 -----------------------
5139 -- Analyze_At_Clause --
5140 -----------------------
5142 -- An at clause is replaced by the corresponding Address attribute
5143 -- definition clause that is the preferred approach in Ada 95.
5145 procedure Analyze_At_Clause
(N
: Node_Id
) is
5146 CS
: constant Boolean := Comes_From_Source
(N
);
5149 -- This is an obsolescent feature
5151 Check_Restriction
(No_Obsolescent_Features
, N
);
5153 if Warn_On_Obsolescent_Feature
then
5155 ("?j?at clause is an obsolescent feature (RM J.7(2))", N
);
5157 ("\?j?use address attribute definition clause instead", N
);
5160 -- Rewrite as address clause
5163 Make_Attribute_Definition_Clause
(Sloc
(N
),
5164 Name
=> Identifier
(N
),
5165 Chars
=> Name_Address
,
5166 Expression
=> Expression
(N
)));
5168 -- We preserve Comes_From_Source, since logically the clause still comes
5169 -- from the source program even though it is changed in form.
5171 Set_Comes_From_Source
(N
, CS
);
5173 -- Analyze rewritten clause
5175 Analyze_Attribute_Definition_Clause
(N
);
5176 end Analyze_At_Clause
;
5178 -----------------------------------------
5179 -- Analyze_Attribute_Definition_Clause --
5180 -----------------------------------------
5182 procedure Analyze_Attribute_Definition_Clause
(N
: Node_Id
) is
5183 Loc
: constant Source_Ptr
:= Sloc
(N
);
5184 Nam
: constant Node_Id
:= Name
(N
);
5185 Attr
: constant Name_Id
:= Chars
(N
);
5186 Expr
: constant Node_Id
:= Expression
(N
);
5187 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attr
);
5190 -- The entity of Nam after it is analyzed. In the case of an incomplete
5191 -- type, this is the underlying type.
5194 -- The underlying entity to which the attribute applies. Generally this
5195 -- is the Underlying_Type of Ent, except in the case where the clause
5196 -- applies to the full view of an incomplete or private type, in which
5197 -- case U_Ent is just a copy of Ent.
5199 FOnly
: Boolean := False;
5200 -- Reset to True for subtype specific attribute (Alignment, Size)
5201 -- and for stream attributes, i.e. those cases where in the call to
5202 -- Rep_Item_Too_Late, FOnly is set True so that only the freezing rules
5203 -- are checked. Note that the case of stream attributes is not clear
5204 -- from the RM, but see AI95-00137. Also, the RM seems to disallow
5205 -- Storage_Size for derived task types, but that is also clearly
5208 procedure Analyze_Put_Image_TSS_Definition
;
5210 procedure Analyze_Stream_TSS_Definition
(TSS_Nam
: TSS_Name_Type
);
5211 -- Common processing for 'Read, 'Write, 'Input and 'Output attribute
5212 -- definition clauses.
5214 function Duplicate_Clause
return Boolean;
5215 -- This routine checks if the aspect for U_Ent being given by attribute
5216 -- definition clause N is for an aspect that has already been specified,
5217 -- and if so gives an error message. If there is a duplicate, True is
5218 -- returned, otherwise there is no error, and False is returned. Size
5219 -- and Value_Size are considered to conflict, but for compatibility,
5220 -- this is merely a warning.
5222 procedure Check_Indexing_Functions
;
5223 -- Check that the function in Constant_Indexing or Variable_Indexing
5224 -- attribute has the proper type structure. If the name is overloaded,
5225 -- check that some interpretation is legal.
5227 procedure Check_Iterator_Functions
;
5228 -- Check that there is a single function in Default_Iterator attribute
5229 -- that has the proper type structure.
5231 function Check_Primitive_Function
(Subp
: Entity_Id
) return Boolean;
5232 -- Common legality check for the previous two
5234 -----------------------------------
5235 -- Analyze_Put_Image_TSS_Definition --
5236 -----------------------------------
5238 procedure Analyze_Put_Image_TSS_Definition
is
5239 Subp
: Entity_Id
:= Empty
;
5244 function Has_Good_Profile
5246 Report
: Boolean := False) return Boolean;
5247 -- Return true if the entity is a subprogram with an appropriate
5248 -- profile for the attribute being defined. If result is False and
5249 -- Report is True, function emits appropriate error.
5251 ----------------------
5252 -- Has_Good_Profile --
5253 ----------------------
5255 function Has_Good_Profile
5257 Report
: Boolean := False) return Boolean
5263 if Ekind
(Subp
) /= E_Procedure
then
5267 F
:= First_Formal
(Subp
);
5273 if Base_Type
(Etype
(F
))
5274 /= Class_Wide_Type
(RTE
(RE_Root_Buffer_Type
))
5278 ("wrong type for Put_Image procedure''s first parameter",
5279 Parameter_Type
(Parent
(F
)));
5285 if Parameter_Mode
(F
) /= E_In_Out_Parameter
then
5288 ("wrong mode for Put_Image procedure''s first parameter",
5299 -- Verify that the prefix of the attribute and the local name for
5300 -- the type of the formal match.
5302 if Base_Type
(Typ
) /= Base_Type
(Ent
) then
5305 ("wrong type for Put_Image procedure''s second parameter",
5306 Parameter_Type
(Parent
(F
)));
5312 if Parameter_Mode
(F
) /= E_In_Parameter
then
5315 ("wrong mode for Put_Image procedure''s second parameter",
5322 if Present
(Next_Formal
(F
)) then
5327 end Has_Good_Profile
;
5329 -- Start of processing for Analyze_Put_Image_TSS_Definition
5332 if not Is_Type
(U_Ent
) then
5333 Error_Msg_N
("local name must be a subtype", Nam
);
5336 elsif not Is_First_Subtype
(U_Ent
) then
5337 Error_Msg_N
("local name must be a first subtype", Nam
);
5341 Pnam
:= TSS
(Base_Type
(U_Ent
), TSS_Put_Image
);
5343 -- If Pnam is present, it can be either inherited from an ancestor
5344 -- type (in which case it is legal to redefine it for this type), or
5345 -- be a previous definition of the attribute for the same type (in
5346 -- which case it is illegal).
5348 -- In the first case, it will have been analyzed already, and we can
5349 -- check that its profile does not match the expected profile for the
5350 -- Put_Image attribute of U_Ent. In the second case, either Pnam has
5351 -- been analyzed (and has the expected profile), or it has not been
5352 -- analyzed yet (case of a type that has not been frozen yet and for
5353 -- which Put_Image has been set using Set_TSS).
5356 and then (No
(First_Entity
(Pnam
)) or else Has_Good_Profile
(Pnam
))
5358 Error_Msg_Sloc
:= Sloc
(Pnam
);
5359 Error_Msg_Name_1
:= Attr
;
5360 Error_Msg_N
("% attribute already defined #", Nam
);
5366 if Is_Entity_Name
(Expr
) then
5367 if not Is_Overloaded
(Expr
) then
5368 if Has_Good_Profile
(Entity
(Expr
), Report
=> True) then
5369 Subp
:= Entity
(Expr
);
5373 Get_First_Interp
(Expr
, I
, It
);
5374 while Present
(It
.Nam
) loop
5375 if Has_Good_Profile
(It
.Nam
) then
5380 Get_Next_Interp
(I
, It
);
5385 if Present
(Subp
) then
5386 if Is_Abstract_Subprogram
(Subp
) then
5387 Error_Msg_N
("Put_Image subprogram must not be abstract", Expr
);
5391 Set_Entity
(Expr
, Subp
);
5392 Set_Etype
(Expr
, Etype
(Subp
));
5394 New_Put_Image_Subprogram
(N
, U_Ent
, Subp
);
5397 Error_Msg_Name_1
:= Attr
;
5398 Error_Msg_N
("incorrect expression for% attribute", Expr
);
5400 end Analyze_Put_Image_TSS_Definition
;
5402 -----------------------------------
5403 -- Analyze_Stream_TSS_Definition --
5404 -----------------------------------
5406 procedure Analyze_Stream_TSS_Definition
(TSS_Nam
: TSS_Name_Type
) is
5407 Subp
: Entity_Id
:= Empty
;
5412 Is_Read
: constant Boolean := (TSS_Nam
= TSS_Stream_Read
);
5413 -- True for Read attribute, False for other attributes
5415 function Has_Good_Profile
5417 Report
: Boolean := False) return Boolean;
5418 -- Return true if the entity is a subprogram with an appropriate
5419 -- profile for the attribute being defined. If result is False and
5420 -- Report is True, function emits appropriate error.
5422 ----------------------
5423 -- Has_Good_Profile --
5424 ----------------------
5426 function Has_Good_Profile
5428 Report
: Boolean := False) return Boolean
5430 Expected_Ekind
: constant array (Boolean) of Entity_Kind
:=
5431 (False => E_Procedure
, True => E_Function
);
5432 Is_Function
: constant Boolean := (TSS_Nam
= TSS_Stream_Input
);
5437 if Ekind
(Subp
) /= Expected_Ekind
(Is_Function
) then
5441 F
:= First_Formal
(Subp
);
5444 or else Ekind
(Etype
(F
)) /= E_Anonymous_Access_Type
5445 or else Base_Type
(Designated_Type
(Etype
(F
))) /=
5446 Class_Wide_Type
(RTE
(RE_Root_Stream_Type
))
5451 if not Is_Function
then
5455 Expected_Mode
: constant array (Boolean) of Entity_Kind
:=
5456 (False => E_In_Parameter
,
5457 True => E_Out_Parameter
);
5459 if Parameter_Mode
(F
) /= Expected_Mode
(Is_Read
) then
5467 Typ
:= Etype
(Subp
);
5470 -- Verify that the prefix of the attribute and the local name for
5471 -- the type of the formal match.
5473 if Base_Type
(Typ
) /= Base_Type
(Ent
) then
5477 if Present
(Next_Formal
(F
)) then
5480 elsif not Is_Scalar_Type
(Typ
)
5481 and then not Is_First_Subtype
(Typ
)
5482 and then not Is_Class_Wide_Type
(Typ
)
5484 if Report
and not Is_First_Subtype
(Typ
) then
5486 ("subtype of formal in stream operation must be a first "
5487 & "subtype", Parameter_Type
(Parent
(F
)));
5495 end Has_Good_Profile
;
5497 -- Start of processing for Analyze_Stream_TSS_Definition
5502 if not Is_Type
(U_Ent
) then
5503 Error_Msg_N
("local name must be a subtype", Nam
);
5506 elsif not Is_First_Subtype
(U_Ent
) then
5507 Error_Msg_N
("local name must be a first subtype", Nam
);
5511 Pnam
:= TSS
(Base_Type
(U_Ent
), TSS_Nam
);
5513 -- If Pnam is present, it can be either inherited from an ancestor
5514 -- type (in which case it is legal to redefine it for this type), or
5515 -- be a previous definition of the attribute for the same type (in
5516 -- which case it is illegal).
5518 -- In the first case, it will have been analyzed already, and we
5519 -- can check that its profile does not match the expected profile
5520 -- for a stream attribute of U_Ent. In the second case, either Pnam
5521 -- has been analyzed (and has the expected profile), or it has not
5522 -- been analyzed yet (case of a type that has not been frozen yet
5523 -- and for which the stream attribute has been set using Set_TSS).
5526 and then (No
(First_Entity
(Pnam
)) or else Has_Good_Profile
(Pnam
))
5528 Error_Msg_Sloc
:= Sloc
(Pnam
);
5529 Error_Msg_Name_1
:= Attr
;
5530 Error_Msg_N
("% attribute already defined #", Nam
);
5536 if Is_Entity_Name
(Expr
) then
5537 if not Is_Overloaded
(Expr
) then
5538 if Has_Good_Profile
(Entity
(Expr
), Report
=> True) then
5539 Subp
:= Entity
(Expr
);
5543 Get_First_Interp
(Expr
, I
, It
);
5544 while Present
(It
.Nam
) loop
5545 if Has_Good_Profile
(It
.Nam
) then
5550 Get_Next_Interp
(I
, It
);
5555 if Present
(Subp
) then
5556 if Is_Abstract_Subprogram
(Subp
) then
5557 Error_Msg_N
("stream subprogram must not be abstract", Expr
);
5560 -- A stream subprogram for an interface type must be a null
5561 -- procedure (RM 13.13.2 (38/3)). Note that the class-wide type
5562 -- of an interface is not an interface type (3.9.4 (6.b/2)).
5564 elsif Is_Interface
(U_Ent
)
5565 and then not Is_Class_Wide_Type
(U_Ent
)
5566 and then not Inside_A_Generic
5568 (Ekind
(Subp
) = E_Function
5572 (Unit_Declaration_Node
(Ultimate_Alias
(Subp
)))))
5575 ("stream subprogram for interface type must be null "
5576 & "procedure", Expr
);
5579 Set_Entity
(Expr
, Subp
);
5580 Set_Etype
(Expr
, Etype
(Subp
));
5582 New_Stream_Subprogram
(N
, U_Ent
, Subp
, TSS_Nam
);
5585 Error_Msg_Name_1
:= Attr
;
5587 if Is_Class_Wide_Type
(Base_Type
(Ent
)) then
5589 ("incorrect expression for class-wide% attribute", Expr
);
5591 Error_Msg_N
("incorrect expression for% attribute", Expr
);
5594 end Analyze_Stream_TSS_Definition
;
5596 ------------------------------
5597 -- Check_Indexing_Functions --
5598 ------------------------------
5600 procedure Check_Indexing_Functions
is
5601 Indexing_Found
: Boolean := False;
5603 procedure Check_Inherited_Indexing
;
5604 -- For a derived type, check that for a derived type, a specification
5605 -- of an indexing aspect can only be confirming, i.e. uses the same
5606 -- name as in the parent type.
5607 -- AI12-0160: Verify that an indexing cannot be specified for
5608 -- a derived type unless it is specified for the parent.
5610 procedure Check_One_Function
(Subp
: Entity_Id
);
5611 -- Check one possible interpretation. Sets Indexing_Found True if a
5612 -- legal indexing function is found.
5614 procedure Illegal_Indexing
(Msg
: String);
5615 -- Diagnose illegal indexing function if not overloaded. In the
5616 -- overloaded case indicate that no legal interpretation exists.
5618 ------------------------------
5619 -- Check_Inherited_Indexing --
5620 ------------------------------
5622 procedure Check_Inherited_Indexing
is
5623 Inherited
: Node_Id
;
5624 Other_Indexing
: Node_Id
;
5627 if Attr
= Name_Constant_Indexing
then
5629 Find_Aspect
(Etype
(Ent
), Aspect_Constant_Indexing
);
5631 Find_Aspect
(Etype
(Ent
), Aspect_Variable_Indexing
);
5633 else pragma Assert
(Attr
= Name_Variable_Indexing
);
5635 Find_Aspect
(Etype
(Ent
), Aspect_Variable_Indexing
);
5637 Find_Aspect
(Etype
(Ent
), Aspect_Constant_Indexing
);
5640 if Present
(Inherited
) then
5641 if Debug_Flag_Dot_XX
then
5644 -- OK if current attribute_definition_clause is expansion of
5645 -- inherited aspect.
5647 elsif Aspect_Rep_Item
(Inherited
) = N
then
5650 -- Check if this is a confirming specification. The name
5651 -- may be overloaded between the parent operation and the
5652 -- inherited one, so we check that the Chars fields match.
5654 elsif Is_Entity_Name
(Expression
(Inherited
))
5655 and then Chars
(Entity
(Expression
(Inherited
))) =
5656 Chars
(Entity
(Expression
(N
)))
5658 Indexing_Found
:= True;
5660 -- Indicate the operation that must be overridden, rather than
5661 -- redefining the indexing aspect.
5665 ("indexing function already inherited from parent type");
5667 ("!override & instead",
5668 N
, Entity
(Expression
(Inherited
)));
5671 -- If not inherited and the parent has another indexing function
5672 -- this is illegal, because it leads to inconsistent results in
5673 -- class-wide calls.
5675 elsif Present
(Other_Indexing
) then
5677 ("cannot specify indexing operation on derived type"
5678 & " if not specified for parent", N
);
5680 end Check_Inherited_Indexing
;
5682 ------------------------
5683 -- Check_One_Function --
5684 ------------------------
5686 procedure Check_One_Function
(Subp
: Entity_Id
) is
5687 Default_Element
: Node_Id
;
5688 Ret_Type
: constant Entity_Id
:= Etype
(Subp
);
5691 if not Is_Overloadable
(Subp
) then
5692 Illegal_Indexing
("illegal indexing function for type&");
5695 elsif Scope
(Subp
) /= Scope
(Ent
) then
5696 if Nkind
(Expr
) = N_Expanded_Name
then
5698 -- Indexing function can't be declared elsewhere
5701 ("indexing function must be declared"
5702 & " in scope of type&");
5705 if Is_Derived_Type
(Ent
) then
5706 Check_Inherited_Indexing
;
5711 elsif No
(First_Formal
(Subp
)) then
5713 ("Indexing requires a function that applies to type&");
5716 elsif No
(Next_Formal
(First_Formal
(Subp
))) then
5718 ("indexing function must have at least two parameters");
5721 elsif Is_Derived_Type
(Ent
) then
5722 Check_Inherited_Indexing
;
5725 if not Check_Primitive_Function
(Subp
) then
5727 ("Indexing aspect requires a function that applies to type&");
5731 -- If partial declaration exists, verify that it is not tagged.
5733 if Ekind
(Current_Scope
) = E_Package
5734 and then Has_Private_Declaration
(Ent
)
5735 and then From_Aspect_Specification
(N
)
5737 List_Containing
(Parent
(Ent
)) =
5738 Private_Declarations
5739 (Specification
(Unit_Declaration_Node
(Current_Scope
)))
5740 and then Nkind
(N
) = N_Attribute_Definition_Clause
5747 First
(Visible_Declarations
5749 (Unit_Declaration_Node
(Current_Scope
))));
5751 while Present
(Decl
) loop
5752 if Nkind
(Decl
) = N_Private_Type_Declaration
5753 and then Ent
= Full_View
(Defining_Identifier
(Decl
))
5754 and then Tagged_Present
(Decl
)
5755 and then No
(Aspect_Specifications
(Decl
))
5758 ("Indexing aspect cannot be specified on full view "
5759 & "if partial view is tagged");
5768 -- An indexing function must return either the default element of
5769 -- the container, or a reference type. For variable indexing it
5770 -- must be the latter.
5773 Find_Value_Of_Aspect
5774 (Etype
(First_Formal
(Subp
)), Aspect_Iterator_Element
);
5776 if Present
(Default_Element
) then
5777 Analyze
(Default_Element
);
5780 -- For variable_indexing the return type must be a reference type
5782 if Attr
= Name_Variable_Indexing
then
5783 if not Has_Implicit_Dereference
(Ret_Type
) then
5785 ("variable indexing must return a reference type");
5788 elsif Is_Access_Constant
5789 (Etype
(First_Discriminant
(Ret_Type
)))
5792 ("variable indexing must return an access to variable");
5797 if Has_Implicit_Dereference
(Ret_Type
)
5800 (Etype
(Get_Reference_Discriminant
(Ret_Type
)))
5803 ("constant indexing must return an access to constant");
5806 elsif Is_Access_Type
(Etype
(First_Formal
(Subp
)))
5807 and then not Is_Access_Constant
(Etype
(First_Formal
(Subp
)))
5810 ("constant indexing must apply to an access to constant");
5815 -- All checks succeeded
5817 Indexing_Found
:= True;
5818 end Check_One_Function
;
5820 -----------------------
5821 -- Illegal_Indexing --
5822 -----------------------
5824 procedure Illegal_Indexing
(Msg
: String) is
5826 Error_Msg_NE
(Msg
, N
, Ent
);
5827 end Illegal_Indexing
;
5829 -- Start of processing for Check_Indexing_Functions
5833 Check_Inherited_Indexing
;
5838 if not Is_Overloaded
(Expr
) then
5839 Check_One_Function
(Entity
(Expr
));
5847 Indexing_Found
:= False;
5848 Get_First_Interp
(Expr
, I
, It
);
5849 while Present
(It
.Nam
) loop
5851 -- Note that analysis will have added the interpretation
5852 -- that corresponds to the dereference. We only check the
5853 -- subprogram itself. Ignore homonyms that may come from
5854 -- derived types in the context.
5856 if Is_Overloadable
(It
.Nam
)
5857 and then Comes_From_Source
(It
.Nam
)
5859 Check_One_Function
(It
.Nam
);
5862 Get_Next_Interp
(I
, It
);
5867 if not Indexing_Found
and then not Error_Posted
(N
) then
5869 ("aspect Indexing requires a local function that applies to "
5870 & "type&", Expr
, Ent
);
5872 end Check_Indexing_Functions
;
5874 ------------------------------
5875 -- Check_Iterator_Functions --
5876 ------------------------------
5878 procedure Check_Iterator_Functions
is
5879 function Valid_Default_Iterator
(Subp
: Entity_Id
) return Boolean;
5880 -- Check one possible interpretation for validity
5882 ----------------------------
5883 -- Valid_Default_Iterator --
5884 ----------------------------
5886 function Valid_Default_Iterator
(Subp
: Entity_Id
) return Boolean is
5887 Root_T
: constant Entity_Id
:= Root_Type
(Etype
(Etype
(Subp
)));
5891 if not Check_Primitive_Function
(Subp
) then
5894 -- The return type must be derived from a type in an instance
5895 -- of Iterator.Interfaces, and thus its root type must have a
5898 elsif Chars
(Root_T
) /= Name_Forward_Iterator
5899 and then Chars
(Root_T
) /= Name_Reversible_Iterator
5904 Formal
:= First_Formal
(Subp
);
5907 -- False if any subsequent formal has no default expression
5909 Next_Formal
(Formal
);
5910 while Present
(Formal
) loop
5911 if No
(Expression
(Parent
(Formal
))) then
5915 Next_Formal
(Formal
);
5918 -- True if all subsequent formals have default expressions
5921 end Valid_Default_Iterator
;
5923 -- Start of processing for Check_Iterator_Functions
5928 if not Is_Entity_Name
(Expr
) then
5929 Error_Msg_N
("aspect Iterator must be a function name", Expr
);
5932 if not Is_Overloaded
(Expr
) then
5933 if Entity
(Expr
) /= Any_Id
5934 and then not Check_Primitive_Function
(Entity
(Expr
))
5937 ("aspect Indexing requires a function that applies to type&",
5938 Entity
(Expr
), Ent
);
5941 -- Flag the default_iterator as well as the denoted function.
5943 if not Valid_Default_Iterator
(Entity
(Expr
)) then
5944 Error_Msg_N
("improper function for default iterator!", Expr
);
5949 Default
: Entity_Id
:= Empty
;
5954 Get_First_Interp
(Expr
, I
, It
);
5955 while Present
(It
.Nam
) loop
5956 if not Check_Primitive_Function
(It
.Nam
)
5957 or else not Valid_Default_Iterator
(It
.Nam
)
5961 elsif Present
(Default
) then
5963 -- An explicit one should override an implicit one
5965 if Comes_From_Source
(Default
) =
5966 Comes_From_Source
(It
.Nam
)
5968 Error_Msg_N
("default iterator must be unique", Expr
);
5969 Error_Msg_Sloc
:= Sloc
(Default
);
5970 Error_Msg_N
("\\possible interpretation#", Expr
);
5971 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
5972 Error_Msg_N
("\\possible interpretation#", Expr
);
5974 elsif Comes_From_Source
(It
.Nam
) then
5981 Get_Next_Interp
(I
, It
);
5984 if Present
(Default
) then
5985 Set_Entity
(Expr
, Default
);
5986 Set_Is_Overloaded
(Expr
, False);
5989 ("no interpretation is a valid default iterator!", Expr
);
5993 end Check_Iterator_Functions
;
5995 -------------------------------
5996 -- Check_Primitive_Function --
5997 -------------------------------
5999 function Check_Primitive_Function
(Subp
: Entity_Id
) return Boolean is
6003 if Ekind
(Subp
) /= E_Function
then
6007 if No
(First_Formal
(Subp
)) then
6010 Ctrl
:= Etype
(First_Formal
(Subp
));
6013 -- To be a primitive operation subprogram has to be in same scope.
6015 if Scope
(Ctrl
) /= Scope
(Subp
) then
6019 -- Type of formal may be the class-wide type, an access to such,
6020 -- or an incomplete view.
6023 or else Ctrl
= Class_Wide_Type
(Ent
)
6025 (Ekind
(Ctrl
) = E_Anonymous_Access_Type
6026 and then (Designated_Type
(Ctrl
) = Ent
6028 Designated_Type
(Ctrl
) = Class_Wide_Type
(Ent
)))
6030 (Ekind
(Ctrl
) = E_Incomplete_Type
6031 and then Full_View
(Ctrl
) = Ent
)
6039 end Check_Primitive_Function
;
6041 ----------------------
6042 -- Duplicate_Clause --
6043 ----------------------
6045 function Duplicate_Clause
return Boolean is
6047 function Check_One_Attr
(Attr_1
, Attr_2
: Name_Id
) return Boolean;
6048 -- Check for one attribute; Attr_1 is the attribute_designator we are
6049 -- looking for. Attr_2 is the attribute_designator of the current
6050 -- node. Normally, this is called just once by Duplicate_Clause, with
6051 -- Attr_1 = Attr_2. However, it needs to be called twice for Size and
6052 -- Value_Size, because these mean the same thing. For compatibility,
6053 -- we allow specifying both Size and Value_Size, but only if the two
6056 --------------------
6057 -- Check_One_Attr --
6058 --------------------
6060 function Check_One_Attr
(Attr_1
, Attr_2
: Name_Id
) return Boolean is
6061 A
: constant Node_Id
:=
6062 Get_Rep_Item
(U_Ent
, Attr_1
, Check_Parents
=> False);
6065 if Attr_1
= Attr_2
then
6066 Error_Msg_Name_1
:= Attr_1
;
6067 Error_Msg_Sloc
:= Sloc
(A
);
6068 Error_Msg_NE
("aspect% for & previously given#", N
, U_Ent
);
6071 pragma Assert
(Attr_1
in Name_Size | Name_Value_Size
);
6072 pragma Assert
(Attr_2
in Name_Size | Name_Value_Size
);
6074 Error_Msg_Name_1
:= Attr_2
;
6075 Error_Msg_Name_2
:= Attr_1
;
6076 Error_Msg_Sloc
:= Sloc
(A
);
6077 Error_Msg_NE
("?% for & conflicts with % #", N
, U_Ent
);
6086 -- Start of processing for Duplicate_Clause
6089 -- Nothing to do if this attribute definition clause comes from
6090 -- an aspect specification, since we could not be duplicating an
6091 -- explicit clause, and we dealt with the case of duplicated aspects
6092 -- in Analyze_Aspect_Specifications.
6094 if From_Aspect_Specification
(N
) then
6098 -- Special cases for Size and Value_Size
6100 if (Chars
(N
) = Name_Size
6101 and then Check_One_Attr
(Name_Value_Size
, Name_Size
))
6103 (Chars
(N
) = Name_Value_Size
6104 and then Check_One_Attr
(Name_Size
, Name_Value_Size
))
6109 -- Normal case (including Size and Value_Size)
6111 return Check_One_Attr
(Chars
(N
), Chars
(N
));
6112 end Duplicate_Clause
;
6114 -- Start of processing for Analyze_Attribute_Definition_Clause
6117 -- The following code is a defense against recursion. Not clear that
6118 -- this can happen legitimately, but perhaps some error situations can
6119 -- cause it, and we did see this recursion during testing.
6121 if Analyzed
(N
) then
6124 Set_Analyzed
(N
, True);
6127 Check_Restriction_No_Use_Of_Attribute
(N
);
6129 if Is_Aspect_Id
(Chars
(N
)) then
6130 -- 6.1/3 No_Specification_of_Aspect: Identifies an aspect for which
6131 -- no aspect_specification, attribute_definition_clause, or pragma
6133 Check_Restriction_No_Specification_Of_Aspect
(N
);
6136 -- Ignore some selected attributes in CodePeer mode since they are not
6137 -- relevant in this context.
6139 if CodePeer_Mode
then
6142 -- Ignore Component_Size in CodePeer mode, to avoid changing the
6143 -- internal representation of types by implicitly packing them.
6145 when Attribute_Component_Size
=>
6146 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
6154 -- Process Ignore_Rep_Clauses option
6156 if Ignore_Rep_Clauses
then
6159 -- The following should be ignored. They do not affect legality
6160 -- and may be target dependent. The basic idea of -gnatI is to
6161 -- ignore any rep clauses that may be target dependent but do not
6162 -- affect legality (except possibly to be rejected because they
6163 -- are incompatible with the compilation target).
6165 when Attribute_Alignment
6166 | Attribute_Bit_Order
6167 | Attribute_Component_Size
6168 | Attribute_Default_Scalar_Storage_Order
6169 | Attribute_Machine_Radix
6170 | Attribute_Object_Size
6171 | Attribute_Scalar_Storage_Order
6174 | Attribute_Stream_Size
6175 | Attribute_Value_Size
6177 Kill_Rep_Clause
(N
);
6180 -- The following should not be ignored, because in the first place
6181 -- they are reasonably portable, and should not cause problems
6182 -- in compiling code from another target, and also they do affect
6183 -- legality, e.g. failing to provide a stream attribute for a type
6184 -- may make a program illegal.
6186 when Attribute_External_Tag
6189 | Attribute_Put_Image
6191 | Attribute_Simple_Storage_Pool
6192 | Attribute_Storage_Pool
6193 | Attribute_Storage_Size
6198 -- We do not do anything here with address clauses, they will be
6199 -- removed by Freeze later on, but for now, it works better to
6200 -- keep them in the tree.
6202 when Attribute_Address
=>
6205 -- Other cases are errors ("attribute& cannot be set with
6206 -- definition clause"), which will be caught below.
6214 Ent
:= Entity
(Nam
);
6216 if Rep_Item_Too_Early
(Ent
, N
) then
6220 -- Rep clause applies to (underlying) full view of private or incomplete
6221 -- type if we have one (if not, this is a premature use of the type).
6222 -- However, some semantic checks need to be done on the specified entity
6223 -- i.e. the private view, so we save it in Ent.
6225 if Is_Private_Type
(Ent
)
6226 and then Is_Derived_Type
(Ent
)
6227 and then not Is_Tagged_Type
(Ent
)
6228 and then No
(Full_View
(Ent
))
6229 and then No
(Underlying_Full_View
(Ent
))
6233 elsif Ekind
(Ent
) = E_Incomplete_Type
then
6235 -- The attribute applies to the full view, set the entity of the
6236 -- attribute definition accordingly.
6238 Ent
:= Underlying_Type
(Ent
);
6240 Set_Entity
(Nam
, Ent
);
6243 U_Ent
:= Underlying_Type
(Ent
);
6246 -- Avoid cascaded error
6248 if Etype
(Nam
) = Any_Type
then
6251 -- Must be declared in current scope or in case of an aspect
6252 -- specification, must be visible in current scope.
6254 elsif Scope
(Ent
) /= Current_Scope
6256 not (From_Aspect_Specification
(N
)
6257 and then Scope_Within_Or_Same
(Current_Scope
, Scope
(Ent
)))
6259 Error_Msg_N
("entity must be declared in this scope", Nam
);
6262 -- Must not be a source renaming (we do have some cases where the
6263 -- expander generates a renaming, and those cases are OK, in such
6264 -- cases any attribute applies to the renamed object as well).
6266 elsif Is_Object
(Ent
)
6267 and then Present
(Renamed_Object
(Ent
))
6269 -- In the case of a renamed object from source, this is an error
6270 -- unless the object is an aggregate and the renaming is created
6271 -- for an object declaration.
6273 if Comes_From_Source
(Renamed_Object
(Ent
))
6274 and then Nkind
(Renamed_Object
(Ent
)) /= N_Aggregate
6276 Get_Name_String
(Chars
(N
));
6277 Error_Msg_Strlen
:= Name_Len
;
6278 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
6280 ("~ clause not allowed for a renaming declaration "
6281 & "(RM 13.1(6))", Nam
);
6284 -- For the case of a compiler generated renaming, the attribute
6285 -- definition clause applies to the renamed object created by the
6286 -- expander. The easiest general way to handle this is to create a
6287 -- copy of the attribute definition clause for this object.
6289 elsif Is_Entity_Name
(Renamed_Object
(Ent
)) then
6291 Make_Attribute_Definition_Clause
(Loc
,
6293 New_Occurrence_Of
(Entity
(Renamed_Object
(Ent
)), Loc
),
6295 Expression
=> Duplicate_Subexpr
(Expression
(N
))));
6297 -- If the renamed object is not an entity, it must be a dereference
6298 -- of an unconstrained function call, and we must introduce a new
6299 -- declaration to capture the expression. This is needed in the case
6300 -- of 'Alignment, where the original declaration must be rewritten.
6304 (Nkind
(Renamed_Object
(Ent
)) = N_Explicit_Dereference
);
6308 -- If no underlying entity, use entity itself, applies to some
6309 -- previously detected error cases ???
6311 elsif No
(U_Ent
) then
6314 -- Cannot specify for a subtype (exception Object/Value_Size)
6316 elsif Is_Type
(U_Ent
)
6317 and then not Is_First_Subtype
(U_Ent
)
6318 and then Id
/= Attribute_Object_Size
6319 and then Id
/= Attribute_Value_Size
6320 and then not From_At_Mod
(N
)
6322 Error_Msg_N
("cannot specify attribute for subtype", Nam
);
6326 Set_Entity
(N
, U_Ent
);
6328 -- Switch on particular attribute
6336 -- Address attribute definition clause
6338 when Attribute_Address
=> Address
: begin
6340 -- A little error check, catch for X'Address use X'Address;
6342 if Nkind
(Nam
) = N_Identifier
6343 and then Nkind
(Expr
) = N_Attribute_Reference
6344 and then Attribute_Name
(Expr
) = Name_Address
6345 and then Nkind
(Prefix
(Expr
)) = N_Identifier
6346 and then Chars
(Nam
) = Chars
(Prefix
(Expr
))
6349 ("address for & is self-referencing", Prefix
(Expr
), Ent
);
6353 -- Not that special case, carry on with analysis of expression
6355 Analyze_And_Resolve
(Expr
, RTE
(RE_Address
));
6357 -- Even when ignoring rep clauses we need to indicate that the
6358 -- entity has an address clause and thus it is legal to declare
6359 -- it imported. Freeze will get rid of the address clause later.
6360 -- Also call Set_Address_Taken to indicate that an address clause
6361 -- was present, even if we are about to remove it.
6363 if Ignore_Rep_Clauses
then
6364 Set_Address_Taken
(U_Ent
);
6366 if Ekind
(U_Ent
) in E_Variable | E_Constant
then
6367 Record_Rep_Item
(U_Ent
, N
);
6373 if Duplicate_Clause
then
6376 -- Case of address clause for subprogram
6378 elsif Is_Subprogram
(U_Ent
) then
6379 if Has_Homonym
(U_Ent
) then
6381 ("address clause cannot be given for overloaded "
6382 & "subprogram", Nam
);
6386 -- For subprograms, all address clauses are permitted, and we
6387 -- mark the subprogram as having a deferred freeze so that Gigi
6388 -- will not elaborate it too soon.
6390 -- Above needs more comments, what is too soon about???
6392 Set_Has_Delayed_Freeze
(U_Ent
);
6394 -- Case of address clause for entry
6396 elsif Ekind
(U_Ent
) = E_Entry
then
6397 if Nkind
(Parent
(N
)) = N_Task_Body
then
6399 ("entry address must be specified in task spec", Nam
);
6403 -- For entries, we require a constant address
6405 Check_Constant_Address_Clause
(Expr
, U_Ent
);
6407 -- Special checks for task types
6409 if Is_Task_Type
(Scope
(U_Ent
))
6410 and then Comes_From_Source
(Scope
(U_Ent
))
6413 ("??entry address declared for entry in task type", N
);
6415 ("\??only one task can be declared of this type", N
);
6418 -- Entry address clauses are obsolescent
6420 Check_Restriction
(No_Obsolescent_Features
, N
);
6422 if Warn_On_Obsolescent_Feature
then
6424 ("?j?attaching interrupt to task entry is an obsolescent "
6425 & "feature (RM J.7.1)", N
);
6427 ("\?j?use interrupt procedure instead", N
);
6430 -- Case of address clause for an object
6432 elsif Ekind
(U_Ent
) in E_Constant | E_Variable
then
6434 -- Disallow case of an address clause for an object of an
6435 -- indefinite subtype which takes its bounds/discriminant/tag
6436 -- from its initial value. Without this, we get a Gigi
6437 -- assertion failure for things like
6438 -- X : String := Some_Function (...) with Address => ...;
6439 -- where the result subtype of the function is unconstrained.
6441 -- We want to reject two cases: the class-wide case, and the
6442 -- case where the FE conjures up a renaming declaration and
6443 -- would then otherwise generate an address specification for
6444 -- that renaming (which is a malformed tree, which is why Gigi
6447 if Is_Class_Wide_Type
(Etype
(U_Ent
)) then
6449 ("address specification not supported for class-wide " &
6450 "object declaration", Nam
);
6452 elsif Is_Constr_Subt_For_U_Nominal
(Etype
(U_Ent
))
6454 Nkind
(Parent
(U_Ent
)) = N_Object_Renaming_Declaration
6456 -- Confirm accuracy of " and dynamic size" message text
6457 -- before including it. We want to include that text when
6458 -- it is correct because it may be useful to the reader.
6459 -- The case where we omit that part of the message text
6460 -- might be dead code, but let's not rely on that.
6463 ("address specification not supported for object " &
6464 "declaration with indefinite nominal subtype" &
6465 (if Size_Known_At_Compile_Time
(Etype
(U_Ent
))
6467 else " and dynamic size"), Nam
);
6472 Expr
: constant Node_Id
:= Expression
(N
);
6477 -- Exported variables cannot have an address clause, because
6478 -- this cancels the effect of the pragma Export.
6480 if Is_Exported
(U_Ent
) then
6482 ("cannot export object with address clause", Nam
);
6486 Find_Overlaid_Entity
(N
, O_Ent
, Off
);
6488 if Present
(O_Ent
) then
6490 -- If the object overlays a constant object, mark it so
6492 if Is_Constant_Object
(O_Ent
) then
6493 Set_Overlays_Constant
(U_Ent
);
6496 -- If the address clause is of the form:
6498 -- for X'Address use Y'Address;
6502 -- C : constant Address := Y'Address;
6504 -- for X'Address use C;
6506 -- then we make an entry in the table to check the size
6507 -- and alignment of the overlaying variable. But we defer
6508 -- this check till after code generation to take full
6509 -- advantage of the annotation done by the back end.
6511 -- If the entity has a generic type, the check will be
6512 -- performed in the instance if the actual type justifies
6513 -- it, and we do not insert the clause in the table to
6514 -- prevent spurious warnings.
6516 -- Note: we used to test Comes_From_Source and only give
6517 -- this warning for source entities, but we have removed
6518 -- this test. It really seems bogus to generate overlays
6519 -- that would trigger this warning in generated code.
6520 -- Furthermore, by removing the test, we handle the
6521 -- aspect case properly.
6523 if Is_Object
(O_Ent
)
6524 and then not Is_Generic_Formal
(O_Ent
)
6525 and then not Is_Generic_Type
(Etype
(U_Ent
))
6526 and then Address_Clause_Overlay_Warnings
6528 Register_Address_Clause_Check
6529 (N
, U_Ent
, No_Uint
, O_Ent
, Off
);
6532 -- If the overlay changes the storage order, warn since
6533 -- the construct is not really supported by the back end.
6534 -- Also mark the entity as being volatile to block the
6535 -- optimizer, even if there is no warranty on the result.
6537 if (Is_Record_Type
(Etype
(U_Ent
))
6538 or else Is_Array_Type
(Etype
(U_Ent
)))
6539 and then (Is_Record_Type
(Etype
(O_Ent
))
6540 or else Is_Array_Type
(Etype
(O_Ent
)))
6541 and then Reverse_Storage_Order
(Etype
(U_Ent
)) /=
6542 Reverse_Storage_Order
(Etype
(O_Ent
))
6545 ("??overlay changes scalar storage order", Expr
);
6546 Set_Treat_As_Volatile
(U_Ent
);
6550 -- If this is not an overlay, mark a variable as being
6551 -- volatile to prevent unwanted optimizations. It's a
6552 -- conservative interpretation of RM 13.3(19) for the
6553 -- cases where the compiler cannot detect potential
6554 -- aliasing issues easily and it also covers the case
6555 -- of an absolute address where the volatile aspect is
6556 -- kind of implicit.
6558 if Ekind
(U_Ent
) = E_Variable
then
6559 Set_Treat_As_Volatile
(U_Ent
);
6562 -- Make an entry in the table for an absolute address as
6563 -- above to check that the value is compatible with the
6564 -- alignment of the object.
6567 Addr
: constant Node_Id
:= Address_Value
(Expr
);
6569 if Compile_Time_Known_Value
(Addr
)
6570 and then Address_Clause_Overlay_Warnings
6572 Register_Address_Clause_Check
6573 (N
, U_Ent
, Expr_Value
(Addr
), Empty
, False);
6578 -- Issue an unconditional warning for a constant overlaying
6579 -- a variable. For the reverse case, we will issue it only
6580 -- if the variable is modified.
6581 -- Within a generic unit an In_Parameter is a constant.
6582 -- It can be instantiated with a variable, in which case
6583 -- there will be a warning on the instance.
6585 if Ekind
(U_Ent
) = E_Constant
6586 and then Present
(O_Ent
)
6587 and then Ekind
(O_Ent
) /= E_Generic_In_Parameter
6588 and then not Overlays_Constant
(U_Ent
)
6589 and then Address_Clause_Overlay_Warnings
6591 Error_Msg_N
("?o?constant overlays a variable", Expr
);
6593 -- Imported variables can have an address clause, but then
6594 -- the import is pretty meaningless except to suppress
6595 -- initializations, so we do not need such variables to
6596 -- be statically allocated (and in fact it causes trouble
6597 -- if the address clause is a local value).
6599 elsif Is_Imported
(U_Ent
) then
6600 Set_Is_Statically_Allocated
(U_Ent
, False);
6603 -- We mark a possible modification of a variable with an
6604 -- address clause, since it is likely aliasing is occurring.
6606 Note_Possible_Modification
(Nam
, Sure
=> False);
6608 -- Legality checks on the address clause for initialized
6609 -- objects is deferred until the freeze point, because
6610 -- a subsequent pragma might indicate that the object
6611 -- is imported and thus not initialized. Also, the address
6612 -- clause might involve entities that have yet to be
6615 Set_Has_Delayed_Freeze
(U_Ent
);
6617 -- If an initialization call has been generated for this
6618 -- object, it needs to be deferred to after the freeze node
6619 -- we have just now added, otherwise GIGI will see a
6620 -- reference to the variable (as actual to the IP call)
6621 -- before its definition.
6624 Init_Call
: constant Node_Id
:=
6625 Remove_Init_Call
(U_Ent
, N
);
6628 if Present
(Init_Call
) then
6629 Append_Freeze_Action
(U_Ent
, Init_Call
);
6631 -- Reset Initialization_Statements pointer so that
6632 -- if there is a pragma Import further down, it can
6633 -- clear any default initialization.
6635 Set_Initialization_Statements
(U_Ent
, Init_Call
);
6639 -- Entity has delayed freeze, so we will generate an
6640 -- alignment check at the freeze point unless suppressed.
6642 if not Range_Checks_Suppressed
(U_Ent
)
6643 and then not Alignment_Checks_Suppressed
(U_Ent
)
6645 Set_Check_Address_Alignment
(N
);
6648 -- Kill the size check code, since we are not allocating
6649 -- the variable, it is somewhere else.
6651 Kill_Size_Check_Code
(U_Ent
);
6654 -- Not a valid entity for an address clause
6657 Error_Msg_N
("address cannot be given for &", Nam
);
6665 -- Alignment attribute definition clause
6667 when Attribute_Alignment
=> Alignment
: declare
6668 Align
: constant Uint
:= Get_Alignment_Value
(Expr
);
6669 Max_Align
: constant Uint
:= UI_From_Int
(Maximum_Alignment
);
6674 if not Is_Type
(U_Ent
)
6675 and then Ekind
(U_Ent
) /= E_Variable
6676 and then Ekind
(U_Ent
) /= E_Constant
6678 Error_Msg_N
("alignment cannot be given for &", Nam
);
6680 elsif Duplicate_Clause
then
6683 elsif Present
(Align
) then
6684 Set_Has_Alignment_Clause
(U_Ent
);
6686 -- Tagged type case, check for attempt to set alignment to a
6687 -- value greater than Max_Align, and reset if so.
6689 if Is_Tagged_Type
(U_Ent
) and then Align
> Max_Align
then
6691 ("alignment for & set to Maximum_Aligment??", Nam
);
6692 Set_Alignment
(U_Ent
, Max_Align
);
6697 Set_Alignment
(U_Ent
, Align
);
6700 -- For an array type, U_Ent is the first subtype. In that case,
6701 -- also set the alignment of the anonymous base type so that
6702 -- other subtypes (such as the itypes for aggregates of the
6703 -- type) also receive the expected alignment.
6705 if Is_Array_Type
(U_Ent
) then
6706 Set_Alignment
(Base_Type
(U_Ent
), Align
);
6715 -- Bit_Order attribute definition clause
6717 when Attribute_Bit_Order
=>
6718 if not Is_Record_Type
(U_Ent
) then
6720 ("Bit_Order can only be defined for record type", Nam
);
6722 elsif Is_Tagged_Type
(U_Ent
) and then Is_Derived_Type
(U_Ent
) then
6724 ("Bit_Order cannot be defined for record extensions", Nam
);
6726 elsif Duplicate_Clause
then
6730 Analyze_And_Resolve
(Expr
, RTE
(RE_Bit_Order
));
6732 if Etype
(Expr
) = Any_Type
then
6735 elsif not Is_OK_Static_Expression
(Expr
) then
6736 Flag_Non_Static_Expr
6737 ("Bit_Order requires static expression!", Expr
);
6739 elsif (Expr_Value
(Expr
) = 0) /= Bytes_Big_Endian
then
6740 Set_Reverse_Bit_Order
(Base_Type
(U_Ent
), True);
6744 --------------------
6745 -- Component_Size --
6746 --------------------
6748 -- Component_Size attribute definition clause
6750 when Attribute_Component_Size
=> Component_Size_Case
: declare
6751 Csize
: constant Uint
:= Static_Integer
(Expr
);
6755 New_Ctyp
: Entity_Id
;
6759 if not Is_Array_Type
(U_Ent
) then
6760 Error_Msg_N
("component size requires array type", Nam
);
6764 Btype
:= Base_Type
(U_Ent
);
6765 Ctyp
:= Component_Type
(Btype
);
6767 if Duplicate_Clause
then
6770 elsif Rep_Item_Too_Early
(Btype
, N
) then
6773 elsif Present
(Csize
) then
6774 Check_Size
(Expr
, Ctyp
, Csize
, Biased
);
6776 -- For the biased case, build a declaration for a subtype that
6777 -- will be used to represent the biased subtype that reflects
6778 -- the biased representation of components. We need the subtype
6779 -- to get proper conversions on referencing elements of the
6784 Make_Defining_Identifier
(Loc
,
6786 New_External_Name
(Chars
(U_Ent
), 'C', 0, 'T'));
6789 Make_Subtype_Declaration
(Loc
,
6790 Defining_Identifier
=> New_Ctyp
,
6791 Subtype_Indication
=>
6792 New_Occurrence_Of
(Component_Type
(Btype
), Loc
));
6794 Set_Parent
(Decl
, N
);
6795 Analyze
(Decl
, Suppress
=> All_Checks
);
6797 Set_Has_Delayed_Freeze
(New_Ctyp
, False);
6798 Reinit_Esize
(New_Ctyp
);
6799 Set_RM_Size
(New_Ctyp
, Csize
);
6800 Reinit_Alignment
(New_Ctyp
);
6801 Set_Is_Itype
(New_Ctyp
, True);
6802 Set_Associated_Node_For_Itype
(New_Ctyp
, U_Ent
);
6804 Set_Component_Type
(Btype
, New_Ctyp
);
6805 Set_Biased
(New_Ctyp
, N
, "component size clause");
6808 Set_Component_Size
(Btype
, Csize
);
6810 -- Deal with warning on overridden size
6812 if Warn_On_Overridden_Size
6813 and then Has_Size_Clause
(Ctyp
)
6814 and then RM_Size
(Ctyp
) /= Csize
6817 ("component size overrides size clause for&?.s?", N
, Ctyp
);
6820 Set_Has_Component_Size_Clause
(Btype
, True);
6821 Set_Has_Non_Standard_Rep
(Btype
, True);
6823 end Component_Size_Case
;
6825 -----------------------
6826 -- Constant_Indexing --
6827 -----------------------
6829 when Attribute_Constant_Indexing
=>
6830 Check_Indexing_Functions
;
6836 when Attribute_CPU
=>
6837 pragma Assert
(From_Aspect_Specification
(N
));
6838 -- The parser forbids this clause in source code, so it must have
6839 -- come from an aspect specification.
6841 if not Is_Task_Type
(U_Ent
) then
6842 Error_Msg_N
("'C'P'U can only be defined for task", Nam
);
6844 elsif Duplicate_Clause
then
6848 -- The expression must be analyzed in the special manner
6849 -- described in "Handling of Default and Per-Object
6850 -- Expressions" in sem.ads.
6852 -- The visibility to the components must be established
6853 -- and restored before and after analysis.
6856 Preanalyze_Spec_Expression
(Expr
, RTE
(RE_CPU_Range
));
6859 -- AI12-0117-1, "Restriction No_Tasks_Unassigned_To_CPU":
6860 -- If the expression is static, and its value is
6861 -- System.Multiprocessors.Not_A_Specific_CPU (i.e. zero) then
6862 -- that's a violation of No_Tasks_Unassigned_To_CPU. It might
6863 -- seem better to refer to Not_A_Specific_CPU here, but that
6864 -- involves a lot of horsing around with Rtsfind, and this
6865 -- value is not going to change, so it's better to hardwire
6868 -- AI12-0055-1, "All properties of a usage profile are defined
6869 -- by pragmas": If the expression is nonstatic, that's a
6870 -- violation of No_Dynamic_CPU_Assignment.
6872 if Is_OK_Static_Expression
(Expr
) then
6873 if Expr_Value
(Expr
) = Uint_0
then
6874 Check_Restriction
(No_Tasks_Unassigned_To_CPU
, Expr
);
6877 Check_Restriction
(No_Dynamic_CPU_Assignment
, Expr
);
6881 ----------------------
6882 -- Default_Iterator --
6883 ----------------------
6885 when Attribute_Default_Iterator
=> Default_Iterator
: declare
6890 -- If target type is untagged, further checks are irrelevant
6892 if not Is_Tagged_Type
(U_Ent
) then
6894 ("aspect Default_Iterator applies to tagged type", Nam
);
6898 Check_Iterator_Functions
;
6902 if not Is_Entity_Name
(Expr
)
6903 or else Ekind
(Entity
(Expr
)) /= E_Function
6905 Error_Msg_N
("aspect Iterator must be a function", Expr
);
6908 Func
:= Entity
(Expr
);
6911 -- The type of the first parameter must be T, T'class, or a
6912 -- corresponding access type (5.5.1 (8/3). If function is
6913 -- parameterless label type accordingly.
6915 if No
(First_Formal
(Func
)) then
6918 Typ
:= Etype
(First_Formal
(Func
));
6922 or else Typ
= Class_Wide_Type
(U_Ent
)
6923 or else (Is_Access_Type
(Typ
)
6924 and then Designated_Type
(Typ
) = U_Ent
)
6925 or else (Is_Access_Type
(Typ
)
6926 and then Designated_Type
(Typ
) =
6927 Class_Wide_Type
(U_Ent
))
6933 ("Default_Iterator must be a primitive of&", Func
, U_Ent
);
6935 end Default_Iterator
;
6937 ------------------------
6938 -- Dispatching_Domain --
6939 ------------------------
6941 when Attribute_Dispatching_Domain
=>
6942 pragma Assert
(From_Aspect_Specification
(N
));
6943 -- The parser forbids this clause in source code, so it must have
6944 -- come from an aspect specification.
6946 if not Is_Task_Type
(U_Ent
) then
6948 ("Dispatching_Domain can only be defined for task", Nam
);
6950 elsif Duplicate_Clause
then
6954 -- The expression must be analyzed in the special manner
6955 -- described in "Handling of Default and Per-Object
6956 -- Expressions" in sem.ads.
6958 -- The visibility to the components must be restored
6962 Preanalyze_Spec_Expression
6963 (Expr
, RTE
(RE_Dispatching_Domain
));
6972 when Attribute_External_Tag
=>
6973 if not Is_Tagged_Type
(U_Ent
) then
6974 Error_Msg_N
("should be a tagged type", Nam
);
6977 if Duplicate_Clause
then
6981 Analyze_And_Resolve
(Expr
, Standard_String
);
6983 if not Is_OK_Static_Expression
(Expr
) then
6984 Flag_Non_Static_Expr
6985 ("static string required for tag name!", Nam
);
6988 if not Is_Library_Level_Entity
(U_Ent
) then
6990 ("??non-unique external tag supplied for &", N
, U_Ent
);
6992 ("\??same external tag applies to all subprogram calls",
6995 ("\??corresponding internal tag cannot be obtained", N
);
6999 --------------------------
7000 -- Implicit_Dereference --
7001 --------------------------
7003 when Attribute_Implicit_Dereference
=>
7005 -- Legality checks already performed at the point of the type
7006 -- declaration, aspect is not delayed.
7014 when Attribute_Input
=>
7015 Analyze_Stream_TSS_Definition
(TSS_Stream_Input
);
7016 Set_Has_Specified_Stream_Input
(Ent
);
7018 ------------------------
7019 -- Interrupt_Priority --
7020 ------------------------
7022 when Attribute_Interrupt_Priority
=>
7023 pragma Assert
(From_Aspect_Specification
(N
));
7024 -- The parser forbids this clause in source code, so it must have
7025 -- come from an aspect specification.
7027 if not Is_Concurrent_Type
(U_Ent
) then
7029 ("Interrupt_Priority can only be defined for task and "
7030 & "protected object", Nam
);
7032 elsif Duplicate_Clause
then
7036 -- The expression must be analyzed in the special manner
7037 -- described in "Handling of Default and Per-Object
7038 -- Expressions" in sem.ads.
7040 -- The visibility to the components must be restored
7044 Preanalyze_Spec_Expression
7045 (Expr
, RTE
(RE_Interrupt_Priority
));
7049 -- Check the No_Task_At_Interrupt_Priority restriction
7051 if Is_Task_Type
(U_Ent
) then
7052 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
7060 when Attribute_Iterable
=>
7063 if Nkind
(Expr
) /= N_Aggregate
then
7064 Error_Msg_N
("aspect Iterable must be an aggregate", Expr
);
7072 Assoc
:= First
(Component_Associations
(Expr
));
7073 while Present
(Assoc
) loop
7074 Analyze
(Expression
(Assoc
));
7076 if not Is_Entity_Name
(Expression
(Assoc
))
7077 or else Ekind
(Entity
(Expression
(Assoc
))) /= E_Function
7079 Error_Msg_N
("value must be a function", Assoc
);
7086 ----------------------
7087 -- Iterator_Element --
7088 ----------------------
7090 when Attribute_Iterator_Element
=>
7093 if not Is_Entity_Name
(Expr
)
7094 or else not Is_Type
(Entity
(Expr
))
7096 Error_Msg_N
("aspect Iterator_Element must be a type", Expr
);
7104 -- Machine radix attribute definition clause
7106 when Attribute_Machine_Radix
=> Machine_Radix
: declare
7107 Radix
: constant Uint
:= Static_Integer
(Expr
);
7110 if not Is_Decimal_Fixed_Point_Type
(U_Ent
) then
7111 Error_Msg_N
("decimal fixed-point type expected for &", Nam
);
7113 elsif Duplicate_Clause
then
7116 elsif Present
(Radix
) then
7117 Set_Has_Machine_Radix_Clause
(U_Ent
);
7118 Set_Has_Non_Standard_Rep
(Base_Type
(U_Ent
));
7123 elsif Radix
= 10 then
7124 Set_Machine_Radix_10
(U_Ent
);
7127 Error_Msg_N
("machine radix value must be 2 or 10", Expr
);
7136 -- Object_Size attribute definition clause
7138 when Attribute_Object_Size
=> Object_Size
: declare
7139 Size
: constant Uint
:= Static_Integer
(Expr
);
7142 pragma Warnings
(Off
, Biased
);
7145 if not Is_Type
(U_Ent
) then
7146 Error_Msg_N
("Object_Size cannot be given for &", Nam
);
7148 elsif Duplicate_Clause
then
7152 Check_Size
(Expr
, U_Ent
, Size
, Biased
);
7154 if No
(Size
) or else Size
<= 0 then
7155 Error_Msg_N
("Object_Size must be positive", Expr
);
7157 elsif Is_Scalar_Type
(U_Ent
) then
7158 if Size
/= 8 and then Size
/= 16 and then Size
/= 32
7159 and then UI_Mod
(Size
, 64) /= 0
7162 ("Object_Size must be 8, 16, 32, or multiple of 64",
7166 elsif Size
mod 8 /= 0 then
7167 Error_Msg_N
("Object_Size must be a multiple of 8", Expr
);
7170 Set_Esize
(U_Ent
, Size
);
7171 Set_Has_Object_Size_Clause
(U_Ent
);
7172 Alignment_Check_For_Size_Change
(U_Ent
, Size
);
7180 when Attribute_Output
=>
7181 Analyze_Stream_TSS_Definition
(TSS_Stream_Output
);
7182 Set_Has_Specified_Stream_Output
(Ent
);
7188 when Attribute_Priority
=>
7190 -- Priority attribute definition clause not allowed except from
7191 -- aspect specification.
7193 if From_Aspect_Specification
(N
) then
7194 if not (Is_Concurrent_Type
(U_Ent
)
7195 or else Ekind
(U_Ent
) = E_Procedure
)
7198 ("Priority can only be defined for task and protected "
7201 elsif Duplicate_Clause
then
7205 -- The expression must be analyzed in the special manner
7206 -- described in "Handling of Default and Per-Object
7207 -- Expressions" in sem.ads.
7209 -- The visibility to the components must be restored
7212 Preanalyze_Spec_Expression
(Expr
, Standard_Integer
);
7215 if not Is_OK_Static_Expression
(Expr
) then
7216 Check_Restriction
(Static_Priorities
, Expr
);
7222 ("attribute& cannot be set with definition clause", N
);
7229 when Attribute_Put_Image
=>
7230 Analyze_Put_Image_TSS_Definition
;
7236 when Attribute_Read
=>
7237 Analyze_Stream_TSS_Definition
(TSS_Stream_Read
);
7238 Set_Has_Specified_Stream_Read
(Ent
);
7240 --------------------------
7241 -- Scalar_Storage_Order --
7242 --------------------------
7244 -- Scalar_Storage_Order attribute definition clause
7246 when Attribute_Scalar_Storage_Order
=>
7247 if not (Is_Record_Type
(U_Ent
) or else Is_Array_Type
(U_Ent
)) then
7249 ("Scalar_Storage_Order can only be defined for record or "
7250 & "array type", Nam
);
7252 elsif Duplicate_Clause
then
7256 Analyze_And_Resolve
(Expr
, RTE
(RE_Bit_Order
));
7258 if Etype
(Expr
) = Any_Type
then
7261 elsif not Is_OK_Static_Expression
(Expr
) then
7262 Flag_Non_Static_Expr
7263 ("Scalar_Storage_Order requires static expression!", Expr
);
7265 elsif (Expr_Value
(Expr
) = 0) /= Bytes_Big_Endian
then
7267 -- Here for the case of a non-default (i.e. non-confirming)
7268 -- Scalar_Storage_Order attribute definition.
7270 if Support_Nondefault_SSO_On_Target
then
7271 Set_Reverse_Storage_Order
(Base_Type
(U_Ent
), True);
7274 ("non-default Scalar_Storage_Order not supported on "
7279 -- Clear SSO default indications since explicit setting of the
7280 -- order overrides the defaults.
7282 Set_SSO_Set_Low_By_Default
(Base_Type
(U_Ent
), False);
7283 Set_SSO_Set_High_By_Default
(Base_Type
(U_Ent
), False);
7286 ------------------------
7287 -- Size or Value_Size --
7288 ------------------------
7290 -- Size or Value_Size attribute definition clause. These are treated
7291 -- the same, except that Size is allowed on objects, and Value_Size
7292 -- is allowed on nonfirst subtypes. First subtypes allow both Size
7293 -- and Value_Size; the treatment is the same for both.
7295 when Attribute_Size | Attribute_Value_Size
=> Size
: declare
7296 Size
: constant Uint
:= Static_Integer
(Expr
);
7298 Attr_Name
: constant String :=
7299 (if Id
= Attribute_Size
then "size"
7300 elsif Id
= Attribute_Value_Size
then "value size"
7301 else ""); -- can't happen
7302 -- Name of the attribute for printing in messages
7304 OK_Prefix
: constant Boolean :=
7305 (if Id
= Attribute_Size
then
7306 Ekind
(U_Ent
) in Type_Kind | Constant_Or_Variable_Kind
7307 elsif Id
= Attribute_Value_Size
then
7308 Ekind
(U_Ent
) in Type_Kind
7309 else False); -- can't happen
7310 -- For X'Size, X can be a type or object; for X'Value_Size,
7311 -- X can be a type. Note that we already checked that 'Size
7312 -- can be specified only for a first subtype.
7317 if not OK_Prefix
then
7318 Error_Msg_N
(Attr_Name
& " cannot be given for &", Nam
);
7320 elsif Duplicate_Clause
then
7323 elsif Is_Array_Type
(U_Ent
)
7324 and then not Is_Constrained
(U_Ent
)
7327 (Attr_Name
& " cannot be given for unconstrained array", Nam
);
7329 elsif Present
(Size
) then
7331 Etyp
: constant Entity_Id
:=
7332 (if Is_Type
(U_Ent
) then U_Ent
else Etype
(U_Ent
));
7335 -- Check size, note that Gigi is in charge of checking that
7336 -- the size of an array or record type is OK. Also we do not
7337 -- check the size in the ordinary fixed-point case, since
7338 -- it is too early to do so (there may be subsequent small
7339 -- clause that affects the size). We can check the size if
7340 -- a small clause has already been given.
7342 if not Is_Ordinary_Fixed_Point_Type
(U_Ent
)
7343 or else Has_Small_Clause
(U_Ent
)
7348 Check_Size
(Expr
, Etyp
, Size
, Biased
);
7349 Set_Biased
(U_Ent
, N
, Attr_Name
& " clause", Biased
);
7353 -- For types, set RM_Size and Esize if appropriate
7355 if Is_Type
(U_Ent
) then
7356 Set_RM_Size
(U_Ent
, Size
);
7358 -- If we are specifying the Size or Value_Size of a
7359 -- first subtype, then for elementary types, increase
7360 -- Object_Size to power of 2, but not less than a storage
7361 -- unit in any case (normally this means it will be byte
7364 -- For all other types, nothing else to do, we leave
7365 -- Esize (object size) unset; the back end will set it
7366 -- from the size and alignment in an appropriate manner.
7368 -- In both cases, we check whether the alignment must be
7369 -- reset in the wake of the size change.
7371 -- For nonfirst subtypes ('Value_Size only), we do
7374 if Is_First_Subtype
(U_Ent
) then
7375 if Is_Elementary_Type
(U_Ent
) then
7376 if Size
<= System_Storage_Unit
then
7378 (U_Ent
, UI_From_Int
(System_Storage_Unit
));
7379 elsif Size
<= 16 then
7380 Set_Esize
(U_Ent
, Uint_16
);
7381 elsif Size
<= 32 then
7382 Set_Esize
(U_Ent
, Uint_32
);
7384 Set_Esize
(U_Ent
, (Size
+ 63) / 64 * 64);
7387 Alignment_Check_For_Size_Change
7388 (U_Ent
, Esize
(U_Ent
));
7390 Alignment_Check_For_Size_Change
(U_Ent
, Size
);
7394 -- For Object'Size, set Esize only
7397 if Is_Elementary_Type
(Etyp
)
7398 and then Size
/= System_Storage_Unit
7402 and then Size
/= System_Max_Integer_Size
7404 Error_Msg_Uint_1
:= UI_From_Int
(System_Storage_Unit
);
7406 UI_From_Int
(System_Max_Integer_Size
);
7408 ("size for primitive object must be a power of 2 in "
7409 & "the range ^-^", N
);
7412 Set_Esize
(U_Ent
, Size
);
7415 -- As of RM 13.1, only confirming size
7416 -- (i.e. (Size = Esize (Etyp))) for aliased object of
7417 -- elementary type must be supported.
7418 -- GNAT rejects nonconfirming size for such object.
7420 if Is_Aliased
(U_Ent
)
7421 and then Is_Elementary_Type
(Etyp
)
7422 and then Known_Esize
(U_Ent
)
7423 and then Size
/= Esize
(Etyp
)
7426 ("nonconfirming Size for aliased object is not "
7430 Set_Has_Size_Clause
(U_Ent
);
7439 -- Small attribute definition clause
7441 when Attribute_Small
=> Small
: declare
7442 Implicit_Base
: constant Entity_Id
:= Base_Type
(U_Ent
);
7446 Analyze_And_Resolve
(Expr
, Any_Real
);
7448 if Etype
(Expr
) = Any_Type
then
7451 elsif not Is_OK_Static_Expression
(Expr
) then
7452 Flag_Non_Static_Expr
7453 ("small requires static expression!", Expr
);
7457 Small
:= Expr_Value_R
(Expr
);
7459 if Small
<= Ureal_0
then
7460 Error_Msg_N
("small value must be greater than zero", Expr
);
7466 if not Is_Ordinary_Fixed_Point_Type
(U_Ent
) then
7468 ("small requires an ordinary fixed point type", Nam
);
7470 elsif Has_Small_Clause
(U_Ent
) then
7471 Error_Msg_N
("small already given for &", Nam
);
7473 elsif Small
> Delta_Value
(U_Ent
) then
7475 ("small value must not be greater than delta value", Nam
);
7478 Set_Small_Value
(U_Ent
, Small
);
7479 Set_Small_Value
(Implicit_Base
, Small
);
7480 Set_Has_Small_Clause
(U_Ent
);
7481 Set_Has_Small_Clause
(Implicit_Base
);
7482 Set_Has_Non_Standard_Rep
(Implicit_Base
);
7490 -- Storage_Pool attribute definition clause
7492 when Attribute_Simple_Storage_Pool
7493 | Attribute_Storage_Pool
7495 Storage_Pool
: declare
7499 procedure Associate_Storage_Pool
7500 (Ent
: Entity_Id
; Pool
: Entity_Id
);
7501 -- Associate Pool to Ent and perform legality checks on subpools
7503 ----------------------------
7504 -- Associate_Storage_Pool --
7505 ----------------------------
7507 procedure Associate_Storage_Pool
7508 (Ent
: Entity_Id
; Pool
: Entity_Id
)
7510 function Object_From
(Pool
: Entity_Id
) return Entity_Id
;
7511 -- Return the entity of which Pool is a part of
7517 function Object_From
7518 (Pool
: Entity_Id
) return Entity_Id
7520 N
: Node_Id
:= Pool
;
7522 if Present
(Renamed_Object
(Pool
)) then
7523 N
:= Renamed_Object
(Pool
);
7526 while Present
(N
) loop
7528 when N_Defining_Identifier
=>
7531 when N_Identifier | N_Expanded_Name
=>
7534 when N_Indexed_Component | N_Selected_Component |
7535 N_Explicit_Dereference
7539 when N_Type_Conversion
=>
7540 N
:= Expression
(N
);
7543 -- ??? we probably should handle more cases but
7544 -- this is good enough in practice for this check
7545 -- on a corner case.
7557 Set_Associated_Storage_Pool
(Ent
, Pool
);
7559 -- Check RM 13.11.4(22-23/3): a specification of a storage pool
7560 -- is illegal if the storage pool supports subpools and:
7561 -- (A) The access type is a general access type.
7562 -- (B) The access type is statically deeper than the storage
7564 -- (C) The storage pool object is a part of a formal parameter;
7565 -- (D) The storage pool object is a part of the dereference of
7566 -- a non-library level general access type;
7568 if Ada_Version
>= Ada_2012
7569 and then RTU_Loaded
(System_Storage_Pools_Subpools
)
7571 Is_Ancestor
(RTE
(RE_Root_Storage_Pool_With_Subpools
),
7576 if Ekind
(Etype
(Ent
)) = E_General_Access_Type
then
7578 ("subpool cannot be used on general access type", Ent
);
7583 if Type_Access_Level
(Ent
)
7584 > Static_Accessibility_Level
7585 (Pool
, Object_Decl_Level
)
7588 ("subpool access type has deeper accessibility "
7589 & "level than pool", Ent
);
7593 Obj
:= Object_From
(Pool
);
7597 if Present
(Obj
) and then Is_Formal
(Obj
) then
7599 ("subpool cannot be part of a parameter", Ent
);
7606 and then Ekind
(Etype
(Obj
)) = E_General_Access_Type
7607 and then not Is_Library_Level_Entity
(Etype
(Obj
))
7610 ("subpool cannot be part of the dereference of a " &
7611 "nested general access type", Ent
);
7615 end Associate_Storage_Pool
;
7618 if Ekind
(U_Ent
) = E_Access_Subprogram_Type
then
7620 ("storage pool cannot be given for access-to-subprogram type",
7624 elsif Ekind
(U_Ent
) not in E_Access_Type | E_General_Access_Type
7627 ("storage pool can only be given for access types", Nam
);
7630 elsif Is_Derived_Type
(U_Ent
) then
7632 ("storage pool cannot be given for a derived access type",
7635 elsif Duplicate_Clause
then
7638 elsif Present
(Associated_Storage_Pool
(U_Ent
)) then
7639 Error_Msg_N
("storage pool already given for &", Nam
);
7643 -- Check for Storage_Size previously given
7646 SS
: constant Node_Id
:=
7647 Get_Attribute_Definition_Clause
7648 (U_Ent
, Attribute_Storage_Size
);
7650 if Present
(SS
) then
7651 Check_Pool_Size_Clash
(U_Ent
, N
, SS
);
7655 -- Storage_Pool case
7657 if Id
= Attribute_Storage_Pool
then
7659 (Expr
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
7661 -- In the Simple_Storage_Pool case, we allow a variable of any
7662 -- simple storage pool type, so we Resolve without imposing an
7666 Analyze_And_Resolve
(Expr
);
7668 if No
(Get_Rep_Pragma
7669 (Etype
(Expr
), Name_Simple_Storage_Pool_Type
))
7672 ("expression must be of a simple storage pool type", Expr
);
7676 if not Denotes_Variable
(Expr
) then
7677 Error_Msg_N
("storage pool must be a variable", Expr
);
7681 if Nkind
(Expr
) = N_Type_Conversion
then
7682 T
:= Etype
(Expression
(Expr
));
7687 -- The Stack_Bounded_Pool is used internally for implementing
7688 -- access types with a Storage_Size. Since it only work properly
7689 -- when used on one specific type, we need to check that it is not
7690 -- hijacked improperly:
7692 -- type T is access Integer;
7693 -- for T'Storage_Size use n;
7694 -- type Q is access Float;
7695 -- for Q'Storage_Size use T'Storage_Size; -- incorrect
7697 if Is_RTE
(Base_Type
(T
), RE_Stack_Bounded_Pool
) then
7698 Error_Msg_N
("non-shareable internal Pool", Expr
);
7702 -- Validate_Remote_Access_To_Class_Wide_Type for attribute
7703 -- Storage_Pool since this attribute cannot be defined for such
7704 -- types (RM E.2.2(17)).
7706 Validate_Remote_Access_To_Class_Wide_Type
(N
);
7708 -- If the argument is a name that is not an entity name, then
7709 -- we construct a renaming operation to define an entity of
7710 -- type storage pool.
7712 if not Is_Entity_Name
(Expr
)
7713 and then Is_Object_Reference
(Expr
)
7715 Pool
:= Make_Temporary
(Loc
, 'P', Expr
);
7718 Rnode
: constant Node_Id
:=
7719 Make_Object_Renaming_Declaration
(Loc
,
7720 Defining_Identifier
=> Pool
,
7722 New_Occurrence_Of
(Etype
(Expr
), Loc
),
7726 -- If the attribute definition clause comes from an aspect
7727 -- clause, then insert the renaming before the associated
7728 -- entity's declaration, since the attribute clause has
7729 -- not yet been appended to the declaration list.
7731 if From_Aspect_Specification
(N
) then
7732 Insert_Before
(Parent
(Entity
(N
)), Rnode
);
7734 Insert_Before
(N
, Rnode
);
7738 Associate_Storage_Pool
(U_Ent
, Pool
);
7741 elsif Is_Entity_Name
(Expr
) then
7742 Pool
:= Entity
(Expr
);
7744 -- If pool is a renamed object, get original one. This can
7745 -- happen with an explicit renaming, and within instances.
7747 while Present
(Renamed_Object
(Pool
))
7748 and then Is_Entity_Name
(Renamed_Object
(Pool
))
7750 Pool
:= Entity
(Renamed_Object
(Pool
));
7753 if Present
(Renamed_Object
(Pool
))
7754 and then Nkind
(Renamed_Object
(Pool
)) = N_Type_Conversion
7755 and then Is_Entity_Name
(Expression
(Renamed_Object
(Pool
)))
7757 Pool
:= Entity
(Expression
(Renamed_Object
(Pool
)));
7760 Associate_Storage_Pool
(U_Ent
, Pool
);
7762 elsif Nkind
(Expr
) = N_Type_Conversion
7763 and then Is_Entity_Name
(Expression
(Expr
))
7764 and then Nkind
(Original_Node
(Expr
)) = N_Attribute_Reference
7766 Pool
:= Entity
(Expression
(Expr
));
7767 Associate_Storage_Pool
(U_Ent
, Pool
);
7770 Error_Msg_N
("incorrect reference to a Storage Pool", Expr
);
7779 -- Storage_Size attribute definition clause
7781 when Attribute_Storage_Size
=> Storage_Size
: declare
7782 Btype
: constant Entity_Id
:= Base_Type
(U_Ent
);
7785 if Is_Task_Type
(U_Ent
) then
7787 -- Check obsolescent (but never obsolescent if from aspect)
7789 if not From_Aspect_Specification
(N
) then
7790 Check_Restriction
(No_Obsolescent_Features
, N
);
7792 if Warn_On_Obsolescent_Feature
then
7794 ("?j?storage size clause for task is an obsolescent "
7795 & "feature (RM J.9)", N
);
7796 Error_Msg_N
("\?j?use Storage_Size pragma instead", N
);
7803 if not Is_Access_Type
(U_Ent
)
7804 and then Ekind
(U_Ent
) /= E_Task_Type
7806 Error_Msg_N
("storage size cannot be given for &", Nam
);
7808 elsif Is_Access_Type
(U_Ent
) and Is_Derived_Type
(U_Ent
) then
7810 ("storage size cannot be given for a derived access type",
7813 elsif Duplicate_Clause
then
7817 -- Validate_Remote_Access_To_Class_Wide_Type for attribute
7818 -- Storage_Size since this attribute cannot be defined for such
7819 -- types (RM E.2.2(17)).
7821 Validate_Remote_Access_To_Class_Wide_Type
(N
);
7823 Analyze_And_Resolve
(Expr
, Any_Integer
);
7825 if Is_Access_Type
(U_Ent
) then
7827 -- Check for Storage_Pool previously given
7830 SP
: constant Node_Id
:=
7831 Get_Attribute_Definition_Clause
7832 (U_Ent
, Attribute_Storage_Pool
);
7835 if Present
(SP
) then
7836 Check_Pool_Size_Clash
(U_Ent
, SP
, N
);
7840 -- Special case of for x'Storage_Size use 0
7842 if Is_OK_Static_Expression
(Expr
)
7843 and then Expr_Value
(Expr
) = 0
7845 Set_No_Pool_Assigned
(Btype
);
7849 Set_Has_Storage_Size_Clause
(Btype
);
7857 when Attribute_Stream_Size
=> Stream_Size
: declare
7858 Size
: constant Uint
:= Static_Integer
(Expr
);
7861 if Ada_Version
<= Ada_95
then
7862 Check_Restriction
(No_Implementation_Attributes
, N
);
7865 if Duplicate_Clause
then
7868 elsif Is_Elementary_Type
(U_Ent
) then
7869 -- Size will be empty if we already detected an error
7870 -- (e.g. Expr is of the wrong type); we might as well
7871 -- give the useful hint below even in that case.
7873 if No
(Size
) or else
7874 (Size
/= System_Storage_Unit
7875 and then Size
/= System_Storage_Unit
* 2
7876 and then Size
/= System_Storage_Unit
* 3
7877 and then Size
/= System_Storage_Unit
* 4
7878 and then Size
/= System_Storage_Unit
* 8)
7881 ("stream size for elementary type must be 8, 16, 24, " &
7884 elsif Known_RM_Size
(U_Ent
) and then RM_Size
(U_Ent
) > Size
then
7885 Error_Msg_Uint_1
:= RM_Size
(U_Ent
);
7887 ("stream size for elementary type must be 8, 16, 24, " &
7888 "32 or 64 and at least ^", N
);
7891 Set_Has_Stream_Size_Clause
(U_Ent
);
7894 Error_Msg_N
("Stream_Size cannot be given for &", Nam
);
7898 -----------------------
7899 -- Variable_Indexing --
7900 -----------------------
7902 when Attribute_Variable_Indexing
=>
7903 Check_Indexing_Functions
;
7909 when Attribute_Write
=>
7910 Analyze_Stream_TSS_Definition
(TSS_Stream_Write
);
7911 Set_Has_Specified_Stream_Write
(Ent
);
7913 -- All other attributes cannot be set
7917 ("attribute& cannot be set with definition clause", N
);
7920 -- The test for the type being frozen must be performed after any
7921 -- expression the clause has been analyzed since the expression itself
7922 -- might cause freezing that makes the clause illegal.
7924 if Rep_Item_Too_Late
(U_Ent
, N
, FOnly
) then
7927 end Analyze_Attribute_Definition_Clause
;
7929 ----------------------------
7930 -- Analyze_Code_Statement --
7931 ----------------------------
7933 procedure Analyze_Code_Statement
(N
: Node_Id
) is
7934 HSS
: constant Node_Id
:= Parent
(N
);
7935 SBody
: constant Node_Id
:= Parent
(HSS
);
7936 Subp
: constant Entity_Id
:= Current_Scope
;
7943 -- Accept foreign code statements for CodePeer. The analysis is skipped
7944 -- to avoid rejecting unrecognized constructs.
7946 if CodePeer_Mode
then
7951 -- Analyze and check we get right type, note that this implements the
7952 -- requirement (RM 13.8(1)) that Machine_Code be with'ed, since that is
7953 -- the only way that Asm_Insn could possibly be visible.
7955 Analyze_And_Resolve
(Expression
(N
));
7957 if Etype
(Expression
(N
)) = Any_Type
then
7959 elsif not Is_RTE
(Etype
(Expression
(N
)), RE_Asm_Insn
) then
7960 Error_Msg_N
("incorrect type for code statement", N
);
7964 Check_Code_Statement
(N
);
7966 -- Make sure we appear in the handled statement sequence of a subprogram
7969 if Nkind
(HSS
) /= N_Handled_Sequence_Of_Statements
7970 or else Nkind
(SBody
) /= N_Subprogram_Body
7973 ("code statement can only appear in body of subprogram", N
);
7977 -- Do remaining checks (RM 13.8(3)) if not already done
7979 if not Is_Machine_Code_Subprogram
(Subp
) then
7980 Set_Is_Machine_Code_Subprogram
(Subp
);
7982 -- No exception handlers allowed
7984 if Present
(Exception_Handlers
(HSS
)) then
7986 ("exception handlers not permitted in machine code subprogram",
7987 First
(Exception_Handlers
(HSS
)));
7990 -- No declarations other than use clauses and pragmas (we allow
7991 -- certain internally generated declarations as well).
7993 Decl
:= First
(Declarations
(SBody
));
7994 while Present
(Decl
) loop
7995 DeclO
:= Original_Node
(Decl
);
7996 if Comes_From_Source
(DeclO
)
7997 and Nkind
(DeclO
) not in N_Pragma
7998 | N_Use_Package_Clause
8000 | N_Implicit_Label_Declaration
8003 ("this declaration is not allowed in machine code subprogram",
8010 -- No statements other than code statements, pragmas, and labels.
8011 -- Again we allow certain internally generated statements.
8013 -- In Ada 2012, qualified expressions are names, and the code
8014 -- statement is initially parsed as a procedure call.
8016 Stmt
:= First
(Statements
(HSS
));
8017 while Present
(Stmt
) loop
8018 StmtO
:= Original_Node
(Stmt
);
8020 -- A procedure call transformed into a code statement is OK
8022 if Ada_Version
>= Ada_2012
8023 and then Nkind
(StmtO
) = N_Procedure_Call_Statement
8024 and then Nkind
(Name
(StmtO
)) = N_Qualified_Expression
8028 elsif Comes_From_Source
(StmtO
)
8029 and then Nkind
(StmtO
) not in
8030 N_Pragma | N_Label | N_Code_Statement
8033 ("this statement is not allowed in machine code subprogram",
8040 end Analyze_Code_Statement
;
8042 -----------------------------------------------
8043 -- Analyze_Enumeration_Representation_Clause --
8044 -----------------------------------------------
8046 procedure Analyze_Enumeration_Representation_Clause
(N
: Node_Id
) is
8047 Ident
: constant Node_Id
:= Identifier
(N
);
8048 Aggr
: constant Node_Id
:= Array_Aggregate
(N
);
8049 Enumtype
: Entity_Id
;
8056 Err
: Boolean := False;
8057 -- Set True to avoid cascade errors and crashes on incorrect source code
8059 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Universal_Integer
));
8060 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(Universal_Integer
));
8061 -- Allowed range of universal integer (= allowed range of enum lit vals)
8065 -- Minimum and maximum values of entries
8067 Max_Node
: Node_Id
:= Empty
; -- init to avoid warning
8068 -- Pointer to node for literal providing max value
8071 if Ignore_Rep_Clauses
then
8072 Kill_Rep_Clause
(N
);
8076 -- Ignore enumeration rep clauses by default in CodePeer mode,
8077 -- unless -gnatd.I is specified, as a work around for potential false
8078 -- positive messages.
8080 if CodePeer_Mode
and not Debug_Flag_Dot_II
then
8084 -- First some basic error checks
8087 Enumtype
:= Entity
(Ident
);
8089 if Enumtype
= Any_Type
8090 or else Rep_Item_Too_Early
(Enumtype
, N
)
8094 Enumtype
:= Underlying_Type
(Enumtype
);
8097 if not Is_Enumeration_Type
(Enumtype
) then
8099 ("enumeration type required, found}",
8100 Ident
, First_Subtype
(Enumtype
));
8104 -- Ignore rep clause on generic actual type. This will already have
8105 -- been flagged on the template as an error, and this is the safest
8106 -- way to ensure we don't get a junk cascaded message in the instance.
8108 if Is_Generic_Actual_Type
(Enumtype
) then
8111 -- Type must be in current scope
8113 elsif Scope
(Enumtype
) /= Current_Scope
then
8114 Error_Msg_N
("type must be declared in this scope", Ident
);
8117 -- Type must be a first subtype
8119 elsif not Is_First_Subtype
(Enumtype
) then
8120 Error_Msg_N
("cannot give enumeration rep clause for subtype", N
);
8123 -- Ignore duplicate rep clause
8125 elsif Has_Enumeration_Rep_Clause
(Enumtype
) then
8126 Error_Msg_N
("duplicate enumeration rep clause ignored", N
);
8129 -- Don't allow rep clause for standard [wide_[wide_]]character
8131 elsif Is_Standard_Character_Type
(Enumtype
) then
8132 Error_Msg_N
("enumeration rep clause not allowed for this type", N
);
8135 -- Check that the expression is a proper aggregate (no parentheses)
8137 elsif Paren_Count
(Aggr
) /= 0 then
8139 ("extra parentheses surrounding aggregate not allowed", Aggr
);
8142 -- Reject the mixing of named and positional entries in the aggregate
8144 elsif Present
(Expressions
(Aggr
))
8145 and then Present
(Component_Associations
(Aggr
))
8147 Error_Msg_N
("cannot mix positional and named entries in "
8148 & "enumeration rep clause", N
);
8151 -- All tests passed, so set rep clause in place
8154 Set_Has_Enumeration_Rep_Clause
(Enumtype
);
8155 Set_Has_Enumeration_Rep_Clause
(Base_Type
(Enumtype
));
8158 -- Now we process the aggregate. Note that we don't use the normal
8159 -- aggregate code for this purpose, because we don't want any of the
8160 -- normal expansion activities, and a number of special semantic
8161 -- rules apply (including the component type being any integer type)
8163 Elit
:= First_Literal
(Enumtype
);
8165 -- Process positional entries
8167 if Present
(Expressions
(Aggr
)) then
8168 Expr
:= First
(Expressions
(Aggr
));
8169 while Present
(Expr
) loop
8171 Error_Msg_N
("too many entries in aggregate", Expr
);
8175 Val
:= Static_Integer
(Expr
);
8177 -- Err signals that we found some incorrect entries processing
8178 -- the list. The final checks for completeness and ordering are
8179 -- skipped in this case.
8184 elsif Val
< Lo
or else Hi
< Val
then
8185 Error_Msg_N
("value outside permitted range", Expr
);
8189 Set_Enumeration_Rep
(Elit
, Val
);
8190 Set_Enumeration_Rep_Expr
(Elit
, Expr
);
8197 -- Process named entries
8199 elsif Present
(Component_Associations
(Aggr
)) then
8200 Assoc
:= First
(Component_Associations
(Aggr
));
8201 while Present
(Assoc
) loop
8202 Choice
:= First
(Choices
(Assoc
));
8204 if Present
(Next
(Choice
)) then
8206 ("multiple choice not allowed here", Next
(Choice
));
8210 if Nkind
(Choice
) = N_Others_Choice
then
8211 Error_Msg_N
("OTHERS choice not allowed here", Choice
);
8214 elsif Nkind
(Choice
) = N_Range
then
8216 -- ??? should allow zero/one element range here
8218 Error_Msg_N
("range not allowed here", Choice
);
8222 Analyze_And_Resolve
(Choice
, Enumtype
);
8224 if Error_Posted
(Choice
) then
8229 if Is_Entity_Name
(Choice
)
8230 and then Is_Type
(Entity
(Choice
))
8232 Error_Msg_N
("subtype name not allowed here", Choice
);
8235 -- ??? should allow static subtype with zero/one entry
8237 elsif Etype
(Choice
) = Base_Type
(Enumtype
) then
8238 if not Is_OK_Static_Expression
(Choice
) then
8239 Flag_Non_Static_Expr
8240 ("non-static expression used for choice!", Choice
);
8244 Elit
:= Expr_Value_E
(Choice
);
8246 if Present
(Enumeration_Rep_Expr
(Elit
)) then
8248 Sloc
(Enumeration_Rep_Expr
(Elit
));
8250 ("representation for& previously given#",
8255 Set_Enumeration_Rep_Expr
(Elit
, Expression
(Assoc
));
8257 Expr
:= Expression
(Assoc
);
8258 Val
:= Static_Integer
(Expr
);
8263 elsif Val
< Lo
or else Hi
< Val
then
8264 Error_Msg_N
("value outside permitted range", Expr
);
8268 Set_Enumeration_Rep
(Elit
, Val
);
8279 -- Aggregate is fully processed. Now we check that a full set of
8280 -- representations was given, and that they are in range and in order.
8281 -- These checks are only done if no other errors occurred.
8287 Elit
:= First_Literal
(Enumtype
);
8288 while Present
(Elit
) loop
8289 if No
(Enumeration_Rep_Expr
(Elit
)) then
8290 Error_Msg_NE
("missing representation for&!", N
, Elit
);
8293 Val
:= Enumeration_Rep
(Elit
);
8299 if Present
(Val
) then
8300 if Present
(Max
) and then Val
<= Max
then
8302 ("enumeration value for& not ordered!",
8303 Enumeration_Rep_Expr
(Elit
), Elit
);
8306 Max_Node
:= Enumeration_Rep_Expr
(Elit
);
8310 -- If there is at least one literal whose representation is not
8311 -- equal to the Pos value, then note that this enumeration type
8312 -- has a non-standard representation.
8314 if Val
/= Enumeration_Pos
(Elit
) then
8315 Set_Has_Non_Standard_Rep
(Base_Type
(Enumtype
));
8322 -- Now set proper size information
8325 Minsize
: Uint
:= UI_From_Int
(Minimum_Size
(Enumtype
));
8328 if Has_Size_Clause
(Enumtype
) then
8330 -- All OK, if size is OK now
8332 if RM_Size
(Enumtype
) >= Minsize
then
8336 -- Try if we can get by with biasing
8339 UI_From_Int
(Minimum_Size
(Enumtype
, Biased
=> True));
8341 -- Error message if even biasing does not work
8343 if RM_Size
(Enumtype
) < Minsize
then
8344 Error_Msg_Uint_1
:= RM_Size
(Enumtype
);
8345 Error_Msg_Uint_2
:= Max
;
8347 ("previously given size (^) is too small "
8348 & "for this value (^)", Max_Node
);
8350 -- If biasing worked, indicate that we now have biased rep
8354 (Enumtype
, Size_Clause
(Enumtype
), "size clause");
8359 Set_RM_Size
(Enumtype
, Minsize
);
8360 Set_Enum_Esize
(Enumtype
);
8363 Set_RM_Size
(Base_Type
(Enumtype
), RM_Size
(Enumtype
));
8364 Set_Esize
(Base_Type
(Enumtype
), Esize
(Enumtype
));
8366 Copy_Alignment
(To
=> Base_Type
(Enumtype
), From
=> Enumtype
);
8370 -- We repeat the too late test in case it froze itself
8372 if Rep_Item_Too_Late
(Enumtype
, N
) then
8375 end Analyze_Enumeration_Representation_Clause
;
8377 ----------------------------
8378 -- Analyze_Free_Statement --
8379 ----------------------------
8381 procedure Analyze_Free_Statement
(N
: Node_Id
) is
8383 Analyze
(Expression
(N
));
8384 end Analyze_Free_Statement
;
8386 ---------------------------
8387 -- Analyze_Freeze_Entity --
8388 ---------------------------
8390 procedure Analyze_Freeze_Entity
(N
: Node_Id
) is
8392 Freeze_Entity_Checks
(N
);
8393 end Analyze_Freeze_Entity
;
8395 -----------------------------------
8396 -- Analyze_Freeze_Generic_Entity --
8397 -----------------------------------
8399 procedure Analyze_Freeze_Generic_Entity
(N
: Node_Id
) is
8400 E
: constant Entity_Id
:= Entity
(N
);
8403 if not Is_Frozen
(E
) and then Has_Delayed_Aspects
(E
) then
8404 Analyze_Aspects_At_Freeze_Point
(E
);
8407 Freeze_Entity_Checks
(N
);
8408 end Analyze_Freeze_Generic_Entity
;
8410 ------------------------------------------
8411 -- Analyze_Record_Representation_Clause --
8412 ------------------------------------------
8414 -- Note: we check as much as we can here, but we can't do any checks
8415 -- based on the position values (e.g. overlap checks) until freeze time
8416 -- because especially in Ada 2005 (machine scalar mode), the processing
8417 -- for non-standard bit order can substantially change the positions.
8418 -- See procedure Check_Record_Representation_Clause (called from Freeze)
8419 -- for the remainder of this processing.
8421 procedure Analyze_Record_Representation_Clause
(N
: Node_Id
) is
8422 Ident
: constant Node_Id
:= Identifier
(N
);
8430 Rectype
: Entity_Id
;
8433 function Is_Inherited
(Comp
: Entity_Id
) return Boolean;
8434 -- True if Comp is an inherited component in a record extension
8440 function Is_Inherited
(Comp
: Entity_Id
) return Boolean is
8441 Comp_Base
: Entity_Id
;
8444 if Ekind
(Rectype
) = E_Record_Subtype
then
8445 Comp_Base
:= Original_Record_Component
(Comp
);
8450 return Comp_Base
/= Original_Record_Component
(Comp_Base
);
8455 Is_Record_Extension
: Boolean;
8456 -- True if Rectype is a record extension
8458 CR_Pragma
: Node_Id
:= Empty
;
8459 -- Points to N_Pragma node if Complete_Representation pragma present
8461 -- Start of processing for Analyze_Record_Representation_Clause
8464 if Ignore_Rep_Clauses
then
8465 Kill_Rep_Clause
(N
);
8470 Rectype
:= Entity
(Ident
);
8472 if Rectype
= Any_Type
or else Rep_Item_Too_Early
(Rectype
, N
) then
8475 Rectype
:= Underlying_Type
(Rectype
);
8478 -- First some basic error checks
8480 if not Is_Record_Type
(Rectype
) then
8482 ("record type required, found}", Ident
, First_Subtype
(Rectype
));
8485 elsif Scope
(Rectype
) /= Current_Scope
then
8486 Error_Msg_N
("type must be declared in this scope", N
);
8489 elsif not Is_First_Subtype
(Rectype
) then
8490 Error_Msg_N
("cannot give record rep clause for subtype", N
);
8493 elsif Has_Record_Rep_Clause
(Rectype
) then
8494 Error_Msg_N
("duplicate record rep clause ignored", N
);
8497 elsif Rep_Item_Too_Late
(Rectype
, N
) then
8501 -- We know we have a first subtype, now possibly go to the anonymous
8502 -- base type to determine whether Rectype is a record extension.
8504 Recdef
:= Type_Definition
(Declaration_Node
(Base_Type
(Rectype
)));
8505 Is_Record_Extension
:=
8506 Nkind
(Recdef
) = N_Derived_Type_Definition
8507 and then Present
(Record_Extension_Part
(Recdef
));
8509 if Present
(Mod_Clause
(N
)) then
8511 M
: constant Node_Id
:= Mod_Clause
(N
);
8512 P
: constant List_Id
:= Pragmas_Before
(M
);
8516 Check_Restriction
(No_Obsolescent_Features
, Mod_Clause
(N
));
8518 if Warn_On_Obsolescent_Feature
then
8520 ("?j?mod clause is an obsolescent feature (RM J.8)", N
);
8522 ("\?j?use alignment attribute definition clause instead", N
);
8529 -- Get the alignment value to perform error checking
8531 Ignore
:= Get_Alignment_Value
(Expression
(M
));
8535 -- For untagged types, clear any existing component clauses for the
8536 -- type. If the type is derived, this is what allows us to override
8537 -- a rep clause for the parent. For type extensions, the representation
8538 -- of the inherited components is inherited, so we want to keep previous
8539 -- component clauses for completeness.
8541 if not Is_Tagged_Type
(Rectype
) then
8542 Comp
:= First_Component_Or_Discriminant
(Rectype
);
8543 while Present
(Comp
) loop
8544 Set_Component_Clause
(Comp
, Empty
);
8545 Next_Component_Or_Discriminant
(Comp
);
8549 -- All done if no component clauses
8551 CC
:= First
(Component_Clauses
(N
));
8557 -- A representation like this applies to the base type
8559 Set_Has_Record_Rep_Clause
(Base_Type
(Rectype
));
8560 Set_Has_Non_Standard_Rep
(Base_Type
(Rectype
));
8561 Set_Has_Specified_Layout
(Base_Type
(Rectype
));
8563 -- Process the component clauses
8565 while Present
(CC
) loop
8569 if Nkind
(CC
) = N_Pragma
then
8572 -- The only pragma of interest is Complete_Representation
8574 if Pragma_Name
(CC
) = Name_Complete_Representation
then
8578 -- Processing for real component clause
8581 Posit
:= Static_Integer
(Position
(CC
));
8582 Fbit
:= Static_Integer
(First_Bit
(CC
));
8583 Lbit
:= Static_Integer
(Last_Bit
(CC
));
8586 and then Present
(Fbit
)
8587 and then Present
(Lbit
)
8590 Error_Msg_N
("position cannot be negative", Position
(CC
));
8593 Error_Msg_N
("first bit cannot be negative", First_Bit
(CC
));
8595 -- The Last_Bit specified in a component clause must not be
8596 -- less than the First_Bit minus one (RM-13.5.1(10)).
8598 elsif Lbit
< Fbit
- 1 then
8600 ("last bit cannot be less than first bit minus one",
8603 -- Values look OK, so find the corresponding record component
8604 -- Even though the syntax allows an attribute reference for
8605 -- implementation-defined components, GNAT does not allow the
8606 -- tag to get an explicit position.
8608 elsif Nkind
(Component_Name
(CC
)) = N_Attribute_Reference
then
8609 if Attribute_Name
(Component_Name
(CC
)) = Name_Tag
then
8610 Error_Msg_N
("position of tag cannot be specified", CC
);
8612 Error_Msg_N
("illegal component name", CC
);
8616 Comp
:= First_Entity
(Rectype
);
8617 while Present
(Comp
) loop
8618 exit when Chars
(Comp
) = Chars
(Component_Name
(CC
));
8624 -- Maybe component of base type that is absent from
8625 -- statically constrained first subtype.
8627 Comp
:= First_Entity
(Base_Type
(Rectype
));
8628 while Present
(Comp
) loop
8629 exit when Chars
(Comp
) = Chars
(Component_Name
(CC
));
8636 ("component clause is for non-existent field", CC
);
8638 -- Ada 2012 (AI05-0026): Any name that denotes a
8639 -- discriminant of an object of an unchecked union type
8640 -- shall not occur within a record_representation_clause.
8642 -- The general restriction of using record rep clauses on
8643 -- Unchecked_Union types has now been lifted. Since it is
8644 -- possible to introduce a record rep clause which mentions
8645 -- the discriminant of an Unchecked_Union in non-Ada 2012
8646 -- code, this check is applied to all versions of the
8649 elsif Ekind
(Comp
) = E_Discriminant
8650 and then Is_Unchecked_Union
(Rectype
)
8653 ("cannot reference discriminant of unchecked union",
8654 Component_Name
(CC
));
8656 elsif Is_Record_Extension
and then Is_Inherited
(Comp
) then
8658 ("component clause not allowed for inherited "
8659 & "component&", CC
, Comp
);
8661 elsif Present
(Component_Clause
(Comp
)) then
8663 -- Diagnose duplicate rep clause, or check consistency
8664 -- if this is an inherited component. In a double fault,
8665 -- there may be a duplicate inconsistent clause for an
8666 -- inherited component.
8668 if Scope
(Original_Record_Component
(Comp
)) = Rectype
8669 or else Parent
(Component_Clause
(Comp
)) = N
8671 Error_Msg_Sloc
:= Sloc
(Component_Clause
(Comp
));
8672 Error_Msg_N
("component clause previously given#", CC
);
8676 Rep1
: constant Node_Id
:= Component_Clause
(Comp
);
8678 if Intval
(Position
(Rep1
)) /=
8679 Intval
(Position
(CC
))
8680 or else Intval
(First_Bit
(Rep1
)) /=
8681 Intval
(First_Bit
(CC
))
8682 or else Intval
(Last_Bit
(Rep1
)) /=
8683 Intval
(Last_Bit
(CC
))
8686 ("component clause inconsistent with "
8687 & "representation of ancestor", CC
);
8689 elsif Warn_On_Redundant_Constructs
then
8691 ("?r?redundant confirming component clause "
8692 & "for component!", CC
);
8697 -- Normal case where this is the first component clause we
8698 -- have seen for this entity, so set it up properly.
8701 -- Make reference for field in record rep clause and set
8702 -- appropriate entity field in the field identifier.
8705 (Comp
, Component_Name
(CC
), Set_Ref
=> False);
8706 Set_Entity_With_Checks
(Component_Name
(CC
), Comp
);
8708 -- Update Fbit and Lbit to the actual bit number
8710 Fbit
:= Fbit
+ UI_From_Int
(SSU
) * Posit
;
8711 Lbit
:= Lbit
+ UI_From_Int
(SSU
) * Posit
;
8713 if Has_Size_Clause
(Rectype
)
8714 and then RM_Size
(Rectype
) <= Lbit
8716 Error_Msg_Uint_1
:= RM_Size
(Rectype
);
8717 Error_Msg_Uint_2
:= Lbit
+ 1;
8718 Error_Msg_N
("bit number out of range of specified "
8719 & "size (expected ^, got ^)",
8722 Set_Component_Clause
(Comp
, CC
);
8723 Set_Component_Bit_Offset
(Comp
, Fbit
);
8724 Set_Esize
(Comp
, 1 + (Lbit
- Fbit
));
8725 Set_Normalized_First_Bit
(Comp
, Fbit
mod SSU
);
8726 Set_Normalized_Position
(Comp
, Fbit
/ SSU
);
8728 if Warn_On_Overridden_Size
8729 and then Has_Size_Clause
(Etype
(Comp
))
8730 and then RM_Size
(Etype
(Comp
)) /= Esize
(Comp
)
8733 ("?.s?component size overrides size clause for&",
8734 Component_Name
(CC
), Etype
(Comp
));
8738 (Component_Name
(CC
),
8744 (Comp
, First_Node
(CC
), "component clause", Biased
);
8746 -- This information is also set in the corresponding
8747 -- component of the base type, found by accessing the
8748 -- Original_Record_Component link if it is present.
8750 Ocomp
:= Original_Record_Component
(Comp
);
8752 if Present
(Ocomp
) and then Ocomp
/= Comp
then
8753 Set_Component_Clause
(Ocomp
, CC
);
8754 Set_Component_Bit_Offset
(Ocomp
, Fbit
);
8755 Set_Esize
(Ocomp
, 1 + (Lbit
- Fbit
));
8756 Set_Normalized_First_Bit
(Ocomp
, Fbit
mod SSU
);
8757 Set_Normalized_Position
(Ocomp
, Fbit
/ SSU
);
8759 -- Note: we don't use Set_Biased here, because we
8760 -- already gave a warning above if needed, and we
8761 -- would get a duplicate for the same name here.
8763 Set_Has_Biased_Representation
8764 (Ocomp
, Has_Biased_Representation
(Comp
));
8767 if Esize
(Comp
) < 0 then
8768 Error_Msg_N
("component size is negative", CC
);
8779 -- Check missing components if Complete_Representation pragma appeared
8781 if Present
(CR_Pragma
) then
8782 Comp
:= First_Component_Or_Discriminant
(Rectype
);
8783 while Present
(Comp
) loop
8784 if No
(Component_Clause
(Comp
)) then
8786 ("missing component clause for &", CR_Pragma
, Comp
);
8789 Next_Component_Or_Discriminant
(Comp
);
8792 -- Give missing components warning if required
8794 elsif Warn_On_Unrepped_Components
then
8796 Num_Repped_Components
: Nat
:= 0;
8797 Num_Unrepped_Components
: Nat
:= 0;
8800 -- First count number of repped and unrepped components
8802 Comp
:= First_Component_Or_Discriminant
(Rectype
);
8803 while Present
(Comp
) loop
8804 if Present
(Component_Clause
(Comp
)) then
8805 Num_Repped_Components
:= Num_Repped_Components
+ 1;
8807 Num_Unrepped_Components
:= Num_Unrepped_Components
+ 1;
8810 Next_Component_Or_Discriminant
(Comp
);
8813 -- We are only interested in the case where there is at least one
8814 -- unrepped component, and at least half the components have rep
8815 -- clauses. We figure that if less than half have them, then the
8816 -- partial rep clause is really intentional. If the component
8817 -- type has no underlying type set at this point (as for a generic
8818 -- formal type), we don't know enough to give a warning on the
8821 if Num_Unrepped_Components
> 0
8822 and then Num_Unrepped_Components
< Num_Repped_Components
8824 Comp
:= First_Component_Or_Discriminant
(Rectype
);
8825 while Present
(Comp
) loop
8826 if No
(Component_Clause
(Comp
))
8827 and then Comes_From_Source
(Comp
)
8828 and then Present
(Underlying_Type
(Etype
(Comp
)))
8829 and then (Is_Scalar_Type
(Underlying_Type
(Etype
(Comp
)))
8830 or else Size_Known_At_Compile_Time
8831 (Underlying_Type
(Etype
(Comp
))))
8832 and then not Has_Warnings_Off
(Rectype
)
8834 -- Ignore discriminant in unchecked union, since it is
8835 -- not there, and cannot have a component clause.
8837 and then (not Is_Unchecked_Union
(Rectype
)
8838 or else Ekind
(Comp
) /= E_Discriminant
)
8840 Error_Msg_Sloc
:= Sloc
(Comp
);
8842 ("?.c?no component clause given for & declared #",
8846 Next_Component_Or_Discriminant
(Comp
);
8851 end Analyze_Record_Representation_Clause
;
8853 ----------------------------------------------
8854 -- Analyze_User_Aspect_Aspect_Specification --
8855 ----------------------------------------------
8857 procedure Analyze_User_Aspect_Aspect_Specification
(N
: Node_Id
) is
8858 OK
: Boolean := True;
8860 procedure Analyze_One_User_Aspect
(Id
: Node_Id
);
8861 -- A User_Aspect aspect specification may specify multiple
8862 -- user-defined aspects. This procedure is called for each one.
8864 -----------------------------
8865 -- Analyze_One_User_Aspect --
8866 -----------------------------
8868 procedure Analyze_One_User_Aspect
(Id
: Node_Id
) is
8869 UAD_Pragma
: constant Node_Id
:=
8870 User_Aspect_Support
.Registered_UAD_Pragma
(Chars
(Id
));
8874 if No
(UAD_Pragma
) then
8875 Error_Msg_N
("No definition for user-defined aspect", Id
);
8879 -- Process args in reverse order so that inserted
8880 -- aspect specs end up in "right" order (although
8881 -- order shouldn't matter).
8882 Arg
:= Last
(Pragma_Argument_Associations
(UAD_Pragma
));
8884 -- Skip first argument, which is the name of the
8885 -- user-defined aspect.
8886 while Present
(Prev
(Arg
)) loop
8888 Exp
: constant Node_Id
:= Expression
(Arg
);
8889 New_Sloc
: constant Source_Ptr
:= Sloc
(N
);
8890 New_Aspect_Spec
: Node_Id
;
8892 New_Exp_List
: List_Id
;
8895 when N_Identifier
=>
8897 Make_Aspect_Specification
8900 New_Copy_Tree
(Exp
, New_Sloc
=> New_Sloc
));
8902 when N_Indexed_Component
=>
8903 New_Exp_List
:= New_List
;
8906 Index_Exp
: Node_Id
:= First
(Expressions
(Exp
));
8908 while Present
(Index_Exp
) loop
8909 Append
(New_Copy_Tree
8910 (Index_Exp
, New_Sloc
=> New_Sloc
),
8911 To
=> New_Exp_List
);
8916 New_Exp
:= Make_Aggregate
8918 Expressions
=> New_Exp_List
,
8919 Is_Parenthesis_Aggregate
=> True);
8922 Make_Aspect_Specification
8925 New_Copy_Tree
(Prefix
(Exp
), New_Sloc
=> New_Sloc
),
8926 Expression
=> New_Exp
);
8929 raise Program_Error
;
8932 Insert_After
(After
=> N
, Node
=> New_Aspect_Spec
);
8936 end Analyze_One_User_Aspect
;
8938 if Analyzed
(N
) then
8942 -- This aspect can be specified for any entity whose
8943 -- syntax allows an aspect specification.
8944 -- The analysis code below constructs new aspect
8945 -- specifications for the given entity; each might
8946 -- turn out to be legal or illegal. That is determined
8947 -- when each of these new aspect_specs is analyzed.
8949 case Nkind
(Expression
(N
)) is
8950 when N_Identifier
=>
8951 Analyze_One_User_Aspect
(Expression
(N
));
8953 OK
:= Is_Parenthesis_Aggregate
(Expression
(N
));
8955 Id
: Node_Id
:= First
(Expressions
(Expression
(N
)));
8957 while Present
(Id
) loop
8958 if Nkind
(Id
) = N_Identifier
then
8959 Analyze_One_User_Aspect
(Id
);
8972 ("Bad argument for User_Aspect aspect specification", N
);
8976 end Analyze_User_Aspect_Aspect_Specification
;
8978 -------------------------------------
8979 -- Build_Discrete_Static_Predicate --
8980 -------------------------------------
8982 procedure Build_Discrete_Static_Predicate
8987 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
8989 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
8991 BLo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Btyp
));
8992 BHi
: constant Uint
:= Expr_Value
(Type_High_Bound
(Btyp
));
8993 -- Low bound and high bound value of base type of Typ
8997 -- Bounds for constructing the static predicate. We use the bound of the
8998 -- subtype if it is static, otherwise the corresponding base type bound.
8999 -- Note: a non-static subtype can have a static predicate.
9004 -- One entry in a Rlist value, a single REnt (range entry) value denotes
9005 -- one range from Lo to Hi. To represent a single value range Lo = Hi =
9008 type RList
is array (Nat
range <>) of REnt
;
9009 -- A list of ranges. The ranges are sorted in increasing order, and are
9010 -- disjoint (there is a gap of at least one value between each range in
9011 -- the table). A value is in the set of ranges in Rlist if it lies
9012 -- within one of these ranges.
9014 False_Range
: constant RList
:=
9015 RList
'(1 .. 0 => REnt'(No_Uint
, No_Uint
));
9016 -- An empty set of ranges represents a range list that can never be
9017 -- satisfied, since there are no ranges in which the value could lie,
9018 -- so it does not lie in any of them. False_Range is a canonical value
9019 -- for this empty set, but general processing should test for an Rlist
9020 -- with length zero (see Is_False predicate), since other null ranges
9021 -- may appear which must be treated as False.
9023 True_Range
: constant RList
:= RList
'(1 => REnt'(BLo
, BHi
));
9024 -- Range representing True, value must be in the base range
9026 function "and" (Left
: RList
; Right
: RList
) return RList
;
9027 -- And's together two range lists, returning a range list. This is a set
9028 -- intersection operation.
9030 function "or" (Left
: RList
; Right
: RList
) return RList
;
9031 -- Or's together two range lists, returning a range list. This is a set
9034 function "not" (Right
: RList
) return RList
;
9035 -- Returns complement of a given range list, i.e. a range list
9036 -- representing all the values in TLo .. THi that are not in the input
9039 function Build_Val
(V
: Uint
) return Node_Id
;
9040 -- Return an analyzed N_Identifier node referencing this value, suitable
9041 -- for use as an entry in the Static_Discrete_Predicate list. This node
9042 -- is typed with the base type.
9044 function Build_Range
(Lo
: Uint
; Hi
: Uint
) return Node_Id
;
9045 -- Return an analyzed N_Range node referencing this range, suitable for
9046 -- use as an entry in the Static_Discrete_Predicate list. This node is
9047 -- typed with the base type.
9051 Static
: access Boolean) return RList
;
9052 -- This is a recursive routine that converts the given expression into a
9053 -- list of ranges, suitable for use in building the static predicate.
9054 -- Static.all will be set to False if the expression is found to be non
9055 -- static. Note that Static.all should be set to True by the caller.
9057 function Is_False
(R
: RList
) return Boolean;
9058 pragma Inline
(Is_False
);
9059 -- Returns True if the given range list is empty, and thus represents a
9060 -- False list of ranges that can never be satisfied.
9062 function Is_True
(R
: RList
) return Boolean;
9063 -- Returns True if R trivially represents the True predicate by having a
9064 -- single range from BLo to BHi.
9066 function Is_Type_Ref
(N
: Node_Id
) return Boolean;
9067 pragma Inline
(Is_Type_Ref
);
9068 -- Returns if True if N is a reference to the type for the predicate in
9069 -- the expression (i.e. if it is an identifier whose Chars field matches
9070 -- the Nam given in the call). N must not be parenthesized, if the type
9071 -- name appears in parens, this routine will return False.
9073 function Lo_Val
(N
: Node_Id
) return Uint
;
9074 -- Given an entry from a Static_Discrete_Predicate list that is either
9075 -- a static expression or static range, gets either the expression value
9076 -- or the low bound of the range.
9078 function Hi_Val
(N
: Node_Id
) return Uint
;
9079 -- Given an entry from a Static_Discrete_Predicate list that is either
9080 -- a static expression or static range, gets either the expression value
9081 -- or the high bound of the range.
9083 function Membership_Entry
9084 (N
: Node_Id
; Static
: access Boolean) return RList
;
9085 -- Given a single membership entry (range, value, or subtype), returns
9086 -- the corresponding range list. Set Static.all to False if not static.
9088 function Membership_Entries
9089 (N
: Node_Id
; Static
: access Boolean) return RList
;
9090 -- Given an element on an alternatives list of a membership operation,
9091 -- returns the range list corresponding to this entry and all following
9092 -- entries (i.e. returns the "or" of this list of values).
9093 -- Set Static.all to False if not static.
9097 Static
: access Boolean) return RList
;
9098 -- Given a type, if it has a static predicate, then set Result to the
9099 -- predicate as a range list, otherwise set Static.all to False.
9101 procedure Warn_If_Test_Ineffective
(REntry
: REnt
; N
: Node_Id
);
9102 -- Issue a warning if REntry includes only values that are
9103 -- outside the range TLo .. THi.
9109 function "and" (Left
: RList
; Right
: RList
) return RList
is
9111 -- First range of result
9113 SLeft
: Nat
:= Left
'First;
9114 -- Start of rest of left entries
9116 SRight
: Nat
:= Right
'First;
9117 -- Start of rest of right entries
9120 -- If either range is True, return the other
9122 if Is_True
(Left
) then
9124 elsif Is_True
(Right
) then
9128 -- If either range is False, return False
9130 if Is_False
(Left
) or else Is_False
(Right
) then
9134 -- Loop to remove entries at start that are disjoint, and thus just
9135 -- get discarded from the result entirely.
9138 -- If no operands left in either operand, result is false
9140 if SLeft
> Left
'Last or else SRight
> Right
'Last then
9143 -- Discard first left operand entry if disjoint with right
9145 elsif Left
(SLeft
).Hi
< Right
(SRight
).Lo
then
9148 -- Discard first right operand entry if disjoint with left
9150 elsif Right
(SRight
).Hi
< Left
(SLeft
).Lo
then
9151 SRight
:= SRight
+ 1;
9153 -- Otherwise we have an overlapping entry
9160 -- Now we have two non-null operands, and first entries overlap. The
9161 -- first entry in the result will be the overlapping part of these
9164 FEnt
:= REnt
'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo),
9165 Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi));
9167 -- Now we can remove the entry that ended at a lower value, since its
9168 -- contribution is entirely contained in Fent.
9170 if Left (SLeft).Hi <= Right (SRight).Hi then
9173 SRight := SRight + 1;
9176 -- Compute result by concatenating this first entry with the "and" of
9177 -- the remaining parts of the left and right operands. Note that if
9178 -- either of these is empty, "and" will yield empty, so that we will
9179 -- end up with just Fent, which is what we want in that case.
9182 FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
9189 function "not" (Right : RList) return RList is
9191 -- Return True if False range
9193 if Is_False (Right) then
9197 -- Return False if True range
9199 if Is_True (Right) then
9203 -- Here if not trivial case
9206 Result : RList (1 .. Right'Length + 1);
9207 -- May need one more entry for gap at beginning and end
9210 -- Number of entries stored in Result
9215 if Right (Right'First).Lo > TLo then
9217 Result (Count) := REnt'(TLo
, Right
(Right
'First).Lo
- 1);
9220 -- Gaps between ranges
9222 for J
in Right
'First .. Right
'Last - 1 loop
9224 Result
(Count
) := REnt
'(Right (J).Hi + 1, Right (J + 1).Lo - 1);
9229 if Right (Right'Last).Hi < THi then
9231 Result (Count) := REnt'(Right
(Right
'Last).Hi
+ 1, THi
);
9234 return Result
(1 .. Count
);
9242 function "or" (Left
: RList
; Right
: RList
) return RList
is
9244 -- First range of result
9246 SLeft
: Nat
:= Left
'First;
9247 -- Start of rest of left entries
9249 SRight
: Nat
:= Right
'First;
9250 -- Start of rest of right entries
9253 -- If either range is True, return True
9255 if Is_True
(Left
) or else Is_True
(Right
) then
9259 -- If either range is False (empty), return the other
9261 if Is_False
(Left
) then
9263 elsif Is_False
(Right
) then
9267 -- Initialize result first entry from left or right operand depending
9268 -- on which starts with the lower range.
9270 if Left
(SLeft
).Lo
< Right
(SRight
).Lo
then
9271 FEnt
:= Left
(SLeft
);
9274 FEnt
:= Right
(SRight
);
9275 SRight
:= SRight
+ 1;
9278 -- This loop eats ranges from left and right operands that are
9279 -- contiguous with the first range we are gathering.
9282 -- Eat first entry in left operand if contiguous or overlapped by
9283 -- gathered first operand of result.
9285 if SLeft
<= Left
'Last
9286 and then Left
(SLeft
).Lo
<= FEnt
.Hi
+ 1
9288 FEnt
.Hi
:= UI_Max
(FEnt
.Hi
, Left
(SLeft
).Hi
);
9291 -- Eat first entry in right operand if contiguous or overlapped by
9292 -- gathered right operand of result.
9294 elsif SRight
<= Right
'Last
9295 and then Right
(SRight
).Lo
<= FEnt
.Hi
+ 1
9297 FEnt
.Hi
:= UI_Max
(FEnt
.Hi
, Right
(SRight
).Hi
);
9298 SRight
:= SRight
+ 1;
9300 -- All done if no more entries to eat
9307 -- Obtain result as the first entry we just computed, concatenated
9308 -- to the "or" of the remaining results (if one operand is empty,
9309 -- this will just concatenate with the other
9312 FEnt
& (Left
(SLeft
.. Left
'Last) or Right
(SRight
.. Right
'Last));
9319 function Build_Range
(Lo
: Uint
; Hi
: Uint
) return Node_Id
is
9324 Low_Bound
=> Build_Val
(Lo
),
9325 High_Bound
=> Build_Val
(Hi
));
9326 Set_Etype
(Result
, Btyp
);
9327 Set_Analyzed
(Result
);
9335 function Build_Val
(V
: Uint
) return Node_Id
is
9339 if Is_Enumeration_Type
(Typ
) then
9340 Result
:= Get_Enum_Lit_From_Pos
(Typ
, V
, Loc
);
9342 Result
:= Make_Integer_Literal
(Loc
, V
);
9345 Set_Etype
(Result
, Btyp
);
9346 Set_Is_Static_Expression
(Result
);
9347 Set_Analyzed
(Result
);
9357 Static
: access Boolean) return RList
9361 Val_Bearer
: Node_Id
;
9364 -- Static expression can only be true or false
9366 if Is_OK_Static_Expression
(Exp
) then
9367 if Expr_Value
(Exp
) = 0 then
9374 -- Otherwise test node type
9385 return Get_RList
(Left_Opnd
(Exp
), Static
)
9387 Get_RList
(Right_Opnd
(Exp
), Static
);
9394 return Get_RList
(Left_Opnd
(Exp
), Static
)
9396 Get_RList
(Right_Opnd
(Exp
), Static
);
9401 return not Get_RList
(Right_Opnd
(Exp
), Static
);
9403 -- Comparisons of type with static value
9405 when N_Op_Compare
=>
9407 -- Type is left operand
9409 if Is_Type_Ref
(Left_Opnd
(Exp
))
9410 and then Is_OK_Static_Expression
(Right_Opnd
(Exp
))
9412 Val_Bearer
:= Right_Opnd
(Exp
);
9414 -- Typ is right operand
9416 elsif Is_Type_Ref
(Right_Opnd
(Exp
))
9417 and then Is_OK_Static_Expression
(Left_Opnd
(Exp
))
9419 Val_Bearer
:= Left_Opnd
(Exp
);
9421 -- Invert sense of comparison
9424 when N_Op_Gt
=> Op
:= N_Op_Lt
;
9425 when N_Op_Lt
=> Op
:= N_Op_Gt
;
9426 when N_Op_Ge
=> Op
:= N_Op_Le
;
9427 when N_Op_Le
=> Op
:= N_Op_Ge
;
9428 when others => null;
9431 -- Other cases are non-static
9434 Static
.all := False;
9438 Val
:= Expr_Value
(Val_Bearer
);
9440 -- Construct range according to comparison operation
9447 REntry
:= (Val
, Val
);
9450 REntry
:= (Val
, THi
);
9453 REntry
:= (Val
+ 1, THi
);
9456 REntry
:= (TLo
, Val
);
9459 REntry
:= (TLo
, Val
- 1);
9462 Warn_If_Test_Ineffective
((Val
, Val
), Val_Bearer
);
9463 return RList
'(REnt'(TLo
, Val
- 1),
9464 REnt
'(Val + 1, THi));
9467 raise Program_Error;
9470 Warn_If_Test_Ineffective (REntry, Val_Bearer);
9471 return RList'(1 => REntry
);
9477 if not Is_Type_Ref
(Left_Opnd
(Exp
)) then
9478 Static
.all := False;
9482 if Present
(Right_Opnd
(Exp
)) then
9483 return Membership_Entry
(Right_Opnd
(Exp
), Static
);
9485 return Membership_Entries
9486 (First
(Alternatives
(Exp
)), Static
);
9489 -- Negative membership (NOT IN)
9492 if not Is_Type_Ref
(Left_Opnd
(Exp
)) then
9493 Static
.all := False;
9497 if Present
(Right_Opnd
(Exp
)) then
9498 return not Membership_Entry
(Right_Opnd
(Exp
), Static
);
9500 return not Membership_Entries
9501 (First
(Alternatives
(Exp
)), Static
);
9504 -- Function call, may be call to static predicate
9506 when N_Function_Call
=>
9507 if Is_Entity_Name
(Name
(Exp
)) then
9509 Ent
: constant Entity_Id
:= Entity
(Name
(Exp
));
9511 if Is_Predicate_Function
(Ent
) then
9512 return Stat_Pred
(Etype
(First_Formal
(Ent
)), Static
);
9517 -- Other function call cases are non-static
9519 Static
.all := False;
9522 -- Qualified expression, dig out the expression
9524 when N_Qualified_Expression
=>
9525 return Get_RList
(Expression
(Exp
), Static
);
9527 when N_Case_Expression
=>
9534 if not Is_Entity_Name
(Expression
(Expr
))
9535 or else Etype
(Expression
(Expr
)) /= Typ
9538 ("expression must denote subtype", Expression
(Expr
));
9542 -- Collect discrete choices in all True alternatives
9544 Choices
:= New_List
;
9545 Alt
:= First
(Alternatives
(Exp
));
9546 while Present
(Alt
) loop
9547 Dep
:= Expression
(Alt
);
9549 if not Is_OK_Static_Expression
(Dep
) then
9550 Static
.all := False;
9553 elsif Is_True
(Expr_Value
(Dep
)) then
9554 Append_List_To
(Choices
,
9555 New_Copy_List
(Discrete_Choices
(Alt
)));
9561 return Membership_Entries
(First
(Choices
), Static
);
9564 -- Expression with actions: if no actions, dig out expression
9566 when N_Expression_With_Actions
=>
9567 if Is_Empty_List
(Actions
(Exp
)) then
9568 return Get_RList
(Expression
(Exp
), Static
);
9570 Static
.all := False;
9577 return (Get_RList
(Left_Opnd
(Exp
), Static
)
9578 and not Get_RList
(Right_Opnd
(Exp
), Static
))
9579 or (Get_RList
(Right_Opnd
(Exp
), Static
)
9580 and not Get_RList
(Left_Opnd
(Exp
), Static
));
9582 -- Any other node type is non-static
9585 Static
.all := False;
9594 function Hi_Val
(N
: Node_Id
) return Uint
is
9596 if Is_OK_Static_Expression
(N
) then
9597 return Expr_Value
(N
);
9599 pragma Assert
(Nkind
(N
) = N_Range
);
9600 return Expr_Value
(High_Bound
(N
));
9608 function Is_False
(R
: RList
) return Boolean is
9610 return R
'Length = 0;
9617 function Is_True
(R
: RList
) return Boolean is
9620 and then R
(R
'First).Lo
= BLo
9621 and then R
(R
'First).Hi
= BHi
;
9628 function Is_Type_Ref
(N
: Node_Id
) return Boolean is
9630 return Nkind
(N
) = N_Identifier
9631 and then Chars
(N
) = Nam
9632 and then Paren_Count
(N
) = 0;
9639 function Lo_Val
(N
: Node_Id
) return Uint
is
9641 if Is_OK_Static_Expression
(N
) then
9642 return Expr_Value
(N
);
9644 pragma Assert
(Nkind
(N
) = N_Range
);
9645 return Expr_Value
(Low_Bound
(N
));
9649 ------------------------
9650 -- Membership_Entries --
9651 ------------------------
9653 function Membership_Entries
9654 (N
: Node_Id
; Static
: access Boolean) return RList
is
9656 if No
(Next
(N
)) then
9657 return Membership_Entry
(N
, Static
);
9659 return Membership_Entry
(N
, Static
)
9660 or Membership_Entries
(Next
(N
), Static
);
9662 end Membership_Entries
;
9664 ----------------------
9665 -- Membership_Entry --
9666 ----------------------
9668 function Membership_Entry
9669 (N
: Node_Id
; Static
: access Boolean) return RList
9678 if Nkind
(N
) = N_Range
then
9679 if not Is_OK_Static_Expression
(Low_Bound
(N
))
9681 not Is_OK_Static_Expression
(High_Bound
(N
))
9683 Static
.all := False;
9686 SLo
:= Expr_Value
(Low_Bound
(N
));
9687 SHi
:= Expr_Value
(High_Bound
(N
));
9689 REntry
: constant REnt
:= (SLo
, SHi
);
9691 Warn_If_Test_Ineffective
(REntry
, N
);
9692 return RList
'(1 => REntry);
9698 elsif Nkind (N) = N_Others_Choice then
9700 Choices : constant List_Id := Others_Discrete_Choices (N);
9702 Range_List : RList (1 .. List_Length (Choices));
9705 Choice := First (Choices);
9707 for J in Range_List'Range loop
9708 Range_List (J) := REnt'(Lo_Val
(Choice
), Hi_Val
(Choice
));
9715 -- Static expression case
9717 elsif Is_OK_Static_Expression
(N
) then
9718 Val
:= Expr_Value
(N
);
9720 REntry
: constant REnt
:= (Val
, Val
);
9722 Warn_If_Test_Ineffective
(REntry
, N
);
9723 return RList
'(1 => REntry);
9726 -- Identifier (other than static expression) case
9728 else pragma Assert (Nkind (N) in N_Expanded_Name | N_Identifier);
9732 if Is_Type (Entity (N)) then
9734 -- If type has predicates, process them
9736 if Has_Predicates (Entity (N)) then
9737 return Stat_Pred (Entity (N), Static);
9739 -- For static subtype without predicates, get range
9741 elsif Is_OK_Static_Subtype (Entity (N)) then
9742 SLo := Expr_Value (Type_Low_Bound (Entity (N)));
9743 SHi := Expr_Value (Type_High_Bound (Entity (N)));
9744 return RList'(1 => REnt
'(SLo, SHi));
9746 -- Any other type makes us non-static
9749 Static.all := False;
9753 -- Any other kind of identifier in predicate (e.g. a non-static
9754 -- expression value) means this is not a static predicate.
9757 Static.all := False;
9761 end Membership_Entry;
9769 Static : access Boolean) return RList is
9771 -- Not static if type does not have static predicates
9773 if not Has_Static_Predicate (Typ) then
9774 Static.all := False;
9778 -- Otherwise we convert the predicate list to a range list
9781 Spred : constant List_Id := Static_Discrete_Predicate (Typ);
9782 Result : RList (1 .. List_Length (Spred));
9786 P := First (Static_Discrete_Predicate (Typ));
9787 for J in Result'Range loop
9788 Result (J) := REnt'(Lo_Val
(P
), Hi_Val
(P
));
9796 procedure Warn_If_Test_Ineffective
(REntry
: REnt
; N
: Node_Id
) is
9798 procedure IPT_Warning
(Msg
: String);
9804 procedure IPT_Warning
(Msg
: String) is
9806 Error_Msg_N
("ineffective predicate test " & Msg
& "?_s?", N
);
9809 -- Start of processing for Warn_If_Test_Ineffective
9812 -- Do nothing if warning disabled
9814 if not Warn_On_Ineffective_Predicate_Test
then
9817 -- skip null-range corner cases
9819 elsif REntry
.Lo
> REntry
.Hi
or else TLo
> THi
then
9822 -- warn if no overlap between subtype bounds and the given range
9824 elsif REntry
.Lo
> THi
or else REntry
.Hi
< TLo
then
9825 Error_Msg_Uint_1
:= REntry
.Lo
;
9826 if REntry
.Lo
/= REntry
.Hi
then
9827 Error_Msg_Uint_2
:= REntry
.Hi
;
9828 IPT_Warning
("range: ^ .. ^");
9829 elsif Is_Enumeration_Type
(Typ
) and then
9830 Nkind
(N
) in N_Identifier | N_Expanded_Name
9832 IPT_Warning
("value: &");
9834 IPT_Warning
("value: ^");
9837 end Warn_If_Test_Ineffective
;
9839 -- Start of processing for Build_Discrete_Static_Predicate
9842 -- Establish bounds for the predicate
9844 if Compile_Time_Known_Value
(Type_Low_Bound
(Typ
)) then
9845 TLo
:= Expr_Value
(Type_Low_Bound
(Typ
));
9850 if Compile_Time_Known_Value
(Type_High_Bound
(Typ
)) then
9851 THi
:= Expr_Value
(Type_High_Bound
(Typ
));
9856 -- Analyze the expression to see if it is a static predicate
9859 Static
: aliased Boolean := True;
9860 Ranges
: constant RList
:= Get_RList
(Expr
, Static
'Access);
9861 -- Range list from expression if it is static
9866 -- If non-static, return doing nothing
9872 -- Convert range list into a form for the static predicate. In the
9873 -- Ranges array, we just have raw ranges, these must be converted
9874 -- to properly typed and analyzed static expressions or range nodes.
9876 -- Note: here we limit ranges to the ranges of the subtype, so that
9877 -- a predicate is always false for values outside the subtype. That
9878 -- seems fine, such values are invalid anyway, and considering them
9879 -- to fail the predicate seems allowed and friendly, and furthermore
9880 -- simplifies processing for case statements and loops.
9884 for J
in Ranges
'Range loop
9886 Lo
: Uint
:= Ranges
(J
).Lo
;
9887 Hi
: Uint
:= Ranges
(J
).Hi
;
9890 -- Ignore completely out of range entry
9892 if Hi
< TLo
or else Lo
> THi
then
9895 -- Otherwise process entry
9898 -- Adjust out of range value to subtype range
9908 -- Convert range into required form
9910 Append_To
(Plist
, Build_Range
(Lo
, Hi
));
9915 -- Processing was successful and all entries were static, so now we
9916 -- can store the result as the predicate list.
9918 Set_Static_Discrete_Predicate
(Typ
, Plist
);
9920 -- Within a generic the predicate functions themselves need not
9923 if Inside_A_Generic
then
9927 -- The processing for static predicates put the expression into
9928 -- canonical form as a series of ranges. It also eliminated
9929 -- duplicates and collapsed and combined ranges. We might as well
9930 -- replace the alternatives list of the right operand of the
9931 -- membership test with the static predicate list, which will
9932 -- usually be more efficient.
9935 New_Alts
: constant List_Id
:= New_List
;
9940 Old_Node
:= First
(Plist
);
9941 while Present
(Old_Node
) loop
9942 New_Node
:= New_Copy
(Old_Node
);
9944 if Nkind
(New_Node
) = N_Range
then
9945 Set_Low_Bound
(New_Node
, New_Copy
(Low_Bound
(Old_Node
)));
9946 Set_High_Bound
(New_Node
, New_Copy
(High_Bound
(Old_Node
)));
9949 Append_To
(New_Alts
, New_Node
);
9953 -- If empty list, replace by False
9955 if Is_Empty_List
(New_Alts
) then
9956 Rewrite
(Expr
, New_Occurrence_Of
(Standard_False
, Loc
));
9958 -- Else replace by set membership test
9963 Left_Opnd
=> Make_Identifier
(Loc
, Nam
),
9964 Right_Opnd
=> Empty
,
9965 Alternatives
=> New_Alts
));
9967 -- Resolve new expression in function context
9969 Push_Scope
(Predicate_Function
(Typ
));
9970 Install_Formals
(Predicate_Function
(Typ
));
9971 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
9976 end Build_Discrete_Static_Predicate
;
9978 --------------------------------
9979 -- Build_Export_Import_Pragma --
9980 --------------------------------
9982 function Build_Export_Import_Pragma
9984 Id
: Entity_Id
) return Node_Id
9986 Asp_Id
: constant Aspect_Id
:= Get_Aspect_Id
(Asp
);
9987 Expr
: constant Node_Id
:= Expression
(Asp
);
9988 Loc
: constant Source_Ptr
:= Sloc
(Asp
);
9999 Create_Pragma
: Boolean := False;
10000 -- This flag is set when the aspect form is such that it warrants the
10001 -- creation of a corresponding pragma.
10004 if Present
(Expr
) then
10005 if Error_Posted
(Expr
) then
10008 elsif Is_True
(Expr_Value
(Expr
)) then
10009 Create_Pragma
:= True;
10012 -- Otherwise the aspect defaults to True
10015 Create_Pragma
:= True;
10018 -- Nothing to do when the expression is False or is erroneous
10020 if not Create_Pragma
then
10024 -- Obtain all interfacing aspects that apply to the related entity
10026 Get_Interfacing_Aspects
10030 Expo_Asp
=> Dummy_1
,
10031 Imp_Asp
=> Dummy_2
,
10036 -- Handle the convention argument
10038 if Present
(Conv
) then
10039 Conv_Arg
:= New_Copy_Tree
(Expression
(Conv
));
10041 -- Assume convention "Ada' when aspect Convention is missing
10044 Conv_Arg
:= Make_Identifier
(Loc
, Name_Ada
);
10048 Make_Pragma_Argument_Association
(Loc
,
10049 Chars
=> Name_Convention
,
10050 Expression
=> Conv_Arg
));
10052 -- Handle the entity argument
10055 Make_Pragma_Argument_Association
(Loc
,
10056 Chars
=> Name_Entity
,
10057 Expression
=> New_Occurrence_Of
(Id
, Loc
)));
10059 -- Handle the External_Name argument
10061 if Present
(EN
) then
10063 Make_Pragma_Argument_Association
(Loc
,
10064 Chars
=> Name_External_Name
,
10065 Expression
=> New_Copy_Tree
(Expression
(EN
))));
10068 -- Handle the Link_Name argument
10070 if Present
(LN
) then
10072 Make_Pragma_Argument_Association
(Loc
,
10073 Chars
=> Name_Link_Name
,
10074 Expression
=> New_Copy_Tree
(Expression
(LN
))));
10078 -- pragma Export/Import
10079 -- (Convention => <Conv>/Ada,
10081 -- [External_Name => <EN>,]
10082 -- [Link_Name => <LN>]);
10086 Pragma_Identifier
=>
10087 Make_Identifier
(Loc
, Chars
(Identifier
(Asp
))),
10088 Pragma_Argument_Associations
=> Args
);
10090 -- Decorate the relevant aspect and the pragma
10092 Set_Aspect_Rep_Item
(Asp
, Prag
);
10094 Set_Corresponding_Aspect
(Prag
, Asp
);
10095 Set_From_Aspect_Specification
(Prag
);
10096 Set_Parent
(Prag
, Asp
);
10098 if Asp_Id
= Aspect_Import
and then Is_Subprogram
(Id
) then
10099 Set_Import_Pragma
(Id
, Prag
);
10103 end Build_Export_Import_Pragma
;
10105 ------------------------------
10106 -- Build_Predicate_Function --
10107 ------------------------------
10109 -- The function constructed here has the form:
10111 -- function typPredicate (Ixxx : typ) return Boolean is
10114 -- typ1Predicate (typ1 (Ixxx))
10115 -- and then typ2Predicate (typ2 (Ixxx))
10117 -- and then exp1 and then exp2 and then ...;
10118 -- end typPredicate;
10120 -- If Predicate_Function_Needs_Membership_Parameter is true, then this
10121 -- function takes an additional boolean parameter; the parameter
10122 -- indicates whether the predicate evaluation is part of a membership
10123 -- test. This parameter is used in two cases: 1) It is passed along
10124 -- if another predicate function is called and that predicate function
10125 -- expects to be passed a boolean parameter. 2) If the Predicate_Failure
10126 -- aspect is directly specified for typ, then we replace the return
10127 -- expression described above with
10128 -- (if <expression described above> then True
10129 -- elsif For_Membership_Test then False
10130 -- else (raise Assertion_Error
10131 -- with <Predicate_Failure expression>))
10132 -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that
10133 -- this is the point at which these expressions get analyzed, providing the
10134 -- required delay, and typ1, typ2, are entities from which predicates are
10135 -- inherited. Note that we do NOT generate Check pragmas, that's because we
10136 -- use this function even if checks are off, e.g. for membership tests.
10138 -- Note that the inherited predicates are evaluated first, as required by
10141 -- Note that Sem_Eval.Real_Or_String_Static_Predicate_Matches depends on
10142 -- the form of this return expression.
10144 -- WARNING: This routine manages Ghost regions. Return statements must be
10145 -- replaced by gotos which jump to the end of the routine and restore the
10148 procedure Build_Predicate_Function
(Typ
: Entity_Id
; N
: Node_Id
) is
10149 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
10151 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
10152 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
10153 -- Save the Ghost-related attributes to restore on exit
10156 -- This is the expression for the result of the function. It is
10157 -- built by connecting the component predicates with AND THEN.
10159 Object_Name
: Name_Id
;
10160 -- Name for argument of Predicate procedure. Note that we use the same
10161 -- name for both predicate functions. That way the reference within the
10162 -- predicate expression is the same in both functions.
10164 Object_Entity
: Entity_Id
;
10165 -- Entity for argument of Predicate procedure
10168 -- The function declaration
10173 Restore_Scope
: Boolean;
10174 -- True if the current scope must be restored on exit
10176 Ancestor_Predicate_Function_Called
: Boolean := False;
10177 -- Does this predicate function include a call to the
10178 -- predication function of an ancestor subtype?
10180 procedure Add_Condition
(Cond
: Node_Id
);
10181 -- Append Cond to Expr using "and then" (or just copy Cond to Expr if
10184 procedure Add_Predicates
;
10185 -- Appends expressions for any Predicate pragmas in the rep item chain
10186 -- Typ to Expr. Note that we look only at items for this exact entity.
10187 -- Inheritance of predicates for the parent type is done by calling the
10188 -- Predicate_Function of the parent type, using Add_Call above.
10190 procedure Add_Call
(T
: Entity_Id
);
10191 -- Includes a call to the predicate function for type T in Expr if
10192 -- Predicate_Function (T) is non-empty.
10194 procedure Replace_Current_Instance_References
10195 (N
: Node_Id
; Typ
, New_Entity
: Entity_Id
);
10196 -- Replace all references to Typ in the tree rooted at N with
10197 -- references to Param. [New_Entity will be a formal parameter of a
10198 -- predicate function.]
10204 procedure Add_Call
(T
: Entity_Id
) is
10208 if Present
(Predicate_Function
(T
)) then
10209 pragma Assert
(Has_Predicates
(Typ
));
10211 -- Build the call to the predicate function of T. The type may be
10212 -- derived, so use an unchecked conversion for the actual.
10215 Dynamic_Mem
: Node_Id
:= Empty
;
10216 Second_Formal
: constant Entity_Id
:=
10217 Next_Entity
(Object_Entity
);
10219 -- Some predicate functions require a second parameter;
10220 -- If one predicate function calls another and the second
10221 -- requires two parameters, then the first should also
10222 -- take two parameters (so that the first function has
10223 -- something to pass to the second function).
10224 if Predicate_Function_Needs_Membership_Parameter
(T
) then
10225 pragma Assert
(Present
(Second_Formal
));
10226 Dynamic_Mem
:= New_Occurrence_Of
(Second_Formal
, Loc
);
10230 Make_Predicate_Call
10233 Unchecked_Convert_To
(T
,
10234 Make_Identifier
(Loc
, Object_Name
)),
10235 Dynamic_Mem
=> Dynamic_Mem
);
10238 -- "and"-in the call to evolving expression
10240 Add_Condition
(Exp
);
10241 Ancestor_Predicate_Function_Called
:= True;
10243 -- Output info message on inheritance if required. Note we do not
10244 -- give this information for generic actual types, since it is
10245 -- unwelcome noise in that case in instantiations. We also
10246 -- generally suppress the message in instantiations, and also
10247 -- if it involves internal names.
10249 if List_Inherited_Aspects
10250 and then not Is_Generic_Actual_Type
(Typ
)
10251 and then Instantiation_Location
(Sloc
(Typ
)) = No_Location
10252 and then not Is_Internal_Name
(Chars
(T
))
10253 and then not Is_Internal_Name
(Chars
(Typ
))
10255 Error_Msg_Sloc
:= Sloc
(Predicate_Function
(T
));
10256 Error_Msg_Node_2
:= T
;
10257 Error_Msg_N
("info: & inherits predicate from & #?.l?", Typ
);
10262 -------------------
10263 -- Add_Condition --
10264 -------------------
10266 procedure Add_Condition
(Cond
: Node_Id
) is
10268 -- This is the first predicate expression
10273 -- Otherwise concatenate to the existing predicate expressions by
10274 -- using "and then".
10278 Make_And_Then
(Loc
,
10279 Left_Opnd
=> Relocate_Node
(Expr
),
10280 Right_Opnd
=> Cond
);
10284 --------------------
10285 -- Add_Predicates --
10286 --------------------
10288 procedure Add_Predicates
is
10289 procedure Add_Predicate
(Prag
: Node_Id
);
10290 -- Concatenate the expression of predicate pragma Prag to Expr by
10291 -- using a short circuit "and then" operator.
10293 -------------------
10294 -- Add_Predicate --
10295 -------------------
10297 procedure Add_Predicate
(Prag
: Node_Id
) is
10300 Asp
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
10304 -- Start of processing for Add_Predicate
10307 -- A ghost predicate is checked only when Ghost mode is enabled.
10308 -- Add a condition for the presence of a predicate to be recorded,
10309 -- which is needed to generate the corresponding predicate
10312 if Is_Ignored_Ghost_Pragma
(Prag
) then
10313 Add_Condition
(New_Occurrence_Of
(Standard_True
, Sloc
(Prag
)));
10317 -- Mark corresponding SCO as enabled
10319 Set_SCO_Pragma_Enabled
(Sloc
(Prag
));
10321 -- Extract the arguments of the pragma
10323 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
10324 Arg2
:= Next
(Arg1
);
10326 Arg1
:= Get_Pragma_Arg
(Arg1
);
10327 Arg2
:= Get_Pragma_Arg
(Arg2
);
10329 -- When the predicate pragma applies to the current type or its
10330 -- full view, replace all occurrences of the subtype name with
10331 -- references to the formal parameter of the predicate function.
10333 if Entity
(Arg1
) = Typ
10334 or else Full_View
(Entity
(Arg1
)) = Typ
10337 Arg2_Copy
: constant Node_Id
:= New_Copy_Tree
(Arg2
);
10339 Replace_Current_Instance_References
10340 (Arg2_Copy
, Typ
=> Typ
, New_Entity
=> Object_Entity
);
10342 -- If the predicate pragma comes from an aspect, replace the
10343 -- saved expression because we need the subtype references
10344 -- replaced for the calls to Preanalyze_Spec_Expression in
10345 -- Check_Aspect_At_xxx routines.
10347 if Present
(Asp
) then
10348 Set_Expression_Copy
(Asp
, New_Copy_Tree
(Arg2_Copy
));
10351 -- "and"-in the Arg2 condition to evolving expression
10353 Add_Condition
(Arg2_Copy
);
10362 -- Start of processing for Add_Predicates
10365 Ritem
:= First_Rep_Item
(Typ
);
10367 -- If the type is private, check whether full view has inherited
10370 if Is_Private_Type
(Typ
)
10371 and then No
(Ritem
)
10372 and then Present
(Full_View
(Typ
))
10374 Ritem
:= First_Rep_Item
(Full_View
(Typ
));
10377 while Present
(Ritem
) loop
10378 if Nkind
(Ritem
) = N_Pragma
10379 and then Pragma_Name
(Ritem
) = Name_Predicate
10381 Add_Predicate
(Ritem
);
10383 -- If the type is declared in an inner package it may be frozen
10384 -- outside of the package, and the generated pragma has not been
10385 -- analyzed yet, so capture the expression for the predicate
10386 -- function at this point.
10388 elsif Nkind
(Ritem
) = N_Aspect_Specification
10389 and then Present
(Aspect_Rep_Item
(Ritem
))
10390 and then Scope_Depth
(Scope
(Typ
)) > Scope_Depth
(Current_Scope
)
10393 Prag
: constant Node_Id
:= Aspect_Rep_Item
(Ritem
);
10396 if Nkind
(Prag
) = N_Pragma
10397 and then Pragma_Name
(Prag
) = Name_Predicate
10399 Add_Predicate
(Prag
);
10404 Next_Rep_Item
(Ritem
);
10406 end Add_Predicates
;
10408 -----------------------------------------
10409 -- Replace_Current_Instance_References --
10410 -----------------------------------------
10412 procedure Replace_Current_Instance_References
10413 (N
: Node_Id
; Typ
, New_Entity
: Entity_Id
)
10415 Root
: Node_Id
renames N
;
10417 procedure Replace_One_Reference
(N
: Node_Id
);
10418 -- Actual parameter for Replace_Type_References_Generic instance
10420 ---------------------------
10421 -- Replace_One_Reference --
10422 ---------------------------
10424 procedure Replace_One_Reference
(N
: Node_Id
) is
10425 pragma Assert
(In_Subtree
(N
, Root
=> Root
));
10427 Rewrite
(N
, New_Occurrence_Of
(New_Entity
, Sloc
(N
)));
10428 -- Use the Sloc of the usage name, not the defining name
10429 end Replace_One_Reference
;
10431 procedure Replace_Type_References
is
10432 new Replace_Type_References_Generic
(Replace_One_Reference
);
10434 Replace_Type_References
(N
, Typ
);
10435 end Replace_Current_Instance_References
;
10437 -- Start of processing for Build_Predicate_Function
10440 -- Return if already built, if type does not have predicates,
10441 -- or if type is a constructed subtype that will inherit a
10442 -- predicate function from its ancestor. In a generic context
10443 -- the predicated parent may not have a predicate function yet
10444 -- but we don't want to build a new one for the subtype. This can
10445 -- happen in an instance body which is nested within a generic
10446 -- unit, in which case Within_A_Generic may be false, SId is
10447 -- Empty, but uses of Typ will receive a predicate check in a
10448 -- context where expansion and tests are enabled.
10450 SId
:= Predicate_Function
(Typ
);
10451 if not Has_Predicates
(Typ
)
10452 or else (Present
(SId
) and then Has_Completion
(SId
))
10455 and then not Comes_From_Source
(Typ
)
10456 and then Ekind
(Typ
) in E_Array_Subtype
10458 | E_Record_Subtype_With_Private
10459 and then Present
(Predicated_Parent
(Typ
)))
10463 -- Do not generate predicate bodies within a generic unit. The
10464 -- expressions have been analyzed already, and the bodies play no role
10465 -- if not within an executable unit. However, if a static predicate is
10466 -- present it must be processed for legality checks such as case
10467 -- coverage in an expression.
10469 elsif Inside_A_Generic
10470 and then not Has_Static_Predicate_Aspect
(Typ
)
10475 -- Ensure that the declarations are added to the scope of the type
10477 if Scope
(Typ
) /= Current_Scope
then
10478 Push_Scope
(Scope
(Typ
));
10479 Restore_Scope
:= True;
10481 Restore_Scope
:= False;
10484 -- The related type may be subject to pragma Ghost. Set the mode now to
10485 -- ensure that the predicate functions are properly marked as Ghost.
10487 Set_Ghost_Mode
(Typ
);
10489 -- Prepare to construct predicate expression
10493 if Present
(SId
) then
10494 FDecl
:= Unit_Declaration_Node
(SId
);
10497 FDecl
:= Build_Predicate_Function_Declaration
(Typ
);
10498 SId
:= Defining_Entity
(FDecl
);
10501 -- Recover name of formal parameter of function that replaces references
10502 -- to the type in predicate expressions.
10505 Defining_Identifier
10506 (First
(Parameter_Specifications
(Specification
(FDecl
))));
10508 Object_Name
:= Chars
(Object_Entity
);
10510 -- Add predicates for ancestor if present. These must come before the
10511 -- ones for the current type, as required by AI12-0071-1.
10513 -- Looks like predicates aren't added for case of inheriting from
10514 -- multiple progenitors???
10519 Atyp
:= Nearest_Ancestor
(Typ
);
10521 -- The type may be private but the full view may inherit predicates
10523 if No
(Atyp
) and then Is_Private_Type
(Typ
) then
10524 Atyp
:= Nearest_Ancestor
(Full_View
(Typ
));
10527 if Present
(Atyp
) then
10532 -- Add Predicates for the current type
10536 -- Case where predicates are present
10538 if Present
(Expr
) then
10540 -- Build the main predicate function
10543 SIdB
: constant Entity_Id
:=
10544 Make_Defining_Identifier
(Loc
,
10545 Chars
=> New_External_Name
(Chars
(Typ
), "Predicate"));
10546 -- The entity for the function body
10552 Mutate_Ekind
(SIdB
, E_Function
);
10553 Set_Is_Predicate_Function
(SIdB
);
10555 -- Build function body
10558 Param_Specs
: constant List_Id
:= New_List
(
10559 Make_Parameter_Specification
(Loc
,
10560 Defining_Identifier
=>
10561 Make_Defining_Identifier
(Loc
, Object_Name
),
10563 New_Occurrence_Of
(Typ
, Loc
)));
10565 -- if Spec has 2 parameters, then body should too
10566 if Present
(Next_Entity
(Object_Entity
)) then
10567 Append
(Make_Parameter_Specification
(Loc
,
10568 Defining_Identifier
=>
10569 Make_Defining_Identifier
10570 (Loc
, Chars
(Next_Entity
(Object_Entity
))),
10572 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
10577 Make_Function_Specification
(Loc
,
10578 Defining_Unit_Name
=> SIdB
,
10579 Parameter_Specifications
=> Param_Specs
,
10580 Result_Definition
=>
10581 New_Occurrence_Of
(Standard_Boolean
, Loc
));
10584 -- The Predicate_Expression attribute is used by SPARK.
10586 -- If Ancestor_Predicate_Function_Called is True, then
10587 -- we try to exclude that call to the ancestor's
10588 -- predicate function by calling Right_Opnd.
10589 -- The call is not excluded in the case where
10590 -- it is not "and"ed with anything else (so we don't have
10591 -- an N_And_Then node). This exclusion is required if the
10592 -- Predicate_Failure aspect is specified for Typ because
10593 -- in that case we are going to drop the N_And_Then node
10594 -- on the floor. Otherwise, it is a question of what is
10595 -- most convenient for SPARK.
10597 Set_Predicate_Expression
10598 (SId
, (if Ancestor_Predicate_Function_Called
10599 and then Nkind
(Expr
) = N_And_Then
10600 then Right_Opnd
(Expr
)
10604 Result_Expr
: Node_Id
:= Expr
;
10605 PF_Expr
: Node_Id
:= Predicate_Failure_Expression
10606 (Typ
, Inherited_OK
=> False);
10607 PF_Expr_Copy
: Node_Id
;
10608 Second_Formal
: constant Entity_Id
:=
10609 Next_Entity
(Object_Entity
);
10611 -- In GNATprove mode we are only interested in the predicate
10612 -- expression itself and don't want a raise expression that
10613 -- comes from the Predicate_Failure. Ditto for CodePeer.
10614 -- And an illegal Predicate_Failure aspect can lead to cases
10615 -- we want to avoid.
10617 if Present
(PF_Expr
)
10618 and then not GNATprove_Mode
10619 and then not CodePeer_Mode
10620 and then Serious_Errors_Detected
= 0
10622 pragma Assert
(Present
(Second_Formal
));
10624 -- This is an ugly hack to cope with an ugly situation.
10625 -- PF_Expr may have children whose Parent attribute
10626 -- does not point back to PF_Expr. If we pass such a
10627 -- tree to New_Copy_Tree, then it does not make a deep
10628 -- copy. But we need a deep copy. So we need to find a
10629 -- tree for which New_Copy_Tree *will* make a deep copy.
10632 function Check_Node_Parent
(Parent_Node
, Node
: Node_Id
)
10633 return Traverse_Result
;
10634 function Check_Node_Parent
(Parent_Node
, Node
: Node_Id
)
10635 return Traverse_Result
is
10637 if Parent_Node
= PF_Expr
10638 and then not Is_List_Member
(Node
)
10641 (Nkind
(PF_Expr
) = Nkind
(Parent
(Node
)));
10643 -- We need PF_Expr to be a node for which
10644 -- New_Copy_Tree will make a deep copy.
10645 PF_Expr
:= Parent
(Node
);
10649 end Check_Node_Parent
;
10650 procedure Check_Parentage
is
10651 new Traverse_Proc_With_Parent
(Check_Node_Parent
);
10653 Check_Parentage
(PF_Expr
);
10654 PF_Expr_Copy
:= New_Copy_Tree
(PF_Expr
);
10657 -- Current instance uses need to have their Entity
10658 -- fields set so that Replace_Current_Instance_References
10659 -- can find them. So we preanalyze. Just for purposes of
10660 -- calls to Is_Current_Instance during this preanalysis,
10661 -- we set the Parent field.
10662 Set_Parent
(PF_Expr_Copy
, Parent
(PF_Expr
));
10663 Preanalyze
(PF_Expr_Copy
);
10664 Set_Parent
(PF_Expr_Copy
, Empty
);
10666 Replace_Current_Instance_References
10667 (PF_Expr_Copy
, Typ
=> Typ
, New_Entity
=> Object_Entity
);
10669 if Ancestor_Predicate_Function_Called
then
10670 -- If the call to an ancestor predicate function
10671 -- returns False, we do not want to raise an
10672 -- exception here. Our Predicate_Failure aspect does
10673 -- not apply in that case. So we have to build a
10674 -- more complicated result expression:
10675 -- (if not Ancestor_Predicate_Function (...) then False
10676 -- elsif Noninherited_Predicates (...) then True
10677 -- elsif Is_Membership_Test then False
10678 -- else (raise Assertion_Error with PF text))
10681 Ancestor_Call
: constant Node_Id
:=
10682 Left_Opnd
(Result_Expr
);
10683 Local_Preds
: constant Node_Id
:=
10684 Right_Opnd
(Result_Expr
);
10687 Make_If_Expression
(Loc
,
10688 Expressions
=> New_List
(
10689 Make_Op_Not
(Loc
, Ancestor_Call
),
10690 New_Occurrence_Of
(Standard_False
, Loc
),
10691 Make_If_Expression
(Loc
,
10693 Expressions
=> New_List
(
10695 New_Occurrence_Of
(Standard_True
, Loc
),
10696 Make_If_Expression
(Loc
,
10698 Expressions
=> New_List
(
10699 New_Occurrence_Of
(Second_Formal
, Loc
),
10700 New_Occurrence_Of
(Standard_False
, Loc
),
10701 Make_Raise_Expression
(Loc
,
10702 New_Occurrence_Of
(RTE
10703 (RE_Assert_Failure
), Loc
),
10704 PF_Expr_Copy
)))))));
10708 -- Build a conditional expression:
10709 -- (if <predicate evaluates to True> then True
10710 -- elsif Is_Membership_Test then False
10711 -- else (raise Assertion_Error with PF text))
10714 Make_If_Expression
(Loc
,
10715 Expressions
=> New_List
(
10717 New_Occurrence_Of
(Standard_True
, Loc
),
10718 Make_If_Expression
(Loc
,
10720 Expressions
=> New_List
(
10721 New_Occurrence_Of
(Second_Formal
, Loc
),
10722 New_Occurrence_Of
(Standard_False
, Loc
),
10723 Make_Raise_Expression
(Loc
,
10724 New_Occurrence_Of
(RTE
10725 (RE_Assert_Failure
), Loc
),
10731 Make_Subprogram_Body
(Loc
,
10732 Specification
=> Spec
,
10733 Declarations
=> Empty_List
,
10734 Handled_Statement_Sequence
=>
10735 Make_Handled_Sequence_Of_Statements
(Loc
,
10736 Statements
=> New_List
(
10737 Make_Simple_Return_Statement
(Loc
,
10738 Expression
=> Result_Expr
))));
10741 -- The declaration has been analyzed when created, and placed
10742 -- after type declaration. Insert body itself after freeze node,
10743 -- unless subprogram declaration is already there, in which case
10744 -- body better be placed afterwards.
10746 if FDecl
= Next
(N
) then
10747 Insert_After_And_Analyze
(FDecl
, FBody
);
10749 Insert_After_And_Analyze
(N
, FBody
);
10752 -- The defining identifier of a quantified expression carries the
10753 -- scope in which the type appears, but when unnesting we need
10754 -- to indicate that its proper scope is the constructed predicate
10755 -- function. The quantified expressions have been converted into
10756 -- loops during analysis and expansion.
10759 function Reset_Quantified_Variable_Scope
10760 (N
: Node_Id
) return Traverse_Result
;
10762 procedure Reset_Quantified_Variables_Scope
is
10763 new Traverse_Proc
(Reset_Quantified_Variable_Scope
);
10765 -------------------------------------
10766 -- Reset_Quantified_Variable_Scope --
10767 -------------------------------------
10769 function Reset_Quantified_Variable_Scope
10770 (N
: Node_Id
) return Traverse_Result
is
10772 if Nkind
(N
) in N_Iterator_Specification
10773 | N_Loop_Parameter_Specification
10775 Set_Scope
(Defining_Identifier
(N
),
10776 Predicate_Function
(Typ
));
10780 end Reset_Quantified_Variable_Scope
;
10783 if Unnest_Subprogram_Mode
then
10784 Reset_Quantified_Variables_Scope
(Expr
);
10788 -- Within a generic unit, prevent a double analysis of the body
10789 -- which will not be marked analyzed yet. This will happen when
10790 -- the freeze node is created during the preanalysis of an
10791 -- expression function.
10793 if Inside_A_Generic
then
10794 Set_Analyzed
(FBody
);
10797 -- Static predicate functions are always side-effect-free, and
10798 -- in most cases dynamic predicate functions are as well. Mark
10799 -- them as such whenever possible, so redundant predicate checks
10800 -- can be optimized. If there is a variable reference within the
10801 -- expression, the function is not pure.
10803 if Expander_Active
then
10805 Side_Effect_Free
(Expr
, Variable_Ref
=> True));
10806 Set_Is_Inlined
(SId
);
10810 -- See if we have a static predicate. Note that the answer may be
10811 -- yes even if we have an explicit Dynamic_Predicate present.
10818 if not Is_Scalar_Type
(Typ
) and then not Is_String_Type
(Typ
) then
10821 PS
:= Is_Predicate_Static
(Expr
, Object_Name
);
10824 -- Case where we have a predicate-static aspect
10828 -- We don't set Has_Static_Predicate_Aspect, since we can have
10829 -- any of the three cases (Predicate, Dynamic_Predicate, or
10830 -- Static_Predicate) generating a predicate with an expression
10831 -- that is predicate-static. We just indicate that we have a
10832 -- predicate that can be treated as static.
10834 Set_Has_Static_Predicate
(Typ
);
10836 -- For discrete subtype, build the static predicate list
10838 if Is_Discrete_Type
(Typ
) then
10839 Build_Discrete_Static_Predicate
(Typ
, Expr
, Object_Name
);
10841 -- If we don't get a static predicate list, it means that we
10842 -- have a case where this is not possible, most typically in
10843 -- the case where we inherit a dynamic predicate. We do not
10844 -- consider this an error, we just leave the predicate as
10845 -- dynamic. But if we do succeed in building the list, then
10846 -- we mark the predicate as static.
10848 if No
(Static_Discrete_Predicate
(Typ
)) then
10849 Set_Has_Static_Predicate
(Typ
, False);
10852 -- For real or string subtype, save predicate expression
10854 elsif Is_Real_Type
(Typ
) or else Is_String_Type
(Typ
) then
10855 Set_Static_Real_Or_String_Predicate
(Typ
, Expr
);
10858 -- Case of dynamic predicate (expression is not predicate-static)
10861 -- Again, we don't set Has_Dynamic_Predicate_Aspect, since that
10862 -- is only set if we have an explicit Dynamic_Predicate aspect
10863 -- given. Here we may simply have a Predicate aspect where the
10864 -- expression happens not to be predicate-static.
10866 -- Emit an error when the predicate is categorized as static
10867 -- but its expression is not predicate-static.
10869 -- First a little fiddling to get a nice location for the
10870 -- message. If the expression is of the form (A and then B),
10871 -- where A is an inherited predicate, then use the right
10872 -- operand for the Sloc. This avoids getting confused by a call
10873 -- to an inherited predicate with a less convenient source
10877 while Nkind
(EN
) = N_And_Then
10878 and then Nkind
(Left_Opnd
(EN
)) = N_Function_Call
10879 and then Is_Predicate_Function
10880 (Entity
(Name
(Left_Opnd
(EN
))))
10882 EN
:= Right_Opnd
(EN
);
10885 -- Now post appropriate message
10887 if Has_Static_Predicate_Aspect
(Typ
) then
10888 if Is_Scalar_Type
(Typ
) or else Is_String_Type
(Typ
) then
10890 ("expression is not predicate-static (RM 3.2.4(16-22))",
10894 ("static predicate requires scalar or string type", EN
);
10901 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
10903 if Restore_Scope
then
10906 end Build_Predicate_Function
;
10908 ------------------------------------------
10909 -- Build_Predicate_Function_Declaration --
10910 ------------------------------------------
10912 -- WARNING: This routine manages Ghost regions. Return statements must be
10913 -- replaced by gotos which jump to the end of the routine and restore the
10916 function Build_Predicate_Function_Declaration
10917 (Typ
: Entity_Id
) return Node_Id
10919 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
10921 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
10922 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
10923 -- Save the Ghost-related attributes to restore on exit
10925 Func_Decl
: Node_Id
;
10926 Func_Id
: Entity_Id
;
10929 CRec_Typ
: Entity_Id
;
10930 -- The corresponding record type of Full_Typ
10932 Full_Typ
: Entity_Id
;
10933 -- The full view of Typ
10935 Priv_Typ
: Entity_Id
;
10936 -- The partial view of Typ
10938 UFull_Typ
: Entity_Id
;
10939 -- The underlying full view of Full_Typ
10942 -- The related type may be subject to pragma Ghost. Set the mode now to
10943 -- ensure that the predicate functions are properly marked as Ghost.
10945 Set_Ghost_Mode
(Typ
);
10948 Make_Defining_Identifier
(Loc
,
10949 Chars
=> New_External_Name
(Chars
(Typ
), "Predicate"));
10951 Mutate_Ekind
(Func_Id
, E_Function
);
10952 Set_Etype
(Func_Id
, Standard_Boolean
);
10953 Set_Is_Internal
(Func_Id
);
10954 Set_Is_Predicate_Function
(Func_Id
);
10955 Set_Predicate_Function
(Typ
, Func_Id
);
10957 -- The predicate function requires debug info when the predicates are
10958 -- subject to Source Coverage Obligations.
10960 if Opt
.Generate_SCO
then
10961 Set_Debug_Info_Needed
(Func_Id
);
10964 -- Obtain all views of the input type
10966 Get_Views
(Typ
, Priv_Typ
, Full_Typ
, UFull_Typ
, CRec_Typ
);
10968 -- Associate the predicate function and various flags with all views
10970 Propagate_Predicate_Attributes
(Priv_Typ
, From_Typ
=> Typ
);
10971 Propagate_Predicate_Attributes
(Full_Typ
, From_Typ
=> Typ
);
10972 Propagate_Predicate_Attributes
(UFull_Typ
, From_Typ
=> Typ
);
10973 Propagate_Predicate_Attributes
(CRec_Typ
, From_Typ
=> Typ
);
10976 Param_Specs
: constant List_Id
:= New_List
(
10977 Make_Parameter_Specification
(Loc
,
10978 Defining_Identifier
=> Make_Temporary
(Loc
, 'I'),
10979 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
10981 if Predicate_Function_Needs_Membership_Parameter
(Typ
) then
10982 -- Add Boolean-valued For_Membership_Test param
10983 Append
(Make_Parameter_Specification
(Loc
,
10984 Defining_Identifier
=> Make_Temporary
(Loc
, 'M'),
10986 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
10991 Make_Function_Specification
(Loc
,
10992 Defining_Unit_Name
=> Func_Id
,
10993 Parameter_Specifications
=> Param_Specs
,
10994 Result_Definition
=>
10995 New_Occurrence_Of
(Standard_Boolean
, Loc
));
10998 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Specification
=> Spec
);
11000 Insert_After
(Parent
(Typ
), Func_Decl
);
11001 Analyze
(Func_Decl
);
11003 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
11006 end Build_Predicate_Function_Declaration
;
11008 -----------------------------------------
11009 -- Check_Aspect_At_End_Of_Declarations --
11010 -----------------------------------------
11012 procedure Check_Aspect_At_End_Of_Declarations
(ASN
: Node_Id
) is
11013 Ent
: constant Entity_Id
:= Entity
(ASN
);
11014 Ident
: constant Node_Id
:= Identifier
(ASN
);
11015 A_Id
: constant Aspect_Id
:= Get_Aspect_Id
(Chars
(Ident
));
11017 End_Decl_Expr
: constant Node_Id
:= Expression_Copy
(ASN
);
11018 -- Expression to be analyzed at end of declarations
11020 Freeze_Expr
: constant Node_Id
:= Expression
(ASN
);
11021 -- Expression from call to Check_Aspect_At_Freeze_Point.
11023 T
: constant Entity_Id
:=
11024 (if Present
(Freeze_Expr
) and A_Id
/= Aspect_Stable_Properties
11025 then Etype
(Original_Node
(Freeze_Expr
))
11027 -- Type required for preanalyze call. We use the original expression to
11028 -- get the proper type, to prevent cascaded errors when the expression
11029 -- is constant-folded. For Stable_Properties, the aspect value is
11030 -- not semantically an expression (although it is syntactically);
11031 -- in particular, it has no type.
11034 -- Set True if error
11036 -- On entry to this procedure, Entity (Ident) contains a copy of the
11037 -- original expression from the aspect, saved for this purpose, and
11038 -- but Expression (Ident) is a preanalyzed copy of the expression,
11039 -- preanalyzed just after the freeze point.
11041 procedure Check_Overloaded_Name
;
11042 -- For aspects whose expression is simply a name, this routine checks if
11043 -- the name is overloaded or not. If so, it verifies there is an
11044 -- interpretation that matches the entity obtained at the freeze point,
11045 -- otherwise the compiler complains.
11047 ---------------------------
11048 -- Check_Overloaded_Name --
11049 ---------------------------
11051 procedure Check_Overloaded_Name
is
11053 if not Is_Overloaded
(End_Decl_Expr
) then
11054 Err
:= not Is_Entity_Name
(End_Decl_Expr
)
11055 or else Entity
(End_Decl_Expr
) /= Entity
(Freeze_Expr
);
11061 Index
: Interp_Index
;
11065 Get_First_Interp
(End_Decl_Expr
, Index
, It
);
11066 while Present
(It
.Typ
) loop
11067 if It
.Nam
= Entity
(Freeze_Expr
) then
11072 Get_Next_Interp
(Index
, It
);
11076 end Check_Overloaded_Name
;
11078 -- Start of processing for Check_Aspect_At_End_Of_Declarations
11081 -- In an instance we do not perform the consistency check between freeze
11082 -- point and end of declarations, because it was done already in the
11083 -- analysis of the generic. Furthermore, the delayed analysis of an
11084 -- aspect of the instance may produce spurious errors when the generic
11085 -- is a child unit that references entities in the parent (which might
11086 -- not be in scope at the freeze point of the instance).
11088 if In_Instance
then
11091 -- The enclosing scope may have been rewritten during expansion (.e.g. a
11092 -- task body is rewritten as a procedure) after this conformance check
11093 -- has been performed, so do not perform it again (it may not easily be
11094 -- done if full visibility of local entities is not available).
11096 elsif not Comes_From_Source
(Current_Scope
) then
11099 -- Case of aspects Dimension, Dimension_System and Synchronization
11101 elsif A_Id
= Aspect_Synchronization
then
11104 -- Case of stream attributes and Put_Image, just have to compare
11105 -- entities. However, the expression is just a possibly-overloaded
11106 -- name, so we need to verify that one of these interpretations is
11107 -- the one available at at the freeze point.
11109 elsif A_Id
in Aspect_Input
11115 Analyze
(End_Decl_Expr
);
11116 Check_Overloaded_Name
;
11118 elsif A_Id
in Aspect_Variable_Indexing
11119 | Aspect_Constant_Indexing
11120 | Aspect_Default_Iterator
11121 | Aspect_Iterator_Element
11122 | Aspect_Integer_Literal
11123 | Aspect_Real_Literal
11124 | Aspect_String_Literal
11126 -- Make type unfrozen before analysis, to prevent spurious errors
11127 -- about late attributes.
11129 Set_Is_Frozen
(Ent
, False);
11130 Analyze
(End_Decl_Expr
);
11131 Set_Is_Frozen
(Ent
, True);
11133 -- If the end of declarations comes before any other freeze point,
11134 -- the Freeze_Expr is not analyzed: no check needed.
11136 if Analyzed
(Freeze_Expr
) and then not In_Instance
then
11137 Check_Overloaded_Name
;
11145 -- In a generic context freeze nodes are not always generated, so
11146 -- analyze the expression now. If the aspect is for a type, we must
11147 -- also make its potential components accessible.
11149 if not Analyzed
(Freeze_Expr
) and then Inside_A_Generic
then
11150 if A_Id
in Aspect_Dynamic_Predicate
11151 | Aspect_Ghost_Predicate
11153 | Aspect_Static_Predicate
11156 Preanalyze_Spec_Expression
(Freeze_Expr
, Standard_Boolean
);
11159 elsif A_Id
= Aspect_Priority
then
11161 Preanalyze_Spec_Expression
(Freeze_Expr
, Any_Integer
);
11165 Preanalyze
(Freeze_Expr
);
11169 -- Indicate that the expression comes from an aspect specification,
11170 -- which is used in subsequent analysis even if expansion is off.
11172 if Present
(End_Decl_Expr
) then
11173 Set_Parent
(End_Decl_Expr
, ASN
);
11176 -- In a generic context the original aspect expressions have not
11177 -- been preanalyzed, so do it now. There are no conformance checks
11178 -- to perform in this case. As before, we have to make components
11179 -- visible for aspects that may reference them.
11181 if Present
(Freeze_Expr
) and then No
(T
) then
11182 if A_Id
in Aspect_Dynamic_Predicate
11183 | Aspect_Ghost_Predicate
11186 | Aspect_Static_Predicate
11189 Check_Aspect_At_Freeze_Point
(ASN
);
11193 Check_Aspect_At_Freeze_Point
(ASN
);
11197 -- The default values attributes may be defined in the private part,
11198 -- and the analysis of the expression may take place when only the
11199 -- partial view is visible. The expression must be scalar, so use
11200 -- the full view to resolve.
11202 elsif A_Id
in Aspect_Default_Component_Value | Aspect_Default_Value
11203 and then Is_Private_Type
(T
)
11205 Preanalyze_Spec_Expression
(End_Decl_Expr
, Full_View
(T
));
11207 -- The following aspect expressions may contain references to
11208 -- components and discriminants of the type.
11210 elsif A_Id
in Aspect_CPU
11211 | Aspect_Dynamic_Predicate
11212 | Aspect_Ghost_Predicate
11215 | Aspect_Static_Predicate
11218 Preanalyze_Spec_Expression
(End_Decl_Expr
, T
);
11221 elsif A_Id
= Aspect_Predicate_Failure
then
11222 Preanalyze_Spec_Expression
(End_Decl_Expr
, Standard_String
);
11223 elsif Present
(End_Decl_Expr
) then
11224 Preanalyze_Spec_Expression
(End_Decl_Expr
, T
);
11228 not Fully_Conformant_Expressions
11229 (End_Decl_Expr
, Freeze_Expr
, Report
=> True);
11232 -- Output error message if error. Force error on aspect specification
11233 -- even if there is an error on the expression itself.
11237 ("!visibility of aspect for& changes after freeze point",
11240 ("info: & is frozen here, (RM 13.1.1 (13/3))??",
11241 Freeze_Node
(Ent
), Ent
);
11243 end Check_Aspect_At_End_Of_Declarations
;
11245 ----------------------------------
11246 -- Check_Aspect_At_Freeze_Point --
11247 ----------------------------------
11249 procedure Check_Aspect_At_Freeze_Point
(ASN
: Node_Id
) is
11250 Ident
: constant Node_Id
:= Identifier
(ASN
);
11251 -- Identifier (use Entity field to save expression)
11253 Expr
: constant Node_Id
:= Expression
(ASN
);
11254 -- For cases where using Entity (Identifier) doesn't work
11256 A_Id
: constant Aspect_Id
:= Get_Aspect_Id
(Chars
(Ident
));
11258 T
: Entity_Id
:= Empty
;
11259 -- Type required for preanalyze call
11262 -- On entry to this procedure, Entity (Ident) contains a copy of the
11263 -- original expression from the aspect, saved for this purpose.
11265 -- On exit from this procedure Entity (Ident) is unchanged, still
11266 -- containing that copy, but Expression (Ident) is a preanalyzed copy
11267 -- of the expression, preanalyzed just after the freeze point.
11269 -- Make a copy of the expression to be preanalyzed
11271 Set_Expression
(ASN
, New_Copy_Tree
(Expression_Copy
(ASN
)));
11273 -- Find type for preanalyze call
11277 -- No_Aspect should be impossible
11280 raise Program_Error
;
11282 -- Aspects taking an optional boolean argument
11284 when Boolean_Aspects
11285 | Library_Unit_Aspects
11287 T
:= Standard_Boolean
;
11289 -- Aspects corresponding to attribute definition clauses
11291 when Aspect_Address
=>
11292 T
:= RTE
(RE_Address
);
11294 when Aspect_Attach_Handler
=>
11295 T
:= RTE
(RE_Interrupt_ID
);
11297 when Aspect_Bit_Order
11298 | Aspect_Scalar_Storage_Order
11300 T
:= RTE
(RE_Bit_Order
);
11302 when Aspect_Convention
=>
11306 T
:= RTE
(RE_CPU_Range
);
11308 -- Default_Component_Value is resolved with the component type
11310 when Aspect_Default_Component_Value
=>
11311 T
:= Component_Type
(Entity
(ASN
));
11313 when Aspect_Default_Storage_Pool
=>
11314 T
:= Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
));
11316 -- Default_Value is resolved with the type entity in question
11318 when Aspect_Default_Value
=>
11321 when Aspect_Dispatching_Domain
=>
11322 T
:= RTE
(RE_Dispatching_Domain
);
11324 when Aspect_External_Tag
=>
11325 T
:= Standard_String
;
11327 when Aspect_External_Name
=>
11328 T
:= Standard_String
;
11330 when Aspect_Link_Name
=>
11331 T
:= Standard_String
;
11333 when Aspect_Interrupt_Priority
11336 T
:= Standard_Integer
;
11338 when Aspect_Relative_Deadline
=>
11339 T
:= RTE
(RE_Time_Span
);
11341 when Aspect_Secondary_Stack_Size
=>
11342 T
:= Standard_Integer
;
11344 when Aspect_Small
=>
11346 -- Note that the expression can be of any real type (not just a
11347 -- real universal literal) as long as it is a static constant.
11351 -- For a simple storage pool, we have to retrieve the type of the
11352 -- pool object associated with the aspect's corresponding attribute
11353 -- definition clause.
11355 when Aspect_Simple_Storage_Pool
=>
11356 T
:= Etype
(Expression
(Aspect_Rep_Item
(ASN
)));
11358 when Aspect_Storage_Pool
=>
11359 T
:= Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
));
11361 when Aspect_Alignment
11362 | Aspect_Component_Size
11363 | Aspect_Machine_Radix
11364 | Aspect_Object_Size
11366 | Aspect_Storage_Size
11367 | Aspect_Stream_Size
11368 | Aspect_Value_Size
11372 when Aspect_Linker_Section
=>
11373 T
:= Standard_String
;
11375 when Aspect_Local_Restrictions
=>
11378 when Aspect_Synchronization
=>
11381 -- Special case, the expression of these aspects is just an entity
11382 -- that does not need any resolution, so just analyze.
11391 Analyze
(Expression
(ASN
));
11394 -- Same for Iterator aspects, where the expression is a function
11395 -- name. Legality rules are checked separately.
11397 when Aspect_Constant_Indexing
11398 | Aspect_Default_Iterator
11399 | Aspect_Iterator_Element
11400 | Aspect_Variable_Indexing
11402 Analyze
(Expression
(ASN
));
11405 -- Same for Literal aspects, where the expression is a function
11406 -- name. Legality rules are checked separately. Use Expr to avoid
11407 -- losing track of the previous resolution of Expression.
11409 when Aspect_Integer_Literal
11410 | Aspect_Real_Literal
11411 | Aspect_String_Literal
11413 Set_Entity
(Expression
(ASN
), Entity
(Expr
));
11414 Set_Etype
(Expression
(ASN
), Etype
(Expr
));
11415 Set_Is_Overloaded
(Expression
(ASN
), False);
11416 Analyze
(Expression
(ASN
));
11419 -- Ditto for Iterable, legality checks in Validate_Iterable_Aspect.
11421 when Aspect_Iterable
=>
11425 Cursor
: constant Entity_Id
:= Get_Cursor_Type
(ASN
, T
);
11430 if Cursor
= Any_Type
then
11434 Assoc
:= First
(Component_Associations
(Expression
(ASN
)));
11435 while Present
(Assoc
) loop
11436 Expr
:= Expression
(Assoc
);
11439 if not Error_Posted
(Expr
) then
11440 Resolve_Iterable_Operation
11441 (Expr
, Cursor
, T
, Chars
(First
(Choices
(Assoc
))));
11450 when Aspect_Aggregate
=>
11451 if Is_Array_Type
(Entity
(ASN
)) then
11453 ("aspect& can only be applied to non-array type",
11456 Resolve_Aspect_Aggregate
(Entity
(ASN
), Expression
(ASN
));
11459 when Aspect_Stable_Properties
=>
11460 Resolve_Aspect_Stable_Properties
11461 (Entity
(ASN
), Expression
(ASN
),
11462 Class_Present
=> Class_Present
(ASN
));
11465 -- Invariant/Predicate take boolean expressions
11467 when Aspect_Dynamic_Predicate
11469 | Aspect_Ghost_Predicate
11471 | Aspect_Static_Predicate
11472 | Aspect_Type_Invariant
11474 T
:= Standard_Boolean
;
11476 when Aspect_Predicate_Failure
=>
11477 T
:= Standard_String
;
11479 -- As for some other aspects above, the expression of this aspect is
11480 -- just an entity that does not need any resolution, so just analyze.
11482 when Aspect_Designated_Storage_Model
=>
11483 Analyze
(Expression
(ASN
));
11486 when Aspect_Storage_Model_Type
=>
11488 -- The aggregate argument of Storage_Model_Type is optional, and
11489 -- when not present the aspect defaults to the native storage
11490 -- model (where the address type is System.Address, and other
11491 -- arguments default to corresponding native storage operations).
11493 if No
(Expression
(ASN
)) then
11502 Addr_Type
: Entity_Id
:= Empty
;
11505 Assoc
:= First
(Component_Associations
(Expression
(ASN
)));
11506 while Present
(Assoc
) loop
11507 Expr
:= Expression
(Assoc
);
11510 if not Error_Posted
(Expr
) then
11511 Resolve_Storage_Model_Type_Argument
11512 (Expr
, T
, Addr_Type
, Chars
(First
(Choices
(Assoc
))));
11521 -- Here is the list of aspects that don't require delay analysis
11523 when Aspect_Abstract_State
11524 | Aspect_Always_Terminates
11526 | Aspect_Async_Readers
11527 | Aspect_Async_Writers
11528 | Aspect_Constant_After_Elaboration
11529 | Aspect_Contract_Cases
11530 | Aspect_Default_Initial_Condition
11533 | Aspect_Dimension_System
11534 | Aspect_Exceptional_Cases
11535 | Aspect_Effective_Reads
11536 | Aspect_Effective_Writes
11537 | Aspect_Extensions_Visible
11540 | Aspect_GNAT_Annotate
11541 | Aspect_Implicit_Dereference
11542 | Aspect_Initial_Condition
11543 | Aspect_Initializes
11544 | Aspect_Max_Entry_Queue_Depth
11545 | Aspect_Max_Entry_Queue_Length
11546 | Aspect_Max_Queue_Length
11547 | Aspect_No_Caching
11548 | Aspect_No_Controlled_Parts
11549 | Aspect_No_Task_Parts
11550 | Aspect_Obsolescent
11553 | Aspect_Postcondition
11555 | Aspect_Precondition
11556 | Aspect_Side_Effects
11557 | Aspect_Refined_Depends
11558 | Aspect_Refined_Global
11559 | Aspect_Refined_Post
11560 | Aspect_Refined_State
11561 | Aspect_Relaxed_Initialization
11562 | Aspect_SPARK_Mode
11563 | Aspect_Subprogram_Variant
11566 | Aspect_Unimplemented
11567 | Aspect_Unsuppress
11568 | Aspect_User_Aspect
11569 | Aspect_Volatile_Function
11571 raise Program_Error
;
11575 -- Do the preanalyze call
11577 if Present
(Expression
(ASN
)) then
11578 Preanalyze_Spec_Expression
(Expression
(ASN
), T
);
11580 end Check_Aspect_At_Freeze_Point
;
11582 -----------------------------------
11583 -- Check_Constant_Address_Clause --
11584 -----------------------------------
11586 procedure Check_Constant_Address_Clause
11590 procedure Check_At_Constant_Address
(Nod
: Node_Id
);
11591 -- Checks that the given node N represents a name whose 'Address is
11592 -- constant (in the same sense as OK_Constant_Address_Clause, i.e. the
11593 -- address value is the same at the point of declaration of U_Ent and at
11594 -- the time of elaboration of the address clause.
11596 procedure Check_Expr_Constants
(Nod
: Node_Id
);
11597 -- Checks that Nod meets the requirements for a constant address clause
11598 -- in the sense of the enclosing procedure.
11600 procedure Check_List_Constants
(Lst
: List_Id
);
11601 -- Check that all elements of list Lst meet the requirements for a
11602 -- constant address clause in the sense of the enclosing procedure.
11604 -------------------------------
11605 -- Check_At_Constant_Address --
11606 -------------------------------
11608 procedure Check_At_Constant_Address
(Nod
: Node_Id
) is
11610 if Is_Entity_Name
(Nod
) then
11611 if Present
(Address_Clause
(Entity
((Nod
)))) then
11613 ("invalid address clause for initialized object &!",
11616 ("address for& cannot depend on another address clause! "
11617 & "(RM 13.1(22))!", Nod
, U_Ent
);
11619 elsif In_Same_Source_Unit
(Entity
(Nod
), U_Ent
)
11620 and then Sloc
(U_Ent
) < Sloc
(Entity
(Nod
))
11623 ("invalid address clause for initialized object &!",
11625 Error_Msg_Node_2
:= U_Ent
;
11627 ("\& must be defined before & (RM 13.1(22))!",
11628 Nod
, Entity
(Nod
));
11631 elsif Nkind
(Nod
) = N_Selected_Component
then
11633 T
: constant Entity_Id
:= Etype
(Prefix
(Nod
));
11636 if (Is_Record_Type
(T
)
11637 and then Has_Discriminants
(T
))
11639 (Is_Access_Type
(T
)
11640 and then Is_Record_Type
(Designated_Type
(T
))
11641 and then Has_Discriminants
(Designated_Type
(T
)))
11644 ("invalid address clause for initialized object &!",
11647 ("\address cannot depend on component of discriminated "
11648 & "record (RM 13.1(22))!", Nod
);
11650 Check_At_Constant_Address
(Prefix
(Nod
));
11654 elsif Nkind
(Nod
) = N_Indexed_Component
then
11655 Check_At_Constant_Address
(Prefix
(Nod
));
11656 Check_List_Constants
(Expressions
(Nod
));
11659 Check_Expr_Constants
(Nod
);
11661 end Check_At_Constant_Address
;
11663 --------------------------
11664 -- Check_Expr_Constants --
11665 --------------------------
11667 procedure Check_Expr_Constants
(Nod
: Node_Id
) is
11668 Loc_U_Ent
: constant Source_Ptr
:= Sloc
(U_Ent
);
11669 Ent
: Entity_Id
:= Empty
;
11672 if Nkind
(Nod
) in N_Has_Etype
11673 and then Etype
(Nod
) = Any_Type
11678 case Nkind
(Nod
) is
11684 when N_Expanded_Name
11687 Ent
:= Entity
(Nod
);
11689 -- We need to look at the original node if it is different
11690 -- from the node, since we may have rewritten things and
11691 -- substituted an identifier representing the rewrite.
11693 if Is_Rewrite_Substitution
(Nod
) then
11694 Check_Expr_Constants
(Original_Node
(Nod
));
11696 -- If the node is an object declaration without initial
11697 -- value, some code has been expanded, and the expression
11698 -- is not constant, even if the constituents might be
11699 -- acceptable, as in A'Address + offset.
11701 if Ekind
(Ent
) = E_Variable
11703 Nkind
(Declaration_Node
(Ent
)) = N_Object_Declaration
11705 No
(Expression
(Declaration_Node
(Ent
)))
11708 ("invalid address clause for initialized object &!",
11711 -- If entity is constant, it may be the result of expanding
11712 -- a check. We must verify that its declaration appears
11713 -- before the object in question, else we also reject the
11716 elsif Ekind
(Ent
) = E_Constant
11717 and then In_Same_Source_Unit
(Ent
, U_Ent
)
11718 and then Sloc
(Ent
) > Loc_U_Ent
11721 ("invalid address clause for initialized object &!",
11728 -- Otherwise look at the identifier and see if it is OK
11730 if Is_Named_Number
(Ent
) or else Is_Type
(Ent
) then
11733 elsif Ekind
(Ent
) in E_Constant | E_In_Parameter
then
11735 -- This is the case where we must have Ent defined before
11736 -- U_Ent. Clearly if they are in different units this
11737 -- requirement is met since the unit containing Ent is
11738 -- already processed.
11740 if not In_Same_Source_Unit
(Ent
, U_Ent
) then
11743 -- Otherwise location of Ent must be before the location
11744 -- of U_Ent, that's what prior defined means.
11746 elsif Sloc
(Ent
) < Loc_U_Ent
then
11751 ("invalid address clause for initialized object &!",
11753 Error_Msg_Node_2
:= U_Ent
;
11755 ("\& must be defined before & (RM 13.1(22))!",
11759 elsif Nkind
(Original_Node
(Nod
)) = N_Function_Call
then
11760 Check_Expr_Constants
(Original_Node
(Nod
));
11764 ("invalid address clause for initialized object &!",
11767 if Comes_From_Source
(Ent
) then
11769 ("\reference to variable& not allowed"
11770 & " (RM 13.1(22))!", Nod
, Ent
);
11773 ("non-static expression not allowed"
11774 & " (RM 13.1(22))!", Nod
);
11778 when N_Integer_Literal
=>
11780 -- If this is a rewritten unchecked conversion, in a system
11781 -- where Address is an integer type, always use the base type
11782 -- for a literal value. This is user-friendly and prevents
11783 -- order-of-elaboration issues with instances of unchecked
11786 if Nkind
(Original_Node
(Nod
)) = N_Function_Call
then
11787 Set_Etype
(Nod
, Base_Type
(Etype
(Nod
)));
11790 when N_Character_Literal
11797 Check_Expr_Constants
(Low_Bound
(Nod
));
11798 Check_Expr_Constants
(High_Bound
(Nod
));
11800 when N_Explicit_Dereference
=>
11801 Check_Expr_Constants
(Prefix
(Nod
));
11803 when N_Indexed_Component
=>
11804 Check_Expr_Constants
(Prefix
(Nod
));
11805 Check_List_Constants
(Expressions
(Nod
));
11808 Check_Expr_Constants
(Prefix
(Nod
));
11809 Check_Expr_Constants
(Discrete_Range
(Nod
));
11811 when N_Selected_Component
=>
11812 Check_Expr_Constants
(Prefix
(Nod
));
11814 when N_Attribute_Reference
=>
11815 if Attribute_Name
(Nod
) in Name_Address
11817 | Name_Unchecked_Access
11818 | Name_Unrestricted_Access
11820 Check_At_Constant_Address
(Prefix
(Nod
));
11822 -- Normally, System'To_Address will have been transformed into
11823 -- an Unchecked_Conversion, but in -gnatc mode, it will not,
11824 -- and we don't want to give an error, because the whole point
11825 -- of 'To_Address is that it is static.
11827 elsif Attribute_Name
(Nod
) = Name_To_Address
then
11828 pragma Assert
(Operating_Mode
= Check_Semantics
);
11832 Check_Expr_Constants
(Prefix
(Nod
));
11833 Check_List_Constants
(Expressions
(Nod
));
11836 when N_Aggregate
=>
11837 Check_List_Constants
(Component_Associations
(Nod
));
11838 Check_List_Constants
(Expressions
(Nod
));
11840 when N_Component_Association
=>
11841 Check_Expr_Constants
(Expression
(Nod
));
11843 when N_Extension_Aggregate
=>
11844 Check_Expr_Constants
(Ancestor_Part
(Nod
));
11845 Check_List_Constants
(Component_Associations
(Nod
));
11846 Check_List_Constants
(Expressions
(Nod
));
11852 | N_Membership_Test
11855 Check_Expr_Constants
(Left_Opnd
(Nod
));
11856 Check_Expr_Constants
(Right_Opnd
(Nod
));
11859 Check_Expr_Constants
(Right_Opnd
(Nod
));
11862 | N_Qualified_Expression
11863 | N_Type_Conversion
11864 | N_Unchecked_Type_Conversion
11866 Check_Expr_Constants
(Expression
(Nod
));
11868 when N_Function_Call
=>
11869 if not Is_Pure
(Entity
(Name
(Nod
))) then
11871 ("invalid address clause for initialized object &!",
11875 ("\function & is not pure (RM 13.1(22))!",
11876 Nod
, Entity
(Name
(Nod
)));
11879 Check_List_Constants
(Parameter_Associations
(Nod
));
11882 when N_Parameter_Association
=>
11883 Check_Expr_Constants
(Explicit_Actual_Parameter
(Nod
));
11887 ("invalid address clause for initialized object &!",
11890 ("\must be constant defined before& (RM 13.1(22))!",
11893 end Check_Expr_Constants
;
11895 --------------------------
11896 -- Check_List_Constants --
11897 --------------------------
11899 procedure Check_List_Constants
(Lst
: List_Id
) is
11903 Nod1
:= First
(Lst
);
11904 while Present
(Nod1
) loop
11905 Check_Expr_Constants
(Nod1
);
11908 end Check_List_Constants
;
11910 -- Start of processing for Check_Constant_Address_Clause
11913 -- If rep_clauses are to be ignored, no need for legality checks. In
11914 -- particular, no need to pester user about rep clauses that violate the
11915 -- rule on constant addresses, given that these clauses will be removed
11916 -- by Freeze before they reach the back end. Similarly in CodePeer mode,
11917 -- we want to relax these checks.
11919 if not Ignore_Rep_Clauses
and not CodePeer_Mode
then
11920 Check_Expr_Constants
(Expr
);
11922 end Check_Constant_Address_Clause
;
11924 ---------------------------
11925 -- Check_Pool_Size_Clash --
11926 ---------------------------
11928 procedure Check_Pool_Size_Clash
(Ent
: Entity_Id
; SP
, SS
: Node_Id
) is
11932 -- We need to find out which one came first. Note that in the case of
11933 -- aspects mixed with pragmas there are cases where the processing order
11934 -- is reversed, which is why we do the check here.
11936 if Sloc
(SP
) < Sloc
(SS
) then
11937 Error_Msg_Sloc
:= Sloc
(SP
);
11939 Error_Msg_NE
("Storage_Pool previously given for&#", Post
, Ent
);
11942 Error_Msg_Sloc
:= Sloc
(SS
);
11944 Error_Msg_NE
("Storage_Size previously given for&#", Post
, Ent
);
11948 ("\cannot have Storage_Size and Storage_Pool (RM 13.11(3))", Post
);
11949 end Check_Pool_Size_Clash
;
11951 ----------------------------------------
11952 -- Check_Record_Representation_Clause --
11953 ----------------------------------------
11955 procedure Check_Record_Representation_Clause
(N
: Node_Id
) is
11956 Loc
: constant Source_Ptr
:= Sloc
(N
);
11957 Ident
: constant Node_Id
:= Identifier
(N
);
11958 Rectype
: Entity_Id
;
11961 Fbit
: Uint
:= No_Uint
;
11962 Lbit
: Uint
:= No_Uint
;
11963 Hbit
: Uint
:= Uint_0
;
11967 Max_Bit_So_Far
: Uint
;
11968 -- Records the maximum bit position so far. If all field positions
11969 -- are monotonically increasing, then we can skip the circuit for
11970 -- checking for overlap, since no overlap is possible.
11972 Tagged_Parent
: Entity_Id
:= Empty
;
11973 -- This is set in the case of an extension for which we have either a
11974 -- size clause or Is_Fully_Repped_Tagged_Type True (indicating that all
11975 -- components are positioned by record representation clauses) on the
11976 -- parent type. In this case we check for overlap between components of
11977 -- this tagged type and the parent component. Tagged_Parent will point
11978 -- to this parent type. For all other cases, Tagged_Parent is Empty.
11980 Parent_Last_Bit
: Uint
:= No_Uint
; -- init to avoid warning
11981 -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the
11982 -- last bit position for any field in the parent type. We only need to
11983 -- check overlap for fields starting below this point.
11985 Overlap_Check_Required
: Boolean;
11986 -- Used to keep track of whether or not an overlap check is required
11988 Overlap_Detected
: Boolean := False;
11989 -- Set True if an overlap is detected
11991 Ccount
: Natural := 0;
11992 -- Number of component clauses in record rep clause
11994 procedure Check_Component_Overlap
(C1_Ent
, C2_Ent
: Entity_Id
);
11995 -- Given two entities for record components or discriminants, checks
11996 -- if they have overlapping component clauses and issues errors if so.
11998 procedure Find_Component
;
11999 -- Finds component entity corresponding to current component clause (in
12000 -- CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin
12001 -- start/stop bits for the field. If there is no matching component or
12002 -- if the matching component does not have a component clause, then
12003 -- that's an error and Comp is set to Empty, but no error message is
12004 -- issued, since the message was already given. Comp is also set to
12005 -- Empty if the current "component clause" is in fact a pragma.
12007 procedure Record_Hole_Check
12008 (Rectype
: Entity_Id
; After_Last
: out Uint
; Warn
: Boolean);
12009 -- Checks for gaps in the given Rectype. Compute After_Last, the bit
12010 -- number after the last component. Warn is True on the initial call,
12011 -- and warnings are given for gaps. For a type extension, this is called
12012 -- recursively to compute After_Last for the parent type; in this case
12013 -- Warn is False and the warnings are suppressed.
12015 procedure Component_Order_Check
(Rectype
: Entity_Id
);
12016 -- Check that the order of component clauses agrees with the order of
12017 -- component declarations, and that the component clauses are given in
12018 -- increasing order of bit offset.
12020 -----------------------------
12021 -- Check_Component_Overlap --
12022 -----------------------------
12024 procedure Check_Component_Overlap
(C1_Ent
, C2_Ent
: Entity_Id
) is
12025 CC1
: constant Node_Id
:= Component_Clause
(C1_Ent
);
12026 CC2
: constant Node_Id
:= Component_Clause
(C2_Ent
);
12029 if Present
(CC1
) and then Present
(CC2
) then
12031 -- Exclude odd case where we have two tag components in the same
12032 -- record, both at location zero. This seems a bit strange, but
12033 -- it seems to happen in some circumstances, perhaps on an error.
12035 if Chars
(C1_Ent
) = Name_uTag
then
12039 -- Here we check if the two fields overlap
12042 S1
: constant Uint
:= Component_Bit_Offset
(C1_Ent
);
12043 S2
: constant Uint
:= Component_Bit_Offset
(C2_Ent
);
12044 E1
: constant Uint
:= S1
+ Esize
(C1_Ent
);
12045 E2
: constant Uint
:= S2
+ Esize
(C2_Ent
);
12048 if E2
<= S1
or else E1
<= S2
then
12051 Error_Msg_Node_2
:= Component_Name
(CC2
);
12052 Error_Msg_Sloc
:= Sloc
(Error_Msg_Node_2
);
12053 Error_Msg_Node_1
:= Component_Name
(CC1
);
12055 ("component& overlaps & #", Component_Name
(CC1
));
12056 Overlap_Detected
:= True;
12060 end Check_Component_Overlap
;
12062 ---------------------------
12063 -- Component_Order_Check --
12064 ---------------------------
12066 procedure Component_Order_Check
(Rectype
: Entity_Id
) is
12067 Comp
: Entity_Id
:= First_Component
(Rectype
);
12068 Clause
: Node_Id
:= First
(Component_Clauses
(N
));
12069 Prev_Bit_Offset
: Uint
:= Uint_0
;
12070 OOO
: constant String :=
12071 "?_r?component clause out of order with respect to declaration";
12074 -- Step Comp through components and Clause through component clauses,
12075 -- skipping pragmas. We ignore discriminants and variant parts,
12076 -- because we get most of the benefit from the plain vanilla
12077 -- component cases, without the extra complexity. If we find a Comp
12078 -- and Clause that don't match, give a warning on both and quit. If
12079 -- we find two subsequent clauses out of order by bit layout, give
12080 -- warning and quit. On each iteration, Prev_Bit_Offset is the one
12081 -- from the previous iteration (or 0 to start).
12083 while Present
(Comp
) and then Present
(Clause
) loop
12084 if Nkind
(Clause
) = N_Component_Clause
12085 and then Ekind
(Entity
(Component_Name
(Clause
))) = E_Component
12087 if Entity
(Component_Name
(Clause
)) /= Comp
then
12088 Error_Msg_N
(OOO
, Comp
);
12089 Error_Msg_N
(OOO
, Clause
);
12093 if not Reverse_Bit_Order
(Rectype
)
12094 and then not Reverse_Storage_Order
(Rectype
)
12095 and then Component_Bit_Offset
(Comp
) < Prev_Bit_Offset
12097 Error_Msg_N
("?_r?memory layout out of order", Clause
);
12101 Prev_Bit_Offset
:= Component_Bit_Offset
(Comp
);
12102 Next_Component
(Comp
);
12107 end Component_Order_Check
;
12109 --------------------
12110 -- Find_Component --
12111 --------------------
12113 procedure Find_Component
is
12115 procedure Search_Component
(R
: Entity_Id
);
12116 -- Search components of R for a match. If found, Comp is set
12118 ----------------------
12119 -- Search_Component --
12120 ----------------------
12122 procedure Search_Component
(R
: Entity_Id
) is
12124 Comp
:= First_Component_Or_Discriminant
(R
);
12125 while Present
(Comp
) loop
12127 -- Ignore error of attribute name for component name (we
12128 -- already gave an error message for this, so no need to
12131 if Nkind
(Component_Name
(CC
)) = N_Attribute_Reference
then
12134 exit when Chars
(Comp
) = Chars
(Component_Name
(CC
));
12137 Next_Component_Or_Discriminant
(Comp
);
12139 end Search_Component
;
12141 -- Start of processing for Find_Component
12144 -- Return with Comp set to Empty if we have a pragma
12146 if Nkind
(CC
) = N_Pragma
then
12151 -- Search current record for matching component
12153 Search_Component
(Rectype
);
12155 -- If not found, maybe component of base type discriminant that is
12156 -- absent from statically constrained first subtype.
12159 Search_Component
(Base_Type
(Rectype
));
12162 -- If no component, or the component does not reference the component
12163 -- clause in question, then there was some previous error for which
12164 -- we already gave a message, so just return with Comp Empty.
12166 if No
(Comp
) or else Component_Clause
(Comp
) /= CC
then
12167 Check_Error_Detected
;
12170 -- Normal case where we have a component clause
12173 Fbit
:= Component_Bit_Offset
(Comp
);
12174 Lbit
:= Fbit
+ Esize
(Comp
) - 1;
12176 end Find_Component
;
12178 -----------------------
12179 -- Record_Hole_Check --
12180 -----------------------
12182 procedure Record_Hole_Check
12183 (Rectype
: Entity_Id
; After_Last
: out Uint
; Warn
: Boolean)
12185 Decl
: constant Node_Id
:= Declaration_Node
(Base_Type
(Rectype
));
12186 -- Full declaration of record type
12188 procedure Check_Component_List
12193 -- Check component list CL for holes. DS is a list of discriminant
12194 -- specifications to be included in the consideration of components.
12195 -- Sbit is the starting bit, which is zero if there are no preceding
12196 -- components (before a variant part, or a parent type, or a tag
12197 -- field). If there are preceding components, Sbit is the bit just
12198 -- after the last such component. Abit is set to the bit just after
12199 -- the last component of DS and CL.
12201 --------------------------
12202 -- Check_Component_List --
12203 --------------------------
12205 procedure Check_Component_List
12211 Compl
: constant Natural :=
12212 Natural (List_Length
(Component_Items
(CL
)) + List_Length
(DS
));
12214 Comps
: array (Natural range 0 .. Compl
) of Entity_Id
;
12215 -- Gather components (zero entry is for sort routine)
12217 Ncomps
: Natural := 0;
12218 -- Number of entries stored in Comps (starting at Comps (1))
12221 -- One component item or discriminant specification
12224 -- Starting bit for next component
12227 -- Component entity
12232 function Lt
(Op1
, Op2
: Natural) return Boolean;
12233 -- Compare routine for Sort
12235 procedure Move
(From
: Natural; To
: Natural);
12236 -- Move routine for Sort
12238 package Sorting
is new GNAT
.Heap_Sort_G
(Move
, Lt
);
12244 function Lt
(Op1
, Op2
: Natural) return Boolean is
12245 K1
: constant Boolean :=
12246 Known_Component_Bit_Offset
(Comps
(Op1
));
12247 K2
: constant Boolean :=
12248 Known_Component_Bit_Offset
(Comps
(Op2
));
12249 -- Record representation clauses can be incomplete, so the
12250 -- Component_Bit_Offsets can be unknown.
12254 return Component_Bit_Offset
(Comps
(Op1
))
12255 < Component_Bit_Offset
(Comps
(Op2
));
12268 procedure Move
(From
: Natural; To
: Natural) is
12270 Comps
(To
) := Comps
(From
);
12273 -- Start of processing for Check_Component_List
12276 -- Gather discriminants into Comp
12278 Citem
:= First
(DS
);
12279 while Present
(Citem
) loop
12280 if Nkind
(Citem
) = N_Discriminant_Specification
then
12282 Ent
: constant Entity_Id
:=
12283 Defining_Identifier
(Citem
);
12285 if Ekind
(Ent
) = E_Discriminant
then
12286 Ncomps
:= Ncomps
+ 1;
12287 Comps
(Ncomps
) := Ent
;
12295 -- Gather component entities into Comp
12297 Citem
:= First
(Component_Items
(CL
));
12298 while Present
(Citem
) loop
12299 if Nkind
(Citem
) = N_Component_Declaration
then
12300 Ncomps
:= Ncomps
+ 1;
12301 Comps
(Ncomps
) := Defining_Identifier
(Citem
);
12307 -- Now sort the component entities based on the first bit.
12308 -- Note we already know there are no overlapping components.
12310 Sorting
.Sort
(Ncomps
);
12312 -- Loop through entries checking for holes
12315 for J
in 1 .. Ncomps
loop
12317 pragma Annotate
(CodePeer
, Modified
, CEnt
);
12320 CBO
: constant Uint
:= Component_Bit_Offset
(CEnt
);
12323 -- Skip components with unknown offsets
12325 if Present
(CBO
) and then CBO
>= 0 then
12326 Error_Msg_Uint_1
:= CBO
- Nbit
;
12328 if Warn
and then Error_Msg_Uint_1
> 0 then
12330 ("?.h?^-bit gap before component&",
12331 Component_Name
(Component_Clause
(CEnt
)),
12335 Nbit
:= CBO
+ Esize
(CEnt
);
12340 -- Set Abit to just after the last nonvariant component
12344 -- Process variant parts recursively if present. Set Abit to the
12345 -- maximum for all variant parts.
12347 if Present
(Variant_Part
(CL
)) then
12349 Var_Start
: constant Uint
:= Nbit
;
12351 Variant
:= First
(Variants
(Variant_Part
(CL
)));
12352 while Present
(Variant
) loop
12353 Check_Component_List
12354 (No_List
, Component_List
(Variant
), Var_Start
, Nbit
);
12356 if Nbit
> Abit
then
12362 end Check_Component_List
;
12367 -- Starting bit for call to Check_Component_List. Zero for an
12368 -- untagged type. The size of the Tag for a nonderived tagged
12369 -- type. Parent size for a type extension.
12371 Record_Definition
: Node_Id
;
12372 -- Record_Definition containing Component_List to pass to
12373 -- Check_Component_List.
12375 -- Start of processing for Record_Hole_Check
12378 if Is_Tagged_Type
(Rectype
) then
12379 Sbit
:= UI_From_Int
(System_Address_Size
);
12384 After_Last
:= Uint_0
;
12386 if Nkind
(Decl
) = N_Full_Type_Declaration
then
12387 Record_Definition
:= Type_Definition
(Decl
);
12389 -- If we have a record extension, set Sbit to point after the last
12390 -- component of the parent type, by calling Record_Hole_Check
12393 if Nkind
(Record_Definition
) = N_Derived_Type_Definition
then
12394 Record_Definition
:= Record_Extension_Part
(Record_Definition
);
12395 Record_Hole_Check
(Underlying_Type
(Parent_Subtype
(Rectype
)),
12396 After_Last
=> Sbit
, Warn
=> False);
12399 if Nkind
(Record_Definition
) = N_Record_Definition
then
12400 Check_Component_List
12401 (Discriminant_Specifications
(Decl
),
12402 Component_List
(Record_Definition
),
12406 end Record_Hole_Check
;
12408 -- Start of processing for Check_Record_Representation_Clause
12412 Rectype
:= Entity
(Ident
);
12414 if Rectype
= Any_Type
then
12418 Rectype
:= Underlying_Type
(Rectype
);
12420 -- See if we have a fully repped derived tagged type
12423 PS
: constant Entity_Id
:= Parent_Subtype
(Rectype
);
12426 if Present
(PS
) and then Known_Static_RM_Size
(PS
) then
12427 Tagged_Parent
:= PS
;
12428 Parent_Last_Bit
:= RM_Size
(PS
) - 1;
12430 elsif Present
(PS
) and then Is_Fully_Repped_Tagged_Type
(PS
) then
12431 Tagged_Parent
:= PS
;
12433 -- Find maximum bit of any component of the parent type
12435 Parent_Last_Bit
:= UI_From_Int
(System_Address_Size
- 1);
12436 Pcomp
:= First_Component_Or_Discriminant
(Tagged_Parent
);
12437 while Present
(Pcomp
) loop
12438 if Present
(Component_Bit_Offset
(Pcomp
))
12439 and then Known_Static_Esize
(Pcomp
)
12444 Component_Bit_Offset
(Pcomp
) + Esize
(Pcomp
) - 1);
12447 Next_Component_Or_Discriminant
(Pcomp
);
12452 -- All done if no component clauses
12454 CC
:= First
(Component_Clauses
(N
));
12460 -- If a tag is present, then create a component clause that places it
12461 -- at the start of the record (otherwise gigi may place it after other
12462 -- fields that have rep clauses).
12464 Fent
:= First_Entity
(Rectype
);
12466 if Nkind
(Fent
) = N_Defining_Identifier
12467 and then Chars
(Fent
) = Name_uTag
12469 Set_Component_Bit_Offset
(Fent
, Uint_0
);
12470 Set_Normalized_Position
(Fent
, Uint_0
);
12471 Set_Normalized_First_Bit
(Fent
, Uint_0
);
12472 Set_Esize
(Fent
, UI_From_Int
(System_Address_Size
));
12474 Set_Component_Clause
(Fent
,
12475 Make_Component_Clause
(Loc
,
12476 Component_Name
=> Make_Identifier
(Loc
, Name_uTag
),
12478 Position
=> Make_Integer_Literal
(Loc
, Uint_0
),
12479 First_Bit
=> Make_Integer_Literal
(Loc
, Uint_0
),
12481 Make_Integer_Literal
(Loc
,
12482 UI_From_Int
(System_Address_Size
- 1))));
12484 Ccount
:= Ccount
+ 1;
12487 Max_Bit_So_Far
:= Uint_Minus_1
;
12488 Overlap_Check_Required
:= False;
12490 -- Process the component clauses
12492 while Present
(CC
) loop
12495 if Present
(Comp
) then
12496 Ccount
:= Ccount
+ 1;
12498 -- We need a full overlap check if record positions non-monotonic
12500 if Fbit
<= Max_Bit_So_Far
then
12501 Overlap_Check_Required
:= True;
12504 Max_Bit_So_Far
:= Lbit
;
12506 -- Check bit position out of range of specified size
12508 if Has_Size_Clause
(Rectype
)
12509 and then RM_Size
(Rectype
) <= Lbit
12511 Error_Msg_Uint_1
:= RM_Size
(Rectype
);
12512 Error_Msg_Uint_2
:= Lbit
+ 1;
12513 Error_Msg_N
("bit number out of range of specified "
12514 & "size (expected ^, got ^)",
12517 -- Check for overlap with tag or parent component
12520 if Is_Tagged_Type
(Rectype
)
12521 and then Fbit
< System_Address_Size
12524 ("component overlaps tag field of&",
12525 Component_Name
(CC
), Rectype
);
12526 Overlap_Detected
:= True;
12528 elsif Present
(Tagged_Parent
)
12529 and then Fbit
<= Parent_Last_Bit
12532 ("component overlaps parent field of&",
12533 Component_Name
(CC
), Rectype
);
12534 Overlap_Detected
:= True;
12537 if Hbit
< Lbit
then
12546 -- Now that we have processed all the component clauses, check for
12547 -- overlap. We have to leave this till last, since the components can
12548 -- appear in any arbitrary order in the representation clause.
12550 -- We do not need this check if all specified ranges were monotonic,
12551 -- as recorded by Overlap_Check_Required being False at this stage.
12553 -- This first section checks if there are any overlapping entries at
12554 -- all. It does this by sorting all entries and then seeing if there are
12555 -- any overlaps. If there are none, then that is decisive, but if there
12556 -- are overlaps, they may still be OK (they may result from fields in
12557 -- different variants).
12559 if Overlap_Check_Required
then
12560 Overlap_Check1
: declare
12562 OC_Fbit
: array (0 .. Ccount
) of Uint
;
12563 -- First-bit values for component clauses, the value is the offset
12564 -- of the first bit of the field from start of record. The zero
12565 -- entry is for use in sorting.
12567 OC_Lbit
: array (0 .. Ccount
) of Uint
;
12568 -- Last-bit values for component clauses, the value is the offset
12569 -- of the last bit of the field from start of record. The zero
12570 -- entry is for use in sorting.
12572 OC_Count
: Natural := 0;
12573 -- Count of entries in OC_Fbit and OC_Lbit
12575 function OC_Lt
(Op1
, Op2
: Natural) return Boolean;
12576 -- Compare routine for Sort
12578 procedure OC_Move
(From
: Natural; To
: Natural);
12579 -- Move routine for Sort
12581 package Sorting
is new GNAT
.Heap_Sort_G
(OC_Move
, OC_Lt
);
12587 function OC_Lt
(Op1
, Op2
: Natural) return Boolean is
12589 return OC_Fbit
(Op1
) < OC_Fbit
(Op2
);
12596 procedure OC_Move
(From
: Natural; To
: Natural) is
12598 OC_Fbit
(To
) := OC_Fbit
(From
);
12599 OC_Lbit
(To
) := OC_Lbit
(From
);
12602 -- Start of processing for Overlap_Check
12605 CC
:= First
(Component_Clauses
(N
));
12606 while Present
(CC
) loop
12608 -- Exclude component clause already marked in error
12610 if not Error_Posted
(CC
) then
12613 if Present
(Comp
) then
12614 OC_Count
:= OC_Count
+ 1;
12615 OC_Fbit
(OC_Count
) := Fbit
;
12616 OC_Lbit
(OC_Count
) := Lbit
;
12623 Sorting
.Sort
(OC_Count
);
12625 Overlap_Check_Required
:= False;
12626 for J
in 1 .. OC_Count
- 1 loop
12627 if OC_Lbit
(J
) >= OC_Fbit
(J
+ 1) then
12628 Overlap_Check_Required
:= True;
12632 end Overlap_Check1
;
12635 -- If Overlap_Check_Required is still True, then we have to do the full
12636 -- scale overlap check, since we have at least two fields that do
12637 -- overlap, and we need to know if that is OK since they are in
12638 -- different variant, or whether we have a definite problem.
12640 if Overlap_Check_Required
then
12641 Overlap_Check2
: declare
12642 C1_Ent
, C2_Ent
: Entity_Id
;
12643 -- Entities of components being checked for overlap
12646 -- Component_List node whose Component_Items are being checked
12649 -- Component declaration for component being checked
12652 C1_Ent
:= First_Entity
(Base_Type
(Rectype
));
12654 -- Loop through all components in record. For each component check
12655 -- for overlap with any of the preceding elements on the component
12656 -- list containing the component and also, if the component is in
12657 -- a variant, check against components outside the case structure.
12658 -- This latter test is repeated recursively up the variant tree.
12660 Main_Component_Loop
: while Present
(C1_Ent
) loop
12661 if Ekind
(C1_Ent
) not in E_Component | E_Discriminant
then
12662 goto Continue_Main_Component_Loop
;
12665 -- Skip overlap check if entity has no declaration node. This
12666 -- happens with discriminants in constrained derived types.
12667 -- Possibly we are missing some checks as a result, but that
12668 -- does not seem terribly serious.
12670 if No
(Declaration_Node
(C1_Ent
)) then
12671 goto Continue_Main_Component_Loop
;
12674 Clist
:= Parent
(List_Containing
(Declaration_Node
(C1_Ent
)));
12676 -- Loop through component lists that need checking. Check the
12677 -- current component list and all lists in variants above us.
12679 Component_List_Loop
: loop
12681 -- If derived type definition, go to full declaration
12682 -- If at outer level, check discriminants if there are any.
12684 if Nkind
(Clist
) = N_Derived_Type_Definition
then
12685 Clist
:= Parent
(Clist
);
12688 -- Outer level of record definition, check discriminants
12689 -- but be careful not to flag a non-stored discriminant
12690 -- and the stored discriminant it renames as overlapping.
12692 if Nkind
(Clist
) in N_Full_Type_Declaration
12693 | N_Private_Type_Declaration
12695 if Has_Discriminants
(Defining_Identifier
(Clist
)) then
12697 First_Discriminant
(Defining_Identifier
(Clist
));
12698 while Present
(C2_Ent
) loop
12700 Original_Record_Component
(C1_Ent
) =
12701 Original_Record_Component
(C2_Ent
);
12702 Check_Component_Overlap
(C1_Ent
, C2_Ent
);
12703 Next_Discriminant
(C2_Ent
);
12707 -- Record extension case
12709 elsif Nkind
(Clist
) = N_Derived_Type_Definition
then
12712 -- Otherwise check one component list
12715 Citem
:= First
(Component_Items
(Clist
));
12716 while Present
(Citem
) loop
12717 if Nkind
(Citem
) = N_Component_Declaration
then
12718 C2_Ent
:= Defining_Identifier
(Citem
);
12719 exit when C1_Ent
= C2_Ent
;
12720 Check_Component_Overlap
(C1_Ent
, C2_Ent
);
12727 -- Check for variants above us (the parent of the Clist can
12728 -- be a variant, in which case its parent is a variant part,
12729 -- and the parent of the variant part is a component list
12730 -- whose components must all be checked against the current
12731 -- component for overlap).
12733 if Nkind
(Parent
(Clist
)) = N_Variant
then
12734 Clist
:= Parent
(Parent
(Parent
(Clist
)));
12736 -- Check for possible discriminant part in record, this
12737 -- is treated essentially as another level in the
12738 -- recursion. For this case the parent of the component
12739 -- list is the record definition, and its parent is the
12740 -- full type declaration containing the discriminant
12743 elsif Nkind
(Parent
(Clist
)) = N_Record_Definition
then
12744 Clist
:= Parent
(Parent
((Clist
)));
12746 -- If neither of these two cases, we are at the top of
12750 exit Component_List_Loop
;
12752 end loop Component_List_Loop
;
12754 <<Continue_Main_Component_Loop
>>
12755 Next_Entity
(C1_Ent
);
12757 end loop Main_Component_Loop
;
12758 end Overlap_Check2
;
12761 -- Skip the following warnings if overlap was detected; programmer
12762 -- should fix the errors first. Also skip the warnings for types in
12763 -- generics, because their representation information is not fully
12766 if not Overlap_Detected
and then not In_Generic_Scope
(Rectype
) then
12767 -- Check for record holes (gaps)
12769 if Warn_On_Record_Holes
then
12773 Record_Hole_Check
(Rectype
, After_Last
=> Ignore
, Warn
=> True);
12777 -- Check for out-of-order component clauses
12779 if Warn_On_Component_Order
then
12780 Component_Order_Check
(Rectype
);
12784 -- For records that have component clauses for all components, and whose
12785 -- size is less than or equal to 32, and which can be fully packed, we
12786 -- need to know the size in the front end to activate possible packed
12787 -- array processing where the component type is a record.
12789 -- At this stage Hbit + 1 represents the first unused bit from all the
12790 -- component clauses processed, so if the component clauses are
12791 -- complete, then this is the length of the record.
12793 -- For records longer than System.Storage_Unit, and for those where not
12794 -- all components have component clauses, the back end determines the
12795 -- length (it may for example be appropriate to round up the size
12796 -- to some convenient boundary, based on alignment considerations, etc).
12798 if not Known_RM_Size
(Rectype
)
12799 and then Hbit
+ 1 <= 32
12800 and then not Strict_Alignment
(Rectype
)
12803 -- Nothing to do if at least one component has no component clause
12805 Comp
:= First_Component_Or_Discriminant
(Rectype
);
12806 while Present
(Comp
) loop
12807 exit when No
(Component_Clause
(Comp
));
12808 Next_Component_Or_Discriminant
(Comp
);
12811 -- If we fall out of loop, all components have component clauses
12812 -- and so we can set the size to the maximum value.
12815 Set_RM_Size
(Rectype
, Hbit
+ 1);
12818 end Check_Record_Representation_Clause
;
12824 procedure Check_Size
12828 Biased
: out Boolean)
12830 procedure Size_Too_Small_Error
(Min_Siz
: Uint
);
12831 -- Emit an error concerning illegal size Siz. Min_Siz denotes the
12834 --------------------------
12835 -- Size_Too_Small_Error --
12836 --------------------------
12838 procedure Size_Too_Small_Error
(Min_Siz
: Uint
) is
12840 Error_Msg_Uint_1
:= Min_Siz
;
12841 Error_Msg_NE
(Size_Too_Small_Message
, N
, T
);
12842 end Size_Too_Small_Error
;
12846 UT
: constant Entity_Id
:= Underlying_Type
(T
);
12849 -- Start of processing for Check_Size
12854 -- Reject patently improper size values
12856 if Is_Elementary_Type
(T
)
12857 and then Siz
> Int
'Last
12859 Error_Msg_N
("Size value too large for elementary type", N
);
12861 if Nkind
(Original_Node
(N
)) = N_Op_Expon
then
12863 ("\maybe '* was meant, rather than '*'*", Original_Node
(N
));
12867 -- Dismiss generic types
12869 if Is_Generic_Type
(T
)
12871 Is_Generic_Type
(UT
)
12873 Is_Generic_Type
(Root_Type
(UT
))
12877 -- Guard against previous errors
12879 elsif No
(UT
) or else UT
= Any_Type
then
12880 Check_Error_Detected
;
12883 -- Check case of bit packed array
12885 elsif Is_Array_Type
(UT
)
12886 and then Known_Static_Component_Size
(UT
)
12887 and then Is_Bit_Packed_Array
(UT
)
12895 Asiz
:= Component_Size
(UT
);
12896 Indx
:= First_Index
(UT
);
12898 Ityp
:= Etype
(Indx
);
12900 -- If non-static bound, then we are not in the business of
12901 -- trying to check the length, and indeed an error will be
12902 -- issued elsewhere, since sizes of non-static array types
12903 -- cannot be set implicitly or explicitly.
12905 if not Is_OK_Static_Subtype
(Ityp
) then
12909 -- Otherwise accumulate next dimension
12911 Asiz
:= Asiz
* (Expr_Value
(Type_High_Bound
(Ityp
)) -
12912 Expr_Value
(Type_Low_Bound
(Ityp
)) +
12916 exit when No
(Indx
);
12919 if Asiz
<= Siz
then
12923 Size_Too_Small_Error
(Asiz
);
12927 -- All other composite types are ignored
12929 elsif Is_Composite_Type
(UT
) then
12932 -- For fixed-point types, don't check minimum if type is not frozen,
12933 -- since we don't know all the characteristics of the type that can
12934 -- affect the size (e.g. a specified small) till freeze time.
12936 elsif Is_Fixed_Point_Type
(UT
) and then not Is_Frozen
(UT
) then
12939 -- Cases for which a minimum check is required
12942 -- Ignore if specified size is correct for the type
12944 if Known_Esize
(UT
) and then Siz
= Esize
(UT
) then
12948 -- Otherwise get minimum size
12950 M
:= UI_From_Int
(Minimum_Size
(UT
));
12954 -- Size is less than minimum size, but one possibility remains
12955 -- that we can manage with the new size if we bias the type.
12957 M
:= UI_From_Int
(Minimum_Size
(UT
, Biased
=> True));
12960 Size_Too_Small_Error
(M
);
12968 --------------------------
12969 -- Freeze_Entity_Checks --
12970 --------------------------
12972 procedure Freeze_Entity_Checks
(N
: Node_Id
) is
12973 procedure Hide_Non_Overridden_Subprograms
(Typ
: Entity_Id
);
12974 -- Inspect the primitive operations of type Typ and hide all pairs of
12975 -- implicitly declared non-overridden non-fully conformant homographs
12976 -- (Ada RM 8.3 12.3/2).
12978 -------------------------------------
12979 -- Hide_Non_Overridden_Subprograms --
12980 -------------------------------------
12982 procedure Hide_Non_Overridden_Subprograms
(Typ
: Entity_Id
) is
12983 procedure Hide_Matching_Homographs
12984 (Subp_Id
: Entity_Id
;
12985 Start_Elmt
: Elmt_Id
);
12986 -- Inspect a list of primitive operations starting with Start_Elmt
12987 -- and find matching implicitly declared non-overridden non-fully
12988 -- conformant homographs of Subp_Id. If found, all matches along
12989 -- with Subp_Id are hidden from all visibility.
12991 function Is_Non_Overridden_Or_Null_Procedure
12992 (Subp_Id
: Entity_Id
) return Boolean;
12993 -- Determine whether subprogram Subp_Id is implicitly declared non-
12994 -- overridden subprogram or an implicitly declared null procedure.
12996 ------------------------------
12997 -- Hide_Matching_Homographs --
12998 ------------------------------
13000 procedure Hide_Matching_Homographs
13001 (Subp_Id
: Entity_Id
;
13002 Start_Elmt
: Elmt_Id
)
13005 Prim_Elmt
: Elmt_Id
;
13008 Prim_Elmt
:= Start_Elmt
;
13009 while Present
(Prim_Elmt
) loop
13010 Prim
:= Node
(Prim_Elmt
);
13012 -- The current primitive is implicitly declared non-overridden
13013 -- non-fully conformant homograph of Subp_Id. Both subprograms
13014 -- must be hidden from visibility.
13016 if Chars
(Prim
) = Chars
(Subp_Id
)
13017 and then Is_Non_Overridden_Or_Null_Procedure
(Prim
)
13018 and then not Fully_Conformant
(Prim
, Subp_Id
)
13020 Set_Is_Hidden_Non_Overridden_Subpgm
(Prim
);
13021 Set_Is_Immediately_Visible
(Prim
, False);
13022 Set_Is_Potentially_Use_Visible
(Prim
, False);
13024 Set_Is_Hidden_Non_Overridden_Subpgm
(Subp_Id
);
13025 Set_Is_Immediately_Visible
(Subp_Id
, False);
13026 Set_Is_Potentially_Use_Visible
(Subp_Id
, False);
13029 Next_Elmt
(Prim_Elmt
);
13031 end Hide_Matching_Homographs
;
13033 -----------------------------------------
13034 -- Is_Non_Overridden_Or_Null_Procedure --
13035 -----------------------------------------
13037 function Is_Non_Overridden_Or_Null_Procedure
13038 (Subp_Id
: Entity_Id
) return Boolean
13040 Alias_Id
: Entity_Id
;
13043 -- The subprogram is inherited (implicitly declared), it does not
13044 -- override and does not cover a primitive of an interface.
13046 if Ekind
(Subp_Id
) in E_Function | E_Procedure
13047 and then Present
(Alias
(Subp_Id
))
13048 and then No
(Interface_Alias
(Subp_Id
))
13049 and then No
(Overridden_Operation
(Subp_Id
))
13051 Alias_Id
:= Alias
(Subp_Id
);
13053 if Requires_Overriding
(Alias_Id
) then
13056 elsif Nkind
(Parent
(Alias_Id
)) = N_Procedure_Specification
13057 and then Null_Present
(Parent
(Alias_Id
))
13064 end Is_Non_Overridden_Or_Null_Procedure
;
13068 Prim_Ops
: constant Elist_Id
:= Direct_Primitive_Operations
(Typ
);
13070 Prim_Elmt
: Elmt_Id
;
13072 -- Start of processing for Hide_Non_Overridden_Subprograms
13075 -- Inspect the list of primitives looking for non-overridden
13078 if Present
(Prim_Ops
) then
13079 Prim_Elmt
:= First_Elmt
(Prim_Ops
);
13080 while Present
(Prim_Elmt
) loop
13081 Prim
:= Node
(Prim_Elmt
);
13082 Next_Elmt
(Prim_Elmt
);
13084 if Is_Non_Overridden_Or_Null_Procedure
(Prim
) then
13085 Hide_Matching_Homographs
13087 Start_Elmt
=> Prim_Elmt
);
13091 end Hide_Non_Overridden_Subprograms
;
13095 E
: constant Entity_Id
:= Entity
(N
);
13097 Nongeneric_Case
: constant Boolean := Nkind
(N
) = N_Freeze_Entity
;
13098 -- True in nongeneric case. Some of the processing here is skipped
13099 -- for the generic case since it is not needed. Basically in the
13100 -- generic case, we only need to do stuff that might generate error
13101 -- messages or warnings.
13103 -- Start of processing for Freeze_Entity_Checks
13106 -- Remember that we are processing a freezing entity. Required to
13107 -- ensure correct decoration of internal entities associated with
13108 -- interfaces (see New_Overloaded_Entity).
13110 Inside_Freezing_Actions
:= Inside_Freezing_Actions
+ 1;
13112 -- For tagged types covering interfaces add internal entities that link
13113 -- the primitives of the interfaces with the primitives that cover them.
13114 -- Note: These entities were originally generated only when generating
13115 -- code because their main purpose was to provide support to initialize
13116 -- the secondary dispatch tables. They are also used to locate
13117 -- primitives covering interfaces when processing generics (see
13118 -- Derive_Subprograms).
13120 -- This is not needed in the generic case
13122 if Ada_Version
>= Ada_2005
13123 and then Nongeneric_Case
13124 and then Ekind
(E
) = E_Record_Type
13125 and then Is_Tagged_Type
(E
)
13126 and then not Is_Interface
(E
)
13127 and then Has_Interfaces
(E
)
13129 -- This would be a good common place to call the routine that checks
13130 -- overriding of interface primitives (and thus factorize calls to
13131 -- Check_Abstract_Overriding located at different contexts in the
13132 -- compiler). However, this is not possible because it causes
13133 -- spurious errors in case of late overriding.
13135 Add_Internal_Interface_Entities
(E
);
13138 -- After all forms of overriding have been resolved, a tagged type may
13139 -- be left with a set of implicitly declared and possibly erroneous
13140 -- abstract subprograms, null procedures and subprograms that require
13141 -- overriding. If this set contains fully conformant homographs, then
13142 -- one is chosen arbitrarily (already done during resolution), otherwise
13143 -- all remaining non-fully conformant homographs are hidden from
13144 -- visibility (Ada RM 8.3 12.3/2).
13146 if Is_Tagged_Type
(E
) then
13147 Hide_Non_Overridden_Subprograms
(E
);
13152 if Ekind
(E
) = E_Record_Type
13153 and then Is_CPP_Class
(E
)
13154 and then Is_Tagged_Type
(E
)
13155 and then Tagged_Type_Expansion
13157 if CPP_Num_Prims
(E
) = 0 then
13159 -- If the CPP type has user defined components then it must import
13160 -- primitives from C++. This is required because if the C++ class
13161 -- has no primitives then the C++ compiler does not added the _tag
13162 -- component to the type.
13164 if First_Entity
(E
) /= Last_Entity
(E
) then
13166 ("'C'P'P type must import at least one primitive from C++??",
13171 -- Check that all its primitives are abstract or imported from C++.
13172 -- Check also availability of the C++ constructor.
13175 Has_Constructors
: constant Boolean := Has_CPP_Constructors
(E
);
13177 Error_Reported
: Boolean := False;
13181 Elmt
:= First_Elmt
(Primitive_Operations
(E
));
13182 while Present
(Elmt
) loop
13183 Prim
:= Node
(Elmt
);
13185 if Comes_From_Source
(Prim
) then
13186 if Is_Abstract_Subprogram
(Prim
) then
13189 elsif not Is_Imported
(Prim
)
13190 or else Convention
(Prim
) /= Convention_CPP
13193 ("primitives of 'C'P'P types must be imported from C++ "
13194 & "or abstract??", Prim
);
13196 elsif not Has_Constructors
13197 and then not Error_Reported
13199 Error_Msg_Name_1
:= Chars
(E
);
13201 ("??'C'P'P constructor required for type %", Prim
);
13202 Error_Reported
:= True;
13211 -- Check Ada derivation of CPP type
13213 if Expander_Active
-- why? losing errors in -gnatc mode???
13214 and then Present
(Etype
(E
)) -- defend against errors
13215 and then Tagged_Type_Expansion
13216 and then Ekind
(E
) = E_Record_Type
13217 and then Etype
(E
) /= E
13218 and then Is_CPP_Class
(Etype
(E
))
13219 and then CPP_Num_Prims
(Etype
(E
)) > 0
13220 and then not Is_CPP_Class
(E
)
13221 and then not Has_CPP_Constructors
(Etype
(E
))
13223 -- If the parent has C++ primitives but it has no constructor then
13224 -- check that all the primitives are overridden in this derivation;
13225 -- otherwise the constructor of the parent is needed to build the
13233 Elmt
:= First_Elmt
(Primitive_Operations
(E
));
13234 while Present
(Elmt
) loop
13235 Prim
:= Node
(Elmt
);
13237 if not Is_Abstract_Subprogram
(Prim
)
13238 and then No
(Interface_Alias
(Prim
))
13239 and then Find_Dispatching_Type
(Ultimate_Alias
(Prim
)) /= E
13241 Error_Msg_Name_1
:= Chars
(Etype
(E
));
13243 ("'C'P'P constructor required for parent type %", E
);
13252 Inside_Freezing_Actions
:= Inside_Freezing_Actions
- 1;
13254 -- For a record type, deal with variant parts. This has to be delayed to
13255 -- this point, because of the issue of statically predicated subtypes,
13256 -- which we have to ensure are frozen before checking choices, since we
13257 -- need to have the static choice list set.
13259 if Is_Record_Type
(E
) then
13260 Check_Variant_Part
: declare
13261 D
: constant Node_Id
:= Declaration_Node
(E
);
13266 Others_Present
: Boolean;
13267 pragma Warnings
(Off
, Others_Present
);
13268 -- Indicates others present, not used in this case
13270 procedure Non_Static_Choice_Error
(Choice
: Node_Id
);
13271 -- Error routine invoked by the generic instantiation below when
13272 -- the variant part has a non static choice.
13274 procedure Process_Declarations
(Variant
: Node_Id
);
13275 -- Processes declarations associated with a variant. We analyzed
13276 -- the declarations earlier (in Sem_Ch3.Analyze_Variant_Part),
13277 -- but we still need the recursive call to Check_Choices for any
13278 -- nested variant to get its choices properly processed. This is
13279 -- also where we expand out the choices if expansion is active.
13281 package Variant_Choices_Processing
is new
13282 Generic_Check_Choices
13283 (Process_Empty_Choice
=> No_OP
,
13284 Process_Non_Static_Choice
=> Non_Static_Choice_Error
,
13285 Process_Associated_Node
=> Process_Declarations
);
13286 use Variant_Choices_Processing
;
13288 -----------------------------
13289 -- Non_Static_Choice_Error --
13290 -----------------------------
13292 procedure Non_Static_Choice_Error
(Choice
: Node_Id
) is
13294 Flag_Non_Static_Expr
13295 ("choice given in variant part is not static!", Choice
);
13296 end Non_Static_Choice_Error
;
13298 --------------------------
13299 -- Process_Declarations --
13300 --------------------------
13302 procedure Process_Declarations
(Variant
: Node_Id
) is
13303 CL
: constant Node_Id
:= Component_List
(Variant
);
13307 -- Check for static predicate present in this variant
13309 if Has_SP_Choice
(Variant
) then
13311 -- Here we expand. You might expect to find this call in
13312 -- Expand_N_Variant_Part, but that is called when we first
13313 -- see the variant part, and we cannot do this expansion
13314 -- earlier than the freeze point, since for statically
13315 -- predicated subtypes, the predicate is not known till
13316 -- the freeze point.
13318 -- Furthermore, we do this expansion even if the expander
13319 -- is not active, because other semantic processing, e.g.
13320 -- for aggregates, requires the expanded list of choices.
13322 -- If the expander is not active, then we can't just clobber
13323 -- the list since it would invalidate the tree.
13324 -- So we have to rewrite the variant part with a Rewrite
13325 -- call that replaces it with a copy and clobber the copy.
13327 if not Expander_Active
then
13329 NewV
: constant Node_Id
:= New_Copy
(Variant
);
13331 Set_Discrete_Choices
13332 (NewV
, New_Copy_List
(Discrete_Choices
(Variant
)));
13333 Rewrite
(Variant
, NewV
);
13337 Expand_Static_Predicates_In_Choices
(Variant
);
13340 -- We don't need to worry about the declarations in the variant
13341 -- (since they were analyzed by Analyze_Choices when we first
13342 -- encountered the variant), but we do need to take care of
13343 -- expansion of any nested variants.
13345 if not Null_Present
(CL
) then
13346 VP
:= Variant_Part
(CL
);
13348 if Present
(VP
) then
13350 (VP
, Variants
(VP
), Etype
(Name
(VP
)), Others_Present
);
13353 end Process_Declarations
;
13355 -- Start of processing for Check_Variant_Part
13358 -- Find component list
13362 if Nkind
(D
) = N_Full_Type_Declaration
then
13363 T
:= Type_Definition
(D
);
13365 if Nkind
(T
) = N_Record_Definition
then
13366 C
:= Component_List
(T
);
13368 elsif Nkind
(T
) = N_Derived_Type_Definition
13369 and then Present
(Record_Extension_Part
(T
))
13371 C
:= Component_List
(Record_Extension_Part
(T
));
13375 -- Case of variant part present
13377 if Present
(C
) and then Present
(Variant_Part
(C
)) then
13378 VP
:= Variant_Part
(C
);
13383 (VP
, Variants
(VP
), Etype
(Name
(VP
)), Others_Present
);
13385 -- If the last variant does not contain the Others choice,
13386 -- replace it with an N_Others_Choice node since Gigi always
13387 -- wants an Others. Note that we do not bother to call Analyze
13388 -- on the modified variant part, since its only effect would be
13389 -- to compute the Others_Discrete_Choices node laboriously, and
13390 -- of course we already know the list of choices corresponding
13391 -- to the others choice (it's the list we're replacing).
13393 -- We only want to do this if the expander is active, since
13394 -- we do not want to clobber the tree.
13396 if Expander_Active
then
13398 Last_Var
: constant Node_Id
:=
13399 Last_Non_Pragma
(Variants
(VP
));
13401 Others_Node
: Node_Id
;
13404 if Nkind
(First
(Discrete_Choices
(Last_Var
))) /=
13407 Others_Node
:= Make_Others_Choice
(Sloc
(Last_Var
));
13408 Set_Others_Discrete_Choices
13409 (Others_Node
, Discrete_Choices
(Last_Var
));
13410 Set_Discrete_Choices
13411 (Last_Var
, New_List
(Others_Node
));
13416 end Check_Variant_Part
;
13419 -- If we have a type with predicates, build predicate function. This is
13420 -- not needed in the generic case, nor within e.g. TSS subprograms and
13421 -- other predefined primitives. For a derived type, ensure that the
13422 -- parent type is already frozen so that its predicate function has been
13423 -- constructed already. This is necessary if the parent is declared
13424 -- in a nested package and its own freeze point has not been reached.
13427 and then Nongeneric_Case
13428 and then Has_Predicates
(E
)
13429 and then Predicate_Check_In_Scope
(N
)
13432 Atyp
: constant Entity_Id
:= Nearest_Ancestor
(E
);
13436 and then Has_Predicates
(Atyp
)
13437 and then not Is_Frozen
(Atyp
)
13439 Freeze_Before
(N
, Atyp
);
13443 -- Before we build a predicate function, ensure that discriminant
13444 -- checking functions are available. The predicate function might
13445 -- need to call these functions if the predicate references any
13446 -- components declared in a variant part.
13448 if Ekind
(E
) = E_Record_Type
and then Has_Discriminants
(E
) then
13449 Build_Or_Copy_Discr_Checking_Funcs
(Parent
(E
));
13452 Build_Predicate_Function
(E
, N
);
13455 -- If type has delayed aspects, this is where we do the preanalysis at
13456 -- the freeze point, as part of the consistent visibility check. Note
13457 -- that this must be done after calling Build_Predicate_Function or
13458 -- Build_Invariant_Procedure since these subprograms fix occurrences of
13459 -- the subtype name in the saved expression so that they will not cause
13460 -- trouble in the preanalysis.
13462 -- This is also not needed in the generic case
13465 and then Has_Delayed_Aspects
(E
)
13466 and then Scope
(E
) = Current_Scope
13472 -- Look for aspect specification entries for this entity
13474 Ritem
:= First_Rep_Item
(E
);
13475 while Present
(Ritem
) loop
13476 if Nkind
(Ritem
) = N_Aspect_Specification
13477 and then Entity
(Ritem
) = E
13478 and then Is_Delayed_Aspect
(Ritem
)
13480 if Get_Aspect_Id
(Ritem
) in Aspect_CPU
13481 | Aspect_Dynamic_Predicate
13482 | Aspect_Ghost_Predicate
13484 | Aspect_Static_Predicate
13487 -- Retrieve the visibility to components and discriminants
13488 -- in order to properly analyze the aspects.
13491 Check_Aspect_At_Freeze_Point
(Ritem
);
13493 -- In the case of predicate aspects, there will be
13494 -- a corresponding Predicate pragma associated with
13495 -- the aspect, and the expression of the pragma also
13496 -- needs to be analyzed at this point, to ensure that
13497 -- Save_Global_References will capture global refs in
13498 -- expressions that occur in generic bodies, for proper
13499 -- later resolution of the pragma in instantiations.
13502 and then Inside_A_Generic
13503 and then Has_Predicates
(E
)
13504 and then Present
(Aspect_Rep_Item
(Ritem
))
13507 Pragma_Args
: constant List_Id
:=
13508 Pragma_Argument_Associations
13509 (Aspect_Rep_Item
(Ritem
));
13510 Pragma_Expr
: constant Node_Id
:=
13511 Expression
(Next
(First
(Pragma_Args
)));
13513 if Present
(Pragma_Expr
) then
13514 Analyze_And_Resolve
13515 (Pragma_Expr
, Standard_Boolean
);
13523 Check_Aspect_At_Freeze_Point
(Ritem
);
13526 -- A pragma Predicate should be checked like one of the
13527 -- corresponding aspects, wrt possible misuse of ghost
13530 elsif Nkind
(Ritem
) = N_Pragma
13531 and then No
(Corresponding_Aspect
(Ritem
))
13533 Get_Pragma_Id
(Pragma_Name
(Ritem
)) = Pragma_Predicate
13535 -- Retrieve the visibility to components and discriminants
13536 -- in order to properly analyze the pragma.
13539 Arg
: constant Node_Id
:=
13540 Next
(First
(Pragma_Argument_Associations
(Ritem
)));
13543 Preanalyze_Spec_Expression
13544 (Expression
(Arg
), Standard_Boolean
);
13549 Next_Rep_Item
(Ritem
);
13554 if not In_Generic_Scope
(E
)
13555 and then Ekind
(E
) = E_Record_Type
13556 and then Is_Tagged_Type
(E
)
13558 Process_Class_Conditions_At_Freeze_Point
(E
);
13560 end Freeze_Entity_Checks
;
13562 -------------------------
13563 -- Get_Alignment_Value --
13564 -------------------------
13566 function Get_Alignment_Value
(Expr
: Node_Id
) return Uint
is
13567 Align
: constant Uint
:= Static_Integer
(Expr
);
13573 elsif Align
< 0 then
13574 Error_Msg_N
("alignment value must be positive", Expr
);
13577 -- If Alignment is specified to be 0, we treat it the same as 1
13579 elsif Align
= 0 then
13583 for J
in Int
range 0 .. 64 loop
13585 M
: constant Uint
:= Uint_2
** J
;
13588 exit when M
= Align
;
13591 Error_Msg_N
("alignment value must be power of 2", Expr
);
13599 end Get_Alignment_Value
;
13601 -----------------------------------
13602 -- Has_Compatible_Representation --
13603 -----------------------------------
13605 function Has_Compatible_Representation
13606 (Target_Typ
, Operand_Typ
: Entity_Id
) return Boolean
13608 -- The subtype-specific representation attributes (Size and Alignment)
13609 -- do not affect representation from the point of view of this function.
13611 T1
: constant Entity_Id
:= Implementation_Base_Type
(Target_Typ
);
13612 T2
: constant Entity_Id
:= Implementation_Base_Type
(Operand_Typ
);
13615 -- Return true immediately for the same base type
13620 -- Tagged types always have the same representation, because it is not
13621 -- possible to specify different representations for common fields.
13623 elsif Is_Tagged_Type
(T1
) then
13626 -- Representations are definitely different if conventions differ
13628 elsif Convention
(T1
) /= Convention
(T2
) then
13631 -- Representations are different if component alignments or scalar
13632 -- storage orders differ.
13634 elsif (Is_Record_Type
(T1
) or else Is_Array_Type
(T1
))
13636 (Is_Record_Type
(T2
) or else Is_Array_Type
(T2
))
13637 and then (Component_Alignment
(T1
) /= Component_Alignment
(T2
)
13639 Reverse_Storage_Order
(T1
) /= Reverse_Storage_Order
(T2
))
13644 -- For arrays, the only real issue is component size. If we know the
13645 -- component size for both arrays, and it is the same, then that's
13646 -- good enough to know we don't have a change of representation.
13648 if Is_Array_Type
(T1
) then
13650 -- In a view conversion, if the target type is an array type having
13651 -- aliased components and the operand type is an array type having
13652 -- unaliased components, then a new object is created (4.6(58.3/4)).
13654 if Has_Aliased_Components
(T1
)
13655 and then not Has_Aliased_Components
(T2
)
13660 if Known_Component_Size
(T1
)
13661 and then Known_Component_Size
(T2
)
13662 and then Component_Size
(T1
) = Component_Size
(T2
)
13667 -- For records, representations are different if reordering differs
13669 elsif Is_Record_Type
(T1
)
13670 and then Is_Record_Type
(T2
)
13671 and then No_Reordering
(T1
) /= No_Reordering
(T2
)
13676 -- Types definitely have same representation if neither has non-standard
13677 -- representation since default representations are always consistent.
13678 -- If only one has non-standard representation, and the other does not,
13679 -- then we consider that they do not have the same representation. They
13680 -- might, but there is no way of telling early enough.
13682 if Has_Non_Standard_Rep
(T1
) then
13683 if not Has_Non_Standard_Rep
(T2
) then
13687 return not Has_Non_Standard_Rep
(T2
);
13690 -- Here the two types both have non-standard representation, and we need
13691 -- to determine if they have the same non-standard representation.
13693 -- For arrays, we simply need to test if the component sizes are the
13694 -- same. Pragma Pack is reflected in modified component sizes, so this
13695 -- check also deals with pragma Pack.
13697 if Is_Array_Type
(T1
) then
13698 return Component_Size
(T1
) = Component_Size
(T2
);
13700 -- Case of record types
13702 elsif Is_Record_Type
(T1
) then
13704 -- Packed status must conform
13706 if Is_Packed
(T1
) /= Is_Packed
(T2
) then
13709 -- If the operand type is derived from the target type and no clause
13710 -- has been given after the derivation, then the representations are
13711 -- the same since the derived type inherits that of the parent type.
13713 elsif Is_Derived_Type
(T2
)
13714 and then Etype
(T2
) = T1
13715 and then not Has_Record_Rep_Clause
(T2
)
13719 -- Otherwise we must check components. Typ2 maybe a constrained
13720 -- subtype with fewer components, so we compare the components
13721 -- of the base types.
13724 Record_Case
: declare
13725 CD1
, CD2
: Entity_Id
;
13727 function Same_Rep
return Boolean;
13728 -- CD1 and CD2 are either components or discriminants. This
13729 -- function tests whether they have the same representation.
13735 function Same_Rep
return Boolean is
13737 if No
(Component_Clause
(CD1
)) then
13738 return No
(Component_Clause
(CD2
));
13740 -- Note: at this point, component clauses have been
13741 -- normalized to the default bit order, so that the
13742 -- comparison of Component_Bit_Offsets is meaningful.
13745 Present
(Component_Clause
(CD2
))
13747 Component_Bit_Offset
(CD1
) = Component_Bit_Offset
(CD2
)
13749 Esize
(CD1
) = Esize
(CD2
);
13753 -- Start of processing for Record_Case
13756 if Has_Discriminants
(T1
) then
13758 -- The number of discriminants may be different if the
13759 -- derived type has fewer (constrained by values). The
13760 -- invisible discriminants retain the representation of
13761 -- the original, so the discrepancy does not per se
13762 -- indicate a different representation.
13764 CD1
:= First_Discriminant
(T1
);
13765 CD2
:= First_Discriminant
(T2
);
13766 while Present
(CD1
) and then Present
(CD2
) loop
13767 if not Same_Rep
then
13770 Next_Discriminant
(CD1
);
13771 Next_Discriminant
(CD2
);
13776 CD1
:= First_Component
(Underlying_Type
(Base_Type
(T1
)));
13777 CD2
:= First_Component
(Underlying_Type
(Base_Type
(T2
)));
13778 while Present
(CD1
) loop
13779 if not Same_Rep
then
13782 Next_Component
(CD1
);
13783 Next_Component
(CD2
);
13791 -- For enumeration types, we must check each literal to see if the
13792 -- representation is the same. Note that we do not permit enumeration
13793 -- representation clauses for Character and Wide_Character, so these
13794 -- cases were already dealt with.
13796 elsif Is_Enumeration_Type
(T1
) then
13797 Enumeration_Case
: declare
13798 L1
, L2
: Entity_Id
;
13801 L1
:= First_Literal
(T1
);
13802 L2
:= First_Literal
(T2
);
13803 while Present
(L1
) loop
13804 if Enumeration_Rep
(L1
) /= Enumeration_Rep
(L2
) then
13813 end Enumeration_Case
;
13815 -- Any other types have the same representation for these purposes
13820 end Has_Compatible_Representation
;
13822 -------------------------------------
13823 -- Inherit_Aspects_At_Freeze_Point --
13824 -------------------------------------
13826 procedure Inherit_Aspects_At_Freeze_Point
(Typ
: Entity_Id
) is
13827 function Get_Inherited_Rep_Item
13829 Nam
: Name_Id
) return Node_Id
;
13830 -- Search the Rep_Item chain of entity E for an instance of a rep item
13831 -- (pragma, attribute definition clause, or aspect specification) whose
13832 -- name matches the given name Nam, and that has been inherited from its
13833 -- parent, i.e. that has not been directly specified for E . If one is
13834 -- found, it is returned, otherwise Empty is returned.
13836 function Get_Inherited_Rep_Item
13839 Nam2
: Name_Id
) return Node_Id
;
13840 -- Search the Rep_Item chain of entity E for an instance of a rep item
13841 -- (pragma, attribute definition clause, or aspect specification) whose
13842 -- name matches one of the given names Nam1 or Nam2, and that has been
13843 -- inherited from its parent, i.e. that has not been directly specified
13844 -- for E . If one is found, it is returned, otherwise Empty is returned.
13846 function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
13847 (Rep_Item
: Node_Id
) return Boolean;
13848 -- This routine checks if Rep_Item is either a pragma or an aspect
13849 -- specification node whose corresponding pragma (if any) is present in
13850 -- the Rep Item chain of the entity it has been specified to.
13852 ----------------------------
13853 -- Get_Inherited_Rep_Item --
13854 ----------------------------
13856 function Get_Inherited_Rep_Item
13858 Nam
: Name_Id
) return Node_Id
13860 Rep
: constant Node_Id
13861 := Get_Rep_Item
(E
, Nam
, Check_Parents
=> True);
13864 and then not Has_Rep_Item
(E
, Nam
, Check_Parents
=> False)
13870 end Get_Inherited_Rep_Item
;
13872 function Get_Inherited_Rep_Item
13875 Nam2
: Name_Id
) return Node_Id
13877 Rep
: constant Node_Id
13878 := Get_Rep_Item
(E
, Nam1
, Nam2
, Check_Parents
=> True);
13881 and then not Has_Rep_Item
(E
, Nam1
, Nam2
, Check_Parents
=> False)
13887 end Get_Inherited_Rep_Item
;
13889 --------------------------------------------------
13890 -- Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item --
13891 --------------------------------------------------
13893 function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
13894 (Rep_Item
: Node_Id
) return Boolean
13898 Nkind
(Rep_Item
) = N_Pragma
13900 Present_In_Rep_Item
(Entity
(Rep_Item
), Aspect_Rep_Item
(Rep_Item
));
13901 end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
;
13905 -- Start of processing for Inherit_Aspects_At_Freeze_Point
13908 -- A representation item is either subtype-specific (Size and Alignment
13909 -- clauses) or type-related (all others). Subtype-specific aspects may
13910 -- differ for different subtypes of the same type (RM 13.1.8).
13912 -- A derived type inherits each type-related representation aspect of
13913 -- its parent type that was directly specified before the declaration of
13914 -- the derived type (RM 13.1.15).
13916 -- A derived subtype inherits each subtype-specific representation
13917 -- aspect of its parent subtype that was directly specified before the
13918 -- declaration of the derived type (RM 13.1.15).
13920 -- The general processing involves inheriting a representation aspect
13921 -- from a parent type whenever the first rep item (aspect specification,
13922 -- attribute definition clause, pragma) corresponding to the given
13923 -- representation aspect in the rep item chain of Typ, if any, isn't
13924 -- directly specified to Typ but to one of its parents.
13926 -- In addition, Convention must be propagated from base type to subtype,
13927 -- because the subtype may have been declared on an incomplete view.
13929 if Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
then
13935 Rep
:= Get_Inherited_Rep_Item
(Typ
, Name_Ada_05
, Name_Ada_2005
);
13937 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
(Rep
)
13939 Set_Is_Ada_2005_Only
(Typ
);
13944 Rep
:= Get_Inherited_Rep_Item
(Typ
, Name_Ada_12
, Name_Ada_2012
);
13946 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
(Rep
)
13948 Set_Is_Ada_2012_Only
(Typ
);
13953 Rep
:= Get_Inherited_Rep_Item
(Typ
, Name_Ada_2022
);
13955 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
(Rep
)
13957 Set_Is_Ada_2022_Only
(Typ
);
13962 Rep
:= Get_Inherited_Rep_Item
(Typ
, Name_Atomic
, Name_Shared
);
13964 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
(Rep
)
13966 Set_Is_Atomic
(Typ
);
13967 Set_Is_Volatile
(Typ
);
13968 Set_Treat_As_Volatile
(Typ
);
13973 if Is_Record_Type
(Typ
)
13974 and then Typ
/= Base_Type
(Typ
) and then Is_Frozen
(Base_Type
(Typ
))
13976 Set_Convention
(Typ
, Convention
(Base_Type
(Typ
)));
13979 -- Default_Component_Value (for base types only)
13981 -- Note that we need to look into the first subtype because the base
13982 -- type may be the implicit base type built by the compiler for the
13983 -- declaration of a constrained subtype with the aspect.
13985 if Is_Array_Type
(Typ
) and then Is_Base_Type
(Typ
) then
13987 F_Typ
: constant Entity_Id
:= First_Subtype
(Typ
);
13993 Get_Inherited_Rep_Item
(F_Typ
, Name_Default_Component_Value
);
13994 if Present
(Rep
) then
13997 -- Deal with private types
13999 if Is_Private_Type
(E
) then
14000 E
:= Full_View
(E
);
14003 Set_Default_Aspect_Component_Value
14004 (Typ
, Default_Aspect_Component_Value
(E
));
14005 Set_Has_Default_Aspect
(Typ
);
14010 -- Default_Value (for base types only)
14012 -- Note that we need to look into the first subtype because the base
14013 -- type may be the implicit base type built by the compiler for the
14014 -- declaration of a constrained subtype with the aspect.
14016 if Is_Scalar_Type
(Typ
) and then Is_Base_Type
(Typ
) then
14018 F_Typ
: constant Entity_Id
:= First_Subtype
(Typ
);
14023 Rep
:= Get_Inherited_Rep_Item
(F_Typ
, Name_Default_Value
);
14024 if Present
(Rep
) then
14027 -- Deal with private types
14029 if Is_Private_Type
(E
) then
14030 E
:= Full_View
(E
);
14033 Set_Default_Aspect_Value
(Typ
, Default_Aspect_Value
(E
));
14034 Set_Has_Default_Aspect
(Typ
);
14041 Rep
:= Get_Inherited_Rep_Item
(Typ
, Name_Discard_Names
);
14043 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
(Rep
)
14045 Set_Discard_Names
(Typ
);
14050 Rep
:= Get_Inherited_Rep_Item
(Typ
, Name_Volatile
);
14052 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
(Rep
)
14054 Set_Is_Volatile
(Typ
);
14055 Set_Treat_As_Volatile
(Typ
);
14058 -- Volatile_Full_Access and Full_Access_Only
14060 Rep
:= Get_Inherited_Rep_Item
14061 (Typ
, Name_Volatile_Full_Access
, Name_Full_Access_Only
);
14063 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
(Rep
)
14065 Set_Is_Volatile_Full_Access
(Typ
);
14066 Set_Is_Volatile
(Typ
);
14067 Set_Treat_As_Volatile
(Typ
);
14070 -- Inheritance for derived types only
14072 if Is_Derived_Type
(Typ
) then
14074 Bas_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
14075 Imp_Bas_Typ
: constant Entity_Id
:= Implementation_Base_Type
(Typ
);
14078 -- Atomic_Components
14080 Rep
:= Get_Inherited_Rep_Item
(Typ
, Name_Atomic_Components
);
14082 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
(Rep
)
14084 Set_Has_Atomic_Components
(Imp_Bas_Typ
);
14087 -- Volatile_Components
14089 Rep
:= Get_Inherited_Rep_Item
(Typ
, Name_Volatile_Components
);
14091 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
(Rep
)
14093 Set_Has_Volatile_Components
(Imp_Bas_Typ
);
14096 -- Finalize_Storage_Only
14098 Rep
:= Get_Inherited_Rep_Item
(Typ
, Name_Finalize_Storage_Only
);
14099 if Present
(Rep
) then
14100 Set_Finalize_Storage_Only
(Bas_Typ
);
14103 -- Universal_Aliasing
14105 Rep
:= Get_Inherited_Rep_Item
(Typ
, Name_Universal_Aliasing
);
14107 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
(Rep
)
14109 Set_Universal_Aliasing
(Imp_Bas_Typ
);
14114 if Is_Record_Type
(Typ
) and then Typ
= Bas_Typ
then
14115 Rep
:= Get_Inherited_Rep_Item
(Typ
, Name_Bit_Order
);
14116 if Present
(Rep
) then
14117 Set_Reverse_Bit_Order
(Bas_Typ
,
14119 (Implementation_Base_Type
(Etype
(Bas_Typ
))));
14123 -- Scalar_Storage_Order
14125 if (Is_Record_Type
(Typ
) or else Is_Array_Type
(Typ
))
14126 and then Typ
= Bas_Typ
14128 -- For a type extension, always inherit from parent; otherwise
14129 -- inherit if no default applies. Note: we do not check for
14130 -- an explicit rep item on the parent type when inheriting,
14131 -- because the parent SSO may itself have been set by default.
14133 if not Has_Rep_Item
(First_Subtype
(Typ
),
14134 Name_Scalar_Storage_Order
, False)
14135 and then (Is_Tagged_Type
(Bas_Typ
)
14136 or else not (SSO_Set_Low_By_Default
(Bas_Typ
)
14138 SSO_Set_High_By_Default
(Bas_Typ
)))
14140 Set_Reverse_Storage_Order
(Bas_Typ
,
14141 Reverse_Storage_Order
14142 (Implementation_Base_Type
(Etype
(Bas_Typ
))));
14144 -- Clear default SSO indications, since the inherited aspect
14145 -- which was set explicitly overrides the default.
14147 Set_SSO_Set_Low_By_Default
(Bas_Typ
, False);
14148 Set_SSO_Set_High_By_Default
(Bas_Typ
, False);
14153 end Inherit_Aspects_At_Freeze_Point
;
14155 ---------------------------------
14156 -- Inherit_Delayed_Rep_Aspects --
14157 ---------------------------------
14159 procedure Inherit_Delayed_Rep_Aspects
(Typ
: Entity_Id
) is
14165 -- Find the first aspect that has been inherited
14167 N
:= First_Rep_Item
(Typ
);
14168 while Present
(N
) loop
14169 if Nkind
(N
) = N_Aspect_Specification
then
14170 exit when Entity
(N
) /= Typ
;
14176 -- There must be one if we reach here
14178 pragma Assert
(Present
(N
));
14181 -- Loop through delayed aspects for the parent type
14183 while Present
(N
) loop
14184 if Nkind
(N
) = N_Aspect_Specification
then
14185 exit when Entity
(N
) /= P
;
14187 if Is_Delayed_Aspect
(N
) then
14188 A
:= Get_Aspect_Id
(N
);
14190 -- Process delayed rep aspect. For Boolean attributes it is
14191 -- not possible to cancel an attribute once set (the attempt
14192 -- to use an aspect with xxx => False is an error) for a
14193 -- derived type. So for those cases, we do not have to check
14194 -- if a clause has been given for the derived type, since it
14195 -- is harmless to set it again if it is already set.
14201 when Aspect_Alignment
=>
14202 if not Has_Alignment_Clause
(Typ
) then
14203 Set_Alignment
(Typ
, Alignment
(P
));
14208 when Aspect_Atomic
=>
14209 if Is_Atomic
(P
) then
14210 Set_Is_Atomic
(Typ
);
14213 -- Atomic_Components
14215 when Aspect_Atomic_Components
=>
14216 if Has_Atomic_Components
(P
) then
14217 Set_Has_Atomic_Components
(Base_Type
(Typ
));
14222 when Aspect_Bit_Order
=>
14223 if Is_Record_Type
(Typ
)
14224 and then No
(Get_Attribute_Definition_Clause
14225 (Typ
, Attribute_Bit_Order
))
14226 and then Reverse_Bit_Order
(P
)
14228 Set_Reverse_Bit_Order
(Base_Type
(Typ
));
14233 when Aspect_Component_Size
=>
14234 if Is_Array_Type
(Typ
)
14235 and then not Has_Component_Size_Clause
(Typ
)
14238 (Base_Type
(Typ
), Component_Size
(P
));
14243 when Aspect_Machine_Radix
=>
14244 if Is_Decimal_Fixed_Point_Type
(Typ
)
14245 and then not Has_Machine_Radix_Clause
(Typ
)
14247 Set_Machine_Radix_10
(Typ
, Machine_Radix_10
(P
));
14250 -- Object_Size (also Size which also sets Object_Size)
14252 when Aspect_Object_Size
14255 if not Has_Size_Clause
(Typ
)
14257 No
(Get_Attribute_Definition_Clause
14258 (Typ
, Attribute_Object_Size
))
14260 Set_Esize
(Typ
, Esize
(P
));
14265 when Aspect_Pack
=>
14266 if not Is_Packed
(Typ
) then
14267 Set_Is_Packed
(Base_Type
(Typ
));
14269 if Is_Bit_Packed_Array
(P
) then
14270 Set_Is_Bit_Packed_Array
(Base_Type
(Typ
));
14271 Set_Packed_Array_Impl_Type
14272 (Typ
, Packed_Array_Impl_Type
(P
));
14276 -- Scalar_Storage_Order
14278 when Aspect_Scalar_Storage_Order
=>
14279 if (Is_Record_Type
(Typ
) or else Is_Array_Type
(Typ
))
14280 and then No
(Get_Attribute_Definition_Clause
14281 (Typ
, Attribute_Scalar_Storage_Order
))
14282 and then Reverse_Storage_Order
(P
)
14284 Set_Reverse_Storage_Order
(Base_Type
(Typ
));
14286 -- Clear default SSO indications, since the aspect
14287 -- overrides the default.
14289 Set_SSO_Set_Low_By_Default
(Base_Type
(Typ
), False);
14290 Set_SSO_Set_High_By_Default
(Base_Type
(Typ
), False);
14295 when Aspect_Small
=>
14296 if Is_Fixed_Point_Type
(Typ
)
14297 and then not Has_Small_Clause
(Typ
)
14299 Set_Small_Value
(Typ
, Small_Value
(P
));
14304 when Aspect_Storage_Size
=>
14305 if (Is_Access_Type
(Typ
) or else Is_Task_Type
(Typ
))
14306 and then not Has_Storage_Size_Clause
(Typ
)
14308 Set_Storage_Size_Variable
14309 (Base_Type
(Typ
), Storage_Size_Variable
(P
));
14314 when Aspect_Value_Size
=>
14316 -- Value_Size is never inherited, it is either set by
14317 -- default, or it is explicitly set for the derived
14318 -- type. So nothing to do here.
14324 when Aspect_Volatile
=>
14325 if Is_Volatile
(P
) then
14326 Set_Is_Volatile
(Typ
);
14329 -- Volatile_Full_Access (also Full_Access_Only)
14331 when Aspect_Volatile_Full_Access
14332 | Aspect_Full_Access_Only
14334 if Is_Volatile_Full_Access
(P
) then
14335 Set_Is_Volatile_Full_Access
(Typ
);
14338 -- Volatile_Components
14340 when Aspect_Volatile_Components
=>
14341 if Has_Volatile_Components
(P
) then
14342 Set_Has_Volatile_Components
(Base_Type
(Typ
));
14345 -- That should be all the Rep Aspects
14348 pragma Assert
(Aspect_Delay
(A
) /= Rep_Aspect
);
14356 end Inherit_Delayed_Rep_Aspects
;
14362 procedure Initialize
is
14364 Address_Clause_Checks
.Init
;
14365 Unchecked_Conversions
.Init
;
14367 -- The following might be needed in the future for some non-GCC back
14369 -- if AAMP_On_Target then
14370 -- Independence_Checks.Init;
14374 ---------------------------
14375 -- Install_Discriminants --
14376 ---------------------------
14378 procedure Install_Discriminants
(E
: Entity_Id
) is
14382 Disc
:= First_Discriminant
(E
);
14383 while Present
(Disc
) loop
14384 Prev
:= Current_Entity
(Disc
);
14385 Set_Current_Entity
(Disc
);
14386 Set_Is_Immediately_Visible
(Disc
);
14387 Set_Homonym
(Disc
, Prev
);
14388 Next_Discriminant
(Disc
);
14390 end Install_Discriminants
;
14392 -------------------------
14393 -- Is_Operational_Item --
14394 -------------------------
14396 function Is_Operational_Item
(N
: Node_Id
) return Boolean is
14398 -- List of operational items is given in AARM 13.1(8.mm/1). It is
14399 -- clearly incomplete, as it does not include iterator aspects, among
14402 return Nkind
(N
) = N_Attribute_Definition_Clause
14404 Get_Attribute_Id
(Chars
(N
)) in Attribute_Constant_Indexing
14405 | Attribute_External_Tag
14406 | Attribute_Default_Iterator
14407 | Attribute_Implicit_Dereference
14409 | Attribute_Iterable
14410 | Attribute_Iterator_Element
14412 | Attribute_Put_Image
14414 | Attribute_Variable_Indexing
14416 end Is_Operational_Item
;
14418 -------------------------
14419 -- Is_Predicate_Static --
14420 -------------------------
14422 -- Note: the basic legality of the expression has already been checked, so
14423 -- we don't need to worry about cases or ranges on strings for example.
14425 function Is_Predicate_Static
14428 Warn
: Boolean := True) return Boolean
14430 function All_Static_Case_Alternatives
(L
: List_Id
) return Boolean;
14431 -- Given a list of case expression alternatives, returns True if all
14432 -- the alternatives are static (have all static choices, and a static
14435 function Is_Type_Ref
(N
: Node_Id
) return Boolean;
14436 pragma Inline
(Is_Type_Ref
);
14437 -- Returns True if N is a reference to the type for the predicate in the
14438 -- expression (i.e. if it is an identifier whose Chars field matches the
14439 -- Nam given in the call). N must not be parenthesized, if the type name
14440 -- appears in parens, this routine will return False.
14442 -- The routine also returns True for function calls generated during the
14443 -- expansion of comparison operators on strings, which are intended to
14444 -- be legal in static predicates, and are converted into calls to array
14445 -- comparison routines in the body of the corresponding predicate
14448 ----------------------------------
14449 -- All_Static_Case_Alternatives --
14450 ----------------------------------
14452 function All_Static_Case_Alternatives
(L
: List_Id
) return Boolean is
14457 while Present
(N
) loop
14458 if not (All_Static_Choices
(Discrete_Choices
(N
))
14459 and then Is_OK_Static_Expression
(Expression
(N
)))
14468 end All_Static_Case_Alternatives
;
14474 function Is_Type_Ref
(N
: Node_Id
) return Boolean is
14476 return (Nkind
(N
) = N_Identifier
14477 and then Chars
(N
) = Nam
14478 and then Paren_Count
(N
) = 0);
14481 -- helper function for recursive calls
14482 function Is_Predicate_Static_Aux
(Expr
: Node_Id
) return Boolean is
14483 (Is_Predicate_Static
(Expr
, Nam
, Warn
=> False));
14485 -- Start of processing for Is_Predicate_Static
14488 -- Handle cases like
14489 -- subtype S is Integer with Static_Predicate =>
14490 -- (Some_Integer_Variable in Integer) and then (S /= 0);
14491 -- where the predicate (which should be rejected) might have been
14492 -- transformed into just "(S /= 0)", which would appear to be
14493 -- a predicate-static expression (and therefore legal).
14495 if Is_Rewrite_Substitution
(Expr
) then
14497 -- Emit warnings for predicates that are always True or always False
14498 -- and were not originally expressed as Boolean literals.
14500 return Result
: constant Boolean :=
14501 Is_Predicate_Static_Aux
(Original_Node
(Expr
))
14503 if Result
and then Warn
and then Is_Entity_Name
(Expr
) then
14504 if Entity
(Expr
) = Standard_True
then
14505 Error_Msg_N
("predicate is redundant (always True)?", Expr
);
14506 elsif Entity
(Expr
) = Standard_False
then
14508 ("predicate is unsatisfiable (always False)?", Expr
);
14514 -- Predicate_Static means one of the following holds. Numbers are the
14515 -- corresponding paragraph numbers in (RM 3.2.4(16-22)).
14517 -- 16: A static expression
14519 if Is_OK_Static_Expression
(Expr
) then
14522 -- 17: A membership test whose simple_expression is the current
14523 -- instance, and whose membership_choice_list meets the requirements
14524 -- for a static membership test.
14526 elsif Nkind
(Expr
) in N_Membership_Test
14527 and then Is_Type_Ref
(Left_Opnd
(Expr
))
14528 and then All_Membership_Choices_Static
(Expr
)
14532 -- 18. A case_expression whose selecting_expression is the current
14533 -- instance, and whose dependent expressions are static expressions.
14535 elsif Nkind
(Expr
) = N_Case_Expression
14536 and then Is_Type_Ref
(Expression
(Expr
))
14537 and then All_Static_Case_Alternatives
(Alternatives
(Expr
))
14541 -- 19. A call to a predefined equality or ordering operator, where one
14542 -- operand is the current instance, and the other is a static
14545 -- Note: the RM is clearly wrong here in not excluding string types.
14546 -- Without this exclusion, we would allow expressions like X > "ABC"
14547 -- to be considered as predicate-static, which is clearly not intended,
14548 -- since the idea is for predicate-static to be a subset of normal
14549 -- static expressions (and "DEF" > "ABC" is not a static expression).
14551 -- However, we do allow internally generated (not from source) equality
14552 -- and inequality operations to be valid on strings (this helps deal
14553 -- with cases where we transform A in "ABC" to A = "ABC).
14555 -- In fact, it appears that the intent of the ARG is to extend static
14556 -- predicates to strings, and that the extension should probably apply
14557 -- to static expressions themselves. The code below accepts comparison
14558 -- operators that apply to static strings.
14560 elsif Nkind
(Expr
) in N_Op_Compare
14561 and then ((Is_Type_Ref
(Left_Opnd
(Expr
))
14562 and then Is_OK_Static_Expression
(Right_Opnd
(Expr
)))
14564 (Is_Type_Ref
(Right_Opnd
(Expr
))
14565 and then Is_OK_Static_Expression
(Left_Opnd
(Expr
))))
14569 -- 20. A call to a predefined boolean logical operator, where each
14570 -- operand is predicate-static.
14572 elsif (Nkind
(Expr
) in N_Op_And | N_Op_Or | N_Op_Xor
14573 and then Is_Predicate_Static_Aux
(Left_Opnd
(Expr
))
14574 and then Is_Predicate_Static_Aux
(Right_Opnd
(Expr
)))
14576 (Nkind
(Expr
) = N_Op_Not
14577 and then Is_Predicate_Static_Aux
(Right_Opnd
(Expr
)))
14581 -- 21. A short-circuit control form where both operands are
14582 -- predicate-static.
14584 elsif Nkind
(Expr
) in N_Short_Circuit
14585 and then Is_Predicate_Static_Aux
(Left_Opnd
(Expr
))
14586 and then Is_Predicate_Static_Aux
(Right_Opnd
(Expr
))
14590 -- 22. A parenthesized predicate-static expression. This does not
14591 -- require any special test, since we just ignore paren levels in
14592 -- all the cases above.
14594 -- One more test that is an implementation artifact caused by the fact
14595 -- that we are analyzing not the original expression, but the generated
14596 -- expression in the body of the predicate function. This can include
14597 -- references to inherited predicates, so that the expression we are
14598 -- processing looks like:
14600 -- xxPredicate (typ (Inns)) and then expression
14602 -- Where the call is to a Predicate function for an inherited predicate.
14603 -- We simply ignore such a call, which could be to either a dynamic or
14604 -- a static predicate. Note that if the parent predicate is dynamic then
14605 -- eventually this type will be marked as dynamic, but you are allowed
14606 -- to specify a static predicate for a subtype which is inheriting a
14607 -- dynamic predicate, so the static predicate validation here ignores
14608 -- the inherited predicate even if it is dynamic.
14609 -- In all cases, a static predicate can only apply to a scalar type.
14611 elsif Nkind
(Expr
) = N_Function_Call
14612 and then Is_Predicate_Function
(Entity
(Name
(Expr
)))
14613 and then Is_Scalar_Type
(Etype
(First_Entity
(Entity
(Name
(Expr
)))))
14617 -- That's an exhaustive list of tests, all other cases are not
14618 -- predicate-static, so we return False.
14623 end Is_Predicate_Static
;
14625 ----------------------
14626 -- Is_Static_Choice --
14627 ----------------------
14629 function Is_Static_Choice
(N
: Node_Id
) return Boolean is
14631 return Nkind
(N
) = N_Others_Choice
14632 or else Is_OK_Static_Expression
(N
)
14633 or else (Is_Entity_Name
(N
) and then Is_Type
(Entity
(N
))
14634 and then Is_OK_Static_Subtype
(Entity
(N
)))
14635 or else (Nkind
(N
) = N_Subtype_Indication
14636 and then Is_OK_Static_Subtype
(Entity
(N
)))
14637 or else (Nkind
(N
) = N_Range
and then Is_OK_Static_Range
(N
));
14638 end Is_Static_Choice
;
14640 ------------------------------
14641 -- Is_Type_Related_Rep_Item --
14642 ------------------------------
14644 function Is_Type_Related_Rep_Item
(N
: Node_Id
) return Boolean is
14647 when N_Attribute_Definition_Clause
=>
14648 -- See AARM 13.1(8.f-8.x) list items that end in "clause"
14649 -- ???: include any GNAT-defined attributes here?
14650 return Get_Attribute_Id
(Chars
(N
)) in Attribute_Bit_Order
14651 | Attribute_Component_Size
14652 | Attribute_Machine_Radix
14653 | Attribute_Storage_Pool
14654 | Attribute_Stream_Size
;
14657 case Get_Pragma_Id
(N
) is
14658 -- See AARM 13.1(8.f-8.x) list items that start with "pragma"
14659 -- ???: include any GNAT-defined pragmas here?
14663 | Pragma_Convention
14665 | Pragma_Independent
14667 | Pragma_Atomic_Components
14668 | Pragma_Independent_Components
14669 | Pragma_Volatile_Components
14670 | Pragma_Discard_Names
14677 when N_Enumeration_Representation_Clause
14678 | N_Record_Representation_Clause
14687 end Is_Type_Related_Rep_Item
;
14689 ---------------------
14690 -- Kill_Rep_Clause --
14691 ---------------------
14693 procedure Kill_Rep_Clause
(N
: Node_Id
) is
14695 pragma Assert
(Ignore_Rep_Clauses
);
14697 -- Note: we use Replace rather than Rewrite, because we don't want
14698 -- tools to be able to use Original_Node to dig out the (undecorated)
14699 -- rep clause that is being replaced.
14701 Replace
(N
, Make_Null_Statement
(Sloc
(N
)));
14703 -- The null statement must be marked as not coming from source. This is
14704 -- so that tools ignore it, and also the back end does not expect bogus
14705 -- "from source" null statements in weird places (e.g. in declarative
14706 -- regions where such null statements are not allowed).
14708 Set_Comes_From_Source
(N
, False);
14709 end Kill_Rep_Clause
;
14715 function Minimum_Size
14717 Biased
: Boolean := False) return Int
14719 Lo
: Uint
:= No_Uint
;
14720 Hi
: Uint
:= No_Uint
;
14721 LoR
: Ureal
:= No_Ureal
;
14722 HiR
: Ureal
:= No_Ureal
;
14723 LoSet
: Boolean := False;
14724 HiSet
: Boolean := False;
14727 Ancest
: Entity_Id
;
14728 R_Typ
: constant Entity_Id
:= Root_Type
(T
);
14733 if T
= Any_Type
then
14734 return Unknown_Minimum_Size
;
14736 -- For generic types, just return unknown. There cannot be any
14737 -- legitimate need to know such a size, but this routine may be
14738 -- called with a generic type as part of normal processing.
14740 elsif Is_Generic_Type
(R_Typ
) or else R_Typ
= Any_Type
then
14741 return Unknown_Minimum_Size
;
14743 -- Access types (cannot have size smaller than System.Address)
14745 elsif Is_Access_Type
(T
) then
14746 return System_Address_Size
;
14748 -- Floating-point types
14750 elsif Is_Floating_Point_Type
(T
) then
14751 return UI_To_Int
(Esize
(R_Typ
));
14755 elsif Is_Discrete_Type
(T
) then
14757 -- The following loop is looking for the nearest compile time known
14758 -- bounds following the ancestor subtype chain. The idea is to find
14759 -- the most restrictive known bounds information.
14763 if Ancest
= Any_Type
or else Etype
(Ancest
) = Any_Type
then
14764 return Unknown_Minimum_Size
;
14768 if Compile_Time_Known_Value
(Type_Low_Bound
(Ancest
)) then
14769 Lo
:= Expr_Rep_Value
(Type_Low_Bound
(Ancest
));
14776 if Compile_Time_Known_Value
(Type_High_Bound
(Ancest
)) then
14777 Hi
:= Expr_Rep_Value
(Type_High_Bound
(Ancest
));
14783 Ancest
:= Ancestor_Subtype
(Ancest
);
14785 if No
(Ancest
) then
14786 Ancest
:= Base_Type
(T
);
14788 if Is_Generic_Type
(Ancest
) then
14789 return Unknown_Minimum_Size
;
14794 -- Fixed-point types. We can't simply use Expr_Value to get the
14795 -- Corresponding_Integer_Value values of the bounds, since these do not
14796 -- get set till the type is frozen, and this routine can be called
14797 -- before the type is frozen. Similarly the test for bounds being static
14798 -- needs to include the case where we have unanalyzed real literals for
14799 -- the same reason.
14801 elsif Is_Fixed_Point_Type
(T
) then
14803 -- The following loop is looking for the nearest compile time known
14804 -- bounds following the ancestor subtype chain. The idea is to find
14805 -- the most restrictive known bounds information.
14809 if Ancest
= Any_Type
or else Etype
(Ancest
) = Any_Type
then
14810 return Unknown_Minimum_Size
;
14813 -- Note: In the following two tests for LoSet and HiSet, it may
14814 -- seem redundant to test for N_Real_Literal here since normally
14815 -- one would assume that the test for the value being known at
14816 -- compile time includes this case. However, there is a glitch.
14817 -- If the real literal comes from folding a non-static expression,
14818 -- then we don't consider any non- static expression to be known
14819 -- at compile time if we are in configurable run time mode (needed
14820 -- in some cases to give a clearer definition of what is and what
14821 -- is not accepted). So the test is indeed needed. Without it, we
14822 -- would set neither Lo_Set nor Hi_Set and get an infinite loop.
14825 if Nkind
(Type_Low_Bound
(Ancest
)) = N_Real_Literal
14826 or else Compile_Time_Known_Value
(Type_Low_Bound
(Ancest
))
14828 LoR
:= Expr_Value_R
(Type_Low_Bound
(Ancest
));
14835 if Nkind
(Type_High_Bound
(Ancest
)) = N_Real_Literal
14836 or else Compile_Time_Known_Value
(Type_High_Bound
(Ancest
))
14838 HiR
:= Expr_Value_R
(Type_High_Bound
(Ancest
));
14844 Ancest
:= Ancestor_Subtype
(Ancest
);
14846 if No
(Ancest
) then
14847 Ancest
:= Base_Type
(T
);
14849 if Is_Generic_Type
(Ancest
) then
14850 return Unknown_Minimum_Size
;
14855 Lo
:= UR_To_Uint
(LoR
/ Small_Value
(T
));
14856 Hi
:= UR_To_Uint
(HiR
/ Small_Value
(T
));
14858 -- No other types allowed
14861 raise Program_Error
;
14864 -- Fall through with Hi and Lo set. Deal with biased case
14867 and then not Is_Fixed_Point_Type
(T
)
14868 and then not (Is_Enumeration_Type
(T
)
14869 and then Has_Non_Standard_Rep
(T
)))
14870 or else Has_Biased_Representation
(T
)
14876 -- Null range case, size is always zero. We only do this in the discrete
14877 -- type case, since that's the odd case that came up. Probably we should
14878 -- also do this in the fixed-point case, but doing so causes peculiar
14879 -- gigi failures, and it is not worth worrying about this incredibly
14880 -- marginal case (explicit null-range fixed-point type declarations).
14882 if Lo
> Hi
and then Is_Discrete_Type
(T
) then
14885 -- Signed case. Note that we consider types like range 1 .. -1 to be
14886 -- signed for the purpose of computing the size, since the bounds have
14887 -- to be accommodated in the base type.
14889 elsif Lo
< 0 or else Hi
< 0 then
14893 -- S = size, B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
14894 -- Note that we accommodate the case where the bounds cross. This
14895 -- can happen either because of the way the bounds are declared
14896 -- or because of the algorithm in Freeze_Fixed_Point_Type.
14910 -- If both bounds are positive, make sure that both are represen-
14911 -- table in the case where the bounds are crossed. This can happen
14912 -- either because of the way the bounds are declared, or because of
14913 -- the algorithm in Freeze_Fixed_Point_Type.
14919 -- S = size, (can accommodate 0 .. (2**size - 1))
14922 while Hi
>= Uint_2
** S
loop
14930 ------------------------------
14931 -- New_Put_Image_Subprogram --
14932 ------------------------------
14934 procedure New_Put_Image_Subprogram
14939 Loc
: constant Source_Ptr
:= Sloc
(N
);
14940 Sname
: constant Name_Id
:=
14941 Make_TSS_Name
(Base_Type
(Ent
), TSS_Put_Image
);
14942 Subp_Id
: Entity_Id
;
14943 Subp_Decl
: Node_Id
;
14947 Defer_Declaration
: constant Boolean :=
14948 Is_Tagged_Type
(Ent
) or else Is_Private_Type
(Ent
);
14949 -- For a tagged type, there is a declaration at the freeze point, and
14950 -- we must generate only a completion of this declaration. We do the
14951 -- same for private types, because the full view might be tagged.
14952 -- Otherwise we generate a declaration at the point of the attribute
14953 -- definition clause. If the attribute definition comes from an aspect
14954 -- specification the declaration is part of the freeze actions of the
14957 function Build_Spec
return Node_Id
;
14958 -- Used for declaration and renaming declaration, so that this is
14959 -- treated as a renaming_as_body.
14965 function Build_Spec
return Node_Id
is
14968 T_Ref
: constant Node_Id
:= New_Occurrence_Of
(Etyp
, Loc
);
14971 Subp_Id
:= Make_Defining_Identifier
(Loc
, Sname
);
14973 -- S : Root_Buffer_Type'Class
14975 Formals
:= New_List
(
14976 Make_Parameter_Specification
(Loc
,
14977 Defining_Identifier
=>
14978 Make_Defining_Identifier
(Loc
, Name_S
),
14979 In_Present
=> True,
14980 Out_Present
=> True,
14982 New_Occurrence_Of
(Etype
(F
), Loc
)));
14986 Append_To
(Formals
,
14987 Make_Parameter_Specification
(Loc
,
14988 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
14989 Parameter_Type
=> T_Ref
));
14992 Make_Procedure_Specification
(Loc
,
14993 Defining_Unit_Name
=> Subp_Id
,
14994 Parameter_Specifications
=> Formals
);
14999 -- Start of processing for New_Put_Image_Subprogram
15002 F
:= First_Formal
(Subp
);
15004 Etyp
:= Etype
(Next_Formal
(F
));
15006 -- Prepare subprogram declaration and insert it as an action on the
15007 -- clause node. The visibility for this entity is used to test for
15008 -- visibility of the attribute definition clause (in the sense of
15009 -- 8.3(23) as amended by AI-195).
15011 if not Defer_Declaration
then
15013 Make_Subprogram_Declaration
(Loc
,
15014 Specification
=> Build_Spec
);
15016 -- For a tagged type, there is always a visible declaration for the
15017 -- Put_Image TSS (it is a predefined primitive operation), and the
15018 -- completion of this declaration occurs at the freeze point, which is
15019 -- not always visible at places where the attribute definition clause is
15020 -- visible. So, we create a dummy entity here for the purpose of
15021 -- tracking the visibility of the attribute definition clause itself.
15025 Make_Defining_Identifier
(Loc
, New_External_Name
(Sname
, 'V'));
15027 Make_Object_Declaration
(Loc
,
15028 Defining_Identifier
=> Subp_Id
,
15029 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
));
15032 if not Defer_Declaration
15033 and then From_Aspect_Specification
(N
)
15034 and then Has_Delayed_Freeze
(Ent
)
15036 Append_Freeze_Action
(Ent
, Subp_Decl
);
15039 Insert_Action
(N
, Subp_Decl
);
15040 Set_Entity
(N
, Subp_Id
);
15044 Make_Subprogram_Renaming_Declaration
(Loc
,
15045 Specification
=> Build_Spec
,
15046 Name
=> New_Occurrence_Of
(Subp
, Loc
));
15048 if Defer_Declaration
then
15049 Set_TSS
(Base_Type
(Ent
), Subp_Id
);
15052 if From_Aspect_Specification
(N
) then
15053 Append_Freeze_Action
(Ent
, Subp_Decl
);
15055 Insert_Action
(N
, Subp_Decl
);
15058 Copy_TSS
(Subp_Id
, Base_Type
(Ent
));
15060 end New_Put_Image_Subprogram
;
15062 ---------------------------
15063 -- New_Stream_Subprogram --
15064 ---------------------------
15066 procedure New_Stream_Subprogram
15070 Nam
: TSS_Name_Type
)
15072 Loc
: constant Source_Ptr
:= Sloc
(N
);
15073 Sname
: constant Name_Id
:= Make_TSS_Name
(Base_Type
(Ent
), Nam
);
15074 Subp_Id
: Entity_Id
;
15075 Subp_Decl
: Node_Id
;
15079 Defer_Declaration
: constant Boolean :=
15080 Is_Tagged_Type
(Ent
) or else Is_Private_Type
(Ent
);
15081 -- For a tagged type, there is a declaration for each stream attribute
15082 -- at the freeze point, and we must generate only a completion of this
15083 -- declaration. We do the same for private types, because the full view
15084 -- might be tagged. Otherwise we generate a declaration at the point of
15085 -- the attribute definition clause. If the attribute definition comes
15086 -- from an aspect specification the declaration is part of the freeze
15087 -- actions of the type.
15089 function Build_Spec
return Node_Id
;
15090 -- Used for declaration and renaming declaration, so that this is
15091 -- treated as a renaming_as_body.
15097 function Build_Spec
return Node_Id
is
15098 Out_P
: constant Boolean := (Nam
= TSS_Stream_Read
);
15101 T_Ref
: constant Node_Id
:= New_Occurrence_Of
(Etyp
, Loc
);
15104 Subp_Id
:= Make_Defining_Identifier
(Loc
, Sname
);
15106 -- S : access Root_Stream_Type'Class
15108 Formals
:= New_List
(
15109 Make_Parameter_Specification
(Loc
,
15110 Defining_Identifier
=>
15111 Make_Defining_Identifier
(Loc
, Name_S
),
15113 Make_Access_Definition
(Loc
,
15115 New_Occurrence_Of
(
15116 Designated_Type
(Etype
(F
)), Loc
))));
15118 if Nam
= TSS_Stream_Input
then
15120 Make_Function_Specification
(Loc
,
15121 Defining_Unit_Name
=> Subp_Id
,
15122 Parameter_Specifications
=> Formals
,
15123 Result_Definition
=> T_Ref
);
15127 Append_To
(Formals
,
15128 Make_Parameter_Specification
(Loc
,
15129 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
15130 Out_Present
=> Out_P
,
15131 Parameter_Type
=> T_Ref
));
15134 Make_Procedure_Specification
(Loc
,
15135 Defining_Unit_Name
=> Subp_Id
,
15136 Parameter_Specifications
=> Formals
);
15142 -- Start of processing for New_Stream_Subprogram
15145 F
:= First_Formal
(Subp
);
15147 if Ekind
(Subp
) = E_Procedure
then
15148 Etyp
:= Etype
(Next_Formal
(F
));
15150 Etyp
:= Etype
(Subp
);
15153 -- Prepare subprogram declaration and insert it as an action on the
15154 -- clause node. The visibility for this entity is used to test for
15155 -- visibility of the attribute definition clause (in the sense of
15156 -- 8.3(23) as amended by AI-195).
15158 if not Defer_Declaration
then
15160 Make_Subprogram_Declaration
(Loc
,
15161 Specification
=> Build_Spec
);
15163 -- For a tagged type, there is always a visible declaration for each
15164 -- stream TSS (it is a predefined primitive operation), and the
15165 -- completion of this declaration occurs at the freeze point, which is
15166 -- not always visible at places where the attribute definition clause is
15167 -- visible. So, we create a dummy entity here for the purpose of
15168 -- tracking the visibility of the attribute definition clause itself.
15172 Make_Defining_Identifier
(Loc
, New_External_Name
(Sname
, 'V'));
15174 Make_Object_Declaration
(Loc
,
15175 Defining_Identifier
=> Subp_Id
,
15176 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
));
15179 if not Defer_Declaration
15180 and then From_Aspect_Specification
(N
)
15181 and then Has_Delayed_Freeze
(Ent
)
15183 Append_Freeze_Action
(Ent
, Subp_Decl
);
15186 Insert_Action
(N
, Subp_Decl
);
15187 Set_Entity
(N
, Subp_Id
);
15191 Make_Subprogram_Renaming_Declaration
(Loc
,
15192 Specification
=> Build_Spec
,
15193 Name
=> New_Occurrence_Of
(Subp
, Loc
));
15195 if Defer_Declaration
then
15196 Set_TSS
(Base_Type
(Ent
), Subp_Id
);
15199 if From_Aspect_Specification
(N
) then
15200 Append_Freeze_Action
(Ent
, Subp_Decl
);
15202 Insert_Action
(N
, Subp_Decl
);
15205 Copy_TSS
(Subp_Id
, Base_Type
(Ent
));
15207 end New_Stream_Subprogram
;
15209 ----------------------
15210 -- No_Type_Rep_Item --
15211 ----------------------
15213 procedure No_Type_Rep_Item
(N
: Node_Id
) is
15215 Error_Msg_N
("|type-related representation item not permitted!", N
);
15216 end No_Type_Rep_Item
;
15222 procedure Pop_Type
(E
: Entity_Id
) is
15224 if Ekind
(E
) = E_Record_Type
and then E
= Current_Scope
then
15228 and then Has_Discriminants
(E
)
15229 and then Nkind
(Parent
(E
)) /= N_Subtype_Declaration
15231 Uninstall_Discriminants
(E
);
15240 procedure Push_Type
(E
: Entity_Id
) is
15244 if Ekind
(E
) = E_Record_Type
then
15247 Comp
:= First_Component
(E
);
15248 while Present
(Comp
) loop
15249 Install_Entity
(Comp
);
15250 Next_Component
(Comp
);
15253 if Has_Discriminants
(E
) then
15254 Install_Discriminants
(E
);
15258 and then Has_Discriminants
(E
)
15259 and then Nkind
(Parent
(E
)) /= N_Subtype_Declaration
15262 Install_Discriminants
(E
);
15266 -----------------------------------
15267 -- Register_Address_Clause_Check --
15268 -----------------------------------
15270 procedure Register_Address_Clause_Check
15277 ACS
: constant Boolean := Scope_Suppress
.Suppress
(Alignment_Check
);
15279 Address_Clause_Checks
.Append
((N
, X
, A
, Y
, Off
, ACS
));
15280 end Register_Address_Clause_Check
;
15282 ------------------------
15283 -- Rep_Item_Too_Early --
15284 ------------------------
15286 function Rep_Item_Too_Early
(T
: Entity_Id
; N
: Node_Id
) return Boolean is
15287 function Has_Generic_Parent
(E
: Entity_Id
) return Boolean;
15288 -- Return True if R or any ancestor is a generic type
15290 ------------------------
15291 -- Has_Generic_Parent --
15292 ------------------------
15294 function Has_Generic_Parent
(E
: Entity_Id
) return Boolean is
15295 Ancestor_Type
: Entity_Id
:= Etype
(E
);
15298 if Is_Generic_Type
(E
) then
15302 while Present
(Ancestor_Type
)
15303 and then not Is_Generic_Type
(Ancestor_Type
)
15304 and then Etype
(Ancestor_Type
) /= Ancestor_Type
15306 Ancestor_Type
:= Etype
(Ancestor_Type
);
15310 Present
(Ancestor_Type
) and then Is_Generic_Type
(Ancestor_Type
);
15311 end Has_Generic_Parent
;
15313 -- Start of processing for Rep_Item_Too_Early
15316 -- Cannot apply non-operational rep items to generic types
15318 if Is_Operational_Item
(N
) then
15322 and then Has_Generic_Parent
(T
)
15323 and then (Nkind
(N
) /= N_Pragma
15324 or else Get_Pragma_Id
(N
) /= Pragma_Convention
)
15326 if Ada_Version
< Ada_2022
then
15328 ("representation item not allowed for generic type", N
);
15335 -- Otherwise check for incomplete type
15337 if Is_Incomplete_Or_Private_Type
(T
)
15338 and then No
(Underlying_Type
(T
))
15340 (Nkind
(N
) /= N_Pragma
15341 or else Get_Pragma_Id
(N
) /= Pragma_Import
)
15344 ("representation item must be after full type declaration", N
);
15347 -- If the type has incomplete components, a representation clause is
15348 -- illegal but stream attributes and Convention pragmas are correct.
15350 elsif Has_Private_Component
(T
) then
15351 if Nkind
(N
) = N_Pragma
then
15356 ("representation item must appear after type is fully defined",
15363 end Rep_Item_Too_Early
;
15365 -----------------------
15366 -- Rep_Item_Too_Late --
15367 -----------------------
15369 function Rep_Item_Too_Late
15372 FOnly
: Boolean := False) return Boolean
15374 procedure Too_Late
;
15375 -- Output message for an aspect being specified too late
15377 -- Note that neither of the above errors is considered a serious one,
15378 -- since the effect is simply that we ignore the representation clause
15380 -- Is this really true? In any case if we make this change we must
15381 -- document the requirement in the spec of Rep_Item_Too_Late that
15382 -- if True is returned, then the rep item must be completely ignored???
15388 procedure Too_Late
is
15390 -- Other compilers seem more relaxed about rep items appearing too
15391 -- late. Since analysis tools typically don't care about rep items
15392 -- anyway, no reason to be too strict about this.
15394 if not Relaxed_RM_Semantics
then
15395 Error_Msg_N
("|representation item appears too late!", N
);
15401 Parent_Type
: Entity_Id
;
15404 -- Start of processing for Rep_Item_Too_Late
15407 -- First make sure entity is not frozen (RM 13.1(9))
15411 -- Exclude imported types, which may be frozen if they appear in a
15412 -- representation clause for a local type.
15414 and then not From_Limited_With
(T
)
15416 -- Exclude generated entities (not coming from source). The common
15417 -- case is when we generate a renaming which prematurely freezes the
15418 -- renamed internal entity, but we still want to be able to set copies
15419 -- of attribute values such as Size/Alignment.
15421 and then Comes_From_Source
(T
)
15423 -- A self-referential aspect is illegal if it forces freezing the
15424 -- entity before the corresponding pragma has been analyzed.
15426 if Nkind
(N
) in N_Attribute_Definition_Clause | N_Pragma
15427 and then From_Aspect_Specification
(N
)
15430 ("aspect specification causes premature freezing of&", N
, T
);
15431 Set_Has_Delayed_Freeze
(T
, False);
15436 S
:= First_Subtype
(T
);
15438 if Present
(Freeze_Node
(S
)) then
15439 if not Relaxed_RM_Semantics
then
15441 ("??no more representation items for }", Freeze_Node
(S
), S
);
15447 -- Check for case of untagged derived type whose parent either has
15448 -- primitive operations (pre Ada 2022), or is a by-reference type (RM
15449 -- 13.1(10)). In this case we do not output a Too_Late message, since
15450 -- there is no earlier point where the rep item could be placed to make
15452 -- ??? Confirming representation clauses should be allowed here.
15456 and then Is_Derived_Type
(T
)
15457 and then not Is_Tagged_Type
(T
)
15459 Parent_Type
:= Etype
(Base_Type
(T
));
15461 if Relaxed_RM_Semantics
then
15464 elsif Ada_Version
<= Ada_2012
15465 and then Has_Primitive_Operations
(Parent_Type
)
15468 ("|representation item not permitted before Ada 2022!", N
);
15470 ("\parent type & has primitive operations!", N
, Parent_Type
);
15473 elsif Is_By_Reference_Type
(Parent_Type
) then
15474 No_Type_Rep_Item
(N
);
15476 ("\parent type & is a by-reference type!", N
, Parent_Type
);
15481 -- No error, but one more warning to consider. The RM (surprisingly)
15482 -- allows this pattern in some cases:
15485 -- primitive operations for S
15486 -- type R is new S;
15487 -- rep clause for S
15489 -- Meaning that calls on the primitive operations of S for values of
15490 -- type R may require possibly expensive implicit conversion operations.
15491 -- So even when this is not an error, it is still worth a warning.
15493 if not Relaxed_RM_Semantics
and then Is_Type
(T
) then
15495 DTL
: constant Entity_Id
:= Derived_Type_Link
(Base_Type
(T
));
15500 -- For now, do not generate this warning for the case of
15501 -- aspect specification using Ada 2012 syntax, since we get
15502 -- wrong messages we do not understand. The whole business
15503 -- of derived types and rep items seems a bit confused when
15504 -- aspects are used, since the aspects are not evaluated
15505 -- till freeze time. However, AI12-0109 confirms (in an AARM
15506 -- ramification) that inheritance in this case is required
15509 and then not From_Aspect_Specification
(N
)
15511 if Is_By_Reference_Type
(T
)
15512 and then not Is_Tagged_Type
(T
)
15513 and then Is_Type_Related_Rep_Item
(N
)
15514 and then (Ada_Version
>= Ada_2012
15515 or else Has_Primitive_Operations
(Base_Type
(T
)))
15517 -- Treat as hard error (AI12-0109, binding interpretation).
15518 -- Implementing a change of representation is not really
15519 -- an option in the case of a by-reference type, so we
15520 -- take this path for all Ada dialects if primitive
15521 -- operations are present.
15522 Error_Msg_Sloc
:= Sloc
(DTL
);
15524 ("representation item for& appears after derived type "
15525 & "declaration#", N
);
15527 elsif Has_Primitive_Operations
(Base_Type
(T
)) then
15528 Error_Msg_Sloc
:= Sloc
(DTL
);
15531 ("representation item for& appears after derived type "
15532 & "declaration#??", N
);
15534 ("\may result in implicit conversions for primitive "
15535 & "operations of&??", N
, T
);
15537 ("\to change representations when called with arguments "
15538 & "of type&??", N
, DTL
);
15544 -- No error, link item into head of chain of rep items for the entity,
15545 -- but avoid chaining if we have an overloadable entity, and the pragma
15546 -- is one that can apply to multiple overloaded entities.
15548 if Is_Overloadable
(T
) and then Nkind
(N
) = N_Pragma
then
15550 Pname
: constant Name_Id
:= Pragma_Name
(N
);
15552 if Pname
in Name_Convention | Name_Import | Name_Export
15553 | Name_External | Name_Interface
15560 Record_Rep_Item
(T
, N
);
15562 end Rep_Item_Too_Late
;
15564 -------------------------------------
15565 -- Replace_Type_References_Generic --
15566 -------------------------------------
15568 procedure Replace_Type_References_Generic
(N
: Node_Id
; T
: Entity_Id
) is
15569 TName
: constant Name_Id
:= Chars
(T
);
15571 function Replace_Type_Ref
(N
: Node_Id
) return Traverse_Result
;
15572 -- Processes a single node in the traversal procedure below, checking
15573 -- if node N should be replaced, and if so, doing the replacement.
15575 function Visible_Component
(Comp
: Name_Id
) return Entity_Id
;
15576 -- Given an identifier in the expression, check whether there is a
15577 -- discriminant, component, protected procedure, or entry of the type
15578 -- that is directy visible, and rewrite it as the corresponding selected
15579 -- component of the formal of the subprogram.
15581 ----------------------
15582 -- Replace_Type_Ref --
15583 ----------------------
15585 function Replace_Type_Ref
(N
: Node_Id
) return Traverse_Result
is
15586 Loc
: constant Source_Ptr
:= Sloc
(N
);
15588 procedure Add_Prefix
(Ref
: Node_Id
; Comp
: Entity_Id
);
15589 -- Add the proper prefix to a reference to a component of the type
15590 -- when it is not already a selected component.
15596 procedure Add_Prefix
(Ref
: Node_Id
; Comp
: Entity_Id
) is
15599 Make_Selected_Component
(Loc
,
15600 Prefix
=> New_Occurrence_Of
(T
, Loc
),
15601 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
)));
15602 Replace_Type_Reference
(Prefix
(Ref
));
15611 -- Start of processing for Replace_Type_Ref
15614 if Nkind
(N
) = N_Identifier
then
15616 -- If not the type name, check whether it is a reference to some
15617 -- other type, which must be frozen before the predicate function
15618 -- is analyzed, i.e. before the freeze node of the type to which
15619 -- the predicate applies.
15621 if Chars
(N
) /= TName
then
15622 if Present
(Current_Entity
(N
))
15623 and then Is_Type
(Current_Entity
(N
))
15625 Freeze_Before
(Freeze_Node
(T
), Current_Entity
(N
));
15628 -- The components of the type are directly visible and can
15629 -- be referenced in the source code without a prefix.
15630 -- If a name denoting a component doesn't already have a
15631 -- prefix, then normalize it by adding a reference to the
15632 -- current instance of the type as a prefix.
15634 -- This isn't right in the pathological corner case of an
15635 -- object-declaring expression (e.g., a quantified expression
15636 -- or a declare expression) that declares an object with the
15637 -- same name as a visible component declaration, thereby hiding
15638 -- the component within that expression. For example, given a
15639 -- record with a Boolean component "C" and a dynamic predicate
15640 -- "C = (for some C in Character => Some_Function (C))", only
15641 -- the first of the two uses of C should have a prefix added
15642 -- here; instead, both will get prefixes.
15644 if Nkind
(Parent
(N
)) /= N_Selected_Component
15645 or else N
/= Selector_Name
(Parent
(N
))
15647 Comp
:= Visible_Component
(Chars
(N
));
15649 if Present
(Comp
) then
15650 Add_Prefix
(N
, Comp
);
15656 -- Otherwise do the replacement if this is not a qualified
15657 -- reference to a homograph of the type itself. Note that the
15658 -- current instance could not appear in such a context, e.g.
15659 -- the prefix of a type conversion.
15662 if Nkind
(Parent
(N
)) /= N_Selected_Component
15663 or else N
/= Selector_Name
(Parent
(N
))
15665 Replace_Type_Reference
(N
);
15671 -- Case of selected component, which may be a subcomponent of the
15672 -- current instance, or an expanded name which is still unanalyzed.
15674 elsif Nkind
(N
) = N_Selected_Component
then
15676 -- If selector name is not our type, keep going (we might still
15677 -- have an occurrence of the type in the prefix). If it is a
15678 -- subcomponent of the current entity, add prefix.
15680 if Nkind
(Selector_Name
(N
)) /= N_Identifier
15681 or else Chars
(Selector_Name
(N
)) /= TName
15683 if Nkind
(Prefix
(N
)) = N_Identifier
then
15684 Comp
:= Visible_Component
(Chars
(Prefix
(N
)));
15686 if Present
(Comp
) then
15687 Add_Prefix
(Prefix
(N
), Comp
);
15693 -- Selector name is our type, check qualification
15696 -- Loop through scopes and prefixes, doing comparison
15698 Scop
:= Current_Scope
;
15699 Pref
:= Prefix
(N
);
15701 -- Continue if no more scopes or scope with no name
15703 if No
(Scop
) or else Nkind
(Scop
) not in N_Has_Chars
then
15707 -- Do replace if prefix is an identifier matching the scope
15708 -- that we are currently looking at.
15710 if Nkind
(Pref
) = N_Identifier
15711 and then Chars
(Pref
) = Chars
(Scop
)
15713 Replace_Type_Reference
(N
);
15717 -- Go check scope above us if prefix is itself of the form
15718 -- of a selected component, whose selector matches the scope
15719 -- we are currently looking at.
15721 if Nkind
(Pref
) = N_Selected_Component
15722 and then Nkind
(Selector_Name
(Pref
)) = N_Identifier
15723 and then Chars
(Selector_Name
(Pref
)) = Chars
(Scop
)
15725 Scop
:= Scope
(Scop
);
15726 Pref
:= Prefix
(Pref
);
15728 -- For anything else, we don't have a match, so keep on
15729 -- going, there are still some weird cases where we may
15730 -- still have a replacement within the prefix.
15738 -- Continue for any other node kind
15743 end Replace_Type_Ref
;
15745 procedure Replace_Type_Refs
is new Traverse_Proc
(Replace_Type_Ref
);
15747 -----------------------
15748 -- Visible_Component --
15749 -----------------------
15751 function Visible_Component
(Comp
: Name_Id
) return Entity_Id
is
15755 -- Types with nameable components are record, task, protected types
15757 if Ekind
(T
) in E_Record_Type | E_Task_Type | E_Protected_Type
then
15758 -- This is a sequential search, which seems acceptable
15759 -- efficiency-wise, given the typical size of component
15760 -- lists, protected operation lists, task item lists, and
15761 -- check expressions.
15763 E
:= First_Entity
(T
);
15764 while Present
(E
) loop
15765 if Comes_From_Source
(E
) and then Chars
(E
) = Comp
then
15772 -- Private discriminated types may have visible discriminants
15774 elsif Is_Private_Type
(T
) and then Has_Discriminants
(T
) then
15776 Decl
: constant Node_Id
:= Declaration_Node
(T
);
15781 -- Loop over the discriminants listed in the discriminant part
15782 -- of the private type declaration to find one with a matching
15783 -- name; then, if it exists, return the discriminant entity of
15784 -- the same name in the type, which is that of its full view.
15786 if Nkind
(Decl
) in N_Private_Extension_Declaration
15787 | N_Private_Type_Declaration
15788 and then Present
(Discriminant_Specifications
(Decl
))
15790 Discr
:= First
(Discriminant_Specifications
(Decl
));
15792 while Present
(Discr
) loop
15793 if Chars
(Defining_Identifier
(Discr
)) = Comp
then
15794 Discr
:= First_Discriminant
(T
);
15796 while Present
(Discr
) loop
15797 if Chars
(Discr
) = Comp
then
15801 Next_Discriminant
(Discr
);
15804 pragma Assert
(False);
15813 -- Nothing by that name
15816 end Visible_Component
;
15818 -- Start of processing for Replace_Type_References_Generic
15821 Replace_Type_Refs
(N
);
15822 end Replace_Type_References_Generic
;
15824 --------------------------------
15825 -- Resolve_Aspect_Expressions --
15826 --------------------------------
15828 procedure Resolve_Aspect_Expressions
(E
: Entity_Id
) is
15829 function Resolve_Name
(N
: Node_Id
) return Traverse_Result
;
15830 -- Verify that all identifiers in the expression, with the exception
15831 -- of references to the current entity, denote visible entities. This
15832 -- is done only to detect visibility errors, as the expression will be
15833 -- properly analyzed/expanded during analysis of the predicate function
15834 -- body. We omit quantified expressions from this test, given that they
15835 -- introduce a local identifier that would require proper expansion to
15836 -- handle properly.
15842 function Resolve_Name
(N
: Node_Id
) return Traverse_Result
is
15843 Dummy
: Traverse_Result
;
15846 if Nkind
(N
) = N_Selected_Component
then
15847 if Nkind
(Prefix
(N
)) = N_Identifier
15848 and then Chars
(Prefix
(N
)) /= Chars
(E
)
15850 Find_Selected_Component
(N
);
15855 -- Resolve identifiers that are not selectors in parameter
15856 -- associations (these are never resolved by visibility).
15858 elsif Nkind
(N
) = N_Identifier
15859 and then Chars
(N
) /= Chars
(E
)
15860 and then (Nkind
(Parent
(N
)) /= N_Parameter_Association
15861 or else N
/= Selector_Name
(Parent
(N
)))
15863 Find_Direct_Name
(N
);
15865 -- Reset the Entity if N is overloaded since the entity may not
15866 -- be the correct one.
15868 if Is_Overloaded
(N
) then
15869 Set_Entity
(N
, Empty
);
15872 -- The name in a component association needs no resolution
15874 elsif Nkind
(N
) = N_Component_Association
then
15875 Dummy
:= Resolve_Name
(Expression
(N
));
15878 elsif Nkind
(N
) = N_Quantified_Expression
then
15885 procedure Resolve_Aspect_Expression
is new Traverse_Proc
(Resolve_Name
);
15889 ASN
: Node_Id
:= First_Rep_Item
(E
);
15891 -- Start of processing for Resolve_Aspect_Expressions
15894 while Present
(ASN
) loop
15895 if Nkind
(ASN
) = N_Aspect_Specification
and then Entity
(ASN
) = E
then
15897 A_Id
: constant Aspect_Id
:= Get_Aspect_Id
(ASN
);
15898 Expr
: constant Node_Id
:= Expression
(ASN
);
15903 when Aspect_Aggregate
=>
15904 Resolve_Aspect_Aggregate
(Entity
(ASN
), Expr
);
15906 when Aspect_Stable_Properties
=>
15907 Resolve_Aspect_Stable_Properties
15908 (Entity
(ASN
), Expr
, Class_Present
(ASN
));
15910 when Aspect_Local_Restrictions
=>
15911 -- Expression is an aggregate, but only syntactically
15914 -- For now we only deal with aspects that do not generate
15915 -- subprograms, or that may mention current instances of
15916 -- types. These will require special handling???.
15918 when Aspect_Invariant
15919 | Aspect_Predicate_Failure
15923 when Aspect_Dynamic_Predicate
15924 | Aspect_Ghost_Predicate
15926 | Aspect_Static_Predicate
15928 -- Preanalyze expression after type replacement to catch
15929 -- name resolution errors if the predicate function has
15930 -- not been built yet.
15932 -- Note that we cannot use Preanalyze_Spec_Expression
15933 -- directly because of the special handling required for
15934 -- quantifiers (see comments on Resolve_Aspect_Expression
15935 -- above) but we need to emulate it properly.
15937 if No
(Predicate_Function
(E
)) then
15939 Save_In_Spec_Expression
: constant Boolean :=
15940 In_Spec_Expression
;
15941 Save_Full_Analysis
: constant Boolean :=
15944 In_Spec_Expression
:= True;
15945 Full_Analysis
:= False;
15946 Expander_Mode_Save_And_Set
(False);
15948 Resolve_Aspect_Expression
(Expr
);
15950 Expander_Mode_Restore
;
15951 Full_Analysis
:= Save_Full_Analysis
;
15952 In_Spec_Expression
:= Save_In_Spec_Expression
;
15956 when Pre_Post_Aspects
=>
15959 when Aspect_Iterable
=>
15960 if Nkind
(Expr
) = N_Aggregate
then
15965 Assoc
:= First
(Component_Associations
(Expr
));
15966 while Present
(Assoc
) loop
15967 if Nkind
(Expression
(Assoc
)) in N_Has_Entity
15969 Find_Direct_Name
(Expression
(Assoc
));
15977 -- The expression for Default_Value is a static expression
15978 -- of the type, but this expression does not freeze the
15979 -- type, so it can still appear in a representation clause
15980 -- before the actual freeze point.
15982 when Aspect_Default_Value
=>
15983 Set_Must_Not_Freeze
(Expr
);
15984 Preanalyze_Spec_Expression
(Expr
, E
);
15986 when Aspect_Priority
=>
15988 Preanalyze_Spec_Expression
(Expr
, Any_Integer
);
15991 -- Ditto for Storage_Size. Any other aspects that carry
15992 -- expressions that should not freeze ??? This is only
15993 -- relevant to the misuse of deferred constants.
15995 when Aspect_Storage_Size
=>
15996 Set_Must_Not_Freeze
(Expr
);
15997 Preanalyze_Spec_Expression
(Expr
, Any_Integer
);
16000 if Present
(Expr
) then
16001 case Aspect_Argument
(A_Id
) is
16003 | Optional_Expression
16005 Analyze_And_Resolve
(Expr
);
16010 if Nkind
(Expr
) = N_Identifier
then
16011 Find_Direct_Name
(Expr
);
16013 elsif Nkind
(Expr
) = N_Selected_Component
then
16014 Find_Selected_Component
(Expr
);
16022 Next_Rep_Item
(ASN
);
16024 end Resolve_Aspect_Expressions
;
16026 ----------------------------
16027 -- Parse_Aspect_Aggregate --
16028 ----------------------------
16030 procedure Parse_Aspect_Aggregate
16032 Empty_Subp
: in out Node_Id
;
16033 Add_Named_Subp
: in out Node_Id
;
16034 Add_Unnamed_Subp
: in out Node_Id
;
16035 New_Indexed_Subp
: in out Node_Id
;
16036 Assign_Indexed_Subp
: in out Node_Id
)
16038 Assoc
: Node_Id
:= First
(Component_Associations
(N
));
16043 while Present
(Assoc
) loop
16044 Subp
:= Expression
(Assoc
);
16045 Op_Name
:= Chars
(First
(Choices
(Assoc
)));
16046 if Op_Name
= Name_Empty
then
16047 Empty_Subp
:= Subp
;
16049 elsif Op_Name
= Name_Add_Named
then
16050 Add_Named_Subp
:= Subp
;
16052 elsif Op_Name
= Name_Add_Unnamed
then
16053 Add_Unnamed_Subp
:= Subp
;
16055 elsif Op_Name
= Name_New_Indexed
then
16056 New_Indexed_Subp
:= Subp
;
16058 elsif Op_Name
= Name_Assign_Indexed
then
16059 Assign_Indexed_Subp
:= Subp
;
16064 end Parse_Aspect_Aggregate
;
16066 -------------------------------------
16067 -- Parse_Aspect_Local_Restrictions --
16068 -------------------------------------
16070 function Parse_Aspect_Local_Restrictions
(Aspect_Spec
: Node_Id
)
16071 return Local_Restrict
.Local_Restriction_Set
16073 use Local_Restrict
;
16075 Result
: Local_Restriction_Set
:= (others => False);
16076 Id
: Node_Id
:= Expression
(Aspect_Spec
);
16077 Is_Agg
: constant Boolean := Nkind
(Id
) = N_Aggregate
16078 and then not Is_Empty_List
(Expressions
(Id
));
16081 Id
:= First
(Expressions
(Id
));
16084 while Present
(Id
) loop
16085 if Nkind
(Id
) /= N_Identifier
then
16086 Error_Msg_N
("local restriction name not an identifier", Id
);
16091 Found
: Boolean := False;
16092 Nam
: constant Name_Id
:= Chars
(Id
);
16094 for L_R
in Local_Restriction
loop
16096 S
: String := L_R
'Img;
16098 -- Note that the instance of System.Case_Util.To_Lower that
16101 -- function To_Lower (A : String) return String
16103 -- cannot be used here because it is not present in the
16104 -- run-time library used by the bootstrap compiler at the
16105 -- time of writing.
16107 if Length_Of_Name
(Nam
) = S
'Length
16108 and then Get_Name_String
(Nam
) = S
16110 if Result
(L_R
) then
16111 Error_Msg_N
("local restriction duplicated", Id
);
16115 Result
(L_R
) := True;
16122 Error_Msg_N
("invalid local restriction name", Id
);
16127 exit when not Is_Agg
;
16132 end Parse_Aspect_Local_Restrictions
;
16134 ------------------------------------
16135 -- Parse_Aspect_Stable_Properties --
16136 ------------------------------------
16138 function Parse_Aspect_Stable_Properties
16139 (Aspect_Spec
: Node_Id
; Negated
: out Boolean) return Subprogram_List
16141 function Extract_Entity
(Expr
: Node_Id
) return Entity_Id
;
16142 -- Given an element of a Stable_Properties aspect spec, return the
16143 -- associated entity.
16144 -- This function updates the Negated flag as a side effect.
16146 --------------------
16147 -- Extract_Entity --
16148 --------------------
16150 function Extract_Entity
(Expr
: Node_Id
) return Entity_Id
is
16153 if Nkind
(Expr
) = N_Op_Not
then
16155 Name
:= Right_Opnd
(Expr
);
16160 if Nkind
(Name
) in N_Has_Entity
then
16161 return Entity
(Name
);
16165 end Extract_Entity
;
16172 -- Start of processing for Parse_Aspect_Stable_Properties
16177 if Nkind
(Aspect_Spec
) /= N_Aggregate
then
16178 return (1 => Extract_Entity
(Aspect_Spec
));
16180 L
:= Expressions
(Aspect_Spec
);
16183 return Result
: Subprogram_List
(1 .. List_Length
(L
)) do
16184 for I
in Result
'Range loop
16185 Result
(I
) := Extract_Entity
(Id
);
16187 if No
(Result
(I
)) then
16188 pragma Assert
(Serious_Errors_Detected
> 0);
16189 goto Ignore_Aspect
;
16197 <<Ignore_Aspect
>> return (1 .. 0 => <>);
16198 end Parse_Aspect_Stable_Properties
;
16200 -------------------------------
16201 -- Validate_Aspect_Aggregate --
16202 -------------------------------
16204 procedure Validate_Aspect_Aggregate
(N
: Node_Id
) is
16205 Empty_Subp
: Node_Id
:= Empty
;
16206 Add_Named_Subp
: Node_Id
:= Empty
;
16207 Add_Unnamed_Subp
: Node_Id
:= Empty
;
16208 New_Indexed_Subp
: Node_Id
:= Empty
;
16209 Assign_Indexed_Subp
: Node_Id
:= Empty
;
16212 Error_Msg_Ada_2022_Feature
("aspect Aggregate", Sloc
(N
));
16214 if Nkind
(N
) /= N_Aggregate
16215 or else Present
(Expressions
(N
))
16216 or else No
(Component_Associations
(N
))
16218 Error_Msg_N
("aspect Aggregate requires an aggregate "
16219 & "with component associations", N
);
16223 Parse_Aspect_Aggregate
(N
,
16224 Empty_Subp
, Add_Named_Subp
, Add_Unnamed_Subp
,
16225 New_Indexed_Subp
, Assign_Indexed_Subp
);
16227 if No
(Empty_Subp
) then
16228 Error_Msg_N
("missing specification for Empty in aggregate", N
);
16231 if Present
(Add_Named_Subp
) then
16232 if Present
(Add_Unnamed_Subp
)
16233 or else Present
(Assign_Indexed_Subp
)
16236 ("conflicting operations for aggregate (RM 4.3.5)", N
);
16240 elsif No
(Add_Named_Subp
)
16241 and then No
(Add_Unnamed_Subp
)
16242 and then No
(Assign_Indexed_Subp
)
16244 Error_Msg_N
("incomplete specification for aggregate", N
);
16246 elsif Present
(New_Indexed_Subp
) /= Present
(Assign_Indexed_Subp
) then
16247 Error_Msg_N
("incomplete specification for indexed aggregate", N
);
16249 end Validate_Aspect_Aggregate
;
16251 -----------------------------------------
16252 -- Validate_Aspect_Local_Restrictions --
16253 -----------------------------------------
16255 procedure Validate_Aspect_Local_Restrictions
(E
: Entity_Id
; N
: Node_Id
) is
16256 use Local_Restrict
;
16258 -- Do not check Is_Parenthesis_Aggregate. We don't want to
16259 -- disallow the more familiar parens, but we also don't
16260 -- want to require parens for a homogeneous list.
16262 if Nkind
(N
) = N_Identifier
and then Paren_Count
(N
) = 1 then
16263 -- a positional aggregate with one element (in effect) is ok
16265 elsif Nkind
(N
) /= N_Aggregate
16266 or else No
(Expressions
(N
))
16267 or else Present
(Component_Associations
(N
))
16270 ("aspect Local_Restrictions requires a parenthesized list", N
);
16275 Set
: constant Local_Restriction_Set
16276 := Parse_Aspect_Local_Restrictions
(Parent
(N
));
16277 pragma Unreferenced
(Set
);
16282 -- This will be relaxed later, e.g. for generic subprograms or
16285 if Ekind
(E
) in Subprogram_Kind | E_Package
then
16286 if Get_Renamed_Entity
(E
) /= E
then
16288 ("aspect Local_Restrictions cannot be specified for "
16289 & "a renaming", N
);
16293 ("aspect Local_Restrictions can only be specified for "
16294 & "a subprogram or package spec", N
);
16296 end Validate_Aspect_Local_Restrictions
;
16298 ---------------------------------------
16299 -- Validate_Aspect_Stable_Properties --
16300 ---------------------------------------
16302 procedure Validate_Aspect_Stable_Properties
16303 (E
: Entity_Id
; N
: Node_Id
; Class_Present
: Boolean)
16305 Is_Aspect_Of_Type
: constant Boolean := Is_Type
(E
);
16307 type Permission
is (Forbidden
, Optional
, Required
);
16308 Modifier_Permission
: Permission
:=
16309 (if Is_Aspect_Of_Type
then Forbidden
else Optional
);
16310 Modifier_Error_Called
: Boolean := False;
16312 procedure Check_Property_Function_Arg
(PF_Arg
: Node_Id
);
16313 -- Check syntax of a property function argument
16315 ----------------------------------
16316 -- Check_Property_Function_Arg --
16317 ----------------------------------
16319 procedure Check_Property_Function_Arg
(PF_Arg
: Node_Id
) is
16320 procedure Modifier_Error
;
16321 -- Generate message about bad "not" modifier if no message already
16322 -- generated. Errors include specifying "not" for an aspect of
16323 -- of a type and specifying "not" for some but not all of the
16324 -- names in a list.
16326 --------------------
16327 -- Modifier_Error --
16328 --------------------
16330 procedure Modifier_Error
is
16332 if Modifier_Error_Called
then
16333 return; -- error message already generated
16336 Modifier_Error_Called
:= True;
16338 if Is_Aspect_Of_Type
then
16340 ("NOT modifier not allowed for Stable_Properties aspect"
16341 & " of a type", PF_Arg
);
16343 Error_Msg_N
("mixed use of NOT modifiers", PF_Arg
);
16345 end Modifier_Error
;
16347 PF_Name
: Node_Id
:= PF_Arg
;
16349 -- Start of processing for Check_Property_Function_Arg
16352 if Nkind
(PF_Arg
) = N_Op_Not
then
16353 PF_Name
:= Right_Opnd
(PF_Arg
);
16355 case Modifier_Permission
is
16359 Modifier_Permission
:= Required
;
16364 case Modifier_Permission
is
16368 Modifier_Permission
:= Forbidden
;
16374 if Nkind
(PF_Name
) not in
16375 N_Identifier | N_Operator_Symbol | N_Selected_Component
16377 Error_Msg_N
("bad property function name", PF_Name
);
16379 end Check_Property_Function_Arg
;
16381 -- Start of processing for Validate_Aspect_Stable_Properties
16384 Error_Msg_Ada_2022_Feature
("aspect Stable_Properties", Sloc
(N
));
16386 if not Is_Aspect_Of_Type
and then not Is_Subprogram
(E
) then
16387 Error_Msg_N
("Stable_Properties aspect can only be specified for "
16388 & "a type or a subprogram", N
);
16389 elsif Class_Present
then
16390 if Is_Aspect_Of_Type
then
16391 if not Is_Tagged_Type
(E
) then
16393 ("Stable_Properties''Class aspect cannot be specified for "
16394 & "an untagged type", N
);
16397 if not Is_Dispatching_Operation
(E
) then
16399 ("Stable_Properties''Class aspect cannot be specified for "
16400 & "a subprogram that is not a primitive subprogram "
16401 & "of a tagged type", N
);
16406 if Nkind
(N
) = N_Aggregate
then
16407 if Present
(Component_Associations
(N
))
16408 or else Null_Record_Present
(N
)
16409 or else No
(Expressions
(N
))
16411 Error_Msg_N
("bad Stable_Properties aspect specification", N
);
16416 PF_Arg
: Node_Id
:= First
(Expressions
(N
));
16418 while Present
(PF_Arg
) loop
16419 Check_Property_Function_Arg
(PF_Arg
);
16424 Check_Property_Function_Arg
(N
);
16426 end Validate_Aspect_Stable_Properties
;
16428 --------------------------------
16429 -- Resolve_Iterable_Operation --
16430 --------------------------------
16432 procedure Resolve_Iterable_Operation
16434 Cursor
: Entity_Id
;
16443 if not Is_Overloaded
(N
) then
16444 if not Is_Entity_Name
(N
)
16445 or else Ekind
(Entity
(N
)) /= E_Function
16446 or else Scope
(Entity
(N
)) /= Scope
(Typ
)
16447 or else No
(First_Formal
(Entity
(N
)))
16448 or else Etype
(First_Formal
(Entity
(N
))) /= Typ
16451 ("iterable primitive must be local function name whose first "
16452 & "formal is an iterable type", N
);
16457 F1
:= First_Formal
(Ent
);
16458 F2
:= Next_Formal
(F1
);
16460 if Nam
= Name_First
then
16462 -- First (Container) => Cursor
16464 if Etype
(Ent
) /= Cursor
then
16465 Error_Msg_N
("primitive for First must yield a cursor", N
);
16466 elsif Present
(F2
) then
16467 Error_Msg_N
("no match for First iterable primitive", N
);
16470 elsif Nam
= Name_Last
then
16472 -- Last (Container) => Cursor
16474 if Etype
(Ent
) /= Cursor
then
16475 Error_Msg_N
("primitive for Last must yield a cursor", N
);
16476 elsif Present
(F2
) then
16477 Error_Msg_N
("no match for Last iterable primitive", N
);
16480 elsif Nam
= Name_Next
then
16482 -- Next (Container, Cursor) => Cursor
16485 or else Etype
(F2
) /= Cursor
16486 or else Etype
(Ent
) /= Cursor
16487 or else Present
(Next_Formal
(F2
))
16489 Error_Msg_N
("no match for Next iterable primitive", N
);
16492 elsif Nam
= Name_Previous
then
16494 -- Previous (Container, Cursor) => Cursor
16497 or else Etype
(F2
) /= Cursor
16498 or else Etype
(Ent
) /= Cursor
16499 or else Present
(Next_Formal
(F2
))
16501 Error_Msg_N
("no match for Previous iterable primitive", N
);
16504 elsif Nam
= Name_Has_Element
then
16506 -- Has_Element (Container, Cursor) => Boolean
16509 or else Etype
(F2
) /= Cursor
16510 or else Etype
(Ent
) /= Standard_Boolean
16511 or else Present
(Next_Formal
(F2
))
16513 Error_Msg_N
("no match for Has_Element iterable primitive", N
);
16516 elsif Nam
= Name_Element
then
16518 -- Element (Container, Cursor) => Element_Type;
16521 or else Etype
(F2
) /= Cursor
16522 or else Present
(Next_Formal
(F2
))
16524 Error_Msg_N
("no match for Element iterable primitive", N
);
16528 raise Program_Error
;
16532 -- Overloaded case: find subprogram with proper signature. Caller
16533 -- will report error if no match is found.
16540 Get_First_Interp
(N
, I
, It
);
16541 while Present
(It
.Typ
) loop
16542 if Ekind
(It
.Nam
) = E_Function
16543 and then Scope
(It
.Nam
) = Scope
(Typ
)
16544 and then Present
(First_Formal
(It
.Nam
))
16545 and then Etype
(First_Formal
(It
.Nam
)) = Typ
16547 F1
:= First_Formal
(It
.Nam
);
16549 if Nam
= Name_First
then
16550 if Etype
(It
.Nam
) = Cursor
16551 and then No
(Next_Formal
(F1
))
16553 Set_Entity
(N
, It
.Nam
);
16557 elsif Nam
= Name_Next
then
16558 F2
:= Next_Formal
(F1
);
16561 and then No
(Next_Formal
(F2
))
16562 and then Etype
(F2
) = Cursor
16563 and then Etype
(It
.Nam
) = Cursor
16565 Set_Entity
(N
, It
.Nam
);
16569 elsif Nam
= Name_Has_Element
then
16570 F2
:= Next_Formal
(F1
);
16573 and then No
(Next_Formal
(F2
))
16574 and then Etype
(F2
) = Cursor
16575 and then Etype
(It
.Nam
) = Standard_Boolean
16577 Set_Entity
(N
, It
.Nam
);
16578 F2
:= Next_Formal
(F1
);
16582 elsif Nam
= Name_Element
then
16583 F2
:= Next_Formal
(F1
);
16586 and then No
(Next_Formal
(F2
))
16587 and then Etype
(F2
) = Cursor
16589 Set_Entity
(N
, It
.Nam
);
16595 Get_Next_Interp
(I
, It
);
16599 end Resolve_Iterable_Operation
;
16601 ------------------------------
16602 -- Resolve_Aspect_Aggregate --
16603 ------------------------------
16605 procedure Resolve_Aspect_Aggregate
16609 function Valid_Empty
(E
: Entity_Id
) return Boolean;
16610 function Valid_Add_Named
(E
: Entity_Id
) return Boolean;
16611 function Valid_Add_Unnamed
(E
: Entity_Id
) return Boolean;
16612 function Valid_New_Indexed
(E
: Entity_Id
) return Boolean;
16613 function Valid_Assign_Indexed
(E
: Entity_Id
) return Boolean;
16614 -- Predicates that establish the legality of each possible operation in
16615 -- an Aggregate aspect.
16618 with function Pred
(Id
: Node_Id
) return Boolean;
16619 procedure Resolve_Operation
(Subp_Id
: Node_Id
);
16620 -- Common processing to resolve each aggregate operation.
16622 ------------------------
16623 -- Valid_Assign_Index --
16624 ------------------------
16626 function Valid_Assign_Indexed
(E
: Entity_Id
) return Boolean is
16628 -- The profile must be the same as for Add_Named, with the added
16629 -- requirement that the key_type be a discrete type.
16631 if Valid_Add_Named
(E
) then
16632 return Is_Discrete_Type
(Etype
(Next_Formal
(First_Formal
(E
))));
16636 end Valid_Assign_Indexed
;
16642 function Valid_Empty
(E
: Entity_Id
) return Boolean is
16644 if Etype
(E
) /= Typ
or else Scope
(E
) /= Scope
(Typ
) then
16647 elsif Ekind
(E
) = E_Constant
then
16650 elsif Ekind
(E
) = E_Function
then
16651 return No
(First_Formal
(E
))
16653 (Is_Integer_Type
(Etype
(First_Formal
(E
)))
16654 and then No
(Next_Formal
(First_Formal
(E
))));
16660 ---------------------
16661 -- Valid_Add_Named --
16662 ---------------------
16664 function Valid_Add_Named
(E
: Entity_Id
) return Boolean is
16665 F2
, F3
: Entity_Id
;
16667 if Ekind
(E
) = E_Procedure
16668 and then Scope
(E
) = Scope
(Typ
)
16669 and then Number_Formals
(E
) = 3
16670 and then Etype
(First_Formal
(E
)) = Typ
16671 and then Ekind
(First_Formal
(E
)) = E_In_Out_Parameter
16673 F2
:= Next_Formal
(First_Formal
(E
));
16674 F3
:= Next_Formal
(F2
);
16675 return Ekind
(F2
) = E_In_Parameter
16676 and then Ekind
(F3
) = E_In_Parameter
16677 and then not Is_Limited_Type
(Etype
(F2
))
16678 and then not Is_Limited_Type
(Etype
(F3
));
16682 end Valid_Add_Named
;
16684 -----------------------
16685 -- Valid_Add_Unnamed --
16686 -----------------------
16688 function Valid_Add_Unnamed
(E
: Entity_Id
) return Boolean is
16690 return Ekind
(E
) = E_Procedure
16691 and then Scope
(E
) = Scope
(Typ
)
16692 and then Number_Formals
(E
) = 2
16693 and then Etype
(First_Formal
(E
)) = Typ
16694 and then Ekind
(First_Formal
(E
)) = E_In_Out_Parameter
16696 not Is_Limited_Type
(Etype
(Next_Formal
(First_Formal
(E
))));
16697 end Valid_Add_Unnamed
;
16699 -----------------------
16700 -- Valid_Nmw_Indexed --
16701 -----------------------
16703 function Valid_New_Indexed
(E
: Entity_Id
) return Boolean is
16705 return Ekind
(E
) = E_Function
16706 and then Scope
(E
) = Scope
(Typ
)
16707 and then Etype
(E
) = Typ
16708 and then Number_Formals
(E
) = 2
16709 and then Is_Discrete_Type
(Etype
(First_Formal
(E
)))
16710 and then Etype
(First_Formal
(E
)) =
16711 Etype
(Next_Formal
(First_Formal
(E
)));
16712 end Valid_New_Indexed
;
16714 -----------------------
16715 -- Resolve_Operation --
16716 -----------------------
16718 procedure Resolve_Operation
(Subp_Id
: Node_Id
) is
16725 if not Is_Overloaded
(Subp_Id
) then
16726 Subp
:= Entity
(Subp_Id
);
16727 if not Pred
(Subp
) then
16729 ("improper aggregate operation for&", Subp_Id
, Typ
);
16733 Set_Entity
(Subp_Id
, Empty
);
16734 Get_First_Interp
(Subp_Id
, I
, It
);
16735 while Present
(It
.Nam
) loop
16736 if Pred
(It
.Nam
) then
16737 Set_Is_Overloaded
(Subp_Id
, False);
16738 Set_Entity
(Subp_Id
, It
.Nam
);
16742 Get_Next_Interp
(I
, It
);
16745 if No
(Entity
(Subp_Id
)) then
16747 ("improper aggregate operation for&", Subp_Id
, Typ
);
16750 end Resolve_Operation
;
16756 procedure Resolve_Empty
is new Resolve_Operation
(Valid_Empty
);
16757 procedure Resolve_Unnamed
is new Resolve_Operation
(Valid_Add_Unnamed
);
16758 procedure Resolve_Named
is new Resolve_Operation
(Valid_Add_Named
);
16759 procedure Resolve_Indexed
is new Resolve_Operation
(Valid_New_Indexed
);
16760 procedure Resolve_Assign_Indexed
16761 is new Resolve_Operation
16762 (Valid_Assign_Indexed
);
16764 -- Start of processing for Resolve_Aspect_Aggregate
16767 Assoc
:= First
(Component_Associations
(Expr
));
16769 while Present
(Assoc
) loop
16770 Op_Name
:= Chars
(First
(Choices
(Assoc
)));
16772 -- When verifying the consistency of aspects between the freeze point
16773 -- and the end of declarations, we use a copy which is not analyzed
16774 -- yet, so do it now.
16776 Subp_Id
:= Expression
(Assoc
);
16777 if No
(Etype
(Subp_Id
)) then
16781 if Op_Name
= Name_Empty
then
16782 Resolve_Empty
(Subp_Id
);
16784 elsif Op_Name
= Name_Add_Named
then
16785 Resolve_Named
(Subp_Id
);
16787 elsif Op_Name
= Name_Add_Unnamed
then
16788 Resolve_Unnamed
(Subp_Id
);
16790 elsif Op_Name
= Name_New_Indexed
then
16791 Resolve_Indexed
(Subp_Id
);
16793 elsif Op_Name
= Name_Assign_Indexed
then
16794 Resolve_Assign_Indexed
(Subp_Id
);
16799 end Resolve_Aspect_Aggregate
;
16801 --------------------------------------
16802 -- Resolve_Aspect_Stable_Properties --
16803 --------------------------------------
16805 procedure Resolve_Aspect_Stable_Properties
16806 (Typ_Or_Subp
: Entity_Id
; Expr
: Node_Id
; Class_Present
: Boolean)
16808 Is_Aspect_Of_Type
: constant Boolean := Is_Type
(Typ_Or_Subp
);
16810 Singleton
: constant Boolean := Nkind
(Expr
) /= N_Aggregate
;
16811 Subp_Name
: Node_Id
:= (if Singleton
16813 else First
(Expressions
(Expr
)));
16816 if Is_Aspect_Of_Type
16817 and then Has_Private_Declaration
(Typ_Or_Subp
)
16818 and then not Is_Private_Type
(Typ_Or_Subp
)
16821 ("Stable_Properties aspect cannot be specified " &
16822 "for the completion of a private type", Typ_Or_Subp
);
16825 -- Analogous checks that the aspect is not specified for a completion
16826 -- in the subprogram case are not performed here because they are not
16827 -- specific to this particular aspect. Right ???
16830 Has_Not
:= Nkind
(Subp_Name
) = N_Op_Not
;
16832 Set_Analyzed
(Subp_Name
); -- ???
16833 Subp_Name
:= Right_Opnd
(Subp_Name
);
16836 if No
(Etype
(Subp_Name
)) then
16837 Analyze
(Subp_Name
);
16841 Subp
: Entity_Id
:= Empty
;
16846 function Is_Property_Function
(E
: Entity_Id
) return Boolean;
16847 -- Implements RM 7.3.4 definition of "property function"
16849 --------------------------
16850 -- Is_Property_Function --
16851 --------------------------
16853 function Is_Property_Function
(E
: Entity_Id
) return Boolean is
16855 if Ekind
(E
) not in E_Function | E_Operator
16856 or else Number_Formals
(E
) /= 1
16862 Param_Type
: constant Entity_Id
:=
16863 Base_Type
(Etype
(First_Formal
(E
)));
16865 function Matches_Param_Type
(Typ
: Entity_Id
)
16867 (Base_Type
(Typ
) = Param_Type
16869 (Is_Class_Wide_Type
(Param_Type
)
16870 and then Is_Ancestor
(Root_Type
(Param_Type
),
16871 Base_Type
(Typ
))));
16873 if Is_Aspect_Of_Type
then
16874 if Matches_Param_Type
(Typ_Or_Subp
) then
16877 elsif Is_Primitive
(Typ_Or_Subp
) then
16879 Formal
: Entity_Id
:= First_Formal
(Typ_Or_Subp
);
16881 while Present
(Formal
) loop
16882 if Matches_Param_Type
(Etype
(Formal
)) then
16884 -- Test whether Typ_Or_Subp (which is a subp
16885 -- in this case) is primitive op of the type
16886 -- of this parameter.
16887 if Scope
(Typ_Or_Subp
) = Scope
(Param_Type
) then
16891 Next_Formal
(Formal
);
16898 end Is_Property_Function
;
16900 if not Is_Overloaded
(Subp_Name
) then
16901 Subp
:= Entity
(Subp_Name
);
16902 if not Is_Property_Function
(Subp
) then
16903 Error_Msg_NE
("improper property function for&",
16904 Subp_Name
, Typ_Or_Subp
);
16908 Set_Entity
(Subp_Name
, Empty
);
16909 Get_First_Interp
(Subp_Name
, I
, It
);
16910 while Present
(It
.Nam
) loop
16911 if Is_Property_Function
(It
.Nam
) then
16912 if Present
(Subp
) then
16914 ("ambiguous property function name for&",
16915 Subp_Name
, Typ_Or_Subp
);
16920 Set_Is_Overloaded
(Subp_Name
, False);
16921 Set_Entity
(Subp_Name
, Subp
);
16924 Get_Next_Interp
(I
, It
);
16928 Error_Msg_NE
("improper property function for&",
16929 Subp_Name
, Typ_Or_Subp
);
16934 -- perform legality (as opposed to name resolution) Subp checks
16936 if Is_Limited_Type
(Etype
(Subp
)) then
16938 ("result type of property function for& is limited",
16939 Subp_Name
, Typ_Or_Subp
);
16942 if Ekind
(First_Formal
(Subp
)) /= E_In_Parameter
then
16944 ("mode of parameter of property function for& is not IN",
16945 Subp_Name
, Typ_Or_Subp
);
16948 if Is_Class_Wide_Type
(Etype
(First_Formal
(Subp
))) then
16949 if not Covers
(Etype
(First_Formal
(Subp
)), Typ_Or_Subp
) then
16951 ("class-wide parameter type of property function " &
16952 "for& does not cover the type",
16953 Subp_Name
, Typ_Or_Subp
);
16955 -- ??? This test is slightly stricter than 7.3.4(12/5);
16956 -- some legal corner cases may be incorrectly rejected.
16957 elsif Scope
(Subp
) /= Scope
(Etype
(First_Formal
(Subp
)))
16960 ("property function for& not declared in same scope " &
16961 "as parameter type",
16962 Subp_Name
, Typ_Or_Subp
);
16964 elsif Is_Aspect_Of_Type
and then
16965 Scope
(Subp
) /= Scope
(Typ_Or_Subp
) and then
16966 Scope
(Subp
) /= Standard_Standard
-- e.g., derived type's "abs"
16969 ("property function for& " &
16970 "not a primitive function of the type",
16971 Subp_Name
, Typ_Or_Subp
);
16975 -- check that Subp was mentioned in param type's aspect spec
16977 Param_Type
: constant Entity_Id
:=
16978 Base_Type
(Etype
(First_Formal
(Subp
)));
16979 Aspect_Spec
: constant Node_Id
:=
16980 Find_Value_Of_Aspect
16981 (Param_Type
, Aspect_Stable_Properties
,
16982 Class_Present
=> Class_Present
);
16983 Found
: Boolean := False;
16985 if Present
(Aspect_Spec
) then
16988 SPF_List
: constant Subprogram_List
:=
16989 Parse_Aspect_Stable_Properties
16990 (Aspect_Spec
, Negated
=> Ignored
);
16992 Found
:= (for some E
of SPF_List
=> E
= Subp
);
16993 -- look through renamings ???
16998 CW_Modifier
: constant String :=
16999 (if Class_Present
then "class-wide " else "");
17003 & "property function for& mentioned after NOT "
17006 & "stable property function of its parameter type",
17007 Subp_Name
, Typ_Or_Subp
);
17014 exit when Singleton
;
17016 Next
((if Has_Not
then Parent
(Subp_Name
) else Subp_Name
));
17017 exit when No
(Subp_Name
);
17020 Set_Analyzed
(Expr
);
17021 end Resolve_Aspect_Stable_Properties
;
17023 -----------------------------------------
17024 -- Resolve_Storage_Model_Type_Argument --
17025 -----------------------------------------
17027 procedure Resolve_Storage_Model_Type_Argument
17030 Addr_Type
: in out Entity_Id
;
17034 type Formal_Profile
is record
17036 Mode
: Formal_Kind
;
17039 type Formal_Profiles
is array (Positive range <>) of Formal_Profile
;
17041 function Aspect_Argument_Profile_Matches
17043 Profiles
: Formal_Profiles
;
17044 Result_Subt
: Entity_Id
;
17045 Err_On_Mismatch
: Boolean) return Boolean;
17046 -- Checks that the formal parameters of subprogram Subp conform to the
17047 -- subtypes and modes specified by Profiles, as well as to the result
17048 -- subtype Result_Subt when that is nonempty.
17050 function Aspect_Argument_Profile_Matches
17052 Profiles
: Formal_Profiles
;
17053 Result_Subt
: Entity_Id
;
17054 Err_On_Mismatch
: Boolean) return Boolean
17057 procedure Report_Argument_Error
17059 Formal
: Entity_Id
:= Empty
;
17060 Subt
: Entity_Id
:= Empty
);
17061 -- If Err_On_Mismatch is True, reports an argument error given by Msg
17062 -- associated with Formal and/or Subt.
17064 procedure Report_Argument_Error
17066 Formal
: Entity_Id
:= Empty
;
17067 Subt
: Entity_Id
:= Empty
)
17070 if Err_On_Mismatch
then
17071 if Present
(Formal
) then
17072 if Present
(Subt
) then
17073 Error_Msg_Node_2
:= Subt
;
17075 Error_Msg_NE
(Msg
, N
, Formal
);
17077 elsif Present
(Subt
) then
17078 Error_Msg_NE
(Msg
, N
, Subt
);
17081 Error_Msg_N
(Msg
, N
);
17084 end Report_Argument_Error
;
17088 Formal
: Entity_Id
:= First_Formal
(Subp
);
17089 Is_Error
: Boolean := False;
17091 -- Start of processing for Aspect_Argument_Profile_Matches
17094 for FP
of Profiles
loop
17095 if No
(Formal
) then
17097 Report_Argument_Error
("missing formal of }", Subt
=> FP
.Subt
);
17100 elsif not Subtypes_Statically_Match
17101 (Etype
(Formal
), FP
.Subt
)
17104 Report_Argument_Error
17105 ("formal& must be of subtype&",
17106 Formal
=> Formal
, Subt
=> FP
.Subt
);
17109 elsif Ekind
(Formal
) /= FP
.Mode
then
17111 Report_Argument_Error
17112 ("formal& has wrong mode", Formal
=> Formal
);
17116 Formal
:= Next_Formal
(Formal
);
17120 and then Present
(Formal
)
17123 Report_Argument_Error
17124 ("too many formals for subprogram in aspect");
17128 and then Present
(Result_Subt
)
17129 and then not Subtypes_Statically_Match
(Etype
(Subp
), Result_Subt
)
17132 Report_Argument_Error
17133 ("subprogram must have result}", Subt
=> Result_Subt
);
17136 return not Is_Error
;
17137 end Aspect_Argument_Profile_Matches
;
17143 Storage_Count_Type
: constant Entity_Id
:= RTE
(RE_Storage_Count
);
17144 System_Address_Type
: constant Entity_Id
:= RTE
(RE_Address
);
17146 -- Start of processing for Resolve_Storage_Model_Type_Argument
17149 if Nam
= Name_Address_Type
then
17150 if not Is_Entity_Name
(N
)
17151 or else not Is_Type
(Entity
(N
))
17152 or else (Root_Type
(Entity
(N
)) /= System_Address_Type
17153 and then not Is_Integer_Type
(Entity
(N
)))
17155 Error_Msg_N
("named entity must be a descendant of System.Address "
17156 & "or an integer type", N
);
17159 Addr_Type
:= Entity
(N
);
17163 -- If Addr_Type is not present as the first association, then we default
17164 -- it to System.Address.
17166 elsif No
(Addr_Type
) then
17167 Addr_Type
:= RTE
(RE_Address
);
17170 if Nam
= Name_Null_Address
then
17171 if not Is_Entity_Name
(N
)
17172 or else not Is_Constant_Object
(Entity
(N
))
17174 not Subtypes_Statically_Match
(Etype
(Entity
(N
)), Addr_Type
)
17177 ("named entity must be constant of subtype}", N
, Addr_Type
);
17182 elsif not Is_Overloaded
(N
) then
17183 if not Is_Entity_Name
(N
)
17184 or else Ekind
(Entity
(N
)) not in E_Function | E_Procedure
17185 or else Scope
(Entity
(N
)) /= Scope
(Typ
)
17187 Error_Msg_N
("argument must be local subprogram name", N
);
17193 if Nam
= Name_Allocate
then
17194 if not Aspect_Argument_Profile_Matches
17197 ((Typ
, E_In_Out_Parameter
),
17198 (Addr_Type
, E_Out_Parameter
),
17199 (Storage_Count_Type
, E_In_Parameter
),
17200 (Storage_Count_Type
, E_In_Parameter
)),
17201 Result_Subt
=> Empty
,
17202 Err_On_Mismatch
=> True)
17204 Error_Msg_N
("no match for Allocate operation", N
);
17207 elsif Nam
= Name_Deallocate
then
17208 if not Aspect_Argument_Profile_Matches
17211 ((Typ
, E_In_Out_Parameter
),
17212 (Addr_Type
, E_In_Parameter
),
17213 (Storage_Count_Type
, E_In_Parameter
),
17214 (Storage_Count_Type
, E_In_Parameter
)),
17215 Result_Subt
=> Empty
,
17216 Err_On_Mismatch
=> True)
17218 Error_Msg_N
("no match for Deallocate operation", N
);
17221 elsif Nam
= Name_Copy_From
then
17222 if not Aspect_Argument_Profile_Matches
17225 ((Typ
, E_In_Out_Parameter
),
17226 (System_Address_Type
, E_In_Parameter
),
17227 (Addr_Type
, E_In_Parameter
),
17228 (Storage_Count_Type
, E_In_Parameter
)),
17229 Result_Subt
=> Empty
,
17230 Err_On_Mismatch
=> True)
17232 Error_Msg_N
("no match for Copy_From operation", N
);
17235 elsif Nam
= Name_Copy_To
then
17236 if not Aspect_Argument_Profile_Matches
17239 ((Typ
, E_In_Out_Parameter
),
17240 (Addr_Type
, E_In_Parameter
),
17241 (System_Address_Type
, E_In_Parameter
),
17242 (Storage_Count_Type
, E_In_Parameter
)),
17243 Result_Subt
=> Empty
,
17244 Err_On_Mismatch
=> True)
17246 Error_Msg_N
("no match for Copy_To operation", N
);
17249 elsif Nam
= Name_Storage_Size
then
17250 if not Aspect_Argument_Profile_Matches
17252 Profiles
=> (1 => (Typ
, E_In_Parameter
)),
17253 Result_Subt
=> Storage_Count_Type
,
17254 Err_On_Mismatch
=> True)
17256 Error_Msg_N
("no match for Storage_Size operation", N
);
17260 null; -- Error will be caught in Validate_Storage_Model_Type_Aspect
17264 -- Overloaded case: find subprogram with proper signature
17269 Found_Match
: Boolean := False;
17272 Get_First_Interp
(N
, I
, It
);
17273 while Present
(It
.Typ
) loop
17274 if Ekind
(It
.Nam
) in E_Function | E_Procedure
17275 and then Scope
(It
.Nam
) = Scope
(Typ
)
17277 if Nam
= Name_Allocate
then
17279 Aspect_Argument_Profile_Matches
17282 ((Typ
, E_In_Out_Parameter
),
17283 (Addr_Type
, E_Out_Parameter
),
17284 (Storage_Count_Type
, E_In_Parameter
),
17285 (Storage_Count_Type
, E_In_Parameter
)),
17286 Result_Subt
=> Empty
,
17287 Err_On_Mismatch
=> False);
17289 elsif Nam
= Name_Deallocate
then
17291 Aspect_Argument_Profile_Matches
17294 ((Typ
, E_In_Out_Parameter
),
17295 (Addr_Type
, E_In_Parameter
),
17296 (Storage_Count_Type
, E_In_Parameter
),
17297 (Storage_Count_Type
, E_In_Parameter
)),
17298 Result_Subt
=> Empty
,
17299 Err_On_Mismatch
=> False);
17301 elsif Nam
= Name_Copy_From
then
17303 Aspect_Argument_Profile_Matches
17306 ((Typ
, E_In_Out_Parameter
),
17307 (System_Address_Type
, E_In_Parameter
),
17308 (Addr_Type
, E_In_Parameter
),
17309 (Storage_Count_Type
, E_In_Parameter
),
17310 (Storage_Count_Type
, E_In_Parameter
)),
17311 Result_Subt
=> Empty
,
17312 Err_On_Mismatch
=> False);
17314 elsif Nam
= Name_Copy_To
then
17316 Aspect_Argument_Profile_Matches
17319 ((Typ
, E_In_Out_Parameter
),
17320 (Addr_Type
, E_In_Parameter
),
17321 (Storage_Count_Type
, E_In_Parameter
),
17322 (System_Address_Type
, E_In_Parameter
),
17323 (Storage_Count_Type
, E_In_Parameter
)),
17324 Result_Subt
=> Empty
,
17325 Err_On_Mismatch
=> False);
17327 elsif Nam
= Name_Storage_Size
then
17329 Aspect_Argument_Profile_Matches
17331 Profiles
=> (1 => (Typ
, E_In_Parameter
)),
17332 Result_Subt
=> Storage_Count_Type
,
17333 Err_On_Mismatch
=> False);
17336 if Found_Match
then
17337 Set_Entity
(N
, It
.Nam
);
17342 Get_Next_Interp
(I
, It
);
17345 if not Found_Match
then
17347 ("no match found for Storage_Model_Type operation", N
);
17351 end Resolve_Storage_Model_Type_Argument
;
17357 procedure Set_Biased
17361 Biased
: Boolean := True)
17365 Set_Has_Biased_Representation
(E
);
17367 if Warn_On_Biased_Representation
then
17369 ("?.b?" & Msg
& " forces biased representation for&", N
, E
);
17374 --------------------
17375 -- Set_Enum_Esize --
17376 --------------------
17378 procedure Set_Enum_Esize
(T
: Entity_Id
) is
17384 -- Find the minimum standard size (8,16,32,64,128) that fits
17386 Lo
:= Enumeration_Rep
(Entity
(Type_Low_Bound
(T
)));
17387 Hi
:= Enumeration_Rep
(Entity
(Type_High_Bound
(T
)));
17390 if Lo
>= -Uint_2
**7 and then Hi
< Uint_2
**7 then
17391 Sz
:= UI_From_Int
(Standard_Character_Size
);
17392 -- Might be > 8 on some targets
17394 elsif Lo
>= -Uint_2
**15 and then Hi
< Uint_2
**15 then
17397 elsif Lo
>= -Uint_2
**31 and then Hi
< Uint_2
**31 then
17400 elsif Lo
>= -Uint_2
**63 and then Hi
< Uint_2
**63 then
17403 else pragma Assert
(Lo
>= -Uint_2
**127 and then Hi
< Uint_2
**127);
17408 if Hi
< Uint_2
**8 then
17409 Sz
:= UI_From_Int
(Standard_Character_Size
);
17411 elsif Hi
< Uint_2
**16 then
17414 elsif Hi
< Uint_2
**32 then
17417 elsif Hi
< Uint_2
**64 then
17420 else pragma Assert
(Hi
< Uint_2
**128);
17425 -- That minimum is the proper size unless we have a foreign convention
17426 -- and the size required is 32 or less, in which case we bump the size
17427 -- up to 32. This is required for C and C++ and seems reasonable for
17428 -- all other foreign conventions.
17430 if Has_Foreign_Convention
(T
)
17431 and then Esize
(T
) < Standard_Integer_Size
17433 -- Don't do this if Short_Enums on target
17435 and then not Target_Short_Enums
17437 Set_Esize
(T
, UI_From_Int
(Standard_Integer_Size
));
17441 end Set_Enum_Esize
;
17443 -----------------------------
17444 -- Uninstall_Discriminants --
17445 -----------------------------
17447 procedure Uninstall_Discriminants
(E
: Entity_Id
) is
17453 -- Discriminants have been made visible for type declarations and
17454 -- protected type declarations, not for subtype declarations.
17456 if Nkind
(Parent
(E
)) /= N_Subtype_Declaration
then
17457 Disc
:= First_Discriminant
(E
);
17458 while Present
(Disc
) loop
17459 if Disc
/= Current_Entity
(Disc
) then
17460 Prev
:= Current_Entity
(Disc
);
17461 while Present
(Prev
)
17462 and then Present
(Homonym
(Prev
))
17463 and then Homonym
(Prev
) /= Disc
17465 Prev
:= Homonym
(Prev
);
17471 Set_Is_Immediately_Visible
(Disc
, False);
17473 Outer
:= Homonym
(Disc
);
17474 while Present
(Outer
) and then Scope
(Outer
) = E
loop
17475 Outer
:= Homonym
(Outer
);
17478 -- Reset homonym link of other entities, but do not modify link
17479 -- between entities in current scope, so that the back end can
17480 -- have a proper count of local overloadings.
17483 Set_Name_Entity_Id
(Chars
(Disc
), Outer
);
17485 elsif Scope
(Prev
) /= Scope
(Disc
) then
17486 Set_Homonym
(Prev
, Outer
);
17489 Next_Discriminant
(Disc
);
17492 end Uninstall_Discriminants
;
17494 ------------------------------
17495 -- Validate_Address_Clauses --
17496 ------------------------------
17498 procedure Validate_Address_Clauses
is
17499 function Offset_Value
(Expr
: Node_Id
) return Uint
;
17500 -- Given an Address attribute reference, return the value in bits of its
17501 -- offset from the first bit of the underlying entity, or 0 if it is not
17502 -- known at compile time.
17508 function Offset_Value
(Expr
: Node_Id
) return Uint
is
17509 N
: Node_Id
:= Prefix
(Expr
);
17511 Val
: Uint
:= Uint_0
;
17514 -- Climb the prefix chain and compute the cumulative offset
17517 if Is_Entity_Name
(N
) then
17520 elsif Nkind
(N
) = N_Selected_Component
then
17521 Off
:= Component_Bit_Offset
(Entity
(Selector_Name
(N
)));
17522 if Present
(Off
) and then Off
>= Uint_0
then
17529 elsif Nkind
(N
) = N_Indexed_Component
then
17530 Off
:= Indexed_Component_Bit_Offset
(N
);
17531 if Present
(Off
) then
17544 -- Start of processing for Validate_Address_Clauses
17547 for J
in Address_Clause_Checks
.First
.. Address_Clause_Checks
.Last
loop
17549 ACCR
: Address_Clause_Check_Record
17550 renames Address_Clause_Checks
.Table
(J
);
17554 X_Alignment
: Uint
;
17555 Y_Alignment
: Uint
:= Uint_0
;
17558 Y_Size
: Uint
:= Uint_0
;
17563 -- Skip processing of this entry if warning already posted, or if
17564 -- alignments are not set.
17566 if not Address_Warning_Posted
(ACCR
.N
)
17567 and then Known_Alignment
(ACCR
.X
)
17568 and then Known_Alignment
(ACCR
.Y
)
17570 Expr
:= Original_Node
(Expression
(ACCR
.N
));
17572 -- Get alignments, sizes and offset, if any
17574 X_Alignment
:= Alignment
(ACCR
.X
);
17575 X_Size
:= Esize
(ACCR
.X
);
17577 if Present
(ACCR
.Y
) then
17578 Y_Alignment
:= Alignment
(ACCR
.Y
);
17580 (if Known_Esize
(ACCR
.Y
) then Esize
(ACCR
.Y
) else Uint_0
);
17584 and then Nkind
(Expr
) = N_Attribute_Reference
17585 and then Attribute_Name
(Expr
) = Name_Address
17587 X_Offs
:= Offset_Value
(Expr
);
17592 -- Check for known value not multiple of alignment
17594 if No
(ACCR
.Y
) then
17595 if not Alignment_Checks_Suppressed
(ACCR
)
17596 and then X_Alignment
/= 0
17597 and then ACCR
.A
mod X_Alignment
/= 0
17600 ("??specified address for& is inconsistent with "
17601 & "alignment", ACCR
.N
, ACCR
.X
);
17603 ("\??program execution may be erroneous (RM 13.3(27))",
17606 Error_Msg_Uint_1
:= X_Alignment
;
17607 Error_Msg_NE
("\??alignment of & is ^", ACCR
.N
, ACCR
.X
);
17610 -- Check for large object overlaying smaller one
17612 elsif Y_Size
> Uint_0
17613 and then X_Size
> Uint_0
17614 and then X_Offs
+ X_Size
> Y_Size
17616 Error_Msg_NE
("??& overlays smaller object", ACCR
.N
, ACCR
.X
);
17618 ("\??program execution may be erroneous", ACCR
.N
);
17620 Error_Msg_Uint_1
:= X_Size
;
17621 Error_Msg_NE
("\??size of & is ^", ACCR
.N
, ACCR
.X
);
17623 Error_Msg_Uint_1
:= Y_Size
;
17624 Error_Msg_NE
("\??size of & is ^", ACCR
.N
, ACCR
.Y
);
17626 if Y_Size
>= X_Size
then
17627 Error_Msg_Uint_1
:= X_Offs
;
17628 Error_Msg_NE
("\??but offset of & is ^", ACCR
.N
, ACCR
.X
);
17631 -- Check for inadequate alignment, both of the base object
17632 -- and of the offset, if any. We only do this check if the
17633 -- run-time Alignment_Check is active. No point in warning
17634 -- if this check has been suppressed (or is suppressed by
17635 -- default in the non-strict alignment machine case).
17637 -- Note: we do not check the alignment if we gave a size
17638 -- warning, since it would likely be redundant.
17640 elsif not Alignment_Checks_Suppressed
(ACCR
)
17641 and then Y_Alignment
/= Uint_0
17643 (Y_Alignment
< X_Alignment
17646 and then Nkind
(Expr
) = N_Attribute_Reference
17647 and then Attribute_Name
(Expr
) = Name_Address
17648 and then Has_Compatible_Alignment
17649 (ACCR
.X
, Prefix
(Expr
), True) /=
17653 ("??specified address for& may be inconsistent with "
17654 & "alignment", ACCR
.N
, ACCR
.X
);
17656 ("\??program execution may be erroneous (RM 13.3(27))",
17659 Error_Msg_Uint_1
:= X_Alignment
;
17660 Error_Msg_NE
("\??alignment of & is ^", ACCR
.N
, ACCR
.X
);
17662 Error_Msg_Uint_1
:= Y_Alignment
;
17663 Error_Msg_NE
("\??alignment of & is ^", ACCR
.N
, ACCR
.Y
);
17665 if Y_Alignment
>= X_Alignment
then
17667 ("\??but offset is not multiple of alignment", ACCR
.N
);
17673 end Validate_Address_Clauses
;
17675 ------------------------------
17676 -- Validate_Iterable_Aspect --
17677 ------------------------------
17679 procedure Validate_Iterable_Aspect
(Typ
: Entity_Id
; ASN
: Node_Id
) is
17680 Aggr
: constant Node_Id
:= Expression
(ASN
);
17685 Cursor
: Entity_Id
;
17687 First_Id
: Entity_Id
:= Empty
;
17688 Last_Id
: Entity_Id
:= Empty
;
17689 Next_Id
: Entity_Id
:= Empty
;
17690 Has_Element_Id
: Entity_Id
:= Empty
;
17691 Element_Id
: Entity_Id
:= Empty
;
17694 if Nkind
(Aggr
) /= N_Aggregate
then
17695 Error_Msg_N
("aspect Iterable must be an aggregate", Aggr
);
17699 Cursor
:= Get_Cursor_Type
(ASN
, Typ
);
17701 -- If previous error aspect is unusable
17703 if Cursor
= Any_Type
then
17707 if not Is_Empty_List
(Expressions
(Aggr
)) then
17709 ("illegal positional association", First
(Expressions
(Aggr
)));
17712 -- Each expression must resolve to a function with the proper signature
17714 Assoc
:= First
(Component_Associations
(Aggr
));
17715 while Present
(Assoc
) loop
17716 Expr
:= Expression
(Assoc
);
17719 Prim
:= First
(Choices
(Assoc
));
17721 if Nkind
(Prim
) /= N_Identifier
or else Present
(Next
(Prim
)) then
17722 Error_Msg_N
("illegal name in association", Prim
);
17724 elsif Chars
(Prim
) = Name_First
then
17725 Resolve_Iterable_Operation
(Expr
, Cursor
, Typ
, Name_First
);
17726 First_Id
:= Entity
(Expr
);
17728 elsif Chars
(Prim
) = Name_Last
then
17729 Resolve_Iterable_Operation
(Expr
, Cursor
, Typ
, Name_Last
);
17730 Last_Id
:= Entity
(Expr
);
17732 elsif Chars
(Prim
) = Name_Previous
then
17733 Resolve_Iterable_Operation
(Expr
, Cursor
, Typ
, Name_Previous
);
17734 Last_Id
:= Entity
(Expr
);
17736 elsif Chars
(Prim
) = Name_Next
then
17737 Resolve_Iterable_Operation
(Expr
, Cursor
, Typ
, Name_Next
);
17738 Next_Id
:= Entity
(Expr
);
17740 elsif Chars
(Prim
) = Name_Has_Element
then
17741 Resolve_Iterable_Operation
(Expr
, Cursor
, Typ
, Name_Has_Element
);
17742 Has_Element_Id
:= Entity
(Expr
);
17744 elsif Chars
(Prim
) = Name_Element
then
17745 Resolve_Iterable_Operation
(Expr
, Cursor
, Typ
, Name_Element
);
17746 Element_Id
:= Entity
(Expr
);
17749 Error_Msg_N
("invalid name for iterable function", Prim
);
17755 if No
(First_Id
) then
17756 Error_Msg_N
("match for First primitive not found", ASN
);
17758 elsif No
(Next_Id
) then
17759 Error_Msg_N
("match for Next primitive not found", ASN
);
17761 elsif No
(Has_Element_Id
) then
17762 Error_Msg_N
("match for Has_Element primitive not found", ASN
);
17764 elsif No
(Element_Id
) or else No
(Last_Id
) then
17767 end Validate_Iterable_Aspect
;
17769 ------------------------------
17770 -- Validate_Literal_Aspect --
17771 ------------------------------
17773 procedure Validate_Literal_Aspect
(Typ
: Entity_Id
; ASN
: Node_Id
) is
17774 A_Id
: constant Aspect_Id
:= Get_Aspect_Id
(ASN
);
17775 pragma Assert
(A_Id
in Aspect_Integer_Literal |
17776 Aspect_Real_Literal | Aspect_String_Literal
);
17777 Func_Name
: constant Node_Id
:= Expression
(ASN
);
17778 Overloaded
: Boolean := Is_Overloaded
(Func_Name
);
17780 I
: Interp_Index
:= 0;
17782 Param_Type
: Entity_Id
;
17783 Match_Found
: Boolean := False;
17784 Match2_Found
: Boolean := False;
17785 Is_Match
: Boolean;
17787 Match2
: Entity_Id
:= Empty
;
17790 (Param_Id
: Entity_Id
; Param_Type
: Entity_Id
) return Boolean;
17791 -- Return True if Param_Id is a non aliased in parameter whose base type
17799 (Param_Id
: Entity_Id
; Param_Type
: Entity_Id
) return Boolean is
17801 return Base_Type
(Etype
(Param_Id
)) = Param_Type
17802 and then Ekind
(Param_Id
) = E_In_Parameter
17803 and then not Is_Aliased
(Param_Id
);
17807 if not Is_Type
(Typ
) then
17808 Error_Msg_N
("aspect can only be specified for a type", ASN
);
17811 elsif not Is_First_Subtype
(Typ
) then
17812 Error_Msg_N
("aspect cannot be specified for a subtype", ASN
);
17816 if A_Id
= Aspect_String_Literal
then
17817 if Is_String_Type
(Typ
) then
17818 Error_Msg_N
("aspect cannot be specified for a string type", ASN
);
17822 Param_Type
:= Standard_Wide_Wide_String
;
17825 if Is_Numeric_Type
(Typ
) then
17826 Error_Msg_N
("aspect cannot be specified for a numeric type", ASN
);
17830 Param_Type
:= Standard_String
;
17833 if not Overloaded
and then No
(Entity
(Func_Name
)) then
17834 -- The aspect is specified by a subprogram name, which
17835 -- may be an operator name given originally by a string.
17837 if Is_Operator_Name
(Chars
(Func_Name
)) then
17838 Analyze_Operator_Symbol
(Func_Name
);
17840 Analyze
(Func_Name
);
17843 Overloaded
:= Is_Overloaded
(Func_Name
);
17847 Get_First_Interp
(Func_Name
, I
=> I
, It
=> It
);
17849 -- only one possible interpretation
17850 It
.Nam
:= Entity
(Func_Name
);
17851 pragma Assert
(Present
(It
.Nam
));
17854 while It
.Nam
/= Empty
loop
17857 if Ekind
(It
.Nam
) = E_Function
17858 and then Base_Type
(Etype
(It
.Nam
)) = Base_Type
(Typ
)
17861 Params
: constant List_Id
:=
17862 Parameter_Specifications
(Parent
(It
.Nam
));
17863 Param_Spec
: Node_Id
;
17866 if List_Length
(Params
) = 1 then
17867 Param_Spec
:= First
(Params
);
17869 Matching
(Defining_Identifier
(Param_Spec
), Param_Type
);
17871 -- Look for the optional overloaded 2-param Real_Literal
17873 elsif List_Length
(Params
) = 2
17874 and then A_Id
= Aspect_Real_Literal
17876 Param_Spec
:= First
(Params
);
17878 if Matching
(Defining_Identifier
(Param_Spec
), Param_Type
)
17880 Param_Spec
:= Next
(Param_Spec
);
17882 if Matching
(Defining_Identifier
(Param_Spec
), Param_Type
)
17884 if No
(Match2
) then
17886 Match2_Found
:= True;
17888 -- If we find more than one possible match then
17889 -- do not take any into account here: since the
17890 -- 2-parameter version of Real_Literal is optional
17891 -- we cannot generate an error here, so let
17892 -- standard resolution fail later if we do need to
17893 -- call this variant.
17895 Match2_Found
:= False;
17904 if Match_Found
then
17905 Error_Msg_N
("aspect specification is ambiguous", ASN
);
17909 Match_Found
:= True;
17913 exit when not Overloaded
;
17915 if not Is_Match
then
17916 Remove_Interp
(I
=> I
);
17919 Get_Next_Interp
(I
=> I
, It
=> It
);
17922 if not Match_Found
then
17924 ("function name in aspect specification cannot be resolved", ASN
);
17928 Set_Entity
(Func_Name
, Match
.Nam
);
17929 Set_Etype
(Func_Name
, Etype
(Match
.Nam
));
17930 Set_Is_Overloaded
(Func_Name
, False);
17932 -- Record the match for 2-parameter function if found
17934 if Match2_Found
then
17935 Set_Related_Expression
(Match
.Nam
, Match2
);
17937 end Validate_Literal_Aspect
;
17939 ----------------------------------------
17940 -- Validate_Storage_Model_Type_Aspect --
17941 ----------------------------------------
17943 procedure Validate_Storage_Model_Type_Aspect
17944 (Typ
: Entity_Id
; ASN
: Node_Id
)
17947 Choice
: Entity_Id
;
17948 Choice_Name
: Name_Id
;
17951 Address_Type_Id
: Entity_Id
:= Empty
;
17952 Null_Address_Id
: Entity_Id
:= Empty
;
17953 Allocate_Id
: Entity_Id
:= Empty
;
17954 Deallocate_Id
: Entity_Id
:= Empty
;
17955 Copy_From_Id
: Entity_Id
:= Empty
;
17956 Copy_To_Id
: Entity_Id
:= Empty
;
17957 Storage_Size_Id
: Entity_Id
:= Empty
;
17959 procedure Check_And_Resolve_Storage_Model_Type_Argument
17962 Argument_Id
: in out Entity_Id
;
17964 -- Checks that the subaspect for Nam has not already been specified for
17965 -- Typ's Storage_Model_Type aspect (i.e., checks Argument_Id = Empty),
17966 -- resolves Expr, and sets Argument_Id to the entity resolved for Expr.
17968 procedure Check_And_Resolve_Storage_Model_Type_Argument
17971 Argument_Id
: in out Entity_Id
;
17974 Name_String
: String := Get_Name_String
(Nam
);
17977 To_Mixed
(Name_String
);
17979 if Present
(Argument_Id
) then
17980 Error_Msg_String
(1 .. Name_String
'Length) := Name_String
;
17981 Error_Msg_Strlen
:= Name_String
'Length;
17983 Error_Msg_N
("~ already specified", Expr
);
17986 Resolve_Storage_Model_Type_Argument
(Expr
, Typ
, Address_Type_Id
, Nam
);
17987 Argument_Id
:= Entity
(Expr
);
17988 end Check_And_Resolve_Storage_Model_Type_Argument
;
17990 -- Start of processing for Validate_Storage_Model_Type_Aspect
17993 -- The aggregate argument of Storage_Model_Type is optional, and when
17994 -- not present the aspect defaults to the native storage model (where
17995 -- the address type is System.Address, and other arguments default to
17996 -- the corresponding native storage operations).
17998 if No
(Expression
(ASN
)) then
18002 -- Each expression must resolve to an entity of the right kind or proper
18005 Assoc
:= First
(Component_Associations
(Expression
(ASN
)));
18006 while Present
(Assoc
) loop
18007 Expr
:= Expression
(Assoc
);
18010 Choice
:= First
(Choices
(Assoc
));
18012 Choice_Name
:= Chars
(Choice
);
18014 if Nkind
(Choice
) /= N_Identifier
or else Present
(Next
(Choice
)) then
18015 Error_Msg_N
("illegal name in association", Choice
);
18017 elsif Choice_Name
= Name_Address_Type
then
18018 if Assoc
/= First
(Component_Associations
(Expression
(ASN
))) then
18019 Error_Msg_N
("Address_Type must be first association", Choice
);
18022 Check_And_Resolve_Storage_Model_Type_Argument
18023 (Expr
, Typ
, Address_Type_Id
, Name_Address_Type
);
18026 -- It's allowed to leave out the Address_Type argument, in which
18027 -- case the address type is defined to default to System.Address.
18029 if No
(Address_Type_Id
) then
18030 Address_Type_Id
:= RTE
(RE_Address
);
18033 if Choice_Name
= Name_Null_Address
then
18034 Check_And_Resolve_Storage_Model_Type_Argument
18035 (Expr
, Typ
, Null_Address_Id
, Name_Null_Address
);
18037 elsif Choice_Name
= Name_Allocate
then
18038 Check_And_Resolve_Storage_Model_Type_Argument
18039 (Expr
, Typ
, Allocate_Id
, Name_Allocate
);
18041 elsif Choice_Name
= Name_Deallocate
then
18042 Check_And_Resolve_Storage_Model_Type_Argument
18043 (Expr
, Typ
, Deallocate_Id
, Name_Deallocate
);
18045 elsif Choice_Name
= Name_Copy_From
then
18046 Check_And_Resolve_Storage_Model_Type_Argument
18047 (Expr
, Typ
, Copy_From_Id
, Name_Copy_From
);
18049 elsif Choice_Name
= Name_Copy_To
then
18050 Check_And_Resolve_Storage_Model_Type_Argument
18051 (Expr
, Typ
, Copy_To_Id
, Name_Copy_To
);
18053 elsif Choice_Name
= Name_Storage_Size
then
18054 Check_And_Resolve_Storage_Model_Type_Argument
18055 (Expr
, Typ
, Storage_Size_Id
, Name_Storage_Size
);
18059 ("invalid name for Storage_Model_Type argument", Choice
);
18066 -- If Address_Type has been specified as or defaults to System.Address,
18067 -- then other "subaspect" arguments can be specified, but are optional.
18068 -- Otherwise, all other arguments are required and an error is flagged
18069 -- about any that are missing.
18071 if Address_Type_Id
= RTE
(RE_Address
) then
18074 elsif No
(Null_Address_Id
) then
18075 Error_Msg_N
("match for Null_Address primitive not found", ASN
);
18077 elsif No
(Allocate_Id
) then
18078 Error_Msg_N
("match for Allocate primitive not found", ASN
);
18080 elsif No
(Deallocate_Id
) then
18081 Error_Msg_N
("match for Deallocate primitive not found", ASN
);
18083 elsif No
(Copy_From_Id
) then
18084 Error_Msg_N
("match for Copy_From primitive not found", ASN
);
18086 elsif No
(Copy_To_Id
) then
18087 Error_Msg_N
("match for Copy_To primitive not found", ASN
);
18089 elsif No
(Storage_Size_Id
) then
18090 Error_Msg_N
("match for Storage_Size primitive not found", ASN
);
18092 end Validate_Storage_Model_Type_Aspect
;
18094 -----------------------------------
18095 -- Validate_Unchecked_Conversion --
18096 -----------------------------------
18098 procedure Validate_Unchecked_Conversion
18100 Act_Unit
: Entity_Id
)
18102 Source
: Entity_Id
;
18103 Target
: Entity_Id
;
18105 procedure Warn_Nonportable
(RE
: RE_Id
);
18106 -- Warn if either source or target of the conversion is a predefined
18107 -- private type, whose representation might differ between releases and
18108 -- targets of the compiler.
18110 ----------------------
18111 -- Warn_Nonportable --
18112 ----------------------
18114 procedure Warn_Nonportable
(RE
: RE_Id
) is
18116 if Is_RTE
(Source
, RE
) or else Is_RTE
(Target
, RE
) then
18117 pragma Assert
(Is_Private_Type
(RTE
(RE
)));
18119 ("?z?representation of & values may change between "
18120 & "'G'N'A'T versions", N
, RTE
(RE
));
18122 end Warn_Nonportable
;
18128 -- Start of processing for Validate_Unchecked_Conversion
18131 -- Obtain source and target types. Note that we call Ancestor_Subtype
18132 -- here because the processing for generic instantiation always makes
18133 -- subtypes, and we want the original frozen actual types.
18135 Source
:= Ancestor_Subtype
(Etype
(First_Formal
(Act_Unit
)));
18136 Target
:= Ancestor_Subtype
(Etype
(Act_Unit
));
18138 -- If either type is generic, the instantiation happens within a generic
18139 -- unit, and there is nothing to check. The proper check will happen
18140 -- when the enclosing generic is instantiated.
18142 if Is_Generic_Type
(Source
) or else Is_Generic_Type
(Target
) then
18146 -- Warn if one of the operands is a private type declared in
18147 -- Ada.Calendar or Ada.Real_Time. Do not emit a warning when compiling
18148 -- GNAT-related sources.
18150 if Warn_On_Unchecked_Conversion
18151 and then not In_Predefined_Unit
(N
)
18153 Warn_Nonportable
(RO_CA_Time
);
18154 Warn_Nonportable
(RO_RT_Time
);
18155 Warn_Nonportable
(RE_Time_Span
);
18158 -- If we are dealing with private types, then do the check on their
18159 -- fully declared counterparts if the full declarations have been
18160 -- encountered (they don't have to be visible, but they must exist).
18162 if Is_Private_Type
(Source
)
18163 and then Present
(Underlying_Type
(Source
))
18165 Source
:= Underlying_Type
(Source
);
18168 if Is_Private_Type
(Target
)
18169 and then Present
(Underlying_Type
(Target
))
18171 Target
:= Underlying_Type
(Target
);
18174 -- Source may be unconstrained array, but not target, except in relaxed
18177 if Is_Array_Type
(Target
)
18178 and then not Is_Constrained
(Target
)
18179 and then not Relaxed_RM_Semantics
18182 ("unchecked conversion to unconstrained array not allowed", N
);
18186 -- Warn if conversion between two different convention pointers
18188 if Is_Access_Type
(Target
)
18189 and then Is_Access_Type
(Source
)
18190 and then Convention
(Target
) /= Convention
(Source
)
18191 and then Warn_On_Unchecked_Conversion
18193 -- Give warnings for subprogram pointers only on most targets
18195 if Is_Access_Subprogram_Type
(Target
)
18196 or else Is_Access_Subprogram_Type
(Source
)
18199 ("?z?conversion between pointers with different conventions!",
18204 -- Make entry in unchecked conversion table for later processing by
18205 -- Validate_Unchecked_Conversions, which will check sizes and alignments
18206 -- (using values set by the back end where possible). This is only done
18207 -- if the appropriate warning is active.
18209 if Warn_On_Unchecked_Conversion
then
18210 Unchecked_Conversions
.Append
18211 (New_Val
=> UC_Entry
'(Eloc => Sloc (N),
18214 Act_Unit => Act_Unit));
18216 -- If both sizes are known statically now, then back-end annotation
18217 -- is not required to do a proper check but if either size is not
18218 -- known statically, then we need the annotation.
18220 if Known_Static_RM_Size (Source)
18222 Known_Static_RM_Size (Target)
18226 Back_Annotate_Rep_Info := True;
18230 -- If unchecked conversion to access type, and access type is declared
18231 -- in the same unit as the unchecked conversion, then set the flag
18232 -- No_Strict_Aliasing (no strict aliasing is implicit here)
18234 if Is_Access_Type (Target)
18235 and then In_Same_Source_Unit (Target, N)
18237 Set_No_Strict_Aliasing (Implementation_Base_Type (Target));
18240 -- If the unchecked conversion is between Address and an access
18241 -- subprogram type, show that we shouldn't use an internal
18242 -- representation for the access subprogram type.
18244 if Is_Access_Subprogram_Type (Target)
18245 and then Is_Descendant_Of_Address (Source)
18246 and then In_Same_Source_Unit (Target, N)
18248 Set_Can_Use_Internal_Rep (Base_Type (Target), False);
18249 elsif Is_Access_Subprogram_Type (Source)
18250 and then Is_Descendant_Of_Address (Target)
18251 and then In_Same_Source_Unit (Source, N)
18253 Set_Can_Use_Internal_Rep (Base_Type (Source), False);
18256 -- Generate N_Validate_Unchecked_Conversion node for back end in case
18257 -- the back end needs to perform special validation checks.
18259 -- Shouldn't this be in Exp_Ch13, since the check only gets done if we
18260 -- have full expansion and the back end is called ???
18263 Make_Validate_Unchecked_Conversion (Sloc (N));
18264 Set_Source_Type (Vnode, Source);
18265 Set_Target_Type (Vnode, Target);
18267 -- If the unchecked conversion node is in a list, just insert before it.
18268 -- If not we have some strange case, not worth bothering about.
18270 if Is_List_Member (N) then
18271 Insert_After (N, Vnode);
18273 end Validate_Unchecked_Conversion;
18275 ------------------------------------
18276 -- Validate_Unchecked_Conversions --
18277 ------------------------------------
18279 procedure Validate_Unchecked_Conversions is
18280 function Is_Null_Array (T : Entity_Id) return Boolean;
18281 -- We want to warn in the case of converting to a wrong-sized array of
18282 -- bytes, including the zero-size case. This returns True in that case,
18283 -- which is necessary because a size of 0 is used to indicate both an
18284 -- unknown size and a size of 0. It's OK for this to return True in
18285 -- other zero-size cases, but we don't go out of our way; for example,
18286 -- we don't bother with multidimensional arrays.
18288 function Is_Null_Array (T : Entity_Id) return Boolean is
18290 if Is_Array_Type (T) and then Is_Constrained (T) then
18292 Index : constant Node_Id := First_Index (T);
18293 R : Node_Id; -- N_Range
18295 case Nkind (Index) is
18298 when N_Subtype_Indication =>
18299 R := Range_Expression (Constraint (Index));
18300 when N_Identifier | N_Expanded_Name =>
18301 R := Scalar_Range (Entity (Index));
18303 raise Program_Error;
18306 return Is_Null_Range (Low_Bound (R), High_Bound (R));
18314 for N in Unchecked_Conversions.First .. Unchecked_Conversions.Last loop
18316 T : UC_Entry renames Unchecked_Conversions.Table (N);
18318 Act_Unit : constant Entity_Id := T.Act_Unit;
18319 Eloc : constant Source_Ptr := T.Eloc;
18320 Source : constant Entity_Id := T.Source;
18321 Target : constant Entity_Id := T.Target;
18327 -- Skip if function marked as warnings off
18329 if Has_Warnings_Off (Act_Unit)
18330 or else Serious_Errors_Detected > 0
18335 -- Don't do the check if warnings off for either type, note the
18336 -- deliberate use of OR here instead of OR ELSE to get the flag
18337 -- Warnings_Off_Used set for both types if appropriate.
18339 if Has_Warnings_Off (Source) or Has_Warnings_Off (Target) then
18343 if (Known_Static_RM_Size (Source)
18344 and then Known_Static_RM_Size (Target))
18345 or else Is_Null_Array (Target)
18347 -- This validation check, which warns if we have unequal sizes
18348 -- for unchecked conversion, and thus implementation dependent
18349 -- semantics, is one of the few occasions on which we use the
18350 -- official RM size instead of Esize. See description in Einfo
18351 -- "Handling of Type'Size Values" for details.
18353 Source_Siz := RM_Size (Source);
18354 Target_Siz := RM_Size (Target);
18356 if Present (Source_Siz) and then Present (Target_Siz)
18357 and then Source_Siz /= Target_Siz
18360 ("?z?types for unchecked conversion have different sizes!",
18363 if All_Errors_Mode then
18364 Error_Msg_Name_1 := Chars (Source);
18365 Error_Msg_Uint_1 := Source_Siz;
18366 Error_Msg_Name_2 := Chars (Target);
18367 Error_Msg_Uint_2 := Target_Siz;
18368 Error_Msg ("\size of % is ^, size of % is ^?z?", Eloc);
18370 Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz);
18372 if Is_Discrete_Type (Source)
18374 Is_Discrete_Type (Target)
18376 if Source_Siz > Target_Siz then
18378 ("\?z?^ high order bits of source will "
18379 & "be ignored!", Eloc);
18381 elsif Is_Unsigned_Type (Source) then
18383 ("\?z?source will be extended with ^ high order "
18384 & "zero bits!", Eloc);
18388 ("\?z?source will be extended with ^ high order "
18389 & "sign bits!", Eloc);
18392 elsif Source_Siz < Target_Siz then
18393 if Is_Discrete_Type (Target) then
18394 if Bytes_Big_Endian then
18396 ("\?z?target value will include ^ undefined "
18397 & "low order bits!", Eloc, Act_Unit);
18400 ("\?z?target value will include ^ undefined "
18401 & "high order bits!", Eloc, Act_Unit);
18406 ("\?z?^ trailing bits of target value will be "
18407 & "undefined!", Eloc, Act_Unit);
18410 else pragma Assert (Source_Siz > Target_Siz);
18411 if Is_Discrete_Type (Source) then
18412 if Bytes_Big_Endian then
18414 ("\?z?^ low order bits of source will be "
18415 & "ignored!", Eloc, Act_Unit);
18418 ("\?z?^ high order bits of source will be "
18419 & "ignored!", Eloc, Act_Unit);
18424 ("\?z?^ trailing bits of source will be "
18425 & "ignored!", Eloc, Act_Unit);
18432 -- If both types are access types, we need to check the alignment.
18433 -- If the alignment of both is specified, we can do it here.
18435 if Serious_Errors_Detected = 0
18436 and then Is_Access_Type (Source)
18437 and then Is_Access_Type (Target)
18438 and then Target_Strict_Alignment
18439 and then Present (Designated_Type (Source))
18440 and then Present (Designated_Type (Target))
18443 D_Source : constant Entity_Id := Designated_Type (Source);
18444 D_Target : constant Entity_Id := Designated_Type (Target);
18447 if Known_Alignment (D_Source)
18449 Known_Alignment (D_Target)
18452 Source_Align : constant Uint := Alignment (D_Source);
18453 Target_Align : constant Uint := Alignment (D_Target);
18456 if Source_Align < Target_Align
18457 and then not Is_Tagged_Type (D_Source)
18459 -- Suppress warning if warnings suppressed on either
18460 -- type or either designated type. Note the use of
18461 -- OR here instead of OR ELSE. That is intentional,
18462 -- we would like to set flag Warnings_Off_Used in
18463 -- all types for which warnings are suppressed.
18465 and then not (Has_Warnings_Off (D_Source)
18467 Has_Warnings_Off (D_Target)
18469 Has_Warnings_Off (Source)
18471 Has_Warnings_Off (Target))
18473 Error_Msg_Uint_1 := Target_Align;
18474 Error_Msg_Uint_2 := Source_Align;
18475 Error_Msg_Node_1 := D_Target;
18476 Error_Msg_Node_2 := D_Source;
18478 ("?z?alignment of & (^) is stricter than "
18479 & "alignment of & (^)!", Eloc, Act_Unit);
18481 ("\?z?resulting access value may have invalid "
18482 & "alignment!", Eloc, Act_Unit);
18493 end Validate_Unchecked_Conversions;
18496 User_Aspect_Support.Analyze_User_Aspect_Aspect_Specification_Hook :=
18497 Analyze_User_Aspect_Aspect_Specification'Access;