1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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 Ada
.Characters
.Latin_1
; use Ada
.Characters
.Latin_1
;
28 with Atree
; use Atree
;
29 with Casing
; use Casing
;
30 with Checks
; use Checks
;
31 with Debug
; use Debug
;
32 with Einfo
; use Einfo
;
33 with Elists
; use Elists
;
34 with Errout
; use Errout
;
36 with Exp_Dist
; use Exp_Dist
;
37 with Exp_Util
; use Exp_Util
;
38 with Expander
; use Expander
;
39 with Freeze
; use Freeze
;
40 with Gnatvsn
; use Gnatvsn
;
41 with Itypes
; use Itypes
;
43 with Lib
.Xref
; use Lib
.Xref
;
44 with Nlists
; use Nlists
;
45 with Nmake
; use Nmake
;
47 with Restrict
; use Restrict
;
48 with Rident
; use Rident
;
49 with Rtsfind
; use Rtsfind
;
50 with Sdefault
; use Sdefault
;
52 with Sem_Aux
; use Sem_Aux
;
53 with Sem_Cat
; use Sem_Cat
;
54 with Sem_Ch6
; use Sem_Ch6
;
55 with Sem_Ch8
; use Sem_Ch8
;
56 with Sem_Ch10
; use Sem_Ch10
;
57 with Sem_Dim
; use Sem_Dim
;
58 with Sem_Dist
; use Sem_Dist
;
59 with Sem_Elab
; use Sem_Elab
;
60 with Sem_Elim
; use Sem_Elim
;
61 with Sem_Eval
; use Sem_Eval
;
62 with Sem_Res
; use Sem_Res
;
63 with Sem_Type
; use Sem_Type
;
64 with Sem_Util
; use Sem_Util
;
65 with Stand
; use Stand
;
66 with Sinfo
; use Sinfo
;
67 with Sinput
; use Sinput
;
68 with Stringt
; use Stringt
;
70 with Stylesw
; use Stylesw
;
71 with Targparm
; use Targparm
;
72 with Ttypes
; use Ttypes
;
73 with Tbuild
; use Tbuild
;
74 with Uintp
; use Uintp
;
75 with Urealp
; use Urealp
;
77 package body Sem_Attr
is
79 True_Value
: constant Uint
:= Uint_1
;
80 False_Value
: constant Uint
:= Uint_0
;
81 -- Synonyms to be used when these constants are used as Boolean values
83 Bad_Attribute
: exception;
84 -- Exception raised if an error is detected during attribute processing,
85 -- used so that we can abandon the processing so we don't run into
86 -- trouble with cascaded errors.
88 -- The following array is the list of attributes defined in the Ada 83 RM
89 -- that are not included in Ada 95, but still get recognized in GNAT.
91 Attribute_83
: constant Attribute_Class_Array
:= Attribute_Class_Array
'(
97 Attribute_Constrained |
104 Attribute_First_Bit |
110 Attribute_Leading_Part |
112 Attribute_Machine_Emax |
113 Attribute_Machine_Emin |
114 Attribute_Machine_Mantissa |
115 Attribute_Machine_Overflows |
116 Attribute_Machine_Radix |
117 Attribute_Machine_Rounds |
123 Attribute_Safe_Emax |
124 Attribute_Safe_Large |
125 Attribute_Safe_Small |
128 Attribute_Storage_Size |
130 Attribute_Terminated |
133 Attribute_Width => True,
136 -- The following array is the list of attributes defined in the Ada 2005
137 -- RM which are not defined in Ada 95. These are recognized in Ada 95 mode,
138 -- but in Ada 95 they are considered to be implementation defined.
140 Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'(
141 Attribute_Machine_Rounding |
144 Attribute_Stream_Size |
145 Attribute_Wide_Wide_Width
=> True,
148 -- The following array contains all attributes that imply a modification
149 -- of their prefixes or result in an access value. Such prefixes can be
150 -- considered as lvalues.
152 Attribute_Name_Implies_Lvalue_Prefix
: constant Attribute_Class_Array
:=
153 Attribute_Class_Array
'(
158 Attribute_Unchecked_Access |
159 Attribute_Unrestricted_Access => True,
162 -----------------------
163 -- Local_Subprograms --
164 -----------------------
166 procedure Eval_Attribute (N : Node_Id);
167 -- Performs compile time evaluation of attributes where possible, leaving
168 -- the Is_Static_Expression/Raises_Constraint_Error flags appropriately
169 -- set, and replacing the node with a literal node if the value can be
170 -- computed at compile time. All static attribute references are folded,
171 -- as well as a number of cases of non-static attributes that can always
172 -- be computed at compile time (e.g. floating-point model attributes that
173 -- are applied to non-static subtypes). Of course in such cases, the
174 -- Is_Static_Expression flag will not be set on the resulting literal.
175 -- Note that the only required action of this procedure is to catch the
176 -- static expression cases as described in the RM. Folding of other cases
177 -- is done where convenient, but some additional non-static folding is in
178 -- N_Expand_Attribute_Reference in cases where this is more convenient.
180 function Is_Anonymous_Tagged_Base
184 -- For derived tagged types that constrain parent discriminants we build
185 -- an anonymous unconstrained base type. We need to recognize the relation
186 -- between the two when analyzing an access attribute for a constrained
187 -- component, before the full declaration for Typ has been analyzed, and
188 -- where therefore the prefix of the attribute does not match the enclosing
191 -----------------------
192 -- Analyze_Attribute --
193 -----------------------
195 procedure Analyze_Attribute (N : Node_Id) is
196 Loc : constant Source_Ptr := Sloc (N);
197 Aname : constant Name_Id := Attribute_Name (N);
198 P : constant Node_Id := Prefix (N);
199 Exprs : constant List_Id := Expressions (N);
200 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
205 -- Type of prefix after analysis
207 P_Base_Type : Entity_Id;
208 -- Base type of prefix after analysis
210 -----------------------
211 -- Local Subprograms --
212 -----------------------
214 procedure Analyze_Access_Attribute;
215 -- Used for Access, Unchecked_Access, Unrestricted_Access attributes.
216 -- Internally, Id distinguishes which of the three cases is involved.
218 procedure Bad_Attribute_For_Predicate;
219 -- Output error message for use of a predicate (First, Last, Range) not
220 -- allowed with a type that has predicates. If the type is a generic
221 -- actual, then the message is a warning, and we generate code to raise
222 -- program error with an appropriate reason. No error message is given
223 -- for internally generated uses of the attributes. This legality rule
224 -- only applies to scalar types.
226 procedure Check_Ada_2012_Attribute;
227 -- Check that we are in Ada 2012 mode for an Ada 2012 attribute, and
228 -- issue appropriate messages if not (and return to caller even in
231 procedure Check_Array_Or_Scalar_Type;
232 -- Common procedure used by First, Last, Range attribute to check
233 -- that the prefix is a constrained array or scalar type, or a name
234 -- of an array object, and that an argument appears only if appropriate
235 -- (i.e. only in the array case).
237 procedure Check_Array_Type;
238 -- Common semantic checks for all array attributes. Checks that the
239 -- prefix is a constrained array type or the name of an array object.
240 -- The error message for non-arrays is specialized appropriately.
242 procedure Check_Asm_Attribute;
243 -- Common semantic checks for Asm_Input and Asm_Output attributes
245 procedure Check_Component;
246 -- Common processing for Bit_Position, First_Bit, Last_Bit, and
247 -- Position. Checks prefix is an appropriate selected component.
249 procedure Check_Decimal_Fixed_Point_Type;
250 -- Check that prefix of attribute N is a decimal fixed-point type
252 procedure Check_Dereference;
253 -- If the prefix of attribute is an object of an access type, then
254 -- introduce an explicit dereference, and adjust P_Type accordingly.
256 procedure Check_Discrete_Type;
257 -- Verify that prefix of attribute N is a discrete type
260 -- Check that no attribute arguments are present
262 procedure Check_Either_E0_Or_E1;
263 -- Check that there are zero or one attribute arguments present
266 -- Check that exactly one attribute argument is present
269 -- Check that two attribute arguments are present
271 procedure Check_Enum_Image;
272 -- If the prefix type is an enumeration type, set all its literals
273 -- as referenced, since the image function could possibly end up
274 -- referencing any of the literals indirectly. Same for Enum_Val.
275 -- Set the flag only if the reference is in the main code unit. Same
276 -- restriction when resolving 'Value
; otherwise an improperly set
277 -- reference when analyzing an inlined body will lose a proper warning
278 -- on a useless with_clause.
280 procedure Check_First_Last_Valid
;
281 -- Perform all checks for First_Valid and Last_Valid attributes
283 procedure Check_Fixed_Point_Type
;
284 -- Verify that prefix of attribute N is a fixed type
286 procedure Check_Fixed_Point_Type_0
;
287 -- Verify that prefix of attribute N is a fixed type and that
288 -- no attribute expressions are present
290 procedure Check_Floating_Point_Type
;
291 -- Verify that prefix of attribute N is a float type
293 procedure Check_Floating_Point_Type_0
;
294 -- Verify that prefix of attribute N is a float type and that
295 -- no attribute expressions are present
297 procedure Check_Floating_Point_Type_1
;
298 -- Verify that prefix of attribute N is a float type and that
299 -- exactly one attribute expression is present
301 procedure Check_Floating_Point_Type_2
;
302 -- Verify that prefix of attribute N is a float type and that
303 -- two attribute expressions are present
305 procedure Legal_Formal_Attribute
;
306 -- Common processing for attributes Definite and Has_Discriminants.
307 -- Checks that prefix is generic indefinite formal type.
309 procedure Check_SPARK_Restriction_On_Attribute
;
310 -- Issue an error in formal mode because attribute N is allowed
312 procedure Check_Integer_Type
;
313 -- Verify that prefix of attribute N is an integer type
315 procedure Check_Modular_Integer_Type
;
316 -- Verify that prefix of attribute N is a modular integer type
318 procedure Check_Not_CPP_Type
;
319 -- Check that P (the prefix of the attribute) is not an CPP type
320 -- for which no Ada predefined primitive is available.
322 procedure Check_Not_Incomplete_Type
;
323 -- Check that P (the prefix of the attribute) is not an incomplete
324 -- type or a private type for which no full view has been given.
326 procedure Check_Object_Reference
(P
: Node_Id
);
327 -- Check that P is an object reference
329 procedure Check_Program_Unit
;
330 -- Verify that prefix of attribute N is a program unit
332 procedure Check_Real_Type
;
333 -- Verify that prefix of attribute N is fixed or float type
335 procedure Check_Scalar_Type
;
336 -- Verify that prefix of attribute N is a scalar type
338 procedure Check_Standard_Prefix
;
339 -- Verify that prefix of attribute N is package Standard
341 procedure Check_Stream_Attribute
(Nam
: TSS_Name_Type
);
342 -- Validity checking for stream attribute. Nam is the TSS name of the
343 -- corresponding possible defined attribute function (e.g. for the
344 -- Read attribute, Nam will be TSS_Stream_Read).
346 procedure Check_PolyORB_Attribute
;
347 -- Validity checking for PolyORB/DSA attribute
349 procedure Check_Task_Prefix
;
350 -- Verify that prefix of attribute N is a task or task type
352 procedure Check_Type
;
353 -- Verify that the prefix of attribute N is a type
355 procedure Check_Unit_Name
(Nod
: Node_Id
);
356 -- Check that Nod is of the form of a library unit name, i.e that
357 -- it is an identifier, or a selected component whose prefix is
358 -- itself of the form of a library unit name. Note that this is
359 -- quite different from Check_Program_Unit, since it only checks
360 -- the syntactic form of the name, not the semantic identity. This
361 -- is because it is used with attributes (Elab_Body, Elab_Spec,
362 -- UET_Address and Elaborated) which can refer to non-visible unit.
364 procedure Error_Attr
(Msg
: String; Error_Node
: Node_Id
);
365 pragma No_Return
(Error_Attr
);
366 procedure Error_Attr
;
367 pragma No_Return
(Error_Attr
);
368 -- Posts error using Error_Msg_N at given node, sets type of attribute
369 -- node to Any_Type, and then raises Bad_Attribute to avoid any further
370 -- semantic processing. The message typically contains a % insertion
371 -- character which is replaced by the attribute name. The call with
372 -- no arguments is used when the caller has already generated the
373 -- required error messages.
375 procedure Error_Attr_P
(Msg
: String);
376 pragma No_Return
(Error_Attr
);
377 -- Like Error_Attr, but error is posted at the start of the prefix
379 procedure S14_Attribute
;
380 -- Called for all attributes defined for formal verification to check
381 -- that the S14_Extensions flag is set.
383 procedure Standard_Attribute
(Val
: Int
);
384 -- Used to process attributes whose prefix is package Standard which
385 -- yield values of type Universal_Integer. The attribute reference
386 -- node is rewritten with an integer literal of the given value.
388 procedure Unexpected_Argument
(En
: Node_Id
);
389 -- Signal unexpected attribute argument (En is the argument)
391 procedure Validate_Non_Static_Attribute_Function_Call
;
392 -- Called when processing an attribute that is a function call to a
393 -- non-static function, i.e. an attribute function that either takes
394 -- non-scalar arguments or returns a non-scalar result. Verifies that
395 -- such a call does not appear in a preelaborable context.
397 ------------------------------
398 -- Analyze_Access_Attribute --
399 ------------------------------
401 procedure Analyze_Access_Attribute
is
402 Acc_Type
: Entity_Id
;
407 function Build_Access_Object_Type
(DT
: Entity_Id
) return Entity_Id
;
408 -- Build an access-to-object type whose designated type is DT,
409 -- and whose Ekind is appropriate to the attribute type. The
410 -- type that is constructed is returned as the result.
412 procedure Build_Access_Subprogram_Type
(P
: Node_Id
);
413 -- Build an access to subprogram whose designated type is the type of
414 -- the prefix. If prefix is overloaded, so is the node itself. The
415 -- result is stored in Acc_Type.
417 function OK_Self_Reference
return Boolean;
418 -- An access reference whose prefix is a type can legally appear
419 -- within an aggregate, where it is obtained by expansion of
420 -- a defaulted aggregate. The enclosing aggregate that contains
421 -- the self-referenced is flagged so that the self-reference can
422 -- be expanded into a reference to the target object (see exp_aggr).
424 ------------------------------
425 -- Build_Access_Object_Type --
426 ------------------------------
428 function Build_Access_Object_Type
(DT
: Entity_Id
) return Entity_Id
is
429 Typ
: constant Entity_Id
:=
431 (E_Access_Attribute_Type
, Current_Scope
, Loc
, 'A');
433 Set_Etype
(Typ
, Typ
);
435 Set_Associated_Node_For_Itype
(Typ
, N
);
436 Set_Directly_Designated_Type
(Typ
, DT
);
438 end Build_Access_Object_Type
;
440 ----------------------------------
441 -- Build_Access_Subprogram_Type --
442 ----------------------------------
444 procedure Build_Access_Subprogram_Type
(P
: Node_Id
) is
445 Index
: Interp_Index
;
448 procedure Check_Local_Access
(E
: Entity_Id
);
449 -- Deal with possible access to local subprogram. If we have such
450 -- an access, we set a flag to kill all tracked values on any call
451 -- because this access value may be passed around, and any called
452 -- code might use it to access a local procedure which clobbers a
453 -- tracked value. If the scope is a loop or block, indicate that
454 -- value tracking is disabled for the enclosing subprogram.
456 function Get_Kind
(E
: Entity_Id
) return Entity_Kind
;
457 -- Distinguish between access to regular/protected subprograms
459 ------------------------
460 -- Check_Local_Access --
461 ------------------------
463 procedure Check_Local_Access
(E
: Entity_Id
) is
465 if not Is_Library_Level_Entity
(E
) then
466 Set_Suppress_Value_Tracking_On_Call
(Current_Scope
);
467 Set_Suppress_Value_Tracking_On_Call
468 (Nearest_Dynamic_Scope
(Current_Scope
));
470 end Check_Local_Access
;
476 function Get_Kind
(E
: Entity_Id
) return Entity_Kind
is
478 if Convention
(E
) = Convention_Protected
then
479 return E_Access_Protected_Subprogram_Type
;
481 return E_Access_Subprogram_Type
;
485 -- Start of processing for Build_Access_Subprogram_Type
488 -- In the case of an access to subprogram, use the name of the
489 -- subprogram itself as the designated type. Type-checking in
490 -- this case compares the signatures of the designated types.
492 -- Note: This fragment of the tree is temporarily malformed
493 -- because the correct tree requires an E_Subprogram_Type entity
494 -- as the designated type. In most cases this designated type is
495 -- later overridden by the semantics with the type imposed by the
496 -- context during the resolution phase. In the specific case of
497 -- the expression Address!(Prim'Unrestricted_Access), used to
498 -- initialize slots of dispatch tables, this work will be done by
499 -- the expander (see Exp_Aggr).
501 -- The reason to temporarily add this kind of node to the tree
502 -- instead of a proper E_Subprogram_Type itype, is the following:
503 -- in case of errors found in the source file we report better
504 -- error messages. For example, instead of generating the
507 -- "expected access to subprogram with profile
508 -- defined at line X"
510 -- we currently generate:
512 -- "expected access to function Z defined at line X"
514 Set_Etype
(N
, Any_Type
);
516 if not Is_Overloaded
(P
) then
517 Check_Local_Access
(Entity
(P
));
519 if not Is_Intrinsic_Subprogram
(Entity
(P
)) then
520 Acc_Type
:= Create_Itype
(Get_Kind
(Entity
(P
)), N
);
521 Set_Is_Public
(Acc_Type
, False);
522 Set_Etype
(Acc_Type
, Acc_Type
);
523 Set_Convention
(Acc_Type
, Convention
(Entity
(P
)));
524 Set_Directly_Designated_Type
(Acc_Type
, Entity
(P
));
525 Set_Etype
(N
, Acc_Type
);
526 Freeze_Before
(N
, Acc_Type
);
530 Get_First_Interp
(P
, Index
, It
);
531 while Present
(It
.Nam
) loop
532 Check_Local_Access
(It
.Nam
);
534 if not Is_Intrinsic_Subprogram
(It
.Nam
) then
535 Acc_Type
:= Create_Itype
(Get_Kind
(It
.Nam
), N
);
536 Set_Is_Public
(Acc_Type
, False);
537 Set_Etype
(Acc_Type
, Acc_Type
);
538 Set_Convention
(Acc_Type
, Convention
(It
.Nam
));
539 Set_Directly_Designated_Type
(Acc_Type
, It
.Nam
);
540 Add_One_Interp
(N
, Acc_Type
, Acc_Type
);
541 Freeze_Before
(N
, Acc_Type
);
544 Get_Next_Interp
(Index
, It
);
548 -- Cannot be applied to intrinsic. Looking at the tests above,
549 -- the only way Etype (N) can still be set to Any_Type is if
550 -- Is_Intrinsic_Subprogram was True for some referenced entity.
552 if Etype
(N
) = Any_Type
then
553 Error_Attr_P
("prefix of % attribute cannot be intrinsic");
555 end Build_Access_Subprogram_Type
;
557 ----------------------
558 -- OK_Self_Reference --
559 ----------------------
561 function OK_Self_Reference
return Boolean is
568 (Nkind
(Par
) = N_Component_Association
569 or else Nkind
(Par
) in N_Subexpr
)
571 if Nkind_In
(Par
, N_Aggregate
, N_Extension_Aggregate
) then
572 if Etype
(Par
) = Typ
then
573 Set_Has_Self_Reference
(Par
);
581 -- No enclosing aggregate, or not a self-reference
584 end OK_Self_Reference
;
586 -- Start of processing for Analyze_Access_Attribute
589 Check_SPARK_Restriction_On_Attribute
;
592 if Nkind
(P
) = N_Character_Literal
then
594 ("prefix of % attribute cannot be enumeration literal");
597 -- Case of access to subprogram
599 if Is_Entity_Name
(P
)
600 and then Is_Overloadable
(Entity
(P
))
602 if Has_Pragma_Inline_Always
(Entity
(P
)) then
604 ("prefix of % attribute cannot be Inline_Always subprogram");
607 if Aname
= Name_Unchecked_Access
then
608 Error_Attr
("attribute% cannot be applied to a subprogram", P
);
611 -- Issue an error if the prefix denotes an eliminated subprogram
613 Check_For_Eliminated_Subprogram
(P
, Entity
(P
));
615 -- Check for obsolescent subprogram reference
617 Check_Obsolescent_2005_Entity
(Entity
(P
), P
);
619 -- Build the appropriate subprogram type
621 Build_Access_Subprogram_Type
(P
);
623 -- For P'Access or P'Unrestricted_Access, where P is a nested
624 -- subprogram, we might be passing P to another subprogram (but we
625 -- don't check that here), which might call P. P could modify
626 -- local variables, so we need to kill current values. It is
627 -- important not to do this for library-level subprograms, because
628 -- Kill_Current_Values is very inefficient in the case of library
629 -- level packages with lots of tagged types.
631 if Is_Library_Level_Entity
(Entity
(Prefix
(N
))) then
634 -- Do not kill values on nodes initializing dispatch tables
635 -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access)
636 -- is currently generated by the expander only for this
637 -- purpose. Done to keep the quality of warnings currently
638 -- generated by the compiler (otherwise any declaration of
639 -- a tagged type cleans constant indications from its scope).
641 elsif Nkind
(Parent
(N
)) = N_Unchecked_Type_Conversion
642 and then (Etype
(Parent
(N
)) = RTE
(RE_Prim_Ptr
)
644 Etype
(Parent
(N
)) = RTE
(RE_Size_Ptr
))
645 and then Is_Dispatching_Operation
646 (Directly_Designated_Type
(Etype
(N
)))
654 -- Treat as call for elaboration purposes and we are all done.
655 -- Suppress this treatment under debug flag.
657 if not Debug_Flag_Dot_UU
then
663 -- Component is an operation of a protected type
665 elsif Nkind
(P
) = N_Selected_Component
666 and then Is_Overloadable
(Entity
(Selector_Name
(P
)))
668 if Ekind
(Entity
(Selector_Name
(P
))) = E_Entry
then
669 Error_Attr_P
("prefix of % attribute must be subprogram");
672 Build_Access_Subprogram_Type
(Selector_Name
(P
));
676 -- Deal with incorrect reference to a type, but note that some
677 -- accesses are allowed: references to the current type instance,
678 -- or in Ada 2005 self-referential pointer in a default-initialized
681 if Is_Entity_Name
(P
) then
684 -- The reference may appear in an aggregate that has been expanded
685 -- into a loop. Locate scope of type definition, if any.
687 Scop
:= Current_Scope
;
688 while Ekind
(Scop
) = E_Loop
loop
689 Scop
:= Scope
(Scop
);
692 if Is_Type
(Typ
) then
694 -- OK if we are within the scope of a limited type
695 -- let's mark the component as having per object constraint
697 if Is_Anonymous_Tagged_Base
(Scop
, Typ
) then
705 Q
: Node_Id
:= Parent
(N
);
709 and then Nkind
(Q
) /= N_Component_Declaration
715 Set_Has_Per_Object_Constraint
716 (Defining_Identifier
(Q
), True);
720 if Nkind
(P
) = N_Expanded_Name
then
722 ("current instance prefix must be a direct name", P
);
725 -- If a current instance attribute appears in a component
726 -- constraint it must appear alone; other contexts (spec-
727 -- expressions, within a task body) are not subject to this
730 if not In_Spec_Expression
731 and then not Has_Completion
(Scop
)
733 Nkind_In
(Parent
(N
), N_Discriminant_Association
,
734 N_Index_Or_Discriminant_Constraint
)
737 ("current instance attribute must appear alone", N
);
740 if Is_CPP_Class
(Root_Type
(Typ
)) then
742 ("??current instance unsupported for derivations of "
743 & "'C'P'P types", N
);
746 -- OK if we are in initialization procedure for the type
747 -- in question, in which case the reference to the type
748 -- is rewritten as a reference to the current object.
750 elsif Ekind
(Scop
) = E_Procedure
751 and then Is_Init_Proc
(Scop
)
752 and then Etype
(First_Formal
(Scop
)) = Typ
755 Make_Attribute_Reference
(Loc
,
756 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
757 Attribute_Name
=> Name_Unrestricted_Access
));
761 -- OK if a task type, this test needs sharpening up ???
763 elsif Is_Task_Type
(Typ
) then
766 -- OK if self-reference in an aggregate in Ada 2005, and
767 -- the reference comes from a copied default expression.
769 -- Note that we check legality of self-reference even if the
770 -- expression comes from source, e.g. when a single component
771 -- association in an aggregate has a box association.
773 elsif Ada_Version
>= Ada_2005
774 and then OK_Self_Reference
778 -- OK if reference to current instance of a protected object
780 elsif Is_Protected_Self_Reference
(P
) then
783 -- Otherwise we have an error case
786 Error_Attr
("% attribute cannot be applied to type", P
);
792 -- If we fall through, we have a normal access to object case.
793 -- Unrestricted_Access is legal wherever an allocator would be
794 -- legal, so its Etype is set to E_Allocator. The expected type
795 -- of the other attributes is a general access type, and therefore
796 -- we label them with E_Access_Attribute_Type.
798 if not Is_Overloaded
(P
) then
799 Acc_Type
:= Build_Access_Object_Type
(P_Type
);
800 Set_Etype
(N
, Acc_Type
);
803 Index
: Interp_Index
;
806 Set_Etype
(N
, Any_Type
);
807 Get_First_Interp
(P
, Index
, It
);
808 while Present
(It
.Typ
) loop
809 Acc_Type
:= Build_Access_Object_Type
(It
.Typ
);
810 Add_One_Interp
(N
, Acc_Type
, Acc_Type
);
811 Get_Next_Interp
(Index
, It
);
816 -- Special cases when we can find a prefix that is an entity name
825 if Is_Entity_Name
(PP
) then
828 -- If we have an access to an object, and the attribute
829 -- comes from source, then set the object as potentially
830 -- source modified. We do this because the resulting access
831 -- pointer can be used to modify the variable, and we might
832 -- not detect this, leading to some junk warnings.
834 Set_Never_Set_In_Source
(Ent
, False);
836 -- Mark entity as address taken, and kill current values
838 Set_Address_Taken
(Ent
);
839 Kill_Current_Values
(Ent
);
842 elsif Nkind_In
(PP
, N_Selected_Component
,
853 -- Check for aliased view unless unrestricted case. We allow a
854 -- nonaliased prefix when within an instance because the prefix may
855 -- have been a tagged formal object, which is defined to be aliased
856 -- even when the actual might not be (other instance cases will have
857 -- been caught in the generic). Similarly, within an inlined body we
858 -- know that the attribute is legal in the original subprogram, and
859 -- therefore legal in the expansion.
861 if Aname
/= Name_Unrestricted_Access
862 and then not Is_Aliased_View
(P
)
863 and then not In_Instance
864 and then not In_Inlined_Body
866 Error_Attr_P
("prefix of % attribute must be aliased");
867 Check_No_Implicit_Aliasing
(P
);
869 end Analyze_Access_Attribute
;
871 ---------------------------------
872 -- Bad_Attribute_For_Predicate --
873 ---------------------------------
875 procedure Bad_Attribute_For_Predicate
is
877 if Is_Scalar_Type
(P_Type
)
878 and then Comes_From_Source
(N
)
880 Error_Msg_Name_1
:= Aname
;
881 Bad_Predicated_Subtype_Use
882 ("type& has predicates, attribute % not allowed", N
, P_Type
);
884 end Bad_Attribute_For_Predicate
;
886 ------------------------------
887 -- Check_Ada_2012_Attribute --
888 ------------------------------
890 procedure Check_Ada_2012_Attribute
is
892 if Ada_Version
< Ada_2012
then
893 Error_Msg_Name_1
:= Aname
;
895 ("attribute % is an Ada 2012 feature", N
);
897 ("\unit must be compiled with -gnat2012 switch", N
);
899 end Check_Ada_2012_Attribute
;
901 --------------------------------
902 -- Check_Array_Or_Scalar_Type --
903 --------------------------------
905 procedure Check_Array_Or_Scalar_Type
is
909 -- Dimension number for array attributes
912 -- Case of string literal or string literal subtype. These cases
913 -- cannot arise from legal Ada code, but the expander is allowed
914 -- to generate them. They require special handling because string
915 -- literal subtypes do not have standard bounds (the whole idea
916 -- of these subtypes is to avoid having to generate the bounds)
918 if Ekind
(P_Type
) = E_String_Literal_Subtype
then
919 Set_Etype
(N
, Etype
(First_Index
(P_Base_Type
)));
924 elsif Is_Scalar_Type
(P_Type
) then
928 Error_Attr
("invalid argument in % attribute", E1
);
930 Set_Etype
(N
, P_Base_Type
);
934 -- The following is a special test to allow 'First to apply to
935 -- private scalar types if the attribute comes from generated
936 -- code. This occurs in the case of Normalize_Scalars code.
938 elsif Is_Private_Type
(P_Type
)
939 and then Present
(Full_View
(P_Type
))
940 and then Is_Scalar_Type
(Full_View
(P_Type
))
941 and then not Comes_From_Source
(N
)
943 Set_Etype
(N
, Implementation_Base_Type
(P_Type
));
945 -- Array types other than string literal subtypes handled above
950 -- We know prefix is an array type, or the name of an array
951 -- object, and that the expression, if present, is static
952 -- and within the range of the dimensions of the type.
954 pragma Assert
(Is_Array_Type
(P_Type
));
955 Index
:= First_Index
(P_Base_Type
);
959 -- First dimension assumed
961 Set_Etype
(N
, Base_Type
(Etype
(Index
)));
964 D
:= UI_To_Int
(Intval
(E1
));
966 for J
in 1 .. D
- 1 loop
970 Set_Etype
(N
, Base_Type
(Etype
(Index
)));
971 Set_Etype
(E1
, Standard_Integer
);
974 end Check_Array_Or_Scalar_Type
;
976 ----------------------
977 -- Check_Array_Type --
978 ----------------------
980 procedure Check_Array_Type
is
982 -- Dimension number for array attributes
985 -- If the type is a string literal type, then this must be generated
986 -- internally, and no further check is required on its legality.
988 if Ekind
(P_Type
) = E_String_Literal_Subtype
then
991 -- If the type is a composite, it is an illegal aggregate, no point
994 elsif P_Type
= Any_Composite
then
998 -- Normal case of array type or subtype
1000 Check_Either_E0_Or_E1
;
1003 if Is_Array_Type
(P_Type
) then
1004 if not Is_Constrained
(P_Type
)
1005 and then Is_Entity_Name
(P
)
1006 and then Is_Type
(Entity
(P
))
1008 -- Note: we do not call Error_Attr here, since we prefer to
1009 -- continue, using the relevant index type of the array,
1010 -- even though it is unconstrained. This gives better error
1011 -- recovery behavior.
1013 Error_Msg_Name_1
:= Aname
;
1015 ("prefix for % attribute must be constrained array", P
);
1018 -- The attribute reference freezes the type, and thus the
1019 -- component type, even if the attribute may not depend on the
1020 -- component. Diagnose arrays with incomplete components now.
1021 -- If the prefix is an access to array, this does not freeze
1022 -- the designated type.
1024 if Nkind
(P
) /= N_Explicit_Dereference
then
1025 Check_Fully_Declared
(Component_Type
(P_Type
), P
);
1028 D
:= Number_Dimensions
(P_Type
);
1031 if Is_Private_Type
(P_Type
) then
1032 Error_Attr_P
("prefix for % attribute may not be private type");
1034 elsif Is_Access_Type
(P_Type
)
1035 and then Is_Array_Type
(Designated_Type
(P_Type
))
1036 and then Is_Entity_Name
(P
)
1037 and then Is_Type
(Entity
(P
))
1039 Error_Attr_P
("prefix of % attribute cannot be access type");
1041 elsif Attr_Id
= Attribute_First
1043 Attr_Id
= Attribute_Last
1045 Error_Attr
("invalid prefix for % attribute", P
);
1048 Error_Attr_P
("prefix for % attribute must be array");
1052 if Present
(E1
) then
1053 Resolve
(E1
, Any_Integer
);
1054 Set_Etype
(E1
, Standard_Integer
);
1056 if not Is_Static_Expression
(E1
)
1057 or else Raises_Constraint_Error
(E1
)
1059 Flag_Non_Static_Expr
1060 ("expression for dimension must be static!", E1
);
1063 elsif UI_To_Int
(Expr_Value
(E1
)) > D
1064 or else UI_To_Int
(Expr_Value
(E1
)) < 1
1066 Error_Attr
("invalid dimension number for array type", E1
);
1070 if (Style_Check
and Style_Check_Array_Attribute_Index
)
1071 and then Comes_From_Source
(N
)
1073 Style
.Check_Array_Attribute_Index
(N
, E1
, D
);
1075 end Check_Array_Type
;
1077 -------------------------
1078 -- Check_Asm_Attribute --
1079 -------------------------
1081 procedure Check_Asm_Attribute
is
1086 -- Check first argument is static string expression
1088 Analyze_And_Resolve
(E1
, Standard_String
);
1090 if Etype
(E1
) = Any_Type
then
1093 elsif not Is_OK_Static_Expression
(E1
) then
1094 Flag_Non_Static_Expr
1095 ("constraint argument must be static string expression!", E1
);
1099 -- Check second argument is right type
1101 Analyze_And_Resolve
(E2
, Entity
(P
));
1103 -- Note: that is all we need to do, we don't need to check
1104 -- that it appears in a correct context. The Ada type system
1105 -- will do that for us.
1107 end Check_Asm_Attribute
;
1109 ---------------------
1110 -- Check_Component --
1111 ---------------------
1113 procedure Check_Component
is
1117 if Nkind
(P
) /= N_Selected_Component
1119 (Ekind
(Entity
(Selector_Name
(P
))) /= E_Component
1121 Ekind
(Entity
(Selector_Name
(P
))) /= E_Discriminant
)
1123 Error_Attr_P
("prefix for % attribute must be selected component");
1125 end Check_Component
;
1127 ------------------------------------
1128 -- Check_Decimal_Fixed_Point_Type --
1129 ------------------------------------
1131 procedure Check_Decimal_Fixed_Point_Type
is
1135 if not Is_Decimal_Fixed_Point_Type
(P_Type
) then
1136 Error_Attr_P
("prefix of % attribute must be decimal type");
1138 end Check_Decimal_Fixed_Point_Type
;
1140 -----------------------
1141 -- Check_Dereference --
1142 -----------------------
1144 procedure Check_Dereference
is
1147 -- Case of a subtype mark
1149 if Is_Entity_Name
(P
) and then Is_Type
(Entity
(P
)) then
1153 -- Case of an expression
1157 if Is_Access_Type
(P_Type
) then
1159 -- If there is an implicit dereference, then we must freeze the
1160 -- designated type of the access type, since the type of the
1161 -- referenced array is this type (see AI95-00106).
1163 -- As done elsewhere, freezing must not happen when pre-analyzing
1164 -- a pre- or postcondition or a default value for an object or for
1165 -- a formal parameter.
1167 if not In_Spec_Expression
then
1168 Freeze_Before
(N
, Designated_Type
(P_Type
));
1172 Make_Explicit_Dereference
(Sloc
(P
),
1173 Prefix
=> Relocate_Node
(P
)));
1175 Analyze_And_Resolve
(P
);
1176 P_Type
:= Etype
(P
);
1178 if P_Type
= Any_Type
then
1179 raise Bad_Attribute
;
1182 P_Base_Type
:= Base_Type
(P_Type
);
1184 end Check_Dereference
;
1186 -------------------------
1187 -- Check_Discrete_Type --
1188 -------------------------
1190 procedure Check_Discrete_Type
is
1194 if not Is_Discrete_Type
(P_Type
) then
1195 Error_Attr_P
("prefix of % attribute must be discrete type");
1197 end Check_Discrete_Type
;
1203 procedure Check_E0
is
1205 if Present
(E1
) then
1206 Unexpected_Argument
(E1
);
1214 procedure Check_E1
is
1216 Check_Either_E0_Or_E1
;
1220 -- Special-case attributes that are functions and that appear as
1221 -- the prefix of another attribute. Error is posted on parent.
1223 if Nkind
(Parent
(N
)) = N_Attribute_Reference
1224 and then (Attribute_Name
(Parent
(N
)) = Name_Address
1226 Attribute_Name
(Parent
(N
)) = Name_Code_Address
1228 Attribute_Name
(Parent
(N
)) = Name_Access
)
1230 Error_Msg_Name_1
:= Attribute_Name
(Parent
(N
));
1231 Error_Msg_N
("illegal prefix for % attribute", Parent
(N
));
1232 Set_Etype
(Parent
(N
), Any_Type
);
1233 Set_Entity
(Parent
(N
), Any_Type
);
1234 raise Bad_Attribute
;
1237 Error_Attr
("missing argument for % attribute", N
);
1246 procedure Check_E2
is
1249 Error_Attr
("missing arguments for % attribute (2 required)", N
);
1251 Error_Attr
("missing argument for % attribute (2 required)", N
);
1255 ---------------------------
1256 -- Check_Either_E0_Or_E1 --
1257 ---------------------------
1259 procedure Check_Either_E0_Or_E1
is
1261 if Present
(E2
) then
1262 Unexpected_Argument
(E2
);
1264 end Check_Either_E0_Or_E1
;
1266 ----------------------
1267 -- Check_Enum_Image --
1268 ----------------------
1270 procedure Check_Enum_Image
is
1274 -- When an enumeration type appears in an attribute reference, all
1275 -- literals of the type are marked as referenced. This must only be
1276 -- done if the attribute reference appears in the current source.
1277 -- Otherwise the information on references may differ between a
1278 -- normal compilation and one that performs inlining.
1280 if Is_Enumeration_Type
(P_Base_Type
)
1281 and then In_Extended_Main_Code_Unit
(N
)
1283 Lit
:= First_Literal
(P_Base_Type
);
1284 while Present
(Lit
) loop
1285 Set_Referenced
(Lit
);
1289 end Check_Enum_Image
;
1291 ----------------------------
1292 -- Check_First_Last_Valid --
1293 ----------------------------
1295 procedure Check_First_Last_Valid
is
1297 Check_Ada_2012_Attribute
;
1298 Check_Discrete_Type
;
1300 -- Freeze the subtype now, so that the following test for predicates
1301 -- works (we set the predicates stuff up at freeze time)
1303 Insert_Actions
(N
, Freeze_Entity
(P_Type
, P
));
1305 -- Now test for dynamic predicate
1307 if Has_Predicates
(P_Type
)
1308 and then No
(Static_Predicate
(P_Type
))
1311 ("prefix of % attribute may not have dynamic predicate");
1314 -- Check non-static subtype
1316 if not Is_Static_Subtype
(P_Type
) then
1317 Error_Attr_P
("prefix of % attribute must be a static subtype");
1320 -- Test case for no values
1322 if Expr_Value
(Type_Low_Bound
(P_Type
)) >
1323 Expr_Value
(Type_High_Bound
(P_Type
))
1324 or else (Has_Predicates
(P_Type
)
1325 and then Is_Empty_List
(Static_Predicate
(P_Type
)))
1328 ("prefix of % attribute must be subtype with "
1329 & "at least one value");
1331 end Check_First_Last_Valid
;
1333 ----------------------------
1334 -- Check_Fixed_Point_Type --
1335 ----------------------------
1337 procedure Check_Fixed_Point_Type
is
1341 if not Is_Fixed_Point_Type
(P_Type
) then
1342 Error_Attr_P
("prefix of % attribute must be fixed point type");
1344 end Check_Fixed_Point_Type
;
1346 ------------------------------
1347 -- Check_Fixed_Point_Type_0 --
1348 ------------------------------
1350 procedure Check_Fixed_Point_Type_0
is
1352 Check_Fixed_Point_Type
;
1354 end Check_Fixed_Point_Type_0
;
1356 -------------------------------
1357 -- Check_Floating_Point_Type --
1358 -------------------------------
1360 procedure Check_Floating_Point_Type
is
1364 if not Is_Floating_Point_Type
(P_Type
) then
1365 Error_Attr_P
("prefix of % attribute must be float type");
1367 end Check_Floating_Point_Type
;
1369 ---------------------------------
1370 -- Check_Floating_Point_Type_0 --
1371 ---------------------------------
1373 procedure Check_Floating_Point_Type_0
is
1375 Check_Floating_Point_Type
;
1377 end Check_Floating_Point_Type_0
;
1379 ---------------------------------
1380 -- Check_Floating_Point_Type_1 --
1381 ---------------------------------
1383 procedure Check_Floating_Point_Type_1
is
1385 Check_Floating_Point_Type
;
1387 end Check_Floating_Point_Type_1
;
1389 ---------------------------------
1390 -- Check_Floating_Point_Type_2 --
1391 ---------------------------------
1393 procedure Check_Floating_Point_Type_2
is
1395 Check_Floating_Point_Type
;
1397 end Check_Floating_Point_Type_2
;
1399 ------------------------
1400 -- Check_Integer_Type --
1401 ------------------------
1403 procedure Check_Integer_Type
is
1407 if not Is_Integer_Type
(P_Type
) then
1408 Error_Attr_P
("prefix of % attribute must be integer type");
1410 end Check_Integer_Type
;
1412 --------------------------------
1413 -- Check_Modular_Integer_Type --
1414 --------------------------------
1416 procedure Check_Modular_Integer_Type
is
1420 if not Is_Modular_Integer_Type
(P_Type
) then
1422 ("prefix of % attribute must be modular integer type");
1424 end Check_Modular_Integer_Type
;
1426 ------------------------
1427 -- Check_Not_CPP_Type --
1428 ------------------------
1430 procedure Check_Not_CPP_Type
is
1432 if Is_Tagged_Type
(Etype
(P
))
1433 and then Convention
(Etype
(P
)) = Convention_CPP
1434 and then Is_CPP_Class
(Root_Type
(Etype
(P
)))
1437 ("invalid use of % attribute with 'C'P'P tagged type");
1439 end Check_Not_CPP_Type
;
1441 -------------------------------
1442 -- Check_Not_Incomplete_Type --
1443 -------------------------------
1445 procedure Check_Not_Incomplete_Type
is
1450 -- Ada 2005 (AI-50217, AI-326): If the prefix is an explicit
1451 -- dereference we have to check wrong uses of incomplete types
1452 -- (other wrong uses are checked at their freezing point).
1454 -- Example 1: Limited-with
1456 -- limited with Pkg;
1458 -- type Acc is access Pkg.T;
1460 -- S : Integer := X.all'Size; -- ERROR
1463 -- Example 2: Tagged incomplete
1465 -- type T is tagged;
1466 -- type Acc is access all T;
1468 -- S : constant Integer := X.all'Size; -- ERROR
1469 -- procedure Q (Obj : Integer := X.all'Alignment); -- ERROR
1471 if Ada_Version
>= Ada_2005
1472 and then Nkind
(P
) = N_Explicit_Dereference
1475 while Nkind
(E
) = N_Explicit_Dereference
loop
1481 if From_With_Type
(Typ
) then
1483 ("prefix of % attribute cannot be an incomplete type");
1486 if Is_Access_Type
(Typ
) then
1487 Typ
:= Directly_Designated_Type
(Typ
);
1490 if Is_Class_Wide_Type
(Typ
) then
1491 Typ
:= Root_Type
(Typ
);
1494 -- A legal use of a shadow entity occurs only when the unit
1495 -- where the non-limited view resides is imported via a regular
1496 -- with clause in the current body. Such references to shadow
1497 -- entities may occur in subprogram formals.
1499 if Is_Incomplete_Type
(Typ
)
1500 and then From_With_Type
(Typ
)
1501 and then Present
(Non_Limited_View
(Typ
))
1502 and then Is_Legal_Shadow_Entity_In_Body
(Typ
)
1504 Typ
:= Non_Limited_View
(Typ
);
1507 if Ekind
(Typ
) = E_Incomplete_Type
1508 and then No
(Full_View
(Typ
))
1511 ("prefix of % attribute cannot be an incomplete type");
1516 if not Is_Entity_Name
(P
)
1517 or else not Is_Type
(Entity
(P
))
1518 or else In_Spec_Expression
1522 Check_Fully_Declared
(P_Type
, P
);
1524 end Check_Not_Incomplete_Type
;
1526 ----------------------------
1527 -- Check_Object_Reference --
1528 ----------------------------
1530 procedure Check_Object_Reference
(P
: Node_Id
) is
1534 -- If we need an object, and we have a prefix that is the name of
1535 -- a function entity, convert it into a function call.
1537 if Is_Entity_Name
(P
)
1538 and then Ekind
(Entity
(P
)) = E_Function
1540 Rtyp
:= Etype
(Entity
(P
));
1543 Make_Function_Call
(Sloc
(P
),
1544 Name
=> Relocate_Node
(P
)));
1546 Analyze_And_Resolve
(P
, Rtyp
);
1548 -- Otherwise we must have an object reference
1550 elsif not Is_Object_Reference
(P
) then
1551 Error_Attr_P
("prefix of % attribute must be object");
1553 end Check_Object_Reference
;
1555 ----------------------------
1556 -- Check_PolyORB_Attribute --
1557 ----------------------------
1559 procedure Check_PolyORB_Attribute
is
1561 Validate_Non_Static_Attribute_Function_Call
;
1566 if Get_PCS_Name
/= Name_PolyORB_DSA
then
1568 ("attribute% requires the 'Poly'O'R'B 'P'C'S", N
);
1570 end Check_PolyORB_Attribute
;
1572 ------------------------
1573 -- Check_Program_Unit --
1574 ------------------------
1576 procedure Check_Program_Unit
is
1578 if Is_Entity_Name
(P
) then
1580 K
: constant Entity_Kind
:= Ekind
(Entity
(P
));
1581 T
: constant Entity_Id
:= Etype
(Entity
(P
));
1584 if K
in Subprogram_Kind
1585 or else K
in Task_Kind
1586 or else K
in Protected_Kind
1587 or else K
= E_Package
1588 or else K
in Generic_Unit_Kind
1589 or else (K
= E_Variable
1593 Is_Protected_Type
(T
)))
1600 Error_Attr_P
("prefix of % attribute must be program unit");
1601 end Check_Program_Unit
;
1603 ---------------------
1604 -- Check_Real_Type --
1605 ---------------------
1607 procedure Check_Real_Type
is
1611 if not Is_Real_Type
(P_Type
) then
1612 Error_Attr_P
("prefix of % attribute must be real type");
1614 end Check_Real_Type
;
1616 -----------------------
1617 -- Check_Scalar_Type --
1618 -----------------------
1620 procedure Check_Scalar_Type
is
1624 if not Is_Scalar_Type
(P_Type
) then
1625 Error_Attr_P
("prefix of % attribute must be scalar type");
1627 end Check_Scalar_Type
;
1629 ------------------------------------------
1630 -- Check_SPARK_Restriction_On_Attribute --
1631 ------------------------------------------
1633 procedure Check_SPARK_Restriction_On_Attribute
is
1635 Error_Msg_Name_1
:= Aname
;
1636 Check_SPARK_Restriction
("attribute % is not allowed", P
);
1637 end Check_SPARK_Restriction_On_Attribute
;
1639 ---------------------------
1640 -- Check_Standard_Prefix --
1641 ---------------------------
1643 procedure Check_Standard_Prefix
is
1647 if Nkind
(P
) /= N_Identifier
1648 or else Chars
(P
) /= Name_Standard
1650 Error_Attr
("only allowed prefix for % attribute is Standard", P
);
1652 end Check_Standard_Prefix
;
1654 ----------------------------
1655 -- Check_Stream_Attribute --
1656 ----------------------------
1658 procedure Check_Stream_Attribute
(Nam
: TSS_Name_Type
) is
1662 In_Shared_Var_Procs
: Boolean;
1663 -- True when compiling the body of System.Shared_Storage.
1664 -- Shared_Var_Procs. For this runtime package (always compiled in
1665 -- GNAT mode), we allow stream attributes references for limited
1666 -- types for the case where shared passive objects are implemented
1667 -- using stream attributes, which is the default in GNAT's persistent
1668 -- storage implementation.
1671 Validate_Non_Static_Attribute_Function_Call
;
1673 -- With the exception of 'Input, Stream attributes are procedures,
1674 -- and can only appear at the position of procedure calls. We check
1675 -- for this here, before they are rewritten, to give a more precise
1678 if Nam
= TSS_Stream_Input
then
1681 elsif Is_List_Member
(N
)
1682 and then not Nkind_In
(Parent
(N
), N_Procedure_Call_Statement
,
1689 ("invalid context for attribute%, which is a procedure", N
);
1693 Btyp
:= Implementation_Base_Type
(P_Type
);
1695 -- Stream attributes not allowed on limited types unless the
1696 -- attribute reference was generated by the expander (in which
1697 -- case the underlying type will be used, as described in Sinfo),
1698 -- or the attribute was specified explicitly for the type itself
1699 -- or one of its ancestors (taking visibility rules into account if
1700 -- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp
1701 -- (with no visibility restriction).
1704 Gen_Body
: constant Node_Id
:= Enclosing_Generic_Body
(N
);
1706 if Present
(Gen_Body
) then
1707 In_Shared_Var_Procs
:=
1708 Is_RTE
(Corresponding_Spec
(Gen_Body
), RE_Shared_Var_Procs
);
1710 In_Shared_Var_Procs
:= False;
1714 if (Comes_From_Source
(N
)
1715 and then not (In_Shared_Var_Procs
or In_Instance
))
1716 and then not Stream_Attribute_Available
(P_Type
, Nam
)
1717 and then not Has_Rep_Pragma
(Btyp
, Name_Stream_Convert
)
1719 Error_Msg_Name_1
:= Aname
;
1721 if Is_Limited_Type
(P_Type
) then
1723 ("limited type& has no% attribute", P
, P_Type
);
1724 Explain_Limited_Type
(P_Type
, P
);
1727 ("attribute% for type& is not available", P
, P_Type
);
1731 -- Check restriction violations
1733 -- First check the No_Streams restriction, which prohibits the use
1734 -- of explicit stream attributes in the source program. We do not
1735 -- prevent the occurrence of stream attributes in generated code,
1736 -- for instance those generated implicitly for dispatching purposes.
1738 if Comes_From_Source
(N
) then
1739 Check_Restriction
(No_Streams
, P
);
1742 -- AI05-0057: if restriction No_Default_Stream_Attributes is active,
1743 -- it is illegal to use a predefined elementary type stream attribute
1744 -- either by itself, or more importantly as part of the attribute
1745 -- subprogram for a composite type.
1747 if Restriction_Active
(No_Default_Stream_Attributes
) then
1752 if Nam
= TSS_Stream_Input
1754 Nam
= TSS_Stream_Read
1757 Type_Without_Stream_Operation
(P_Type
, TSS_Stream_Read
);
1760 Type_Without_Stream_Operation
(P_Type
, TSS_Stream_Write
);
1764 Check_Restriction
(No_Default_Stream_Attributes
, N
);
1767 ("missing user-defined Stream Read or Write for type&",
1769 if not Is_Elementary_Type
(P_Type
) then
1771 ("\which is a component of type&", N
, P_Type
);
1777 -- Check special case of Exception_Id and Exception_Occurrence which
1778 -- are not allowed for restriction No_Exception_Registration.
1780 if Restriction_Check_Required
(No_Exception_Registration
)
1781 and then (Is_RTE
(P_Type
, RE_Exception_Id
)
1783 Is_RTE
(P_Type
, RE_Exception_Occurrence
))
1785 Check_Restriction
(No_Exception_Registration
, P
);
1788 -- Here we must check that the first argument is an access type
1789 -- that is compatible with Ada.Streams.Root_Stream_Type'Class.
1791 Analyze_And_Resolve
(E1
);
1794 -- Note: the double call to Root_Type here is needed because the
1795 -- root type of a class-wide type is the corresponding type (e.g.
1796 -- X for X'Class, and we really want to go to the root.)
1798 if not Is_Access_Type
(Etyp
)
1799 or else Root_Type
(Root_Type
(Designated_Type
(Etyp
))) /=
1800 RTE
(RE_Root_Stream_Type
)
1803 ("expected access to Ada.Streams.Root_Stream_Type''Class", E1
);
1806 -- Check that the second argument is of the right type if there is
1807 -- one (the Input attribute has only one argument so this is skipped)
1809 if Present
(E2
) then
1812 if Nam
= TSS_Stream_Read
1813 and then not Is_OK_Variable_For_Out_Formal
(E2
)
1816 ("second argument of % attribute must be a variable", E2
);
1819 Resolve
(E2
, P_Type
);
1823 end Check_Stream_Attribute
;
1825 -----------------------
1826 -- Check_Task_Prefix --
1827 -----------------------
1829 procedure Check_Task_Prefix
is
1833 -- Ada 2005 (AI-345): Attribute 'Terminated can be applied to
1834 -- task interface class-wide types.
1836 if Is_Task_Type
(Etype
(P
))
1837 or else (Is_Access_Type
(Etype
(P
))
1838 and then Is_Task_Type
(Designated_Type
(Etype
(P
))))
1839 or else (Ada_Version
>= Ada_2005
1840 and then Ekind
(Etype
(P
)) = E_Class_Wide_Type
1841 and then Is_Interface
(Etype
(P
))
1842 and then Is_Task_Interface
(Etype
(P
)))
1847 if Ada_Version
>= Ada_2005
then
1849 ("prefix of % attribute must be a task or a task " &
1850 "interface class-wide object");
1853 Error_Attr_P
("prefix of % attribute must be a task");
1856 end Check_Task_Prefix
;
1862 -- The possibilities are an entity name denoting a type, or an
1863 -- attribute reference that denotes a type (Base or Class). If
1864 -- the type is incomplete, replace it with its full view.
1866 procedure Check_Type
is
1868 if not Is_Entity_Name
(P
)
1869 or else not Is_Type
(Entity
(P
))
1871 Error_Attr_P
("prefix of % attribute must be a type");
1873 elsif Is_Protected_Self_Reference
(P
) then
1875 ("prefix of % attribute denotes current instance "
1876 & "(RM 9.4(21/2))");
1878 elsif Ekind
(Entity
(P
)) = E_Incomplete_Type
1879 and then Present
(Full_View
(Entity
(P
)))
1881 P_Type
:= Full_View
(Entity
(P
));
1882 Set_Entity
(P
, P_Type
);
1886 ---------------------
1887 -- Check_Unit_Name --
1888 ---------------------
1890 procedure Check_Unit_Name
(Nod
: Node_Id
) is
1892 if Nkind
(Nod
) = N_Identifier
then
1895 elsif Nkind_In
(Nod
, N_Selected_Component
, N_Expanded_Name
) then
1896 Check_Unit_Name
(Prefix
(Nod
));
1898 if Nkind
(Selector_Name
(Nod
)) = N_Identifier
then
1903 Error_Attr
("argument for % attribute must be unit name", P
);
1904 end Check_Unit_Name
;
1910 procedure Error_Attr
is
1912 Set_Etype
(N
, Any_Type
);
1913 Set_Entity
(N
, Any_Type
);
1914 raise Bad_Attribute
;
1917 procedure Error_Attr
(Msg
: String; Error_Node
: Node_Id
) is
1919 Error_Msg_Name_1
:= Aname
;
1920 Error_Msg_N
(Msg
, Error_Node
);
1928 procedure Error_Attr_P
(Msg
: String) is
1930 Error_Msg_Name_1
:= Aname
;
1931 Error_Msg_F
(Msg
, P
);
1935 ----------------------------
1936 -- Legal_Formal_Attribute --
1937 ----------------------------
1939 procedure Legal_Formal_Attribute
is
1943 if not Is_Entity_Name
(P
)
1944 or else not Is_Type
(Entity
(P
))
1946 Error_Attr_P
("prefix of % attribute must be generic type");
1948 elsif Is_Generic_Actual_Type
(Entity
(P
))
1950 or else In_Inlined_Body
1954 elsif Is_Generic_Type
(Entity
(P
)) then
1955 if not Is_Indefinite_Subtype
(Entity
(P
)) then
1957 ("prefix of % attribute must be indefinite generic type");
1962 ("prefix of % attribute must be indefinite generic type");
1965 Set_Etype
(N
, Standard_Boolean
);
1966 end Legal_Formal_Attribute
;
1972 procedure S14_Attribute
is
1974 if not Formal_Extensions
then
1976 ("attribute % requires the use of debug switch -gnatd.V", N
);
1980 ------------------------
1981 -- Standard_Attribute --
1982 ------------------------
1984 procedure Standard_Attribute
(Val
: Int
) is
1986 Check_Standard_Prefix
;
1987 Rewrite
(N
, Make_Integer_Literal
(Loc
, Val
));
1989 end Standard_Attribute
;
1991 -------------------------
1992 -- Unexpected Argument --
1993 -------------------------
1995 procedure Unexpected_Argument
(En
: Node_Id
) is
1997 Error_Attr
("unexpected argument for % attribute", En
);
1998 end Unexpected_Argument
;
2000 -------------------------------------------------
2001 -- Validate_Non_Static_Attribute_Function_Call --
2002 -------------------------------------------------
2004 -- This function should be moved to Sem_Dist ???
2006 procedure Validate_Non_Static_Attribute_Function_Call
is
2008 if In_Preelaborated_Unit
2009 and then not In_Subprogram_Or_Concurrent_Unit
2011 Flag_Non_Static_Expr
2012 ("non-static function call in preelaborated unit!", N
);
2014 end Validate_Non_Static_Attribute_Function_Call
;
2016 -- Start of processing for Analyze_Attribute
2019 -- Immediate return if unrecognized attribute (already diagnosed
2020 -- by parser, so there is nothing more that we need to do)
2022 if not Is_Attribute_Name
(Aname
) then
2023 raise Bad_Attribute
;
2026 -- Deal with Ada 83 issues
2028 if Comes_From_Source
(N
) then
2029 if not Attribute_83
(Attr_Id
) then
2030 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
2031 Error_Msg_Name_1
:= Aname
;
2032 Error_Msg_N
("(Ada 83) attribute% is not standard??", N
);
2035 if Attribute_Impl_Def
(Attr_Id
) then
2036 Check_Restriction
(No_Implementation_Attributes
, N
);
2041 -- Deal with Ada 2005 attributes that are
2043 if Attribute_05
(Attr_Id
) and then Ada_Version
< Ada_2005
then
2044 Check_Restriction
(No_Implementation_Attributes
, N
);
2047 -- Remote access to subprogram type access attribute reference needs
2048 -- unanalyzed copy for tree transformation. The analyzed copy is used
2049 -- for its semantic information (whether prefix is a remote subprogram
2050 -- name), the unanalyzed copy is used to construct new subtree rooted
2051 -- with N_Aggregate which represents a fat pointer aggregate.
2053 if Aname
= Name_Access
then
2054 Discard_Node
(Copy_Separate_Tree
(N
));
2057 -- Analyze prefix and exit if error in analysis. If the prefix is an
2058 -- incomplete type, use full view if available. Note that there are
2059 -- some attributes for which we do not analyze the prefix, since the
2060 -- prefix is not a normal name, or else needs special handling.
2062 if Aname
/= Name_Elab_Body
2064 Aname
/= Name_Elab_Spec
2066 Aname
/= Name_Elab_Subp_Body
2068 Aname
/= Name_UET_Address
2070 Aname
/= Name_Enabled
2075 P_Type
:= Etype
(P
);
2077 if Is_Entity_Name
(P
)
2078 and then Present
(Entity
(P
))
2079 and then Is_Type
(Entity
(P
))
2081 if Ekind
(Entity
(P
)) = E_Incomplete_Type
then
2082 P_Type
:= Get_Full_View
(P_Type
);
2083 Set_Entity
(P
, P_Type
);
2084 Set_Etype
(P
, P_Type
);
2086 elsif Entity
(P
) = Current_Scope
2087 and then Is_Record_Type
(Entity
(P
))
2089 -- Use of current instance within the type. Verify that if the
2090 -- attribute appears within a constraint, it yields an access
2091 -- type, other uses are illegal.
2099 and then Nkind
(Parent
(Par
)) /= N_Component_Definition
2101 Par
:= Parent
(Par
);
2105 and then Nkind
(Par
) = N_Subtype_Indication
2107 if Attr_Id
/= Attribute_Access
2108 and then Attr_Id
/= Attribute_Unchecked_Access
2109 and then Attr_Id
/= Attribute_Unrestricted_Access
2112 ("in a constraint the current instance can only"
2113 & " be used with an access attribute", N
);
2120 if P_Type
= Any_Type
then
2121 raise Bad_Attribute
;
2124 P_Base_Type
:= Base_Type
(P_Type
);
2127 -- Analyze expressions that may be present, exiting if an error occurs
2133 -- Do not analyze the expressions of attribute Loop_Entry. Depending on
2134 -- the number of arguments and/or the nature of the first argument, the
2135 -- whole attribute reference may be rewritten into an indexed component.
2136 -- In the case of two or more arguments, the expressions are analyzed
2137 -- when the indexed component is analyzed, otherwise the sole argument
2138 -- is preanalyzed to determine whether it is a loop name.
2140 elsif Aname
= Name_Loop_Entry
then
2141 E1
:= First
(Exprs
);
2143 if Present
(E1
) then
2148 E1
:= First
(Exprs
);
2151 -- Check for missing/bad expression (result of previous error)
2153 if No
(E1
) or else Etype
(E1
) = Any_Type
then
2154 raise Bad_Attribute
;
2159 if Present
(E2
) then
2162 if Etype
(E2
) = Any_Type
then
2163 raise Bad_Attribute
;
2166 if Present
(Next
(E2
)) then
2167 Unexpected_Argument
(Next
(E2
));
2172 -- Ada 2005 (AI-345): Ensure that the compiler gives exactly the current
2173 -- output compiling in Ada 95 mode for the case of ambiguous prefixes.
2175 if Ada_Version
< Ada_2005
2176 and then Is_Overloaded
(P
)
2177 and then Aname
/= Name_Access
2178 and then Aname
/= Name_Address
2179 and then Aname
/= Name_Code_Address
2180 and then Aname
/= Name_Count
2181 and then Aname
/= Name_Result
2182 and then Aname
/= Name_Unchecked_Access
2184 Error_Attr
("ambiguous prefix for % attribute", P
);
2186 elsif Ada_Version
>= Ada_2005
2187 and then Is_Overloaded
(P
)
2188 and then Aname
/= Name_Access
2189 and then Aname
/= Name_Address
2190 and then Aname
/= Name_Code_Address
2191 and then Aname
/= Name_Result
2192 and then Aname
/= Name_Unchecked_Access
2194 -- Ada 2005 (AI-345): Since protected and task types have primitive
2195 -- entry wrappers, the attributes Count, Caller and AST_Entry require
2198 if Ada_Version
>= Ada_2005
2199 and then (Aname
= Name_Count
2200 or else Aname
= Name_Caller
2201 or else Aname
= Name_AST_Entry
)
2204 Count
: Natural := 0;
2209 Get_First_Interp
(P
, I
, It
);
2210 while Present
(It
.Nam
) loop
2211 if Comes_From_Source
(It
.Nam
) then
2217 Get_Next_Interp
(I
, It
);
2221 Error_Attr
("ambiguous prefix for % attribute", P
);
2223 Set_Is_Overloaded
(P
, False);
2228 Error_Attr
("ambiguous prefix for % attribute", P
);
2232 -- In SPARK, attributes of private types are only allowed if the full
2233 -- type declaration is visible.
2235 if Is_Entity_Name
(P
)
2236 and then Present
(Entity
(P
)) -- needed in some cases
2237 and then Is_Type
(Entity
(P
))
2238 and then Is_Private_Type
(P_Type
)
2239 and then not In_Open_Scopes
(Scope
(P_Type
))
2240 and then not In_Spec_Expression
2242 Check_SPARK_Restriction
("invisible attribute of type", N
);
2245 -- Remaining processing depends on attribute
2249 -- Attributes related to Ada 2012 iterators. Attribute specifications
2250 -- exist for these, but they cannot be queried.
2252 when Attribute_Constant_Indexing |
2253 Attribute_Default_Iterator |
2254 Attribute_Implicit_Dereference |
2255 Attribute_Iterator_Element |
2256 Attribute_Variable_Indexing
=>
2257 Error_Msg_N
("illegal attribute", N
);
2259 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
2260 -- were already rejected by the parser. Thus they shouldn't appear here.
2262 when Internal_Attribute_Id
=>
2263 raise Program_Error
;
2269 when Attribute_Abort_Signal
=>
2270 Check_Standard_Prefix
;
2271 Rewrite
(N
, New_Reference_To
(Stand
.Abort_Signal
, Loc
));
2278 when Attribute_Access
=>
2279 Analyze_Access_Attribute
;
2285 when Attribute_Address
=>
2288 -- Check for some junk cases, where we have to allow the address
2289 -- attribute but it does not make much sense, so at least for now
2290 -- just replace with Null_Address.
2292 -- We also do this if the prefix is a reference to the AST_Entry
2293 -- attribute. If expansion is active, the attribute will be
2294 -- replaced by a function call, and address will work fine and
2295 -- get the proper value, but if expansion is not active, then
2296 -- the check here allows proper semantic analysis of the reference.
2298 -- An Address attribute created by expansion is legal even when it
2299 -- applies to other entity-denoting expressions.
2301 if Is_Protected_Self_Reference
(P
) then
2303 -- Address attribute on a protected object self reference is legal
2307 elsif Is_Entity_Name
(P
) then
2309 Ent
: constant Entity_Id
:= Entity
(P
);
2312 if Is_Subprogram
(Ent
) then
2313 Set_Address_Taken
(Ent
);
2314 Kill_Current_Values
(Ent
);
2316 -- An Address attribute is accepted when generated by the
2317 -- compiler for dispatching operation, and an error is
2318 -- issued once the subprogram is frozen (to avoid confusing
2319 -- errors about implicit uses of Address in the dispatch
2320 -- table initialization).
2322 if Has_Pragma_Inline_Always
(Entity
(P
))
2323 and then Comes_From_Source
(P
)
2326 ("prefix of % attribute cannot be Inline_Always" &
2329 -- It is illegal to apply 'Address to an intrinsic
2330 -- subprogram. This is now formalized in AI05-0095.
2331 -- In an instance, an attempt to obtain 'Address of an
2332 -- intrinsic subprogram (e.g the renaming of a predefined
2333 -- operator that is an actual) raises Program_Error.
2335 elsif Convention
(Ent
) = Convention_Intrinsic
then
2338 Make_Raise_Program_Error
(Loc
,
2339 Reason
=> PE_Address_Of_Intrinsic
));
2343 ("cannot take Address of intrinsic subprogram", N
);
2346 -- Issue an error if prefix denotes an eliminated subprogram
2349 Check_For_Eliminated_Subprogram
(P
, Ent
);
2352 elsif Is_Object
(Ent
)
2353 or else Ekind
(Ent
) = E_Label
2355 Set_Address_Taken
(Ent
);
2357 -- Deal with No_Implicit_Aliasing restriction
2359 if Restriction_Check_Required
(No_Implicit_Aliasing
) then
2360 if not Is_Aliased_View
(P
) then
2361 Check_Restriction
(No_Implicit_Aliasing
, P
);
2363 Check_No_Implicit_Aliasing
(P
);
2367 -- If we have an address of an object, and the attribute
2368 -- comes from source, then set the object as potentially
2369 -- source modified. We do this because the resulting address
2370 -- can potentially be used to modify the variable and we
2371 -- might not detect this, leading to some junk warnings.
2373 Set_Never_Set_In_Source
(Ent
, False);
2375 elsif (Is_Concurrent_Type
(Etype
(Ent
))
2376 and then Etype
(Ent
) = Base_Type
(Ent
))
2377 or else Ekind
(Ent
) = E_Package
2378 or else Is_Generic_Unit
(Ent
)
2381 New_Occurrence_Of
(RTE
(RE_Null_Address
), Sloc
(N
)));
2384 Error_Attr
("invalid prefix for % attribute", P
);
2388 elsif Nkind
(P
) = N_Attribute_Reference
2389 and then Attribute_Name
(P
) = Name_AST_Entry
2392 New_Occurrence_Of
(RTE
(RE_Null_Address
), Sloc
(N
)));
2394 elsif Is_Object_Reference
(P
) then
2397 elsif Nkind
(P
) = N_Selected_Component
2398 and then Is_Subprogram
(Entity
(Selector_Name
(P
)))
2402 -- What exactly are we allowing here ??? and is this properly
2403 -- documented in the sinfo documentation for this node ???
2405 elsif not Comes_From_Source
(N
) then
2409 Error_Attr
("invalid prefix for % attribute", P
);
2412 Set_Etype
(N
, RTE
(RE_Address
));
2418 when Attribute_Address_Size
=>
2419 Standard_Attribute
(System_Address_Size
);
2425 when Attribute_Adjacent
=>
2426 Check_Floating_Point_Type_2
;
2427 Set_Etype
(N
, P_Base_Type
);
2428 Resolve
(E1
, P_Base_Type
);
2429 Resolve
(E2
, P_Base_Type
);
2435 when Attribute_Aft
=>
2436 Check_Fixed_Point_Type_0
;
2437 Set_Etype
(N
, Universal_Integer
);
2443 when Attribute_Alignment
=>
2445 -- Don't we need more checking here, cf Size ???
2448 Check_Not_Incomplete_Type
;
2450 Set_Etype
(N
, Universal_Integer
);
2456 when Attribute_Asm_Input
=>
2457 Check_Asm_Attribute
;
2459 -- The back-end may need to take the address of E2
2461 if Is_Entity_Name
(E2
) then
2462 Set_Address_Taken
(Entity
(E2
));
2465 Set_Etype
(N
, RTE
(RE_Asm_Input_Operand
));
2471 when Attribute_Asm_Output
=>
2472 Check_Asm_Attribute
;
2474 if Etype
(E2
) = Any_Type
then
2477 elsif Aname
= Name_Asm_Output
then
2478 if not Is_Variable
(E2
) then
2480 ("second argument for Asm_Output is not variable", E2
);
2484 Note_Possible_Modification
(E2
, Sure
=> True);
2486 -- The back-end may need to take the address of E2
2488 if Is_Entity_Name
(E2
) then
2489 Set_Address_Taken
(Entity
(E2
));
2492 Set_Etype
(N
, RTE
(RE_Asm_Output_Operand
));
2498 when Attribute_AST_Entry
=> AST_Entry
: declare
2504 -- Indicates if entry family index is present. Note the coding
2505 -- here handles the entry family case, but in fact it cannot be
2506 -- executed currently, because pragma AST_Entry does not permit
2507 -- the specification of an entry family.
2509 procedure Bad_AST_Entry
;
2510 -- Signal a bad AST_Entry pragma
2512 function OK_Entry
(E
: Entity_Id
) return Boolean;
2513 -- Checks that E is of an appropriate entity kind for an entry
2514 -- (i.e. E_Entry if Index is False, or E_Entry_Family if Index
2515 -- is set True for the entry family case). In the True case,
2516 -- makes sure that Is_AST_Entry is set on the entry.
2522 procedure Bad_AST_Entry
is
2524 Error_Attr_P
("prefix for % attribute must be task entry");
2531 function OK_Entry
(E
: Entity_Id
) return Boolean is
2536 Result
:= (Ekind
(E
) = E_Entry_Family
);
2538 Result
:= (Ekind
(E
) = E_Entry
);
2542 if not Is_AST_Entry
(E
) then
2543 Error_Msg_Name_2
:= Aname
;
2544 Error_Attr
("% attribute requires previous % pragma", P
);
2551 -- Start of processing for AST_Entry
2557 -- Deal with entry family case
2559 if Nkind
(P
) = N_Indexed_Component
then
2567 Ptyp
:= Etype
(Pref
);
2569 if Ptyp
= Any_Type
or else Error_Posted
(Pref
) then
2573 -- If the prefix is a selected component whose prefix is of an
2574 -- access type, then introduce an explicit dereference.
2575 -- ??? Could we reuse Check_Dereference here?
2577 if Nkind
(Pref
) = N_Selected_Component
2578 and then Is_Access_Type
(Ptyp
)
2581 Make_Explicit_Dereference
(Sloc
(Pref
),
2582 Relocate_Node
(Pref
)));
2583 Analyze_And_Resolve
(Pref
, Designated_Type
(Ptyp
));
2586 -- Prefix can be of the form a.b, where a is a task object
2587 -- and b is one of the entries of the corresponding task type.
2589 if Nkind
(Pref
) = N_Selected_Component
2590 and then OK_Entry
(Entity
(Selector_Name
(Pref
)))
2591 and then Is_Object_Reference
(Prefix
(Pref
))
2592 and then Is_Task_Type
(Etype
(Prefix
(Pref
)))
2596 -- Otherwise the prefix must be an entry of a containing task,
2597 -- or of a variable of the enclosing task type.
2600 if Nkind_In
(Pref
, N_Identifier
, N_Expanded_Name
) then
2601 Ent
:= Entity
(Pref
);
2603 if not OK_Entry
(Ent
)
2604 or else not In_Open_Scopes
(Scope
(Ent
))
2614 Set_Etype
(N
, RTE
(RE_AST_Handler
));
2617 -----------------------------
2618 -- Atomic_Always_Lock_Free --
2619 -----------------------------
2621 when Attribute_Atomic_Always_Lock_Free
=>
2624 Set_Etype
(N
, Standard_Boolean
);
2630 -- Note: when the base attribute appears in the context of a subtype
2631 -- mark, the analysis is done by Sem_Ch8.Find_Type, rather than by
2632 -- the following circuit.
2634 when Attribute_Base
=> Base
: declare
2642 if Ada_Version
>= Ada_95
2643 and then not Is_Scalar_Type
(Typ
)
2644 and then not Is_Generic_Type
(Typ
)
2646 Error_Attr_P
("prefix of Base attribute must be scalar type");
2648 elsif Sloc
(Typ
) = Standard_Location
2649 and then Base_Type
(Typ
) = Typ
2650 and then Warn_On_Redundant_Constructs
2652 Error_Msg_NE
-- CODEFIX
2653 ("?r?redundant attribute, & is its own base type", N
, Typ
);
2656 if Nkind
(Parent
(N
)) /= N_Attribute_Reference
then
2657 Error_Msg_Name_1
:= Aname
;
2658 Check_SPARK_Restriction
2659 ("attribute% is only allowed as prefix of another attribute", P
);
2662 Set_Etype
(N
, Base_Type
(Entity
(P
)));
2663 Set_Entity
(N
, Base_Type
(Entity
(P
)));
2664 Rewrite
(N
, New_Reference_To
(Entity
(N
), Loc
));
2672 when Attribute_Bit
=> Bit
:
2676 if not Is_Object_Reference
(P
) then
2677 Error_Attr_P
("prefix for % attribute must be object");
2679 -- What about the access object cases ???
2685 Set_Etype
(N
, Universal_Integer
);
2692 when Attribute_Bit_Order
=> Bit_Order
:
2697 if not Is_Record_Type
(P_Type
) then
2698 Error_Attr_P
("prefix of % attribute must be record type");
2701 if Bytes_Big_Endian
xor Reverse_Bit_Order
(P_Type
) then
2703 New_Occurrence_Of
(RTE
(RE_High_Order_First
), Loc
));
2706 New_Occurrence_Of
(RTE
(RE_Low_Order_First
), Loc
));
2709 Set_Etype
(N
, RTE
(RE_Bit_Order
));
2712 -- Reset incorrect indication of staticness
2714 Set_Is_Static_Expression
(N
, False);
2721 -- Note: in generated code, we can have a Bit_Position attribute
2722 -- applied to a (naked) record component (i.e. the prefix is an
2723 -- identifier that references an E_Component or E_Discriminant
2724 -- entity directly, and this is interpreted as expected by Gigi.
2725 -- The following code will not tolerate such usage, but when the
2726 -- expander creates this special case, it marks it as analyzed
2727 -- immediately and sets an appropriate type.
2729 when Attribute_Bit_Position
=>
2730 if Comes_From_Source
(N
) then
2734 Set_Etype
(N
, Universal_Integer
);
2740 when Attribute_Body_Version
=>
2743 Set_Etype
(N
, RTE
(RE_Version_String
));
2749 when Attribute_Callable
=>
2751 Set_Etype
(N
, Standard_Boolean
);
2758 when Attribute_Caller
=> Caller
: declare
2765 if Nkind_In
(P
, N_Identifier
, N_Expanded_Name
) then
2768 if not Is_Entry
(Ent
) then
2769 Error_Attr
("invalid entry name", N
);
2773 Error_Attr
("invalid entry name", N
);
2777 for J
in reverse 0 .. Scope_Stack
.Last
loop
2778 S
:= Scope_Stack
.Table
(J
).Entity
;
2780 if S
= Scope
(Ent
) then
2781 Error_Attr
("Caller must appear in matching accept or body", N
);
2787 Set_Etype
(N
, RTE
(RO_AT_Task_Id
));
2794 when Attribute_Ceiling
=>
2795 Check_Floating_Point_Type_1
;
2796 Set_Etype
(N
, P_Base_Type
);
2797 Resolve
(E1
, P_Base_Type
);
2803 when Attribute_Class
=>
2804 Check_Restriction
(No_Dispatch
, N
);
2808 -- Applying Class to untagged incomplete type is obsolescent in Ada
2809 -- 2005. Note that we can't test Is_Tagged_Type here on P_Type, since
2810 -- this flag gets set by Find_Type in this situation.
2812 if Restriction_Check_Required
(No_Obsolescent_Features
)
2813 and then Ada_Version
>= Ada_2005
2814 and then Ekind
(P_Type
) = E_Incomplete_Type
2817 DN
: constant Node_Id
:= Declaration_Node
(P_Type
);
2819 if Nkind
(DN
) = N_Incomplete_Type_Declaration
2820 and then not Tagged_Present
(DN
)
2822 Check_Restriction
(No_Obsolescent_Features
, P
);
2831 when Attribute_Code_Address
=>
2834 if Nkind
(P
) = N_Attribute_Reference
2835 and then (Attribute_Name
(P
) = Name_Elab_Body
2837 Attribute_Name
(P
) = Name_Elab_Spec
)
2841 elsif not Is_Entity_Name
(P
)
2842 or else (Ekind
(Entity
(P
)) /= E_Function
2844 Ekind
(Entity
(P
)) /= E_Procedure
)
2846 Error_Attr
("invalid prefix for % attribute", P
);
2847 Set_Address_Taken
(Entity
(P
));
2849 -- Issue an error if the prefix denotes an eliminated subprogram
2852 Check_For_Eliminated_Subprogram
(P
, Entity
(P
));
2855 Set_Etype
(N
, RTE
(RE_Address
));
2857 ----------------------
2858 -- Compiler_Version --
2859 ----------------------
2861 when Attribute_Compiler_Version
=>
2863 Check_Standard_Prefix
;
2864 Rewrite
(N
, Make_String_Literal
(Loc
, "GNAT " & Gnat_Version_String
));
2865 Analyze_And_Resolve
(N
, Standard_String
);
2867 --------------------
2868 -- Component_Size --
2869 --------------------
2871 when Attribute_Component_Size
=>
2873 Set_Etype
(N
, Universal_Integer
);
2875 -- Note: unlike other array attributes, unconstrained arrays are OK
2877 if Is_Array_Type
(P_Type
) and then not Is_Constrained
(P_Type
) then
2887 when Attribute_Compose
=>
2888 Check_Floating_Point_Type_2
;
2889 Set_Etype
(N
, P_Base_Type
);
2890 Resolve
(E1
, P_Base_Type
);
2891 Resolve
(E2
, Any_Integer
);
2897 when Attribute_Constrained
=>
2899 Set_Etype
(N
, Standard_Boolean
);
2901 -- Case from RM J.4(2) of constrained applied to private type
2903 if Is_Entity_Name
(P
) and then Is_Type
(Entity
(P
)) then
2904 Check_Restriction
(No_Obsolescent_Features
, P
);
2906 if Warn_On_Obsolescent_Feature
then
2908 ("constrained for private type is an " &
2909 "obsolescent feature (RM J.4)?j?", N
);
2912 -- If we are within an instance, the attribute must be legal
2913 -- because it was valid in the generic unit. Ditto if this is
2914 -- an inlining of a function declared in an instance.
2917 or else In_Inlined_Body
2921 -- For sure OK if we have a real private type itself, but must
2922 -- be completed, cannot apply Constrained to incomplete type.
2924 elsif Is_Private_Type
(Entity
(P
)) then
2926 -- Note: this is one of the Annex J features that does not
2927 -- generate a warning from -gnatwj, since in fact it seems
2928 -- very useful, and is used in the GNAT runtime.
2930 Check_Not_Incomplete_Type
;
2934 -- Normal (non-obsolescent case) of application to object of
2935 -- a discriminated type.
2938 Check_Object_Reference
(P
);
2940 -- If N does not come from source, then we allow the
2941 -- the attribute prefix to be of a private type whose
2942 -- full type has discriminants. This occurs in cases
2943 -- involving expanded calls to stream attributes.
2945 if not Comes_From_Source
(N
) then
2946 P_Type
:= Underlying_Type
(P_Type
);
2949 -- Must have discriminants or be an access type designating
2950 -- a type with discriminants. If it is a classwide type is ???
2951 -- has unknown discriminants.
2953 if Has_Discriminants
(P_Type
)
2954 or else Has_Unknown_Discriminants
(P_Type
)
2956 (Is_Access_Type
(P_Type
)
2957 and then Has_Discriminants
(Designated_Type
(P_Type
)))
2961 -- Also allow an object of a generic type if extensions allowed
2962 -- and allow this for any type at all.
2964 elsif (Is_Generic_Type
(P_Type
)
2965 or else Is_Generic_Actual_Type
(P_Type
))
2966 and then Extensions_Allowed
2972 -- Fall through if bad prefix
2975 ("prefix of % attribute must be object of discriminated type");
2981 when Attribute_Copy_Sign
=>
2982 Check_Floating_Point_Type_2
;
2983 Set_Etype
(N
, P_Base_Type
);
2984 Resolve
(E1
, P_Base_Type
);
2985 Resolve
(E2
, P_Base_Type
);
2991 when Attribute_Count
=> Count
:
3000 if Nkind_In
(P
, N_Identifier
, N_Expanded_Name
) then
3003 if Ekind
(Ent
) /= E_Entry
then
3004 Error_Attr
("invalid entry name", N
);
3007 elsif Nkind
(P
) = N_Indexed_Component
then
3008 if not Is_Entity_Name
(Prefix
(P
))
3009 or else No
(Entity
(Prefix
(P
)))
3010 or else Ekind
(Entity
(Prefix
(P
))) /= E_Entry_Family
3012 if Nkind
(Prefix
(P
)) = N_Selected_Component
3013 and then Present
(Entity
(Selector_Name
(Prefix
(P
))))
3014 and then Ekind
(Entity
(Selector_Name
(Prefix
(P
)))) =
3018 ("attribute % must apply to entry of current task", P
);
3021 Error_Attr
("invalid entry family name", P
);
3026 Ent
:= Entity
(Prefix
(P
));
3029 elsif Nkind
(P
) = N_Selected_Component
3030 and then Present
(Entity
(Selector_Name
(P
)))
3031 and then Ekind
(Entity
(Selector_Name
(P
))) = E_Entry
3034 ("attribute % must apply to entry of current task", P
);
3037 Error_Attr
("invalid entry name", N
);
3041 for J
in reverse 0 .. Scope_Stack
.Last
loop
3042 S
:= Scope_Stack
.Table
(J
).Entity
;
3044 if S
= Scope
(Ent
) then
3045 if Nkind
(P
) = N_Expanded_Name
then
3046 Tsk
:= Entity
(Prefix
(P
));
3048 -- The prefix denotes either the task type, or else a
3049 -- single task whose task type is being analyzed.
3054 or else (not Is_Type
(Tsk
)
3055 and then Etype
(Tsk
) = S
3056 and then not (Comes_From_Source
(S
)))
3061 ("Attribute % must apply to entry of current task", N
);
3067 elsif Ekind
(Scope
(Ent
)) in Task_Kind
3069 not Ekind_In
(S
, E_Loop
, E_Block
, E_Entry
, E_Entry_Family
)
3071 Error_Attr
("Attribute % cannot appear in inner unit", N
);
3073 elsif Ekind
(Scope
(Ent
)) = E_Protected_Type
3074 and then not Has_Completion
(Scope
(Ent
))
3076 Error_Attr
("attribute % can only be used inside body", N
);
3080 if Is_Overloaded
(P
) then
3082 Index
: Interp_Index
;
3086 Get_First_Interp
(P
, Index
, It
);
3088 while Present
(It
.Nam
) loop
3089 if It
.Nam
= Ent
then
3092 -- Ada 2005 (AI-345): Do not consider primitive entry
3093 -- wrappers generated for task or protected types.
3095 elsif Ada_Version
>= Ada_2005
3096 and then not Comes_From_Source
(It
.Nam
)
3101 Error_Attr
("ambiguous entry name", N
);
3104 Get_Next_Interp
(Index
, It
);
3109 Set_Etype
(N
, Universal_Integer
);
3112 -----------------------
3113 -- Default_Bit_Order --
3114 -----------------------
3116 when Attribute_Default_Bit_Order
=> Default_Bit_Order
:
3118 Check_Standard_Prefix
;
3120 if Bytes_Big_Endian
then
3122 Make_Integer_Literal
(Loc
, False_Value
));
3125 Make_Integer_Literal
(Loc
, True_Value
));
3128 Set_Etype
(N
, Universal_Integer
);
3129 Set_Is_Static_Expression
(N
);
3130 end Default_Bit_Order
;
3136 when Attribute_Definite
=>
3137 Legal_Formal_Attribute
;
3143 when Attribute_Delta
=>
3144 Check_Fixed_Point_Type_0
;
3145 Set_Etype
(N
, Universal_Real
);
3151 when Attribute_Denorm
=>
3152 Check_Floating_Point_Type_0
;
3153 Set_Etype
(N
, Standard_Boolean
);
3155 ---------------------
3156 -- Descriptor_Size --
3157 ---------------------
3159 when Attribute_Descriptor_Size
=>
3162 if not Is_Entity_Name
(P
)
3163 or else not Is_Type
(Entity
(P
))
3165 Error_Attr_P
("prefix of attribute % must denote a type");
3168 Set_Etype
(N
, Universal_Integer
);
3174 when Attribute_Digits
=>
3178 if not Is_Floating_Point_Type
(P_Type
)
3179 and then not Is_Decimal_Fixed_Point_Type
(P_Type
)
3182 ("prefix of % attribute must be float or decimal type");
3185 Set_Etype
(N
, Universal_Integer
);
3191 -- Also handles processing for Elab_Spec and Elab_Subp_Body
3193 when Attribute_Elab_Body |
3194 Attribute_Elab_Spec |
3195 Attribute_Elab_Subp_Body
=>
3198 Check_Unit_Name
(P
);
3199 Set_Etype
(N
, Standard_Void_Type
);
3201 -- We have to manually call the expander in this case to get
3202 -- the necessary expansion (normally attributes that return
3203 -- entities are not expanded).
3211 -- Shares processing with Elab_Body
3217 when Attribute_Elaborated
=>
3219 Check_Unit_Name
(P
);
3220 Set_Etype
(N
, Standard_Boolean
);
3226 when Attribute_Emax
=>
3227 Check_Floating_Point_Type_0
;
3228 Set_Etype
(N
, Universal_Integer
);
3234 when Attribute_Enabled
=>
3235 Check_Either_E0_Or_E1
;
3237 if Present
(E1
) then
3238 if not Is_Entity_Name
(E1
) or else No
(Entity
(E1
)) then
3239 Error_Msg_N
("entity name expected for Enabled attribute", E1
);
3244 if Nkind
(P
) /= N_Identifier
then
3245 Error_Msg_N
("identifier expected (check name)", P
);
3246 elsif Get_Check_Id
(Chars
(P
)) = No_Check_Id
then
3247 Error_Msg_N
("& is not a recognized check name", P
);
3250 Set_Etype
(N
, Standard_Boolean
);
3256 when Attribute_Enum_Rep
=> Enum_Rep
: declare
3258 if Present
(E1
) then
3260 Check_Discrete_Type
;
3261 Resolve
(E1
, P_Base_Type
);
3264 if not Is_Entity_Name
(P
)
3265 or else (not Is_Object
(Entity
(P
))
3267 Ekind
(Entity
(P
)) /= E_Enumeration_Literal
)
3270 ("prefix of % attribute must be " &
3271 "discrete type/object or enum literal");
3275 Set_Etype
(N
, Universal_Integer
);
3282 when Attribute_Enum_Val
=> Enum_Val
: begin
3286 if not Is_Enumeration_Type
(P_Type
) then
3287 Error_Attr_P
("prefix of % attribute must be enumeration type");
3290 -- If the enumeration type has a standard representation, the effect
3291 -- is the same as 'Val, so rewrite the attribute as a 'Val.
3293 if not Has_Non_Standard_Rep
(P_Base_Type
) then
3295 Make_Attribute_Reference
(Loc
,
3296 Prefix
=> Relocate_Node
(Prefix
(N
)),
3297 Attribute_Name
=> Name_Val
,
3298 Expressions
=> New_List
(Relocate_Node
(E1
))));
3299 Analyze_And_Resolve
(N
, P_Base_Type
);
3301 -- Non-standard representation case (enumeration with holes)
3305 Resolve
(E1
, Any_Integer
);
3306 Set_Etype
(N
, P_Base_Type
);
3314 when Attribute_Epsilon
=>
3315 Check_Floating_Point_Type_0
;
3316 Set_Etype
(N
, Universal_Real
);
3322 when Attribute_Exponent
=>
3323 Check_Floating_Point_Type_1
;
3324 Set_Etype
(N
, Universal_Integer
);
3325 Resolve
(E1
, P_Base_Type
);
3331 when Attribute_External_Tag
=>
3335 Set_Etype
(N
, Standard_String
);
3337 if not Is_Tagged_Type
(P_Type
) then
3338 Error_Attr_P
("prefix of % attribute must be tagged");
3345 when Attribute_Fast_Math
=>
3346 Check_Standard_Prefix
;
3347 Rewrite
(N
, New_Occurrence_Of
(Boolean_Literals
(Fast_Math
), Loc
));
3353 when Attribute_First
=>
3354 Check_Array_Or_Scalar_Type
;
3355 Bad_Attribute_For_Predicate
;
3361 when Attribute_First_Bit
=>
3363 Set_Etype
(N
, Universal_Integer
);
3369 when Attribute_First_Valid
=>
3370 Check_First_Last_Valid
;
3371 Set_Etype
(N
, P_Type
);
3377 when Attribute_Fixed_Value
=>
3379 Check_Fixed_Point_Type
;
3380 Resolve
(E1
, Any_Integer
);
3381 Set_Etype
(N
, P_Base_Type
);
3387 when Attribute_Floor
=>
3388 Check_Floating_Point_Type_1
;
3389 Set_Etype
(N
, P_Base_Type
);
3390 Resolve
(E1
, P_Base_Type
);
3396 when Attribute_Fore
=>
3397 Check_Fixed_Point_Type_0
;
3398 Set_Etype
(N
, Universal_Integer
);
3404 when Attribute_Fraction
=>
3405 Check_Floating_Point_Type_1
;
3406 Set_Etype
(N
, P_Base_Type
);
3407 Resolve
(E1
, P_Base_Type
);
3413 when Attribute_From_Any
=>
3415 Check_PolyORB_Attribute
;
3416 Set_Etype
(N
, P_Base_Type
);
3418 -----------------------
3419 -- Has_Access_Values --
3420 -----------------------
3422 when Attribute_Has_Access_Values
=>
3425 Set_Etype
(N
, Standard_Boolean
);
3427 -----------------------
3428 -- Has_Tagged_Values --
3429 -----------------------
3431 when Attribute_Has_Tagged_Values
=>
3434 Set_Etype
(N
, Standard_Boolean
);
3436 -----------------------
3437 -- Has_Discriminants --
3438 -----------------------
3440 when Attribute_Has_Discriminants
=>
3441 Legal_Formal_Attribute
;
3447 when Attribute_Identity
=>
3451 if Etype
(P
) = Standard_Exception_Type
then
3452 Set_Etype
(N
, RTE
(RE_Exception_Id
));
3454 -- Ada 2005 (AI-345): Attribute 'Identity may be applied to
3455 -- task interface class-wide types.
3457 elsif Is_Task_Type
(Etype
(P
))
3458 or else (Is_Access_Type
(Etype
(P
))
3459 and then Is_Task_Type
(Designated_Type
(Etype
(P
))))
3460 or else (Ada_Version
>= Ada_2005
3461 and then Ekind
(Etype
(P
)) = E_Class_Wide_Type
3462 and then Is_Interface
(Etype
(P
))
3463 and then Is_Task_Interface
(Etype
(P
)))
3466 Set_Etype
(N
, RTE
(RO_AT_Task_Id
));
3469 if Ada_Version
>= Ada_2005
then
3471 ("prefix of % attribute must be an exception, a " &
3472 "task or a task interface class-wide object");
3475 ("prefix of % attribute must be a task or an exception");
3483 when Attribute_Image
=> Image
:
3485 Check_SPARK_Restriction_On_Attribute
;
3487 Set_Etype
(N
, Standard_String
);
3489 if Is_Real_Type
(P_Type
) then
3490 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3491 Error_Msg_Name_1
:= Aname
;
3493 ("(Ada 83) % attribute not allowed for real types", N
);
3497 if Is_Enumeration_Type
(P_Type
) then
3498 Check_Restriction
(No_Enumeration_Maps
, N
);
3502 Resolve
(E1
, P_Base_Type
);
3504 Validate_Non_Static_Attribute_Function_Call
;
3511 when Attribute_Img
=> Img
:
3514 Set_Etype
(N
, Standard_String
);
3516 if not Is_Scalar_Type
(P_Type
)
3517 or else (Is_Entity_Name
(P
) and then Is_Type
(Entity
(P
)))
3520 ("prefix of % attribute must be scalar object name");
3530 when Attribute_Input
=>
3532 Check_Stream_Attribute
(TSS_Stream_Input
);
3533 Set_Etype
(N
, P_Base_Type
);
3539 when Attribute_Integer_Value
=>
3542 Resolve
(E1
, Any_Fixed
);
3544 -- Signal an error if argument type is not a specific fixed-point
3545 -- subtype. An error has been signalled already if the argument
3546 -- was not of a fixed-point type.
3548 if Etype
(E1
) = Any_Fixed
and then not Error_Posted
(E1
) then
3549 Error_Attr
("argument of % must be of a fixed-point type", E1
);
3552 Set_Etype
(N
, P_Base_Type
);
3558 when Attribute_Invalid_Value
=>
3561 Set_Etype
(N
, P_Base_Type
);
3562 Invalid_Value_Used
:= True;
3568 when Attribute_Large
=>
3571 Set_Etype
(N
, Universal_Real
);
3577 when Attribute_Last
=>
3578 Check_Array_Or_Scalar_Type
;
3579 Bad_Attribute_For_Predicate
;
3585 when Attribute_Last_Bit
=>
3587 Set_Etype
(N
, Universal_Integer
);
3593 when Attribute_Last_Valid
=>
3594 Check_First_Last_Valid
;
3595 Set_Etype
(N
, P_Type
);
3601 when Attribute_Leading_Part
=>
3602 Check_Floating_Point_Type_2
;
3603 Set_Etype
(N
, P_Base_Type
);
3604 Resolve
(E1
, P_Base_Type
);
3605 Resolve
(E2
, Any_Integer
);
3611 when Attribute_Length
=>
3613 Set_Etype
(N
, Universal_Integer
);
3619 when Attribute_Lock_Free
=>
3621 Set_Etype
(N
, Standard_Boolean
);
3623 if not Is_Protected_Type
(P_Type
) then
3625 ("prefix of % attribute must be a protected object");
3632 when Attribute_Loop_Entry
=> Loop_Entry
: declare
3633 procedure Check_References_In_Prefix
(Loop_Id
: Entity_Id
);
3634 -- Inspect the prefix for any uses of entities declared within the
3635 -- related loop. Loop_Id denotes the loop identifier.
3637 procedure Convert_To_Indexed_Component
;
3638 -- Transform the attribute reference into an indexed component where
3639 -- the prefix is Prefix'Loop_Entry and the expressions are associated
3640 -- with the indexed component.
3642 --------------------------------
3643 -- Check_References_In_Prefix --
3644 --------------------------------
3646 procedure Check_References_In_Prefix
(Loop_Id
: Entity_Id
) is
3647 Loop_Decl
: constant Node_Id
:= Label_Construct
(Parent
(Loop_Id
));
3649 function Check_Reference
(Nod
: Node_Id
) return Traverse_Result
;
3650 -- Determine whether a reference mentions an entity declared
3651 -- within the related loop.
3653 function Declared_Within
(Nod
: Node_Id
) return Boolean;
3654 -- Determine whether Nod appears in the subtree of Loop_Decl
3656 ---------------------
3657 -- Check_Reference --
3658 ---------------------
3660 function Check_Reference
(Nod
: Node_Id
) return Traverse_Result
is
3662 if Nkind
(Nod
) = N_Identifier
3663 and then Present
(Entity
(Nod
))
3664 and then Declared_Within
(Declaration_Node
(Entity
(Nod
)))
3667 ("prefix of attribute % cannot reference local entities",
3673 end Check_Reference
;
3675 procedure Check_References
is new Traverse_Proc
(Check_Reference
);
3677 ---------------------
3678 -- Declared_Within --
3679 ---------------------
3681 function Declared_Within
(Nod
: Node_Id
) return Boolean is
3686 while Present
(Stmt
) loop
3687 if Stmt
= Loop_Decl
then
3690 -- Prevent the search from going too far
3692 elsif Nkind_In
(Stmt
, N_Entry_Body
,
3694 N_Package_Declaration
,
3702 Stmt
:= Parent
(Stmt
);
3706 end Declared_Within
;
3708 -- Start of processing for Check_Prefix_For_Local_References
3711 Check_References
(P
);
3712 end Check_References_In_Prefix
;
3714 ----------------------------------
3715 -- Convert_To_Indexed_Component --
3716 ----------------------------------
3718 procedure Convert_To_Indexed_Component
is
3719 New_Loop_Entry
: constant Node_Id
:= Relocate_Node
(N
);
3722 -- The new Loop_Entry loses its arguments. They will be converted
3723 -- into the expressions of the indexed component.
3725 Set_Expressions
(New_Loop_Entry
, No_List
);
3728 Make_Indexed_Component
(Loc
,
3729 Prefix
=> New_Loop_Entry
,
3730 Expressions
=> Exprs
));
3731 end Convert_To_Indexed_Component
;
3735 Enclosing_Loop
: Node_Id
;
3736 In_Loop_Assertion
: Boolean := False;
3737 Loop_Id
: Entity_Id
:= Empty
;
3741 -- Start of processing for Loop_Entry
3746 -- The attribute reference appears as
3747 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
3749 -- In this case, the loop name is omitted and the arguments are part
3750 -- of an indexed component. Transform the whole attribute reference
3751 -- to reflect this scenario.
3753 if Present
(E2
) then
3754 Convert_To_Indexed_Component
;
3758 -- The attribute reference appears as
3759 -- Prefix'Loop_Entry (Loop_Name)
3761 -- Prefix'Loop_Entry (Expr1)
3763 -- Depending on what Expr1 resolves to, either rewrite the reference
3764 -- into an indexed component or continue with the analysis.
3766 elsif Present
(E1
) then
3768 -- Do not expand the argument as it may have side effects. Simply
3769 -- preanalyze to determine whether it is a loop or something else.
3771 Preanalyze_And_Resolve
(E1
);
3773 if Is_Entity_Name
(E1
)
3774 and then Present
(Entity
(E1
))
3775 and then Ekind
(Entity
(E1
)) = E_Loop
3777 Loop_Id
:= Entity
(E1
);
3779 -- The argument is not a loop name
3782 Convert_To_Indexed_Component
;
3788 -- The prefix must denote an object
3790 if not Is_Object_Reference
(P
) then
3791 Error_Attr_P
("prefix of attribute % must denote an object");
3794 -- The prefix cannot be of a limited type because the expansion of
3795 -- Loop_Entry must create a constant initialized by the evaluated
3798 if Is_Immutably_Limited_Type
(Etype
(P
)) then
3799 Error_Attr_P
("prefix of attribute % cannot be limited");
3802 -- Climb the parent chain to verify the location of the attribute and
3803 -- find the enclosing loop.
3806 while Present
(Stmt
) loop
3808 -- Locate the enclosing Loop_Invariant / Loop_Variant pragma (if
3809 -- any). Note that when these two are expanded, we must look for
3810 -- an Assertion pragma.
3812 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
3814 (Pragma_Name
(Original_Node
(Stmt
)) = Name_Assert
3816 Pragma_Name
(Original_Node
(Stmt
)) = Name_Loop_Invariant
3818 Pragma_Name
(Original_Node
(Stmt
)) = Name_Loop_Variant
)
3820 In_Loop_Assertion
:= True;
3822 -- Locate the enclosing loop (if any). Note that Ada 2012 array
3823 -- iteration may be expanded into several nested loops, we are
3824 -- interested in the outermost one which has the loop identifier.
3826 elsif Nkind
(Stmt
) = N_Loop_Statement
3827 and then Present
(Identifier
(Stmt
))
3829 Enclosing_Loop
:= Stmt
;
3831 -- The original attribute reference may lack a loop name. Use
3832 -- the name of the enclosing loop because it is the related
3835 if No
(Loop_Id
) then
3836 Loop_Id
:= Entity
(Identifier
(Enclosing_Loop
));
3841 -- Prevent the search from going too far
3843 elsif Nkind_In
(Stmt
, N_Entry_Body
,
3845 N_Package_Declaration
,
3853 Stmt
:= Parent
(Stmt
);
3856 -- Loop_Entry must appear within a Loop_Assertion pragma
3858 if not In_Loop_Assertion
then
3860 ("attribute % must appear within pragma Loop_Variant or " &
3861 "Loop_Invariant", N
);
3864 -- A Loop_Entry that applies to a given loop statement shall not
3865 -- appear within a body of accept statement, if this construct is
3866 -- itself enclosed by the given loop statement.
3868 for J
in reverse 0 .. Scope_Stack
.Last
loop
3869 Scop
:= Scope_Stack
.Table
(J
).Entity
;
3871 if Ekind
(Scop
) = E_Loop
and then Scop
= Loop_Id
then
3874 elsif Ekind_In
(Scop
, E_Block
, E_Loop
, E_Return_Statement
) then
3879 ("attribute % cannot appear in body or accept statement", N
);
3884 -- The prefix cannot mention entities declared within the related
3885 -- loop because they will not be visible once the prefix is moved
3886 -- outside the loop.
3888 Check_References_In_Prefix
(Loop_Id
);
3890 -- The prefix must denote a static entity if the pragma does not
3891 -- apply to the innermost enclosing loop statement.
3893 if Present
(Enclosing_Loop
)
3894 and then Entity
(Identifier
(Enclosing_Loop
)) /= Loop_Id
3895 and then not Is_Entity_Name
(P
)
3897 Error_Attr_P
("prefix of attribute % must denote an entity");
3900 Set_Etype
(N
, Etype
(P
));
3902 -- Associate the attribute with its related loop
3904 if No
(Loop_Entry_Attributes
(Loop_Id
)) then
3905 Set_Loop_Entry_Attributes
(Loop_Id
, New_Elmt_List
);
3908 -- A Loop_Entry may be [pre]analyzed several times, depending on the
3909 -- context. Ensure that it appears only once in the attributes list
3910 -- of the related loop.
3912 Append_Unique_Elmt
(N
, Loop_Entry_Attributes
(Loop_Id
));
3919 when Attribute_Machine
=>
3920 Check_Floating_Point_Type_1
;
3921 Set_Etype
(N
, P_Base_Type
);
3922 Resolve
(E1
, P_Base_Type
);
3928 when Attribute_Machine_Emax
=>
3929 Check_Floating_Point_Type_0
;
3930 Set_Etype
(N
, Universal_Integer
);
3936 when Attribute_Machine_Emin
=>
3937 Check_Floating_Point_Type_0
;
3938 Set_Etype
(N
, Universal_Integer
);
3940 ----------------------
3941 -- Machine_Mantissa --
3942 ----------------------
3944 when Attribute_Machine_Mantissa
=>
3945 Check_Floating_Point_Type_0
;
3946 Set_Etype
(N
, Universal_Integer
);
3948 -----------------------
3949 -- Machine_Overflows --
3950 -----------------------
3952 when Attribute_Machine_Overflows
=>
3955 Set_Etype
(N
, Standard_Boolean
);
3961 when Attribute_Machine_Radix
=>
3964 Set_Etype
(N
, Universal_Integer
);
3966 ----------------------
3967 -- Machine_Rounding --
3968 ----------------------
3970 when Attribute_Machine_Rounding
=>
3971 Check_Floating_Point_Type_1
;
3972 Set_Etype
(N
, P_Base_Type
);
3973 Resolve
(E1
, P_Base_Type
);
3975 --------------------
3976 -- Machine_Rounds --
3977 --------------------
3979 when Attribute_Machine_Rounds
=>
3982 Set_Etype
(N
, Standard_Boolean
);
3988 when Attribute_Machine_Size
=>
3991 Check_Not_Incomplete_Type
;
3992 Set_Etype
(N
, Universal_Integer
);
3998 when Attribute_Mantissa
=>
4001 Set_Etype
(N
, Universal_Integer
);
4007 when Attribute_Max
=>
4010 Resolve
(E1
, P_Base_Type
);
4011 Resolve
(E2
, P_Base_Type
);
4012 Set_Etype
(N
, P_Base_Type
);
4014 ----------------------------------
4015 -- Max_Alignment_For_Allocation --
4016 -- Max_Size_In_Storage_Elements --
4017 ----------------------------------
4019 when Attribute_Max_Alignment_For_Allocation |
4020 Attribute_Max_Size_In_Storage_Elements
=>
4023 Check_Not_Incomplete_Type
;
4024 Set_Etype
(N
, Universal_Integer
);
4026 -----------------------
4027 -- Maximum_Alignment --
4028 -----------------------
4030 when Attribute_Maximum_Alignment
=>
4031 Standard_Attribute
(Ttypes
.Maximum_Alignment
);
4033 --------------------
4034 -- Mechanism_Code --
4035 --------------------
4037 when Attribute_Mechanism_Code
=>
4038 if not Is_Entity_Name
(P
)
4039 or else not Is_Subprogram
(Entity
(P
))
4041 Error_Attr_P
("prefix of % attribute must be subprogram");
4044 Check_Either_E0_Or_E1
;
4046 if Present
(E1
) then
4047 Resolve
(E1
, Any_Integer
);
4048 Set_Etype
(E1
, Standard_Integer
);
4050 if not Is_Static_Expression
(E1
) then
4051 Flag_Non_Static_Expr
4052 ("expression for parameter number must be static!", E1
);
4055 elsif UI_To_Int
(Intval
(E1
)) > Number_Formals
(Entity
(P
))
4056 or else UI_To_Int
(Intval
(E1
)) < 0
4058 Error_Attr
("invalid parameter number for % attribute", E1
);
4062 Set_Etype
(N
, Universal_Integer
);
4068 when Attribute_Min
=>
4071 Resolve
(E1
, P_Base_Type
);
4072 Resolve
(E2
, P_Base_Type
);
4073 Set_Etype
(N
, P_Base_Type
);
4079 when Attribute_Mod
=>
4081 -- Note: this attribute is only allowed in Ada 2005 mode, but
4082 -- we do not need to test that here, since Mod is only recognized
4083 -- as an attribute name in Ada 2005 mode during the parse.
4086 Check_Modular_Integer_Type
;
4087 Resolve
(E1
, Any_Integer
);
4088 Set_Etype
(N
, P_Base_Type
);
4094 when Attribute_Model
=>
4095 Check_Floating_Point_Type_1
;
4096 Set_Etype
(N
, P_Base_Type
);
4097 Resolve
(E1
, P_Base_Type
);
4103 when Attribute_Model_Emin
=>
4104 Check_Floating_Point_Type_0
;
4105 Set_Etype
(N
, Universal_Integer
);
4111 when Attribute_Model_Epsilon
=>
4112 Check_Floating_Point_Type_0
;
4113 Set_Etype
(N
, Universal_Real
);
4115 --------------------
4116 -- Model_Mantissa --
4117 --------------------
4119 when Attribute_Model_Mantissa
=>
4120 Check_Floating_Point_Type_0
;
4121 Set_Etype
(N
, Universal_Integer
);
4127 when Attribute_Model_Small
=>
4128 Check_Floating_Point_Type_0
;
4129 Set_Etype
(N
, Universal_Real
);
4135 when Attribute_Modulus
=>
4137 Check_Modular_Integer_Type
;
4138 Set_Etype
(N
, Universal_Integer
);
4140 --------------------
4141 -- Null_Parameter --
4142 --------------------
4144 when Attribute_Null_Parameter
=> Null_Parameter
: declare
4145 Parnt
: constant Node_Id
:= Parent
(N
);
4146 GParnt
: constant Node_Id
:= Parent
(Parnt
);
4148 procedure Bad_Null_Parameter
(Msg
: String);
4149 -- Used if bad Null parameter attribute node is found. Issues
4150 -- given error message, and also sets the type to Any_Type to
4151 -- avoid blowups later on from dealing with a junk node.
4153 procedure Must_Be_Imported
(Proc_Ent
: Entity_Id
);
4154 -- Called to check that Proc_Ent is imported subprogram
4156 ------------------------
4157 -- Bad_Null_Parameter --
4158 ------------------------
4160 procedure Bad_Null_Parameter
(Msg
: String) is
4162 Error_Msg_N
(Msg
, N
);
4163 Set_Etype
(N
, Any_Type
);
4164 end Bad_Null_Parameter
;
4166 ----------------------
4167 -- Must_Be_Imported --
4168 ----------------------
4170 procedure Must_Be_Imported
(Proc_Ent
: Entity_Id
) is
4171 Pent
: constant Entity_Id
:= Ultimate_Alias
(Proc_Ent
);
4174 -- Ignore check if procedure not frozen yet (we will get
4175 -- another chance when the default parameter is reanalyzed)
4177 if not Is_Frozen
(Pent
) then
4180 elsif not Is_Imported
(Pent
) then
4182 ("Null_Parameter can only be used with imported subprogram");
4187 end Must_Be_Imported
;
4189 -- Start of processing for Null_Parameter
4194 Set_Etype
(N
, P_Type
);
4196 -- Case of attribute used as default expression
4198 if Nkind
(Parnt
) = N_Parameter_Specification
then
4199 Must_Be_Imported
(Defining_Entity
(GParnt
));
4201 -- Case of attribute used as actual for subprogram (positional)
4203 elsif Nkind
(Parnt
) in N_Subprogram_Call
4204 and then Is_Entity_Name
(Name
(Parnt
))
4206 Must_Be_Imported
(Entity
(Name
(Parnt
)));
4208 -- Case of attribute used as actual for subprogram (named)
4210 elsif Nkind
(Parnt
) = N_Parameter_Association
4211 and then Nkind
(GParnt
) in N_Subprogram_Call
4212 and then Is_Entity_Name
(Name
(GParnt
))
4214 Must_Be_Imported
(Entity
(Name
(GParnt
)));
4216 -- Not an allowed case
4220 ("Null_Parameter must be actual or default parameter");
4228 when Attribute_Object_Size
=>
4231 Check_Not_Incomplete_Type
;
4232 Set_Etype
(N
, Universal_Integer
);
4238 when Attribute_Old
=> Old
: declare
4240 -- The enclosing scope, excluding loops for quantified expressions.
4241 -- During analysis, it is the postcondition subprogram. During
4242 -- pre-analysis, it is the scope of the subprogram declaration.
4245 -- During pre-analysis, Prag is the enclosing pragma node if any
4248 -- Find enclosing scopes, excluding loops
4250 CS
:= Current_Scope
;
4251 while Ekind
(CS
) = E_Loop
loop
4255 -- If we are in Spec_Expression mode, this should be the prescan of
4256 -- the postcondition (or contract case, or test case) pragma.
4258 if In_Spec_Expression
then
4260 -- Check in postcondition or Ensures clause
4263 while not Nkind_In
(Prag
, N_Pragma
,
4264 N_Function_Specification
,
4265 N_Procedure_Specification
,
4268 Prag
:= Parent
(Prag
);
4271 if Nkind
(Prag
) /= N_Pragma
then
4272 Error_Attr
("% attribute can only appear in postcondition", P
);
4274 elsif Get_Pragma_Id
(Prag
) = Pragma_Contract_Case
4276 Get_Pragma_Id
(Prag
) = Pragma_Test_Case
4279 Arg_Ens
: constant Node_Id
:=
4280 Get_Ensures_From_CTC_Pragma
(Prag
);
4285 while Arg
/= Prag
and Arg
/= Arg_Ens
loop
4286 Arg
:= Parent
(Arg
);
4289 if Arg
/= Arg_Ens
then
4290 if Get_Pragma_Id
(Prag
) = Pragma_Contract_Case
then
4292 ("% attribute misplaced inside contract case", P
);
4295 ("% attribute misplaced inside test case", P
);
4300 elsif Get_Pragma_Id
(Prag
) /= Pragma_Postcondition
then
4301 Error_Attr
("% attribute can only appear in postcondition", P
);
4304 -- Body case, where we must be inside a generated _Postcondition
4305 -- procedure, or else the attribute use is definitely misplaced. The
4306 -- postcondition itself may have generated transient scopes, and is
4307 -- not necessarily the current one.
4310 while Present
(CS
) and then CS
/= Standard_Standard
loop
4311 if Chars
(CS
) = Name_uPostconditions
then
4318 if Chars
(CS
) /= Name_uPostconditions
then
4319 Error_Attr
("% attribute can only appear in postcondition", P
);
4323 -- Either the attribute reference is generated for a Requires
4324 -- clause, in which case no expressions follow, or it is a
4325 -- primary. In that case, if expressions follow, the attribute
4326 -- reference is an indexable object, so rewrite the node
4329 if Present
(E1
) then
4331 Make_Indexed_Component
(Loc
,
4333 Make_Attribute_Reference
(Loc
,
4334 Prefix
=> Relocate_Node
(Prefix
(N
)),
4335 Attribute_Name
=> Name_Old
),
4336 Expressions
=> Expressions
(N
)));
4344 -- Prefix has not been analyzed yet, and its full analysis will
4345 -- take place during expansion (see below).
4347 Preanalyze_And_Resolve
(P
);
4348 P_Type
:= Etype
(P
);
4349 Set_Etype
(N
, P_Type
);
4351 if Is_Limited_Type
(P_Type
) then
4352 Error_Attr
("attribute % cannot apply to limited objects", P
);
4355 if Is_Entity_Name
(P
)
4356 and then Is_Constant_Object
(Entity
(P
))
4359 ("??attribute Old applied to constant has no effect", P
);
4362 -- The attribute appears within a pre/postcondition, but refers to
4363 -- an entity in the enclosing subprogram. If it is a component of
4364 -- a formal its expansion might generate actual subtypes that may
4365 -- be referenced in an inner context, and which must be elaborated
4366 -- within the subprogram itself. If the prefix includes a function
4367 -- call it may involve finalization actions that should only be
4368 -- inserted when the attribute has been rewritten as a declarations.
4369 -- As a result, if the prefix is not a simple name we create
4370 -- a declaration for it now, and insert it at the start of the
4371 -- enclosing subprogram. This is properly an expansion activity
4372 -- but it has to be performed now to prevent out-of-order issues.
4374 -- This expansion is both harmful and not needed in Alfa mode, since
4375 -- the formal verification backend relies on the types of nodes
4376 -- (hence is not robust w.r.t. a change to base type here), and does
4377 -- not suffer from the out-of-order issue described above. Thus, this
4378 -- expansion is skipped in Alfa mode.
4380 if not Is_Entity_Name
(P
) and then not Alfa_Mode
then
4381 P_Type
:= Base_Type
(P_Type
);
4382 Set_Etype
(N
, P_Type
);
4383 Set_Etype
(P
, P_Type
);
4384 Analyze_Dimension
(N
);
4389 ----------------------
4390 -- Overlaps_Storage --
4391 ----------------------
4393 when Attribute_Overlaps_Storage
=>
4396 -- Both arguments must be objects of any type
4398 Analyze_And_Resolve
(P
);
4399 Analyze_And_Resolve
(E1
);
4400 Check_Object_Reference
(P
);
4401 Check_Object_Reference
(E1
);
4402 Set_Etype
(N
, Standard_Boolean
);
4408 when Attribute_Output
=>
4410 Check_Stream_Attribute
(TSS_Stream_Output
);
4411 Set_Etype
(N
, Standard_Void_Type
);
4412 Resolve
(N
, Standard_Void_Type
);
4418 when Attribute_Partition_ID
=> Partition_Id
:
4422 if P_Type
/= Any_Type
then
4423 if not Is_Library_Level_Entity
(Entity
(P
)) then
4425 ("prefix of % attribute must be library-level entity");
4427 -- The defining entity of prefix should not be declared inside a
4428 -- Pure unit. RM E.1(8). Is_Pure was set during declaration.
4430 elsif Is_Entity_Name
(P
)
4431 and then Is_Pure
(Entity
(P
))
4433 Error_Attr_P
("prefix of% attribute must not be declared pure");
4437 Set_Etype
(N
, Universal_Integer
);
4440 -------------------------
4441 -- Passed_By_Reference --
4442 -------------------------
4444 when Attribute_Passed_By_Reference
=>
4447 Set_Etype
(N
, Standard_Boolean
);
4453 when Attribute_Pool_Address
=>
4455 Set_Etype
(N
, RTE
(RE_Address
));
4461 when Attribute_Pos
=>
4462 Check_Discrete_Type
;
4465 if Is_Boolean_Type
(P_Type
) then
4466 Error_Msg_Name_1
:= Aname
;
4467 Error_Msg_Name_2
:= Chars
(P_Type
);
4468 Check_SPARK_Restriction
4469 ("attribute% is not allowed for type%", P
);
4472 Resolve
(E1
, P_Base_Type
);
4473 Set_Etype
(N
, Universal_Integer
);
4479 when Attribute_Position
=>
4481 Set_Etype
(N
, Universal_Integer
);
4487 when Attribute_Pred
=>
4491 if Is_Real_Type
(P_Type
) or else Is_Boolean_Type
(P_Type
) then
4492 Error_Msg_Name_1
:= Aname
;
4493 Error_Msg_Name_2
:= Chars
(P_Type
);
4494 Check_SPARK_Restriction
4495 ("attribute% is not allowed for type%", P
);
4498 Resolve
(E1
, P_Base_Type
);
4499 Set_Etype
(N
, P_Base_Type
);
4501 -- Nothing to do for real type case
4503 if Is_Real_Type
(P_Type
) then
4506 -- If not modular type, test for overflow check required
4509 if not Is_Modular_Integer_Type
(P_Type
)
4510 and then not Range_Checks_Suppressed
(P_Base_Type
)
4512 Enable_Range_Check
(E1
);
4520 -- Ada 2005 (AI-327): Dynamic ceiling priorities
4522 when Attribute_Priority
=>
4523 if Ada_Version
< Ada_2005
then
4524 Error_Attr
("% attribute is allowed only in Ada 2005 mode", P
);
4529 -- The prefix must be a protected object (AARM D.5.2 (2/2))
4533 if Is_Protected_Type
(Etype
(P
))
4534 or else (Is_Access_Type
(Etype
(P
))
4535 and then Is_Protected_Type
(Designated_Type
(Etype
(P
))))
4537 Resolve
(P
, Etype
(P
));
4539 Error_Attr_P
("prefix of % attribute must be a protected object");
4542 Set_Etype
(N
, Standard_Integer
);
4544 -- Must be called from within a protected procedure or entry of the
4545 -- protected object.
4552 while S
/= Etype
(P
)
4553 and then S
/= Standard_Standard
4558 if S
= Standard_Standard
then
4559 Error_Attr
("the attribute % is only allowed inside protected "
4564 Validate_Non_Static_Attribute_Function_Call
;
4570 when Attribute_Range
=>
4571 Check_Array_Or_Scalar_Type
;
4572 Bad_Attribute_For_Predicate
;
4574 if Ada_Version
= Ada_83
4575 and then Is_Scalar_Type
(P_Type
)
4576 and then Comes_From_Source
(N
)
4579 ("(Ada 83) % attribute not allowed for scalar type", P
);
4586 when Attribute_Result
=> Result
: declare
4588 -- The enclosing scope, excluding loops for quantified expressions
4591 -- During analysis, CS is the postcondition subprogram and PS the
4592 -- source subprogram to which the postcondition applies. During
4593 -- pre-analysis, CS is the scope of the subprogram declaration.
4596 -- During pre-analysis, Prag is the enclosing pragma node if any
4599 -- Find the proper enclosing scope
4601 CS
:= Current_Scope
;
4602 while Present
(CS
) loop
4604 -- Skip generated loops
4606 if Ekind
(CS
) = E_Loop
then
4609 -- Skip the special _Parent scope generated to capture references
4610 -- to formals during the process of subprogram inlining.
4612 elsif Ekind
(CS
) = E_Function
4613 and then Chars
(CS
) = Name_uParent
4623 -- If the enclosing subprogram is always inlined, the enclosing
4624 -- postcondition will not be propagated to the expanded call.
4626 if not In_Spec_Expression
4627 and then Has_Pragma_Inline_Always
(PS
)
4628 and then Warn_On_Redundant_Constructs
4631 ("postconditions on inlined functions not enforced?r?", N
);
4634 -- If we are in the scope of a function and in Spec_Expression mode,
4635 -- this is likely the prescan of the postcondition (or contract case,
4636 -- or test case) pragma, and we just set the proper type. If there is
4637 -- an error it will be caught when the real Analyze call is done.
4639 if Ekind
(CS
) = E_Function
4640 and then In_Spec_Expression
4644 if Chars
(CS
) /= Chars
(P
) then
4645 Error_Msg_Name_1
:= Name_Result
;
4648 ("incorrect prefix for % attribute, expected &", P
, CS
);
4652 -- Check in postcondition or Ensures clause of function
4655 while not Nkind_In
(Prag
, N_Pragma
,
4656 N_Function_Specification
,
4659 Prag
:= Parent
(Prag
);
4662 if Nkind
(Prag
) /= N_Pragma
then
4664 ("% attribute can only appear in postcondition of function",
4667 elsif Get_Pragma_Id
(Prag
) = Pragma_Contract_Case
4669 Get_Pragma_Id
(Prag
) = Pragma_Test_Case
4672 Arg_Ens
: constant Node_Id
:=
4673 Get_Ensures_From_CTC_Pragma
(Prag
);
4678 while Arg
/= Prag
and Arg
/= Arg_Ens
loop
4679 Arg
:= Parent
(Arg
);
4682 if Arg
/= Arg_Ens
then
4683 if Get_Pragma_Id
(Prag
) = Pragma_Contract_Case
then
4685 ("% attribute misplaced inside contract case", P
);
4688 ("% attribute misplaced inside test case", P
);
4693 elsif Get_Pragma_Id
(Prag
) /= Pragma_Postcondition
then
4695 ("% attribute can only appear in postcondition of function",
4699 -- The attribute reference is a primary. If expressions follow,
4700 -- the attribute reference is really an indexable object, so
4701 -- rewrite and analyze as an indexed component.
4703 if Present
(E1
) then
4705 Make_Indexed_Component
(Loc
,
4707 Make_Attribute_Reference
(Loc
,
4708 Prefix
=> Relocate_Node
(Prefix
(N
)),
4709 Attribute_Name
=> Name_Result
),
4710 Expressions
=> Expressions
(N
)));
4715 Set_Etype
(N
, Etype
(CS
));
4717 -- If several functions with that name are visible,
4718 -- the intended one is the current scope.
4720 if Is_Overloaded
(P
) then
4722 Set_Is_Overloaded
(P
, False);
4725 -- Body case, where we must be inside a generated _Postcondition
4726 -- procedure, and the prefix must be on the scope stack, or else the
4727 -- attribute use is definitely misplaced. The postcondition itself
4728 -- may have generated transient scopes, and is not necessarily the
4732 while Present
(CS
) and then CS
/= Standard_Standard
loop
4733 if Chars
(CS
) = Name_uPostconditions
then
4742 if Chars
(CS
) = Name_uPostconditions
4743 and then Ekind
(PS
) = E_Function
4747 if Nkind_In
(P
, N_Identifier
, N_Operator_Symbol
)
4748 and then Chars
(P
) = Chars
(PS
)
4752 -- Within an instance, the prefix designates the local renaming
4753 -- of the original generic.
4755 elsif Is_Entity_Name
(P
)
4756 and then Ekind
(Entity
(P
)) = E_Function
4757 and then Present
(Alias
(Entity
(P
)))
4758 and then Chars
(Alias
(Entity
(P
))) = Chars
(PS
)
4764 ("incorrect prefix for % attribute, expected &", P
, PS
);
4768 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Name_uResult
));
4769 Analyze_And_Resolve
(N
, Etype
(PS
));
4773 ("% attribute can only appear in postcondition of function",
4783 when Attribute_Range_Length
=>
4785 Check_Discrete_Type
;
4786 Set_Etype
(N
, Universal_Integer
);
4792 when Attribute_Read
=>
4794 Check_Stream_Attribute
(TSS_Stream_Read
);
4795 Set_Etype
(N
, Standard_Void_Type
);
4796 Resolve
(N
, Standard_Void_Type
);
4797 Note_Possible_Modification
(E2
, Sure
=> True);
4803 when Attribute_Ref
=>
4807 if Nkind
(P
) /= N_Expanded_Name
4808 or else not Is_RTE
(P_Type
, RE_Address
)
4810 Error_Attr_P
("prefix of % attribute must be System.Address");
4813 Analyze_And_Resolve
(E1
, Any_Integer
);
4814 Set_Etype
(N
, RTE
(RE_Address
));
4820 when Attribute_Remainder
=>
4821 Check_Floating_Point_Type_2
;
4822 Set_Etype
(N
, P_Base_Type
);
4823 Resolve
(E1
, P_Base_Type
);
4824 Resolve
(E2
, P_Base_Type
);
4830 when Attribute_Round
=>
4832 Check_Decimal_Fixed_Point_Type
;
4833 Set_Etype
(N
, P_Base_Type
);
4835 -- Because the context is universal_real (3.5.10(12)) it is a
4836 -- legal context for a universal fixed expression. This is the
4837 -- only attribute whose functional description involves U_R.
4839 if Etype
(E1
) = Universal_Fixed
then
4841 Conv
: constant Node_Id
:= Make_Type_Conversion
(Loc
,
4842 Subtype_Mark
=> New_Occurrence_Of
(Universal_Real
, Loc
),
4843 Expression
=> Relocate_Node
(E1
));
4851 Resolve
(E1
, Any_Real
);
4857 when Attribute_Rounding
=>
4858 Check_Floating_Point_Type_1
;
4859 Set_Etype
(N
, P_Base_Type
);
4860 Resolve
(E1
, P_Base_Type
);
4866 when Attribute_Safe_Emax
=>
4867 Check_Floating_Point_Type_0
;
4868 Set_Etype
(N
, Universal_Integer
);
4874 when Attribute_Safe_First
=>
4875 Check_Floating_Point_Type_0
;
4876 Set_Etype
(N
, Universal_Real
);
4882 when Attribute_Safe_Large
=>
4885 Set_Etype
(N
, Universal_Real
);
4891 when Attribute_Safe_Last
=>
4892 Check_Floating_Point_Type_0
;
4893 Set_Etype
(N
, Universal_Real
);
4899 when Attribute_Safe_Small
=>
4902 Set_Etype
(N
, Universal_Real
);
4908 when Attribute_Same_Storage
=>
4909 Check_Ada_2012_Attribute
;
4912 -- The arguments must be objects of any type
4914 Analyze_And_Resolve
(P
);
4915 Analyze_And_Resolve
(E1
);
4916 Check_Object_Reference
(P
);
4917 Check_Object_Reference
(E1
);
4918 Set_Etype
(N
, Standard_Boolean
);
4920 --------------------------
4921 -- Scalar_Storage_Order --
4922 --------------------------
4924 when Attribute_Scalar_Storage_Order
=> Scalar_Storage_Order
:
4929 if not Is_Record_Type
(P_Type
) or else Is_Array_Type
(P_Type
) then
4931 ("prefix of % attribute must be record or array type");
4934 if Bytes_Big_Endian
xor Reverse_Storage_Order
(P_Type
) then
4936 New_Occurrence_Of
(RTE
(RE_High_Order_First
), Loc
));
4939 New_Occurrence_Of
(RTE
(RE_Low_Order_First
), Loc
));
4942 Set_Etype
(N
, RTE
(RE_Bit_Order
));
4945 -- Reset incorrect indication of staticness
4947 Set_Is_Static_Expression
(N
, False);
4948 end Scalar_Storage_Order
;
4954 when Attribute_Scale
=>
4956 Check_Decimal_Fixed_Point_Type
;
4957 Set_Etype
(N
, Universal_Integer
);
4963 when Attribute_Scaling
=>
4964 Check_Floating_Point_Type_2
;
4965 Set_Etype
(N
, P_Base_Type
);
4966 Resolve
(E1
, P_Base_Type
);
4972 when Attribute_Signed_Zeros
=>
4973 Check_Floating_Point_Type_0
;
4974 Set_Etype
(N
, Standard_Boolean
);
4980 when Attribute_Size | Attribute_VADS_Size
=> Size
:
4984 -- If prefix is parameterless function call, rewrite and resolve
4987 if Is_Entity_Name
(P
)
4988 and then Ekind
(Entity
(P
)) = E_Function
4992 -- Similar processing for a protected function call
4994 elsif Nkind
(P
) = N_Selected_Component
4995 and then Ekind
(Entity
(Selector_Name
(P
))) = E_Function
5000 if Is_Object_Reference
(P
) then
5001 Check_Object_Reference
(P
);
5003 elsif Is_Entity_Name
(P
)
5004 and then (Is_Type
(Entity
(P
))
5005 or else Ekind
(Entity
(P
)) = E_Enumeration_Literal
)
5009 elsif Nkind
(P
) = N_Type_Conversion
5010 and then not Comes_From_Source
(P
)
5015 Error_Attr_P
("invalid prefix for % attribute");
5018 Check_Not_Incomplete_Type
;
5020 Set_Etype
(N
, Universal_Integer
);
5027 when Attribute_Small
=>
5030 Set_Etype
(N
, Universal_Real
);
5036 when Attribute_Storage_Pool |
5037 Attribute_Simple_Storage_Pool
=> Storage_Pool
:
5041 if Is_Access_Type
(P_Type
) then
5042 if Ekind
(P_Type
) = E_Access_Subprogram_Type
then
5044 ("cannot use % attribute for access-to-subprogram type");
5047 -- Set appropriate entity
5049 if Present
(Associated_Storage_Pool
(Root_Type
(P_Type
))) then
5050 Set_Entity
(N
, Associated_Storage_Pool
(Root_Type
(P_Type
)));
5052 Set_Entity
(N
, RTE
(RE_Global_Pool_Object
));
5055 if Attr_Id
= Attribute_Storage_Pool
then
5056 if Present
(Get_Rep_Pragma
(Etype
(Entity
(N
)),
5057 Name_Simple_Storage_Pool_Type
))
5059 Error_Msg_Name_1
:= Aname
;
5060 Error_Msg_N
("cannot use % attribute for type with simple "
5061 & "storage pool??", N
);
5063 ("\Program_Error will be raised at run time??", N
);
5066 (N
, Make_Raise_Program_Error
5067 (Sloc
(N
), Reason
=> PE_Explicit_Raise
));
5070 Set_Etype
(N
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
5072 -- In the Simple_Storage_Pool case, verify that the pool entity is
5073 -- actually of a simple storage pool type, and set the attribute's
5074 -- type to the pool object's type.
5077 if not Present
(Get_Rep_Pragma
(Etype
(Entity
(N
)),
5078 Name_Simple_Storage_Pool_Type
))
5081 ("cannot use % attribute for type without simple " &
5085 Set_Etype
(N
, Etype
(Entity
(N
)));
5088 -- Validate_Remote_Access_To_Class_Wide_Type for attribute
5089 -- Storage_Pool since this attribute is not defined for such
5090 -- types (RM E.2.3(22)).
5092 Validate_Remote_Access_To_Class_Wide_Type
(N
);
5095 Error_Attr_P
("prefix of % attribute must be access type");
5103 when Attribute_Storage_Size
=> Storage_Size
:
5107 if Is_Task_Type
(P_Type
) then
5108 Set_Etype
(N
, Universal_Integer
);
5110 -- Use with tasks is an obsolescent feature
5112 Check_Restriction
(No_Obsolescent_Features
, P
);
5114 elsif Is_Access_Type
(P_Type
) then
5115 if Ekind
(P_Type
) = E_Access_Subprogram_Type
then
5117 ("cannot use % attribute for access-to-subprogram type");
5120 if Is_Entity_Name
(P
)
5121 and then Is_Type
(Entity
(P
))
5124 Set_Etype
(N
, Universal_Integer
);
5126 -- Validate_Remote_Access_To_Class_Wide_Type for attribute
5127 -- Storage_Size since this attribute is not defined for
5128 -- such types (RM E.2.3(22)).
5130 Validate_Remote_Access_To_Class_Wide_Type
(N
);
5132 -- The prefix is allowed to be an implicit dereference of an
5133 -- access value designating a task.
5137 Set_Etype
(N
, Universal_Integer
);
5141 Error_Attr_P
("prefix of % attribute must be access or task type");
5149 when Attribute_Storage_Unit
=>
5150 Standard_Attribute
(Ttypes
.System_Storage_Unit
);
5156 when Attribute_Stream_Size
=>
5160 if Is_Entity_Name
(P
)
5161 and then Is_Elementary_Type
(Entity
(P
))
5163 Set_Etype
(N
, Universal_Integer
);
5165 Error_Attr_P
("invalid prefix for % attribute");
5172 when Attribute_Stub_Type
=>
5176 if Is_Remote_Access_To_Class_Wide_Type
(Base_Type
(P_Type
)) then
5178 -- For a real RACW [sub]type, use corresponding stub type
5180 if not Is_Generic_Type
(P_Type
) then
5183 (Corresponding_Stub_Type
(Base_Type
(P_Type
)), Loc
));
5185 -- For a generic type (that has been marked as an RACW using the
5186 -- Remote_Access_Type aspect or pragma), use a generic RACW stub
5187 -- type. Note that if the actual is not a remote access type, the
5188 -- instantiation will fail.
5191 -- Note: we go to the underlying type here because the view
5192 -- returned by RTE (RE_RACW_Stub_Type) might be incomplete.
5196 (Underlying_Type
(RTE
(RE_RACW_Stub_Type
)), Loc
));
5201 ("prefix of% attribute must be remote access to classwide");
5208 when Attribute_Succ
=>
5212 if Is_Real_Type
(P_Type
) or else Is_Boolean_Type
(P_Type
) then
5213 Error_Msg_Name_1
:= Aname
;
5214 Error_Msg_Name_2
:= Chars
(P_Type
);
5215 Check_SPARK_Restriction
5216 ("attribute% is not allowed for type%", P
);
5219 Resolve
(E1
, P_Base_Type
);
5220 Set_Etype
(N
, P_Base_Type
);
5222 -- Nothing to do for real type case
5224 if Is_Real_Type
(P_Type
) then
5227 -- If not modular type, test for overflow check required
5230 if not Is_Modular_Integer_Type
(P_Type
)
5231 and then not Range_Checks_Suppressed
(P_Base_Type
)
5233 Enable_Range_Check
(E1
);
5237 --------------------------------
5238 -- System_Allocator_Alignment --
5239 --------------------------------
5241 when Attribute_System_Allocator_Alignment
=>
5242 Standard_Attribute
(Ttypes
.System_Allocator_Alignment
);
5248 when Attribute_Tag
=> Tag
:
5253 if not Is_Tagged_Type
(P_Type
) then
5254 Error_Attr_P
("prefix of % attribute must be tagged");
5256 -- Next test does not apply to generated code why not, and what does
5257 -- the illegal reference mean???
5259 elsif Is_Object_Reference
(P
)
5260 and then not Is_Class_Wide_Type
(P_Type
)
5261 and then Comes_From_Source
(N
)
5264 ("% attribute can only be applied to objects " &
5265 "of class - wide type");
5268 -- The prefix cannot be an incomplete type. However, references to
5269 -- 'Tag can be generated when expanding interface conversions, and
5272 if Comes_From_Source
(N
) then
5273 Check_Not_Incomplete_Type
;
5276 -- Set appropriate type
5278 Set_Etype
(N
, RTE
(RE_Tag
));
5285 when Attribute_Target_Name
=> Target_Name
: declare
5286 TN
: constant String := Sdefault
.Target_Name
.all;
5290 Check_Standard_Prefix
;
5294 if TN
(TL
) = '/' or else TN
(TL
) = '\' then
5299 Make_String_Literal
(Loc
,
5300 Strval
=> TN
(TN
'First .. TL
)));
5301 Analyze_And_Resolve
(N
, Standard_String
);
5308 when Attribute_Terminated
=>
5310 Set_Etype
(N
, Standard_Boolean
);
5317 when Attribute_To_Address
=>
5321 if Nkind
(P
) /= N_Identifier
5322 or else Chars
(P
) /= Name_System
5324 Error_Attr_P
("prefix of % attribute must be System");
5327 Generate_Reference
(RTE
(RE_Address
), P
);
5328 Analyze_And_Resolve
(E1
, Any_Integer
);
5329 Set_Etype
(N
, RTE
(RE_Address
));
5335 when Attribute_To_Any
=>
5337 Check_PolyORB_Attribute
;
5338 Set_Etype
(N
, RTE
(RE_Any
));
5344 when Attribute_Truncation
=>
5345 Check_Floating_Point_Type_1
;
5346 Resolve
(E1
, P_Base_Type
);
5347 Set_Etype
(N
, P_Base_Type
);
5353 when Attribute_Type_Class
=>
5356 Check_Not_Incomplete_Type
;
5357 Set_Etype
(N
, RTE
(RE_Type_Class
));
5363 when Attribute_TypeCode
=>
5365 Check_PolyORB_Attribute
;
5366 Set_Etype
(N
, RTE
(RE_TypeCode
));
5372 when Attribute_Type_Key
=>
5376 -- This processing belongs in Eval_Attribute ???
5379 function Type_Key
return String_Id
;
5380 -- A very preliminary implementation. For now, a signature
5381 -- consists of only the type name. This is clearly incomplete
5382 -- (e.g., adding a new field to a record type should change the
5383 -- type's Type_Key attribute).
5389 function Type_Key
return String_Id
is
5390 Full_Name
: constant String_Id
:=
5391 Fully_Qualified_Name_String
(Entity
(P
));
5394 -- Copy all characters in Full_Name but the trailing NUL
5397 for J
in 1 .. String_Length
(Full_Name
) - 1 loop
5398 Store_String_Char
(Get_String_Char
(Full_Name
, Int
(J
)));
5401 Store_String_Chars
("'Type_Key");
5406 Rewrite
(N
, Make_String_Literal
(Loc
, Type_Key
));
5409 Analyze_And_Resolve
(N
, Standard_String
);
5415 when Attribute_UET_Address
=>
5417 Check_Unit_Name
(P
);
5418 Set_Etype
(N
, RTE
(RE_Address
));
5420 -----------------------
5421 -- Unbiased_Rounding --
5422 -----------------------
5424 when Attribute_Unbiased_Rounding
=>
5425 Check_Floating_Point_Type_1
;
5426 Set_Etype
(N
, P_Base_Type
);
5427 Resolve
(E1
, P_Base_Type
);
5429 ----------------------
5430 -- Unchecked_Access --
5431 ----------------------
5433 when Attribute_Unchecked_Access
=>
5434 if Comes_From_Source
(N
) then
5435 Check_Restriction
(No_Unchecked_Access
, N
);
5438 Analyze_Access_Attribute
;
5440 -------------------------
5441 -- Unconstrained_Array --
5442 -------------------------
5444 when Attribute_Unconstrained_Array
=>
5447 Check_Not_Incomplete_Type
;
5448 Set_Etype
(N
, Standard_Boolean
);
5450 ------------------------------
5451 -- Universal_Literal_String --
5452 ------------------------------
5454 -- This is a GNAT specific attribute whose prefix must be a named
5455 -- number where the expression is either a single numeric literal,
5456 -- or a numeric literal immediately preceded by a minus sign. The
5457 -- result is equivalent to a string literal containing the text of
5458 -- the literal as it appeared in the source program with a possible
5459 -- leading minus sign.
5461 when Attribute_Universal_Literal_String
=> Universal_Literal_String
:
5465 if not Is_Entity_Name
(P
)
5466 or else Ekind
(Entity
(P
)) not in Named_Kind
5468 Error_Attr_P
("prefix for % attribute must be named number");
5475 Src
: Source_Buffer_Ptr
;
5478 Expr
:= Original_Node
(Expression
(Parent
(Entity
(P
))));
5480 if Nkind
(Expr
) = N_Op_Minus
then
5482 Expr
:= Original_Node
(Right_Opnd
(Expr
));
5487 if not Nkind_In
(Expr
, N_Integer_Literal
, N_Real_Literal
) then
5489 ("named number for % attribute must be simple literal", N
);
5492 -- Build string literal corresponding to source literal text
5497 Store_String_Char
(Get_Char_Code
('-'));
5501 Src
:= Source_Text
(Get_Source_File_Index
(S
));
5503 while Src
(S
) /= ';' and then Src
(S
) /= ' ' loop
5504 Store_String_Char
(Get_Char_Code
(Src
(S
)));
5508 -- Now we rewrite the attribute with the string literal
5511 Make_String_Literal
(Loc
, End_String
));
5515 end Universal_Literal_String
;
5517 -------------------------
5518 -- Unrestricted_Access --
5519 -------------------------
5521 -- This is a GNAT specific attribute which is like Access except that
5522 -- all scope checks and checks for aliased views are omitted.
5524 when Attribute_Unrestricted_Access
=>
5526 -- If from source, deal with relevant restrictions
5528 if Comes_From_Source
(N
) then
5529 Check_Restriction
(No_Unchecked_Access
, N
);
5531 if Nkind
(P
) in N_Has_Entity
5532 and then Present
(Entity
(P
))
5533 and then Is_Object
(Entity
(P
))
5535 Check_Restriction
(No_Implicit_Aliasing
, N
);
5539 if Is_Entity_Name
(P
) then
5540 Set_Address_Taken
(Entity
(P
));
5543 Analyze_Access_Attribute
;
5549 when Attribute_Update
=> Update
: declare
5550 Comps
: Elist_Id
:= No_Elist
;
5552 procedure Check_Component_Reference
5555 -- Comp is a record component (possibly a discriminant) and Typ is a
5556 -- record type. Determine whether Comp is a legal component of Typ.
5557 -- Emit an error if Comp mentions a discriminant or is not a unique
5558 -- component reference in the update aggregate.
5560 -------------------------------
5561 -- Check_Component_Reference --
5562 -------------------------------
5564 procedure Check_Component_Reference
5568 Comp_Name
: constant Name_Id
:= Chars
(Comp
);
5570 function Is_Duplicate_Component
return Boolean;
5571 -- Determine whether component Comp already appears in list Comps
5573 ----------------------------
5574 -- Is_Duplicate_Component --
5575 ----------------------------
5577 function Is_Duplicate_Component
return Boolean is
5578 Comp_Elmt
: Elmt_Id
;
5581 if Present
(Comps
) then
5582 Comp_Elmt
:= First_Elmt
(Comps
);
5583 while Present
(Comp_Elmt
) loop
5584 if Chars
(Node
(Comp_Elmt
)) = Comp_Name
then
5588 Next_Elmt
(Comp_Elmt
);
5593 end Is_Duplicate_Component
;
5597 Comp_Or_Discr
: Entity_Id
;
5599 -- Start of processing for Check_Component_Reference
5602 -- Find the discriminant or component whose name corresponds to
5603 -- Comp. A simple character comparison is sufficient because all
5604 -- visible names within a record type are unique.
5606 Comp_Or_Discr
:= First_Entity
(Typ
);
5607 while Present
(Comp_Or_Discr
) loop
5608 if Chars
(Comp_Or_Discr
) = Comp_Name
then
5612 Comp_Or_Discr
:= Next_Entity
(Comp_Or_Discr
);
5615 -- Diagnose possible erroneous references
5617 if Present
(Comp_Or_Discr
) then
5618 if Ekind
(Comp_Or_Discr
) = E_Discriminant
then
5620 ("attribute % may not modify record discriminants", Comp
);
5622 else pragma Assert
(Ekind
(Comp_Or_Discr
) = E_Component
);
5623 if Is_Duplicate_Component
then
5624 Error_Msg_NE
("component & already updated", Comp
, Comp
);
5626 -- Mark this component as processed
5630 Comps
:= New_Elmt_List
;
5633 Append_Elmt
(Comp
, Comps
);
5637 -- The update aggregate mentions an entity that does not belong to
5642 ("& is not a component of aggregate subtype", Comp
, Comp
);
5644 end Check_Component_Reference
;
5651 -- Start of processing for Update
5657 if not Is_Object_Reference
(P
) then
5658 Error_Attr_P
("prefix of attribute % must denote an object");
5660 elsif not Is_Array_Type
(P_Type
)
5661 and then not Is_Record_Type
(P_Type
)
5663 Error_Attr_P
("prefix of attribute % must be a record or array");
5665 elsif Is_Immutably_Limited_Type
(P_Type
) then
5666 Error_Attr
("prefix of attribute % cannot be limited", N
);
5668 elsif Nkind
(E1
) /= N_Aggregate
then
5669 Error_Attr
("attribute % requires component association list", N
);
5672 -- Inspect the update aggregate, looking at all the associations and
5673 -- choices. Perform the following checks:
5675 -- 1) Legality of "others" in all cases
5676 -- 2) Component legality for records
5678 -- The remaining checks are performed on the expanded attribute
5680 Assoc
:= First
(Component_Associations
(E1
));
5681 while Present
(Assoc
) loop
5682 Comp
:= First
(Choices
(Assoc
));
5683 while Present
(Comp
) loop
5684 if Nkind
(Comp
) = N_Others_Choice
then
5686 ("others choice not allowed in attribute %", Comp
);
5688 elsif Is_Record_Type
(P_Type
) then
5689 Check_Component_Reference
(Comp
, P_Type
);
5698 -- The type of attribute Update is that of the prefix
5700 Set_Etype
(N
, P_Type
);
5707 when Attribute_Val
=> Val
: declare
5710 Check_Discrete_Type
;
5712 if Is_Boolean_Type
(P_Type
) then
5713 Error_Msg_Name_1
:= Aname
;
5714 Error_Msg_Name_2
:= Chars
(P_Type
);
5715 Check_SPARK_Restriction
5716 ("attribute% is not allowed for type%", P
);
5719 Resolve
(E1
, Any_Integer
);
5720 Set_Etype
(N
, P_Base_Type
);
5722 -- Note, we need a range check in general, but we wait for the
5723 -- Resolve call to do this, since we want to let Eval_Attribute
5724 -- have a chance to find an static illegality first!
5731 when Attribute_Valid
=>
5734 -- Ignore check for object if we have a 'Valid reference generated
5735 -- by the expanded code, since in some cases valid checks can occur
5736 -- on items that are names, but are not objects (e.g. attributes).
5738 if Comes_From_Source
(N
) then
5739 Check_Object_Reference
(P
);
5742 if not Is_Scalar_Type
(P_Type
) then
5743 Error_Attr_P
("object for % attribute must be of scalar type");
5746 -- If the attribute appears within the subtype's own predicate
5747 -- function, then issue a warning that this will cause infinite
5751 Pred_Func
: constant Entity_Id
:= Predicate_Function
(P_Type
);
5754 if Present
(Pred_Func
) and then Current_Scope
= Pred_Func
then
5756 ("attribute Valid requires a predicate check??", N
);
5757 Error_Msg_N
("\and will result in infinite recursion??", N
);
5761 Set_Etype
(N
, Standard_Boolean
);
5767 when Attribute_Valid_Scalars
=>
5769 Check_Object_Reference
(P
);
5771 if No_Scalar_Parts
(P_Type
) then
5772 Error_Attr_P
("??attribute % always True, no scalars to check");
5775 Set_Etype
(N
, Standard_Boolean
);
5781 when Attribute_Value
=> Value
:
5783 Check_SPARK_Restriction_On_Attribute
;
5787 -- Case of enumeration type
5789 -- When an enumeration type appears in an attribute reference, all
5790 -- literals of the type are marked as referenced. This must only be
5791 -- done if the attribute reference appears in the current source.
5792 -- Otherwise the information on references may differ between a
5793 -- normal compilation and one that performs inlining.
5795 if Is_Enumeration_Type
(P_Type
)
5796 and then In_Extended_Main_Code_Unit
(N
)
5798 Check_Restriction
(No_Enumeration_Maps
, N
);
5800 -- Mark all enumeration literals as referenced, since the use of
5801 -- the Value attribute can implicitly reference any of the
5802 -- literals of the enumeration base type.
5805 Ent
: Entity_Id
:= First_Literal
(P_Base_Type
);
5807 while Present
(Ent
) loop
5808 Set_Referenced
(Ent
);
5814 -- Set Etype before resolving expression because expansion of
5815 -- expression may require enclosing type. Note that the type
5816 -- returned by 'Value is the base type of the prefix type.
5818 Set_Etype
(N
, P_Base_Type
);
5819 Validate_Non_Static_Attribute_Function_Call
;
5826 when Attribute_Value_Size
=>
5829 Check_Not_Incomplete_Type
;
5830 Set_Etype
(N
, Universal_Integer
);
5836 when Attribute_Version
=>
5839 Set_Etype
(N
, RTE
(RE_Version_String
));
5845 when Attribute_Wchar_T_Size
=>
5846 Standard_Attribute
(Interfaces_Wchar_T_Size
);
5852 when Attribute_Wide_Image
=> Wide_Image
:
5854 Check_SPARK_Restriction_On_Attribute
;
5856 Set_Etype
(N
, Standard_Wide_String
);
5858 Resolve
(E1
, P_Base_Type
);
5859 Validate_Non_Static_Attribute_Function_Call
;
5862 ---------------------
5863 -- Wide_Wide_Image --
5864 ---------------------
5866 when Attribute_Wide_Wide_Image
=> Wide_Wide_Image
:
5869 Set_Etype
(N
, Standard_Wide_Wide_String
);
5871 Resolve
(E1
, P_Base_Type
);
5872 Validate_Non_Static_Attribute_Function_Call
;
5873 end Wide_Wide_Image
;
5879 when Attribute_Wide_Value
=> Wide_Value
:
5881 Check_SPARK_Restriction_On_Attribute
;
5885 -- Set Etype before resolving expression because expansion
5886 -- of expression may require enclosing type.
5888 Set_Etype
(N
, P_Type
);
5889 Validate_Non_Static_Attribute_Function_Call
;
5892 ---------------------
5893 -- Wide_Wide_Value --
5894 ---------------------
5896 when Attribute_Wide_Wide_Value
=> Wide_Wide_Value
:
5901 -- Set Etype before resolving expression because expansion
5902 -- of expression may require enclosing type.
5904 Set_Etype
(N
, P_Type
);
5905 Validate_Non_Static_Attribute_Function_Call
;
5906 end Wide_Wide_Value
;
5908 ---------------------
5909 -- Wide_Wide_Width --
5910 ---------------------
5912 when Attribute_Wide_Wide_Width
=>
5915 Set_Etype
(N
, Universal_Integer
);
5921 when Attribute_Wide_Width
=>
5922 Check_SPARK_Restriction_On_Attribute
;
5925 Set_Etype
(N
, Universal_Integer
);
5931 when Attribute_Width
=>
5932 Check_SPARK_Restriction_On_Attribute
;
5935 Set_Etype
(N
, Universal_Integer
);
5941 when Attribute_Word_Size
=>
5942 Standard_Attribute
(System_Word_Size
);
5948 when Attribute_Write
=>
5950 Check_Stream_Attribute
(TSS_Stream_Write
);
5951 Set_Etype
(N
, Standard_Void_Type
);
5952 Resolve
(N
, Standard_Void_Type
);
5956 -- All errors raise Bad_Attribute, so that we get out before any further
5957 -- damage occurs when an error is detected (for example, if we check for
5958 -- one attribute expression, and the check succeeds, we want to be able
5959 -- to proceed securely assuming that an expression is in fact present.
5961 -- Note: we set the attribute analyzed in this case to prevent any
5962 -- attempt at reanalysis which could generate spurious error msgs.
5965 when Bad_Attribute
=>
5967 Set_Etype
(N
, Any_Type
);
5969 end Analyze_Attribute
;
5971 --------------------
5972 -- Eval_Attribute --
5973 --------------------
5975 procedure Eval_Attribute
(N
: Node_Id
) is
5976 Loc
: constant Source_Ptr
:= Sloc
(N
);
5977 Aname
: constant Name_Id
:= Attribute_Name
(N
);
5978 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Aname
);
5979 P
: constant Node_Id
:= Prefix
(N
);
5981 C_Type
: constant Entity_Id
:= Etype
(N
);
5982 -- The type imposed by the context
5985 -- First expression, or Empty if none
5988 -- Second expression, or Empty if none
5990 P_Entity
: Entity_Id
;
5991 -- Entity denoted by prefix
5994 -- The type of the prefix
5996 P_Base_Type
: Entity_Id
;
5997 -- The base type of the prefix type
5999 P_Root_Type
: Entity_Id
;
6000 -- The root type of the prefix type
6003 -- True if the result is Static. This is set by the general processing
6004 -- to true if the prefix is static, and all expressions are static. It
6005 -- can be reset as processing continues for particular attributes
6007 Lo_Bound
, Hi_Bound
: Node_Id
;
6008 -- Expressions for low and high bounds of type or array index referenced
6009 -- by First, Last, or Length attribute for array, set by Set_Bounds.
6012 -- Constraint error node used if we have an attribute reference has
6013 -- an argument that raises a constraint error. In this case we replace
6014 -- the attribute with a raise constraint_error node. This is important
6015 -- processing, since otherwise gigi might see an attribute which it is
6016 -- unprepared to deal with.
6018 procedure Check_Concurrent_Discriminant
(Bound
: Node_Id
);
6019 -- If Bound is a reference to a discriminant of a task or protected type
6020 -- occurring within the object's body, rewrite attribute reference into
6021 -- a reference to the corresponding discriminal. Use for the expansion
6022 -- of checks against bounds of entry family index subtypes.
6024 procedure Check_Expressions
;
6025 -- In case where the attribute is not foldable, the expressions, if
6026 -- any, of the attribute, are in a non-static context. This procedure
6027 -- performs the required additional checks.
6029 function Compile_Time_Known_Bounds
(Typ
: Entity_Id
) return Boolean;
6030 -- Determines if the given type has compile time known bounds. Note
6031 -- that we enter the case statement even in cases where the prefix
6032 -- type does NOT have known bounds, so it is important to guard any
6033 -- attempt to evaluate both bounds with a call to this function.
6035 procedure Compile_Time_Known_Attribute
(N
: Node_Id
; Val
: Uint
);
6036 -- This procedure is called when the attribute N has a non-static
6037 -- but compile time known value given by Val. It includes the
6038 -- necessary checks for out of range values.
6040 function Fore_Value
return Nat
;
6041 -- Computes the Fore value for the current attribute prefix, which is
6042 -- known to be a static fixed-point type. Used by Fore and Width.
6044 function Is_VAX_Float
(Typ
: Entity_Id
) return Boolean;
6045 -- Determine whether Typ denotes a VAX floating point type
6047 function Mantissa
return Uint
;
6048 -- Returns the Mantissa value for the prefix type
6050 procedure Set_Bounds
;
6051 -- Used for First, Last and Length attributes applied to an array or
6052 -- array subtype. Sets the variables Lo_Bound and Hi_Bound to the low
6053 -- and high bound expressions for the index referenced by the attribute
6054 -- designator (i.e. the first index if no expression is present, and the
6055 -- N'th index if the value N is present as an expression). Also used for
6056 -- First and Last of scalar types and for First_Valid and Last_Valid.
6057 -- Static is reset to False if the type or index type is not statically
6060 function Statically_Denotes_Entity
(N
: Node_Id
) return Boolean;
6061 -- Verify that the prefix of a potentially static array attribute
6062 -- satisfies the conditions of 4.9 (14).
6064 -----------------------------------
6065 -- Check_Concurrent_Discriminant --
6066 -----------------------------------
6068 procedure Check_Concurrent_Discriminant
(Bound
: Node_Id
) is
6070 -- The concurrent (task or protected) type
6073 if Nkind
(Bound
) = N_Identifier
6074 and then Ekind
(Entity
(Bound
)) = E_Discriminant
6075 and then Is_Concurrent_Record_Type
(Scope
(Entity
(Bound
)))
6077 Tsk
:= Corresponding_Concurrent_Type
(Scope
(Entity
(Bound
)));
6079 if In_Open_Scopes
(Tsk
) and then Has_Completion
(Tsk
) then
6081 -- Find discriminant of original concurrent type, and use
6082 -- its current discriminal, which is the renaming within
6083 -- the task/protected body.
6087 (Find_Body_Discriminal
(Entity
(Bound
)), Loc
));
6090 end Check_Concurrent_Discriminant
;
6092 -----------------------
6093 -- Check_Expressions --
6094 -----------------------
6096 procedure Check_Expressions
is
6100 while Present
(E
) loop
6101 Check_Non_Static_Context
(E
);
6104 end Check_Expressions
;
6106 ----------------------------------
6107 -- Compile_Time_Known_Attribute --
6108 ----------------------------------
6110 procedure Compile_Time_Known_Attribute
(N
: Node_Id
; Val
: Uint
) is
6111 T
: constant Entity_Id
:= Etype
(N
);
6114 Fold_Uint
(N
, Val
, False);
6116 -- Check that result is in bounds of the type if it is static
6118 if Is_In_Range
(N
, T
, Assume_Valid
=> False) then
6121 elsif Is_Out_Of_Range
(N
, T
) then
6122 Apply_Compile_Time_Constraint_Error
6123 (N
, "value not in range of}??", CE_Range_Check_Failed
);
6125 elsif not Range_Checks_Suppressed
(T
) then
6126 Enable_Range_Check
(N
);
6129 Set_Do_Range_Check
(N
, False);
6131 end Compile_Time_Known_Attribute
;
6133 -------------------------------
6134 -- Compile_Time_Known_Bounds --
6135 -------------------------------
6137 function Compile_Time_Known_Bounds
(Typ
: Entity_Id
) return Boolean is
6140 Compile_Time_Known_Value
(Type_Low_Bound
(Typ
))
6142 Compile_Time_Known_Value
(Type_High_Bound
(Typ
));
6143 end Compile_Time_Known_Bounds
;
6149 -- Note that the Fore calculation is based on the actual values
6150 -- of the bounds, and does not take into account possible rounding.
6152 function Fore_Value
return Nat
is
6153 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(P_Type
));
6154 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(P_Type
));
6155 Small
: constant Ureal
:= Small_Value
(P_Type
);
6156 Lo_Real
: constant Ureal
:= Lo
* Small
;
6157 Hi_Real
: constant Ureal
:= Hi
* Small
;
6162 -- Bounds are given in terms of small units, so first compute
6163 -- proper values as reals.
6165 T
:= UR_Max
(abs Lo_Real
, abs Hi_Real
);
6168 -- Loop to compute proper value if more than one digit required
6170 while T
>= Ureal_10
loop
6182 function Is_VAX_Float
(Typ
: Entity_Id
) return Boolean is
6185 Is_Floating_Point_Type
(Typ
)
6187 (Float_Format
= 'V' or else Float_Rep
(Typ
) = VAX_Native
);
6194 -- Table of mantissa values accessed by function Computed using
6197 -- T'Mantissa = integer next above (D * log(10)/log(2)) + 1)
6199 -- where D is T'Digits (RM83 3.5.7)
6201 Mantissa_Value
: constant array (Nat
range 1 .. 40) of Nat
:= (
6243 function Mantissa
return Uint
is
6246 UI_From_Int
(Mantissa_Value
(UI_To_Int
(Digits_Value
(P_Type
))));
6253 procedure Set_Bounds
is
6259 -- For a string literal subtype, we have to construct the bounds.
6260 -- Valid Ada code never applies attributes to string literals, but
6261 -- it is convenient to allow the expander to generate attribute
6262 -- references of this type (e.g. First and Last applied to a string
6265 -- Note that the whole point of the E_String_Literal_Subtype is to
6266 -- avoid this construction of bounds, but the cases in which we
6267 -- have to materialize them are rare enough that we don't worry!
6269 -- The low bound is simply the low bound of the base type. The
6270 -- high bound is computed from the length of the string and this
6273 if Ekind
(P_Type
) = E_String_Literal_Subtype
then
6274 Ityp
:= Etype
(First_Index
(Base_Type
(P_Type
)));
6275 Lo_Bound
:= Type_Low_Bound
(Ityp
);
6278 Make_Integer_Literal
(Sloc
(P
),
6280 Expr_Value
(Lo_Bound
) + String_Literal_Length
(P_Type
) - 1);
6282 Set_Parent
(Hi_Bound
, P
);
6283 Analyze_And_Resolve
(Hi_Bound
, Etype
(Lo_Bound
));
6286 -- For non-array case, just get bounds of scalar type
6288 elsif Is_Scalar_Type
(P_Type
) then
6291 -- For a fixed-point type, we must freeze to get the attributes
6292 -- of the fixed-point type set now so we can reference them.
6294 if Is_Fixed_Point_Type
(P_Type
)
6295 and then not Is_Frozen
(Base_Type
(P_Type
))
6296 and then Compile_Time_Known_Value
(Type_Low_Bound
(P_Type
))
6297 and then Compile_Time_Known_Value
(Type_High_Bound
(P_Type
))
6299 Freeze_Fixed_Point_Type
(Base_Type
(P_Type
));
6302 -- For array case, get type of proper index
6308 Ndim
:= UI_To_Int
(Expr_Value
(E1
));
6311 Indx
:= First_Index
(P_Type
);
6312 for J
in 1 .. Ndim
- 1 loop
6316 -- If no index type, get out (some other error occurred, and
6317 -- we don't have enough information to complete the job!)
6325 Ityp
:= Etype
(Indx
);
6328 -- A discrete range in an index constraint is allowed to be a
6329 -- subtype indication. This is syntactically a pain, but should
6330 -- not propagate to the entity for the corresponding index subtype.
6331 -- After checking that the subtype indication is legal, the range
6332 -- of the subtype indication should be transfered to the entity.
6333 -- The attributes for the bounds should remain the simple retrievals
6334 -- that they are now.
6336 Lo_Bound
:= Type_Low_Bound
(Ityp
);
6337 Hi_Bound
:= Type_High_Bound
(Ityp
);
6339 if not Is_Static_Subtype
(Ityp
) then
6344 -------------------------------
6345 -- Statically_Denotes_Entity --
6346 -------------------------------
6348 function Statically_Denotes_Entity
(N
: Node_Id
) return Boolean is
6352 if not Is_Entity_Name
(N
) then
6359 Nkind
(Parent
(E
)) /= N_Object_Renaming_Declaration
6360 or else Statically_Denotes_Entity
(Renamed_Object
(E
));
6361 end Statically_Denotes_Entity
;
6363 -- Start of processing for Eval_Attribute
6366 -- Acquire first two expressions (at the moment, no attributes take more
6367 -- than two expressions in any case).
6369 if Present
(Expressions
(N
)) then
6370 E1
:= First
(Expressions
(N
));
6377 -- Special processing for Enabled attribute. This attribute has a very
6378 -- special prefix, and the easiest way to avoid lots of special checks
6379 -- to protect this special prefix from causing trouble is to deal with
6380 -- this attribute immediately and be done with it.
6382 if Id
= Attribute_Enabled
then
6384 -- We skip evaluation if the expander is not active. This is not just
6385 -- an optimization. It is of key importance that we not rewrite the
6386 -- attribute in a generic template, since we want to pick up the
6387 -- setting of the check in the instance, and testing expander active
6388 -- is as easy way of doing this as any.
6390 if Expander_Active
then
6392 C
: constant Check_Id
:= Get_Check_Id
(Chars
(P
));
6397 if C
in Predefined_Check_Id
then
6398 R
:= Scope_Suppress
.Suppress
(C
);
6400 R
:= Is_Check_Suppressed
(Empty
, C
);
6404 R
:= Is_Check_Suppressed
(Entity
(E1
), C
);
6407 Rewrite
(N
, New_Occurrence_Of
(Boolean_Literals
(not R
), Loc
));
6414 -- Special processing for cases where the prefix is an object. For
6415 -- this purpose, a string literal counts as an object (attributes
6416 -- of string literals can only appear in generated code).
6418 if Is_Object_Reference
(P
) or else Nkind
(P
) = N_String_Literal
then
6420 -- For Component_Size, the prefix is an array object, and we apply
6421 -- the attribute to the type of the object. This is allowed for
6422 -- both unconstrained and constrained arrays, since the bounds
6423 -- have no influence on the value of this attribute.
6425 if Id
= Attribute_Component_Size
then
6426 P_Entity
:= Etype
(P
);
6428 -- For First and Last, the prefix is an array object, and we apply
6429 -- the attribute to the type of the array, but we need a constrained
6430 -- type for this, so we use the actual subtype if available.
6432 elsif Id
= Attribute_First
6436 Id
= Attribute_Length
6439 AS
: constant Entity_Id
:= Get_Actual_Subtype_If_Available
(P
);
6442 if Present
(AS
) and then Is_Constrained
(AS
) then
6445 -- If we have an unconstrained type we cannot fold
6453 -- For Size, give size of object if available, otherwise we
6454 -- cannot fold Size.
6456 elsif Id
= Attribute_Size
then
6457 if Is_Entity_Name
(P
)
6458 and then Known_Esize
(Entity
(P
))
6460 Compile_Time_Known_Attribute
(N
, Esize
(Entity
(P
)));
6468 -- For Alignment, give size of object if available, otherwise we
6469 -- cannot fold Alignment.
6471 elsif Id
= Attribute_Alignment
then
6472 if Is_Entity_Name
(P
)
6473 and then Known_Alignment
(Entity
(P
))
6475 Fold_Uint
(N
, Alignment
(Entity
(P
)), False);
6483 -- For Lock_Free, we apply the attribute to the type of the object.
6484 -- This is allowed since we have already verified that the type is a
6487 elsif Id
= Attribute_Lock_Free
then
6488 P_Entity
:= Etype
(P
);
6490 -- No other attributes for objects are folded
6497 -- Cases where P is not an object. Cannot do anything if P is
6498 -- not the name of an entity.
6500 elsif not Is_Entity_Name
(P
) then
6504 -- Otherwise get prefix entity
6507 P_Entity
:= Entity
(P
);
6510 -- At this stage P_Entity is the entity to which the attribute
6511 -- is to be applied. This is usually simply the entity of the
6512 -- prefix, except in some cases of attributes for objects, where
6513 -- as described above, we apply the attribute to the object type.
6515 -- First foldable possibility is a scalar or array type (RM 4.9(7))
6516 -- that is not generic (generic types are eliminated by RM 4.9(25)).
6517 -- Note we allow non-static non-generic types at this stage as further
6520 if Is_Type
(P_Entity
)
6521 and then (Is_Scalar_Type
(P_Entity
) or Is_Array_Type
(P_Entity
))
6522 and then (not Is_Generic_Type
(P_Entity
))
6526 -- Second foldable possibility is an array object (RM 4.9(8))
6528 elsif (Ekind
(P_Entity
) = E_Variable
6530 Ekind
(P_Entity
) = E_Constant
)
6531 and then Is_Array_Type
(Etype
(P_Entity
))
6532 and then (not Is_Generic_Type
(Etype
(P_Entity
)))
6534 P_Type
:= Etype
(P_Entity
);
6536 -- If the entity is an array constant with an unconstrained nominal
6537 -- subtype then get the type from the initial value. If the value has
6538 -- been expanded into assignments, there is no expression and the
6539 -- attribute reference remains dynamic.
6541 -- We could do better here and retrieve the type ???
6543 if Ekind
(P_Entity
) = E_Constant
6544 and then not Is_Constrained
(P_Type
)
6546 if No
(Constant_Value
(P_Entity
)) then
6549 P_Type
:= Etype
(Constant_Value
(P_Entity
));
6553 -- Definite must be folded if the prefix is not a generic type,
6554 -- that is to say if we are within an instantiation. Same processing
6555 -- applies to the GNAT attributes Atomic_Always_Lock_Free,
6556 -- Has_Discriminants, Lock_Free, Type_Class, Has_Tagged_Value, and
6557 -- Unconstrained_Array.
6559 elsif (Id
= Attribute_Atomic_Always_Lock_Free
6561 Id
= Attribute_Definite
6563 Id
= Attribute_Has_Access_Values
6565 Id
= Attribute_Has_Discriminants
6567 Id
= Attribute_Has_Tagged_Values
6569 Id
= Attribute_Lock_Free
6571 Id
= Attribute_Type_Class
6573 Id
= Attribute_Unconstrained_Array
6575 Id
= Attribute_Max_Alignment_For_Allocation
)
6576 and then not Is_Generic_Type
(P_Entity
)
6580 -- We can fold 'Size applied to a type if the size is known (as happens
6581 -- for a size from an attribute definition clause). At this stage, this
6582 -- can happen only for types (e.g. record types) for which the size is
6583 -- always non-static. We exclude generic types from consideration (since
6584 -- they have bogus sizes set within templates).
6586 elsif Id
= Attribute_Size
6587 and then Is_Type
(P_Entity
)
6588 and then (not Is_Generic_Type
(P_Entity
))
6589 and then Known_Static_RM_Size
(P_Entity
)
6591 Compile_Time_Known_Attribute
(N
, RM_Size
(P_Entity
));
6594 -- We can fold 'Alignment applied to a type if the alignment is known
6595 -- (as happens for an alignment from an attribute definition clause).
6596 -- At this stage, this can happen only for types (e.g. record
6597 -- types) for which the size is always non-static. We exclude
6598 -- generic types from consideration (since they have bogus
6599 -- sizes set within templates).
6601 elsif Id
= Attribute_Alignment
6602 and then Is_Type
(P_Entity
)
6603 and then (not Is_Generic_Type
(P_Entity
))
6604 and then Known_Alignment
(P_Entity
)
6606 Compile_Time_Known_Attribute
(N
, Alignment
(P_Entity
));
6609 -- If this is an access attribute that is known to fail accessibility
6610 -- check, rewrite accordingly.
6612 elsif Attribute_Name
(N
) = Name_Access
6613 and then Raises_Constraint_Error
(N
)
6616 Make_Raise_Program_Error
(Loc
,
6617 Reason
=> PE_Accessibility_Check_Failed
));
6618 Set_Etype
(N
, C_Type
);
6621 -- No other cases are foldable (they certainly aren't static, and at
6622 -- the moment we don't try to fold any cases other than the ones above).
6629 -- If either attribute or the prefix is Any_Type, then propagate
6630 -- Any_Type to the result and don't do anything else at all.
6632 if P_Type
= Any_Type
6633 or else (Present
(E1
) and then Etype
(E1
) = Any_Type
)
6634 or else (Present
(E2
) and then Etype
(E2
) = Any_Type
)
6636 Set_Etype
(N
, Any_Type
);
6640 -- Scalar subtype case. We have not yet enforced the static requirement
6641 -- of (RM 4.9(7)) and we don't intend to just yet, since there are cases
6642 -- of non-static attribute references (e.g. S'Digits for a non-static
6643 -- floating-point type, which we can compute at compile time).
6645 -- Note: this folding of non-static attributes is not simply a case of
6646 -- optimization. For many of the attributes affected, Gigi cannot handle
6647 -- the attribute and depends on the front end having folded them away.
6649 -- Note: although we don't require staticness at this stage, we do set
6650 -- the Static variable to record the staticness, for easy reference by
6651 -- those attributes where it matters (e.g. Succ and Pred), and also to
6652 -- be used to ensure that non-static folded things are not marked as
6653 -- being static (a check that is done right at the end).
6655 P_Root_Type
:= Root_Type
(P_Type
);
6656 P_Base_Type
:= Base_Type
(P_Type
);
6658 -- If the root type or base type is generic, then we cannot fold. This
6659 -- test is needed because subtypes of generic types are not always
6660 -- marked as being generic themselves (which seems odd???)
6662 if Is_Generic_Type
(P_Root_Type
)
6663 or else Is_Generic_Type
(P_Base_Type
)
6668 if Is_Scalar_Type
(P_Type
) then
6669 Static
:= Is_OK_Static_Subtype
(P_Type
);
6671 -- Array case. We enforce the constrained requirement of (RM 4.9(7-8))
6672 -- since we can't do anything with unconstrained arrays. In addition,
6673 -- only the First, Last and Length attributes are possibly static.
6675 -- Atomic_Always_Lock_Free, Definite, Has_Access_Values,
6676 -- Has_Discriminants, Has_Tagged_Values, Lock_Free, Type_Class, and
6677 -- Unconstrained_Array are again exceptions, because they apply as well
6678 -- to unconstrained types.
6680 -- In addition Component_Size is an exception since it is possibly
6681 -- foldable, even though it is never static, and it does apply to
6682 -- unconstrained arrays. Furthermore, it is essential to fold this
6683 -- in the packed case, since otherwise the value will be incorrect.
6685 elsif Id
= Attribute_Atomic_Always_Lock_Free
6687 Id
= Attribute_Definite
6689 Id
= Attribute_Has_Access_Values
6691 Id
= Attribute_Has_Discriminants
6693 Id
= Attribute_Has_Tagged_Values
6695 Id
= Attribute_Lock_Free
6697 Id
= Attribute_Type_Class
6699 Id
= Attribute_Unconstrained_Array
6701 Id
= Attribute_Component_Size
6705 elsif Id
/= Attribute_Max_Alignment_For_Allocation
then
6706 if not Is_Constrained
(P_Type
)
6707 or else (Id
/= Attribute_First
and then
6708 Id
/= Attribute_Last
and then
6709 Id
/= Attribute_Length
)
6715 -- The rules in (RM 4.9(7,8)) require a static array, but as in the
6716 -- scalar case, we hold off on enforcing staticness, since there are
6717 -- cases which we can fold at compile time even though they are not
6718 -- static (e.g. 'Length applied to a static index, even though other
6719 -- non-static indexes make the array type non-static). This is only
6720 -- an optimization, but it falls out essentially free, so why not.
6721 -- Again we compute the variable Static for easy reference later
6722 -- (note that no array attributes are static in Ada 83).
6724 -- We also need to set Static properly for subsequent legality checks
6725 -- which might otherwise accept non-static constants in contexts
6726 -- where they are not legal.
6728 Static
:= Ada_Version
>= Ada_95
6729 and then Statically_Denotes_Entity
(P
);
6735 N
:= First_Index
(P_Type
);
6737 -- The expression is static if the array type is constrained
6738 -- by given bounds, and not by an initial expression. Constant
6739 -- strings are static in any case.
6741 if Root_Type
(P_Type
) /= Standard_String
then
6743 Static
and then not Is_Constr_Subt_For_U_Nominal
(P_Type
);
6746 while Present
(N
) loop
6747 Static
:= Static
and then Is_Static_Subtype
(Etype
(N
));
6749 -- If however the index type is generic, or derived from
6750 -- one, attributes cannot be folded.
6752 if Is_Generic_Type
(Root_Type
(Etype
(N
)))
6753 and then Id
/= Attribute_Component_Size
6763 -- Check any expressions that are present. Note that these expressions,
6764 -- depending on the particular attribute type, are either part of the
6765 -- attribute designator, or they are arguments in a case where the
6766 -- attribute reference returns a function. In the latter case, the
6767 -- rule in (RM 4.9(22)) applies and in particular requires the type
6768 -- of the expressions to be scalar in order for the attribute to be
6769 -- considered to be static.
6776 while Present
(E
) loop
6778 -- If expression is not static, then the attribute reference
6779 -- result certainly cannot be static.
6781 if not Is_Static_Expression
(E
) then
6785 -- If the result is not known at compile time, or is not of
6786 -- a scalar type, then the result is definitely not static,
6787 -- so we can quit now.
6789 if not Compile_Time_Known_Value
(E
)
6790 or else not Is_Scalar_Type
(Etype
(E
))
6792 -- An odd special case, if this is a Pos attribute, this
6793 -- is where we need to apply a range check since it does
6794 -- not get done anywhere else.
6796 if Id
= Attribute_Pos
then
6797 if Is_Integer_Type
(Etype
(E
)) then
6798 Apply_Range_Check
(E
, Etype
(N
));
6805 -- If the expression raises a constraint error, then so does
6806 -- the attribute reference. We keep going in this case because
6807 -- we are still interested in whether the attribute reference
6808 -- is static even if it is not static.
6810 elsif Raises_Constraint_Error
(E
) then
6811 Set_Raises_Constraint_Error
(N
);
6817 if Raises_Constraint_Error
(Prefix
(N
)) then
6822 -- Deal with the case of a static attribute reference that raises
6823 -- constraint error. The Raises_Constraint_Error flag will already
6824 -- have been set, and the Static flag shows whether the attribute
6825 -- reference is static. In any case we certainly can't fold such an
6826 -- attribute reference.
6828 -- Note that the rewriting of the attribute node with the constraint
6829 -- error node is essential in this case, because otherwise Gigi might
6830 -- blow up on one of the attributes it never expects to see.
6832 -- The constraint_error node must have the type imposed by the context,
6833 -- to avoid spurious errors in the enclosing expression.
6835 if Raises_Constraint_Error
(N
) then
6837 Make_Raise_Constraint_Error
(Sloc
(N
),
6838 Reason
=> CE_Range_Check_Failed
);
6839 Set_Etype
(CE_Node
, Etype
(N
));
6840 Set_Raises_Constraint_Error
(CE_Node
);
6842 Rewrite
(N
, Relocate_Node
(CE_Node
));
6843 Set_Is_Static_Expression
(N
, Static
);
6847 -- At this point we have a potentially foldable attribute reference.
6848 -- If Static is set, then the attribute reference definitely obeys
6849 -- the requirements in (RM 4.9(7,8,22)), and it definitely can be
6850 -- folded. If Static is not set, then the attribute may or may not
6851 -- be foldable, and the individual attribute processing routines
6852 -- test Static as required in cases where it makes a difference.
6854 -- In the case where Static is not set, we do know that all the
6855 -- expressions present are at least known at compile time (we assumed
6856 -- above that if this was not the case, then there was no hope of static
6857 -- evaluation). However, we did not require that the bounds of the
6858 -- prefix type be compile time known, let alone static). That's because
6859 -- there are many attributes that can be computed at compile time on
6860 -- non-static subtypes, even though such references are not static
6863 -- For VAX float, the root type is an IEEE type. So make sure to use the
6864 -- base type instead of the root-type for floating point attributes.
6868 -- Attributes related to Ada 2012 iterators (placeholder ???)
6870 when Attribute_Constant_Indexing |
6871 Attribute_Default_Iterator |
6872 Attribute_Implicit_Dereference |
6873 Attribute_Iterator_Element |
6874 Attribute_Variable_Indexing
=> null;
6876 -- Internal attributes used to deal with Ada 2012 delayed aspects.
6877 -- These were already rejected by the parser. Thus they shouldn't
6880 when Internal_Attribute_Id
=>
6881 raise Program_Error
;
6887 when Attribute_Adjacent
=>
6891 (P_Base_Type
, Expr_Value_R
(E1
), Expr_Value_R
(E2
)),
6898 when Attribute_Aft
=>
6899 Fold_Uint
(N
, Aft_Value
(P_Type
), True);
6905 when Attribute_Alignment
=> Alignment_Block
: declare
6906 P_TypeA
: constant Entity_Id
:= Underlying_Type
(P_Type
);
6909 -- Fold if alignment is set and not otherwise
6911 if Known_Alignment
(P_TypeA
) then
6912 Fold_Uint
(N
, Alignment
(P_TypeA
), Is_Discrete_Type
(P_TypeA
));
6914 end Alignment_Block
;
6920 -- Can only be folded in No_Ast_Handler case
6922 when Attribute_AST_Entry
=>
6923 if not Is_AST_Entry
(P_Entity
) then
6925 New_Occurrence_Of
(RTE
(RE_No_AST_Handler
), Loc
));
6930 -----------------------------
6931 -- Atomic_Always_Lock_Free --
6932 -----------------------------
6934 -- Atomic_Always_Lock_Free attribute is a Boolean, thus no need to fold
6937 when Attribute_Atomic_Always_Lock_Free
=> Atomic_Always_Lock_Free
:
6939 V
: constant Entity_Id
:=
6941 (Support_Atomic_Primitives_On_Target
6942 and then Support_Atomic_Primitives
(P_Type
));
6945 Rewrite
(N
, New_Occurrence_Of
(V
, Loc
));
6947 -- Analyze and resolve as boolean. Note that this attribute is a
6948 -- static attribute in GNAT.
6950 Analyze_And_Resolve
(N
, Standard_Boolean
);
6952 end Atomic_Always_Lock_Free
;
6958 -- Bit can never be folded
6960 when Attribute_Bit
=>
6967 -- Body_version can never be static
6969 when Attribute_Body_Version
=>
6976 when Attribute_Ceiling
=>
6978 (N
, Eval_Fat
.Ceiling
(P_Base_Type
, Expr_Value_R
(E1
)), Static
);
6980 --------------------
6981 -- Component_Size --
6982 --------------------
6984 when Attribute_Component_Size
=>
6985 if Known_Static_Component_Size
(P_Type
) then
6986 Fold_Uint
(N
, Component_Size
(P_Type
), False);
6993 when Attribute_Compose
=>
6996 Eval_Fat
.Compose
(P_Base_Type
, Expr_Value_R
(E1
), Expr_Value
(E2
)),
7003 -- Constrained is never folded for now, there may be cases that
7004 -- could be handled at compile time. To be looked at later.
7006 when Attribute_Constrained
=>
7013 when Attribute_Copy_Sign
=>
7017 (P_Base_Type
, Expr_Value_R
(E1
), Expr_Value_R
(E2
)),
7024 when Attribute_Definite
=>
7025 Rewrite
(N
, New_Occurrence_Of
(
7026 Boolean_Literals
(not Is_Indefinite_Subtype
(P_Entity
)), Loc
));
7027 Analyze_And_Resolve
(N
, Standard_Boolean
);
7033 when Attribute_Delta
=>
7034 Fold_Ureal
(N
, Delta_Value
(P_Type
), True);
7040 when Attribute_Denorm
=>
7042 (N
, UI_From_Int
(Boolean'Pos (Has_Denormals
(P_Type
))), True);
7044 ---------------------
7045 -- Descriptor_Size --
7046 ---------------------
7048 when Attribute_Descriptor_Size
=>
7055 when Attribute_Digits
=>
7056 Fold_Uint
(N
, Digits_Value
(P_Type
), True);
7062 when Attribute_Emax
=>
7064 -- Ada 83 attribute is defined as (RM83 3.5.8)
7066 -- T'Emax = 4 * T'Mantissa
7068 Fold_Uint
(N
, 4 * Mantissa
, True);
7074 when Attribute_Enum_Rep
=>
7076 -- For an enumeration type with a non-standard representation use
7077 -- the Enumeration_Rep field of the proper constant. Note that this
7078 -- will not work for types Character/Wide_[Wide-]Character, since no
7079 -- real entities are created for the enumeration literals, but that
7080 -- does not matter since these two types do not have non-standard
7081 -- representations anyway.
7083 if Is_Enumeration_Type
(P_Type
)
7084 and then Has_Non_Standard_Rep
(P_Type
)
7086 Fold_Uint
(N
, Enumeration_Rep
(Expr_Value_E
(E1
)), Static
);
7088 -- For enumeration types with standard representations and all
7089 -- other cases (i.e. all integer and modular types), Enum_Rep
7090 -- is equivalent to Pos.
7093 Fold_Uint
(N
, Expr_Value
(E1
), Static
);
7100 when Attribute_Enum_Val
=> Enum_Val
: declare
7104 -- We have something like Enum_Type'Enum_Val (23), so search for a
7105 -- corresponding value in the list of Enum_Rep values for the type.
7107 Lit
:= First_Literal
(P_Base_Type
);
7109 if Enumeration_Rep
(Lit
) = Expr_Value
(E1
) then
7110 Fold_Uint
(N
, Enumeration_Pos
(Lit
), Static
);
7117 Apply_Compile_Time_Constraint_Error
7118 (N
, "no representation value matches",
7119 CE_Range_Check_Failed
,
7120 Warn
=> not Static
);
7130 when Attribute_Epsilon
=>
7132 -- Ada 83 attribute is defined as (RM83 3.5.8)
7134 -- T'Epsilon = 2.0**(1 - T'Mantissa)
7136 Fold_Ureal
(N
, Ureal_2
** (1 - Mantissa
), True);
7142 when Attribute_Exponent
=>
7144 Eval_Fat
.Exponent
(P_Base_Type
, Expr_Value_R
(E1
)), Static
);
7150 when Attribute_First
=> First_Attr
:
7154 if Compile_Time_Known_Value
(Lo_Bound
) then
7155 if Is_Real_Type
(P_Type
) then
7156 Fold_Ureal
(N
, Expr_Value_R
(Lo_Bound
), Static
);
7158 Fold_Uint
(N
, Expr_Value
(Lo_Bound
), Static
);
7161 -- Replace VAX Float_Type'First with a reference to the temporary
7162 -- which represents the low bound of the type. This transformation
7163 -- is needed since the back end cannot evaluate 'First on VAX.
7165 elsif Is_VAX_Float
(P_Type
)
7166 and then Nkind
(Lo_Bound
) = N_Identifier
7168 Rewrite
(N
, New_Reference_To
(Entity
(Lo_Bound
), Sloc
(N
)));
7172 Check_Concurrent_Discriminant
(Lo_Bound
);
7180 when Attribute_First_Valid
=> First_Valid
:
7182 if Has_Predicates
(P_Type
)
7183 and then Present
(Static_Predicate
(P_Type
))
7186 FirstN
: constant Node_Id
:= First
(Static_Predicate
(P_Type
));
7188 if Nkind
(FirstN
) = N_Range
then
7189 Fold_Uint
(N
, Expr_Value
(Low_Bound
(FirstN
)), Static
);
7191 Fold_Uint
(N
, Expr_Value
(FirstN
), Static
);
7197 Fold_Uint
(N
, Expr_Value
(Lo_Bound
), Static
);
7205 when Attribute_Fixed_Value
=>
7212 when Attribute_Floor
=>
7214 (N
, Eval_Fat
.Floor
(P_Base_Type
, Expr_Value_R
(E1
)), Static
);
7220 when Attribute_Fore
=>
7221 if Compile_Time_Known_Bounds
(P_Type
) then
7222 Fold_Uint
(N
, UI_From_Int
(Fore_Value
), Static
);
7229 when Attribute_Fraction
=>
7231 (N
, Eval_Fat
.Fraction
(P_Base_Type
, Expr_Value_R
(E1
)), Static
);
7233 -----------------------
7234 -- Has_Access_Values --
7235 -----------------------
7237 when Attribute_Has_Access_Values
=>
7238 Rewrite
(N
, New_Occurrence_Of
7239 (Boolean_Literals
(Has_Access_Values
(P_Root_Type
)), Loc
));
7240 Analyze_And_Resolve
(N
, Standard_Boolean
);
7242 -----------------------
7243 -- Has_Discriminants --
7244 -----------------------
7246 when Attribute_Has_Discriminants
=>
7247 Rewrite
(N
, New_Occurrence_Of
(
7248 Boolean_Literals
(Has_Discriminants
(P_Entity
)), Loc
));
7249 Analyze_And_Resolve
(N
, Standard_Boolean
);
7251 -----------------------
7252 -- Has_Tagged_Values --
7253 -----------------------
7255 when Attribute_Has_Tagged_Values
=>
7256 Rewrite
(N
, New_Occurrence_Of
7257 (Boolean_Literals
(Has_Tagged_Component
(P_Root_Type
)), Loc
));
7258 Analyze_And_Resolve
(N
, Standard_Boolean
);
7264 when Attribute_Identity
=>
7271 -- Image is a scalar attribute, but is never static, because it is
7272 -- not a static function (having a non-scalar argument (RM 4.9(22))
7273 -- However, we can constant-fold the image of an enumeration literal
7274 -- if names are available.
7276 when Attribute_Image
=>
7277 if Is_Entity_Name
(E1
)
7278 and then Ekind
(Entity
(E1
)) = E_Enumeration_Literal
7279 and then not Discard_Names
(First_Subtype
(Etype
(E1
)))
7280 and then not Global_Discard_Names
7283 Lit
: constant Entity_Id
:= Entity
(E1
);
7287 Get_Unqualified_Decoded_Name_String
(Chars
(Lit
));
7288 Set_Casing
(All_Upper_Case
);
7289 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
7291 Rewrite
(N
, Make_String_Literal
(Loc
, Strval
=> Str
));
7292 Analyze_And_Resolve
(N
, Standard_String
);
7293 Set_Is_Static_Expression
(N
, False);
7301 -- Img is a scalar attribute, but is never static, because it is
7302 -- not a static function (having a non-scalar argument (RM 4.9(22))
7304 when Attribute_Img
=>
7311 -- We never try to fold Integer_Value (though perhaps we could???)
7313 when Attribute_Integer_Value
=>
7320 -- Invalid_Value is a scalar attribute that is never static, because
7321 -- the value is by design out of range.
7323 when Attribute_Invalid_Value
=>
7330 when Attribute_Large
=>
7332 -- For fixed-point, we use the identity:
7334 -- T'Large = (2.0**T'Mantissa - 1.0) * T'Small
7336 if Is_Fixed_Point_Type
(P_Type
) then
7338 Make_Op_Multiply
(Loc
,
7340 Make_Op_Subtract
(Loc
,
7344 Make_Real_Literal
(Loc
, Ureal_2
),
7346 Make_Attribute_Reference
(Loc
,
7348 Attribute_Name
=> Name_Mantissa
)),
7349 Right_Opnd
=> Make_Real_Literal
(Loc
, Ureal_1
)),
7352 Make_Real_Literal
(Loc
, Small_Value
(Entity
(P
)))));
7354 Analyze_And_Resolve
(N
, C_Type
);
7356 -- Floating-point (Ada 83 compatibility)
7359 -- Ada 83 attribute is defined as (RM83 3.5.8)
7361 -- T'Large = 2.0**T'Emax * (1.0 - 2.0**(-T'Mantissa))
7365 -- T'Emax = 4 * T'Mantissa
7369 Ureal_2
** (4 * Mantissa
) * (Ureal_1
- Ureal_2
** (-Mantissa
)),
7377 when Attribute_Lock_Free
=> Lock_Free
: declare
7378 V
: constant Entity_Id
:= Boolean_Literals
(Uses_Lock_Free
(P_Type
));
7381 Rewrite
(N
, New_Occurrence_Of
(V
, Loc
));
7383 -- Analyze and resolve as boolean. Note that this attribute is a
7384 -- static attribute in GNAT.
7386 Analyze_And_Resolve
(N
, Standard_Boolean
);
7394 when Attribute_Last
=> Last_Attr
:
7398 if Compile_Time_Known_Value
(Hi_Bound
) then
7399 if Is_Real_Type
(P_Type
) then
7400 Fold_Ureal
(N
, Expr_Value_R
(Hi_Bound
), Static
);
7402 Fold_Uint
(N
, Expr_Value
(Hi_Bound
), Static
);
7405 -- Replace VAX Float_Type'Last with a reference to the temporary
7406 -- which represents the high bound of the type. This transformation
7407 -- is needed since the back end cannot evaluate 'Last on VAX.
7409 elsif Is_VAX_Float
(P_Type
)
7410 and then Nkind
(Hi_Bound
) = N_Identifier
7412 Rewrite
(N
, New_Reference_To
(Entity
(Hi_Bound
), Sloc
(N
)));
7416 Check_Concurrent_Discriminant
(Hi_Bound
);
7424 when Attribute_Last_Valid
=> Last_Valid
:
7426 if Has_Predicates
(P_Type
)
7427 and then Present
(Static_Predicate
(P_Type
))
7430 LastN
: constant Node_Id
:= Last
(Static_Predicate
(P_Type
));
7432 if Nkind
(LastN
) = N_Range
then
7433 Fold_Uint
(N
, Expr_Value
(High_Bound
(LastN
)), Static
);
7435 Fold_Uint
(N
, Expr_Value
(LastN
), Static
);
7441 Fold_Uint
(N
, Expr_Value
(Hi_Bound
), Static
);
7449 when Attribute_Leading_Part
=>
7452 Eval_Fat
.Leading_Part
7453 (P_Base_Type
, Expr_Value_R
(E1
), Expr_Value
(E2
)),
7460 when Attribute_Length
=> Length
: declare
7464 -- If any index type is a formal type, or derived from one, the
7465 -- bounds are not static. Treating them as static can produce
7466 -- spurious warnings or improper constant folding.
7468 Ind
:= First_Index
(P_Type
);
7469 while Present
(Ind
) loop
7470 if Is_Generic_Type
(Root_Type
(Etype
(Ind
))) then
7479 -- For two compile time values, we can compute length
7481 if Compile_Time_Known_Value
(Lo_Bound
)
7482 and then Compile_Time_Known_Value
(Hi_Bound
)
7485 UI_Max
(0, 1 + (Expr_Value
(Hi_Bound
) - Expr_Value
(Lo_Bound
))),
7489 -- One more case is where Hi_Bound and Lo_Bound are compile-time
7490 -- comparable, and we can figure out the difference between them.
7493 Diff
: aliased Uint
;
7497 Compile_Time_Compare
7498 (Lo_Bound
, Hi_Bound
, Diff
'Access, Assume_Valid
=> False)
7501 Fold_Uint
(N
, Uint_1
, False);
7504 Fold_Uint
(N
, Uint_0
, False);
7507 if Diff
/= No_Uint
then
7508 Fold_Uint
(N
, Diff
+ 1, False);
7521 -- Loop_Entry acts as an alias of a constant initialized to the prefix
7522 -- of the said attribute at the point of entry into the related loop. As
7523 -- such, the attribute reference does not need to be evaluated because
7524 -- the prefix is the one that is evaluted.
7526 when Attribute_Loop_Entry
=>
7533 when Attribute_Machine
=>
7537 (P_Base_Type
, Expr_Value_R
(E1
), Eval_Fat
.Round
, N
),
7544 when Attribute_Machine_Emax
=>
7545 Fold_Uint
(N
, Machine_Emax_Value
(P_Type
), Static
);
7551 when Attribute_Machine_Emin
=>
7552 Fold_Uint
(N
, Machine_Emin_Value
(P_Type
), Static
);
7554 ----------------------
7555 -- Machine_Mantissa --
7556 ----------------------
7558 when Attribute_Machine_Mantissa
=>
7559 Fold_Uint
(N
, Machine_Mantissa_Value
(P_Type
), Static
);
7561 -----------------------
7562 -- Machine_Overflows --
7563 -----------------------
7565 when Attribute_Machine_Overflows
=>
7567 -- Always true for fixed-point
7569 if Is_Fixed_Point_Type
(P_Type
) then
7570 Fold_Uint
(N
, True_Value
, True);
7572 -- Floating point case
7576 UI_From_Int
(Boolean'Pos (Machine_Overflows_On_Target
)),
7584 when Attribute_Machine_Radix
=>
7585 if Is_Fixed_Point_Type
(P_Type
) then
7586 if Is_Decimal_Fixed_Point_Type
(P_Type
)
7587 and then Machine_Radix_10
(P_Type
)
7589 Fold_Uint
(N
, Uint_10
, True);
7591 Fold_Uint
(N
, Uint_2
, True);
7594 -- All floating-point type always have radix 2
7597 Fold_Uint
(N
, Uint_2
, True);
7600 ----------------------
7601 -- Machine_Rounding --
7602 ----------------------
7604 -- Note: for the folding case, it is fine to treat Machine_Rounding
7605 -- exactly the same way as Rounding, since this is one of the allowed
7606 -- behaviors, and performance is not an issue here. It might be a bit
7607 -- better to give the same result as it would give at run time, even
7608 -- though the non-determinism is certainly permitted.
7610 when Attribute_Machine_Rounding
=>
7612 (N
, Eval_Fat
.Rounding
(P_Base_Type
, Expr_Value_R
(E1
)), Static
);
7614 --------------------
7615 -- Machine_Rounds --
7616 --------------------
7618 when Attribute_Machine_Rounds
=>
7620 -- Always False for fixed-point
7622 if Is_Fixed_Point_Type
(P_Type
) then
7623 Fold_Uint
(N
, False_Value
, True);
7625 -- Else yield proper floating-point result
7629 (N
, UI_From_Int
(Boolean'Pos (Machine_Rounds_On_Target
)), True);
7636 -- Note: Machine_Size is identical to Object_Size
7638 when Attribute_Machine_Size
=> Machine_Size
: declare
7639 P_TypeA
: constant Entity_Id
:= Underlying_Type
(P_Type
);
7642 if Known_Esize
(P_TypeA
) then
7643 Fold_Uint
(N
, Esize
(P_TypeA
), True);
7651 when Attribute_Mantissa
=>
7653 -- Fixed-point mantissa
7655 if Is_Fixed_Point_Type
(P_Type
) then
7657 -- Compile time foldable case
7659 if Compile_Time_Known_Value
(Type_Low_Bound
(P_Type
))
7661 Compile_Time_Known_Value
(Type_High_Bound
(P_Type
))
7663 -- The calculation of the obsolete Ada 83 attribute Mantissa
7664 -- is annoying, because of AI00143, quoted here:
7666 -- !question 84-01-10
7668 -- Consider the model numbers for F:
7670 -- type F is delta 1.0 range -7.0 .. 8.0;
7672 -- The wording requires that F'MANTISSA be the SMALLEST
7673 -- integer number for which each bound of the specified
7674 -- range is either a model number or lies at most small
7675 -- distant from a model number. This means F'MANTISSA
7676 -- is required to be 3 since the range -7.0 .. 7.0 fits
7677 -- in 3 signed bits, and 8 is "at most" 1.0 from a model
7678 -- number, namely, 7. Is this analysis correct? Note that
7679 -- this implies the upper bound of the range is not
7680 -- represented as a model number.
7682 -- !response 84-03-17
7684 -- The analysis is correct. The upper and lower bounds for
7685 -- a fixed point type can lie outside the range of model
7696 LBound
:= Expr_Value_R
(Type_Low_Bound
(P_Type
));
7697 UBound
:= Expr_Value_R
(Type_High_Bound
(P_Type
));
7698 Bound
:= UR_Max
(UR_Abs
(LBound
), UR_Abs
(UBound
));
7699 Max_Man
:= UR_Trunc
(Bound
/ Small_Value
(P_Type
));
7701 -- If the Bound is exactly a model number, i.e. a multiple
7702 -- of Small, then we back it off by one to get the integer
7703 -- value that must be representable.
7705 if Small_Value
(P_Type
) * Max_Man
= Bound
then
7706 Max_Man
:= Max_Man
- 1;
7709 -- Now find corresponding size = Mantissa value
7712 while 2 ** Siz
< Max_Man
loop
7716 Fold_Uint
(N
, Siz
, True);
7720 -- The case of dynamic bounds cannot be evaluated at compile
7721 -- time. Instead we use a runtime routine (see Exp_Attr).
7726 -- Floating-point Mantissa
7729 Fold_Uint
(N
, Mantissa
, True);
7736 when Attribute_Max
=> Max
:
7738 if Is_Real_Type
(P_Type
) then
7740 (N
, UR_Max
(Expr_Value_R
(E1
), Expr_Value_R
(E2
)), Static
);
7742 Fold_Uint
(N
, UI_Max
(Expr_Value
(E1
), Expr_Value
(E2
)), Static
);
7746 ----------------------------------
7747 -- Max_Alignment_For_Allocation --
7748 ----------------------------------
7750 -- Max_Alignment_For_Allocation is usually the Alignment. However,
7751 -- arrays are allocated with dope, so we need to take into account both
7752 -- the alignment of the array, which comes from the component alignment,
7753 -- and the alignment of the dope. Also, if the alignment is unknown, we
7754 -- use the max (it's OK to be pessimistic).
7756 when Attribute_Max_Alignment_For_Allocation
=>
7758 A
: Uint
:= UI_From_Int
(Ttypes
.Maximum_Alignment
);
7760 if Known_Alignment
(P_Type
) and then
7761 (not Is_Array_Type
(P_Type
) or else Alignment
(P_Type
) > A
)
7763 A
:= Alignment
(P_Type
);
7766 Fold_Uint
(N
, A
, Static
);
7769 ----------------------------------
7770 -- Max_Size_In_Storage_Elements --
7771 ----------------------------------
7773 -- Max_Size_In_Storage_Elements is simply the Size rounded up to a
7774 -- Storage_Unit boundary. We can fold any cases for which the size
7775 -- is known by the front end.
7777 when Attribute_Max_Size_In_Storage_Elements
=>
7778 if Known_Esize
(P_Type
) then
7780 (Esize
(P_Type
) + System_Storage_Unit
- 1) /
7781 System_Storage_Unit
,
7785 --------------------
7786 -- Mechanism_Code --
7787 --------------------
7789 when Attribute_Mechanism_Code
=>
7793 Mech
: Mechanism_Type
;
7797 Mech
:= Mechanism
(P_Entity
);
7800 Val
:= UI_To_Int
(Expr_Value
(E1
));
7802 Formal
:= First_Formal
(P_Entity
);
7803 for J
in 1 .. Val
- 1 loop
7804 Next_Formal
(Formal
);
7806 Mech
:= Mechanism
(Formal
);
7810 Fold_Uint
(N
, UI_From_Int
(Int
(-Mech
)), True);
7818 when Attribute_Min
=> Min
:
7820 if Is_Real_Type
(P_Type
) then
7822 (N
, UR_Min
(Expr_Value_R
(E1
), Expr_Value_R
(E2
)), Static
);
7825 (N
, UI_Min
(Expr_Value
(E1
), Expr_Value
(E2
)), Static
);
7833 when Attribute_Mod
=>
7835 (N
, UI_Mod
(Expr_Value
(E1
), Modulus
(P_Base_Type
)), Static
);
7841 when Attribute_Model
=>
7843 (N
, Eval_Fat
.Model
(P_Base_Type
, Expr_Value_R
(E1
)), Static
);
7849 when Attribute_Model_Emin
=>
7850 Fold_Uint
(N
, Model_Emin_Value
(P_Base_Type
), Static
);
7856 when Attribute_Model_Epsilon
=>
7857 Fold_Ureal
(N
, Model_Epsilon_Value
(P_Base_Type
), Static
);
7859 --------------------
7860 -- Model_Mantissa --
7861 --------------------
7863 when Attribute_Model_Mantissa
=>
7864 Fold_Uint
(N
, Model_Mantissa_Value
(P_Base_Type
), Static
);
7870 when Attribute_Model_Small
=>
7871 Fold_Ureal
(N
, Model_Small_Value
(P_Base_Type
), Static
);
7877 when Attribute_Modulus
=>
7878 Fold_Uint
(N
, Modulus
(P_Type
), True);
7880 --------------------
7881 -- Null_Parameter --
7882 --------------------
7884 -- Cannot fold, we know the value sort of, but the whole point is
7885 -- that there is no way to talk about this imaginary value except
7886 -- by using the attribute, so we leave it the way it is.
7888 when Attribute_Null_Parameter
=>
7895 -- The Object_Size attribute for a type returns the Esize of the
7896 -- type and can be folded if this value is known.
7898 when Attribute_Object_Size
=> Object_Size
: declare
7899 P_TypeA
: constant Entity_Id
:= Underlying_Type
(P_Type
);
7902 if Known_Esize
(P_TypeA
) then
7903 Fold_Uint
(N
, Esize
(P_TypeA
), True);
7907 ----------------------
7908 -- Overlaps_Storage --
7909 ----------------------
7911 when Attribute_Overlaps_Storage
=>
7914 -------------------------
7915 -- Passed_By_Reference --
7916 -------------------------
7918 -- Scalar types are never passed by reference
7920 when Attribute_Passed_By_Reference
=>
7921 Fold_Uint
(N
, False_Value
, True);
7927 when Attribute_Pos
=>
7928 Fold_Uint
(N
, Expr_Value
(E1
), True);
7934 when Attribute_Pred
=> Pred
:
7936 -- Floating-point case
7938 if Is_Floating_Point_Type
(P_Type
) then
7940 (N
, Eval_Fat
.Pred
(P_Base_Type
, Expr_Value_R
(E1
)), Static
);
7944 elsif Is_Fixed_Point_Type
(P_Type
) then
7946 (N
, Expr_Value_R
(E1
) - Small_Value
(P_Type
), True);
7948 -- Modular integer case (wraps)
7950 elsif Is_Modular_Integer_Type
(P_Type
) then
7951 Fold_Uint
(N
, (Expr_Value
(E1
) - 1) mod Modulus
(P_Type
), Static
);
7953 -- Other scalar cases
7956 pragma Assert
(Is_Scalar_Type
(P_Type
));
7958 if Is_Enumeration_Type
(P_Type
)
7959 and then Expr_Value
(E1
) =
7960 Expr_Value
(Type_Low_Bound
(P_Base_Type
))
7962 Apply_Compile_Time_Constraint_Error
7963 (N
, "Pred of `&''First`",
7964 CE_Overflow_Check_Failed
,
7966 Warn
=> not Static
);
7972 Fold_Uint
(N
, Expr_Value
(E1
) - 1, Static
);
7980 -- No processing required, because by this stage, Range has been
7981 -- replaced by First .. Last, so this branch can never be taken.
7983 when Attribute_Range
=>
7984 raise Program_Error
;
7990 when Attribute_Range_Length
=>
7993 -- Can fold if both bounds are compile time known
7995 if Compile_Time_Known_Value
(Hi_Bound
)
7996 and then Compile_Time_Known_Value
(Lo_Bound
)
8000 (0, Expr_Value
(Hi_Bound
) - Expr_Value
(Lo_Bound
) + 1),
8004 -- One more case is where Hi_Bound and Lo_Bound are compile-time
8005 -- comparable, and we can figure out the difference between them.
8008 Diff
: aliased Uint
;
8012 Compile_Time_Compare
8013 (Lo_Bound
, Hi_Bound
, Diff
'Access, Assume_Valid
=> False)
8016 Fold_Uint
(N
, Uint_1
, False);
8019 Fold_Uint
(N
, Uint_0
, False);
8022 if Diff
/= No_Uint
then
8023 Fold_Uint
(N
, Diff
+ 1, False);
8035 when Attribute_Ref
=>
8036 Fold_Uint
(N
, Expr_Value
(E1
), True);
8042 when Attribute_Remainder
=> Remainder
: declare
8043 X
: constant Ureal
:= Expr_Value_R
(E1
);
8044 Y
: constant Ureal
:= Expr_Value_R
(E2
);
8047 if UR_Is_Zero
(Y
) then
8048 Apply_Compile_Time_Constraint_Error
8049 (N
, "division by zero in Remainder",
8050 CE_Overflow_Check_Failed
,
8051 Warn
=> not Static
);
8057 Fold_Ureal
(N
, Eval_Fat
.Remainder
(P_Base_Type
, X
, Y
), Static
);
8064 when Attribute_Round
=> Round
:
8070 -- First we get the (exact result) in units of small
8072 Sr
:= Expr_Value_R
(E1
) / Small_Value
(C_Type
);
8074 -- Now round that exactly to an integer
8076 Si
:= UR_To_Uint
(Sr
);
8078 -- Finally the result is obtained by converting back to real
8080 Fold_Ureal
(N
, Si
* Small_Value
(C_Type
), Static
);
8087 when Attribute_Rounding
=>
8089 (N
, Eval_Fat
.Rounding
(P_Base_Type
, Expr_Value_R
(E1
)), Static
);
8095 when Attribute_Safe_Emax
=>
8096 Fold_Uint
(N
, Safe_Emax_Value
(P_Type
), Static
);
8102 when Attribute_Safe_First
=>
8103 Fold_Ureal
(N
, Safe_First_Value
(P_Type
), Static
);
8109 when Attribute_Safe_Large
=>
8110 if Is_Fixed_Point_Type
(P_Type
) then
8112 (N
, Expr_Value_R
(Type_High_Bound
(P_Base_Type
)), Static
);
8114 Fold_Ureal
(N
, Safe_Last_Value
(P_Type
), Static
);
8121 when Attribute_Safe_Last
=>
8122 Fold_Ureal
(N
, Safe_Last_Value
(P_Type
), Static
);
8128 when Attribute_Safe_Small
=>
8130 -- In Ada 95, the old Ada 83 attribute Safe_Small is redundant
8131 -- for fixed-point, since is the same as Small, but we implement
8132 -- it for backwards compatibility.
8134 if Is_Fixed_Point_Type
(P_Type
) then
8135 Fold_Ureal
(N
, Small_Value
(P_Type
), Static
);
8137 -- Ada 83 Safe_Small for floating-point cases
8140 Fold_Ureal
(N
, Model_Small_Value
(P_Type
), Static
);
8147 when Attribute_Same_Storage
=>
8154 when Attribute_Scale
=>
8155 Fold_Uint
(N
, Scale_Value
(P_Type
), True);
8161 when Attribute_Scaling
=>
8165 (P_Base_Type
, Expr_Value_R
(E1
), Expr_Value
(E2
)),
8172 when Attribute_Signed_Zeros
=>
8174 (N
, UI_From_Int
(Boolean'Pos (Has_Signed_Zeros
(P_Type
))), Static
);
8180 -- Size attribute returns the RM size. All scalar types can be folded,
8181 -- as well as any types for which the size is known by the front end,
8182 -- including any type for which a size attribute is specified.
8184 when Attribute_Size | Attribute_VADS_Size
=> Size
: declare
8185 P_TypeA
: constant Entity_Id
:= Underlying_Type
(P_Type
);
8188 if RM_Size
(P_TypeA
) /= Uint_0
then
8192 if Id
= Attribute_VADS_Size
or else Use_VADS_Size
then
8194 S
: constant Node_Id
:= Size_Clause
(P_TypeA
);
8197 -- If a size clause applies, then use the size from it.
8198 -- This is one of the rare cases where we can use the
8199 -- Size_Clause field for a subtype when Has_Size_Clause
8200 -- is False. Consider:
8202 -- type x is range 1 .. 64;
8203 -- for x'size use 12;
8204 -- subtype y is x range 0 .. 3;
8206 -- Here y has a size clause inherited from x, but normally
8207 -- it does not apply, and y'size is 2. However, y'VADS_Size
8208 -- is indeed 12 and not 2.
8211 and then Is_OK_Static_Expression
(Expression
(S
))
8213 Fold_Uint
(N
, Expr_Value
(Expression
(S
)), True);
8215 -- If no size is specified, then we simply use the object
8216 -- size in the VADS_Size case (e.g. Natural'Size is equal
8217 -- to Integer'Size, not one less).
8220 Fold_Uint
(N
, Esize
(P_TypeA
), True);
8224 -- Normal case (Size) in which case we want the RM_Size
8229 Static
and then Is_Discrete_Type
(P_TypeA
));
8238 when Attribute_Small
=>
8240 -- The floating-point case is present only for Ada 83 compatibility.
8241 -- Note that strictly this is an illegal addition, since we are
8242 -- extending an Ada 95 defined attribute, but we anticipate an
8243 -- ARG ruling that will permit this.
8245 if Is_Floating_Point_Type
(P_Type
) then
8247 -- Ada 83 attribute is defined as (RM83 3.5.8)
8249 -- T'Small = 2.0**(-T'Emax - 1)
8253 -- T'Emax = 4 * T'Mantissa
8255 Fold_Ureal
(N
, Ureal_2
** ((-(4 * Mantissa
)) - 1), Static
);
8257 -- Normal Ada 95 fixed-point case
8260 Fold_Ureal
(N
, Small_Value
(P_Type
), True);
8267 when Attribute_Stream_Size
=>
8274 when Attribute_Succ
=> Succ
:
8276 -- Floating-point case
8278 if Is_Floating_Point_Type
(P_Type
) then
8280 (N
, Eval_Fat
.Succ
(P_Base_Type
, Expr_Value_R
(E1
)), Static
);
8284 elsif Is_Fixed_Point_Type
(P_Type
) then
8285 Fold_Ureal
(N
, Expr_Value_R
(E1
) + Small_Value
(P_Type
), Static
);
8287 -- Modular integer case (wraps)
8289 elsif Is_Modular_Integer_Type
(P_Type
) then
8290 Fold_Uint
(N
, (Expr_Value
(E1
) + 1) mod Modulus
(P_Type
), Static
);
8292 -- Other scalar cases
8295 pragma Assert
(Is_Scalar_Type
(P_Type
));
8297 if Is_Enumeration_Type
(P_Type
)
8298 and then Expr_Value
(E1
) =
8299 Expr_Value
(Type_High_Bound
(P_Base_Type
))
8301 Apply_Compile_Time_Constraint_Error
8302 (N
, "Succ of `&''Last`",
8303 CE_Overflow_Check_Failed
,
8305 Warn
=> not Static
);
8310 Fold_Uint
(N
, Expr_Value
(E1
) + 1, Static
);
8319 when Attribute_Truncation
=>
8322 Eval_Fat
.Truncation
(P_Base_Type
, Expr_Value_R
(E1
)),
8329 when Attribute_Type_Class
=> Type_Class
: declare
8330 Typ
: constant Entity_Id
:= Underlying_Type
(P_Base_Type
);
8334 if Is_Descendent_Of_Address
(Typ
) then
8335 Id
:= RE_Type_Class_Address
;
8337 elsif Is_Enumeration_Type
(Typ
) then
8338 Id
:= RE_Type_Class_Enumeration
;
8340 elsif Is_Integer_Type
(Typ
) then
8341 Id
:= RE_Type_Class_Integer
;
8343 elsif Is_Fixed_Point_Type
(Typ
) then
8344 Id
:= RE_Type_Class_Fixed_Point
;
8346 elsif Is_Floating_Point_Type
(Typ
) then
8347 Id
:= RE_Type_Class_Floating_Point
;
8349 elsif Is_Array_Type
(Typ
) then
8350 Id
:= RE_Type_Class_Array
;
8352 elsif Is_Record_Type
(Typ
) then
8353 Id
:= RE_Type_Class_Record
;
8355 elsif Is_Access_Type
(Typ
) then
8356 Id
:= RE_Type_Class_Access
;
8358 elsif Is_Enumeration_Type
(Typ
) then
8359 Id
:= RE_Type_Class_Enumeration
;
8361 elsif Is_Task_Type
(Typ
) then
8362 Id
:= RE_Type_Class_Task
;
8364 -- We treat protected types like task types. It would make more
8365 -- sense to have another enumeration value, but after all the
8366 -- whole point of this feature is to be exactly DEC compatible,
8367 -- and changing the type Type_Class would not meet this requirement.
8369 elsif Is_Protected_Type
(Typ
) then
8370 Id
:= RE_Type_Class_Task
;
8372 -- Not clear if there are any other possibilities, but if there
8373 -- are, then we will treat them as the address case.
8376 Id
:= RE_Type_Class_Address
;
8379 Rewrite
(N
, New_Occurrence_Of
(RTE
(Id
), Loc
));
8382 -----------------------
8383 -- Unbiased_Rounding --
8384 -----------------------
8386 when Attribute_Unbiased_Rounding
=>
8389 Eval_Fat
.Unbiased_Rounding
(P_Base_Type
, Expr_Value_R
(E1
)),
8392 -------------------------
8393 -- Unconstrained_Array --
8394 -------------------------
8396 when Attribute_Unconstrained_Array
=> Unconstrained_Array
: declare
8397 Typ
: constant Entity_Id
:= Underlying_Type
(P_Type
);
8400 Rewrite
(N
, New_Occurrence_Of
(
8402 Is_Array_Type
(P_Type
)
8403 and then not Is_Constrained
(Typ
)), Loc
));
8405 -- Analyze and resolve as boolean, note that this attribute is
8406 -- a static attribute in GNAT.
8408 Analyze_And_Resolve
(N
, Standard_Boolean
);
8410 end Unconstrained_Array
;
8412 -- Attribute Update is never static
8418 when Attribute_Update
=>
8425 -- Processing is shared with Size
8431 when Attribute_Val
=> Val
:
8433 if Expr_Value
(E1
) < Expr_Value
(Type_Low_Bound
(P_Base_Type
))
8435 Expr_Value
(E1
) > Expr_Value
(Type_High_Bound
(P_Base_Type
))
8437 Apply_Compile_Time_Constraint_Error
8438 (N
, "Val expression out of range",
8439 CE_Range_Check_Failed
,
8440 Warn
=> not Static
);
8446 Fold_Uint
(N
, Expr_Value
(E1
), Static
);
8454 -- The Value_Size attribute for a type returns the RM size of the
8455 -- type. This an always be folded for scalar types, and can also
8456 -- be folded for non-scalar types if the size is set.
8458 when Attribute_Value_Size
=> Value_Size
: declare
8459 P_TypeA
: constant Entity_Id
:= Underlying_Type
(P_Type
);
8461 if RM_Size
(P_TypeA
) /= Uint_0
then
8462 Fold_Uint
(N
, RM_Size
(P_TypeA
), True);
8470 -- Version can never be static
8472 when Attribute_Version
=>
8479 -- Wide_Image is a scalar attribute, but is never static, because it
8480 -- is not a static function (having a non-scalar argument (RM 4.9(22))
8482 when Attribute_Wide_Image
=>
8485 ---------------------
8486 -- Wide_Wide_Image --
8487 ---------------------
8489 -- Wide_Wide_Image is a scalar attribute but is never static, because it
8490 -- is not a static function (having a non-scalar argument (RM 4.9(22)).
8492 when Attribute_Wide_Wide_Image
=>
8495 ---------------------
8496 -- Wide_Wide_Width --
8497 ---------------------
8499 -- Processing for Wide_Wide_Width is combined with Width
8505 -- Processing for Wide_Width is combined with Width
8511 -- This processing also handles the case of Wide_[Wide_]Width
8513 when Attribute_Width |
8514 Attribute_Wide_Width |
8515 Attribute_Wide_Wide_Width
=> Width
:
8517 if Compile_Time_Known_Bounds
(P_Type
) then
8519 -- Floating-point types
8521 if Is_Floating_Point_Type
(P_Type
) then
8523 -- Width is zero for a null range (RM 3.5 (38))
8525 if Expr_Value_R
(Type_High_Bound
(P_Type
)) <
8526 Expr_Value_R
(Type_Low_Bound
(P_Type
))
8528 Fold_Uint
(N
, Uint_0
, True);
8531 -- For floating-point, we have +N.dddE+nnn where length
8532 -- of ddd is determined by type'Digits - 1, but is one
8533 -- if Digits is one (RM 3.5 (33)).
8535 -- nnn is set to 2 for Short_Float and Float (32 bit
8536 -- floats), and 3 for Long_Float and Long_Long_Float.
8537 -- For machines where Long_Long_Float is the IEEE
8538 -- extended precision type, the exponent takes 4 digits.
8542 Int
'Max (2, UI_To_Int
(Digits_Value
(P_Type
)));
8545 if Esize
(P_Type
) <= 32 then
8547 elsif Esize
(P_Type
) = 64 then
8553 Fold_Uint
(N
, UI_From_Int
(Len
), True);
8557 -- Fixed-point types
8559 elsif Is_Fixed_Point_Type
(P_Type
) then
8561 -- Width is zero for a null range (RM 3.5 (38))
8563 if Expr_Value
(Type_High_Bound
(P_Type
)) <
8564 Expr_Value
(Type_Low_Bound
(P_Type
))
8566 Fold_Uint
(N
, Uint_0
, True);
8568 -- The non-null case depends on the specific real type
8571 -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34))
8574 (N
, UI_From_Int
(Fore_Value
+ 1) + Aft_Value
(P_Type
),
8582 R
: constant Entity_Id
:= Root_Type
(P_Type
);
8583 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(P_Type
));
8584 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(P_Type
));
8597 -- Width for types derived from Standard.Character
8598 -- and Standard.Wide_[Wide_]Character.
8600 elsif Is_Standard_Character_Type
(P_Type
) then
8603 -- Set W larger if needed
8605 for J
in UI_To_Int
(Lo
) .. UI_To_Int
(Hi
) loop
8607 -- All wide characters look like Hex_hhhhhhhh
8611 -- No need to compute this more than once!
8616 C
:= Character'Val (J
);
8618 -- Test for all cases where Character'Image
8619 -- yields an image that is longer than three
8620 -- characters. First the cases of Reserved_xxx
8621 -- names (length = 12).
8624 when Reserved_128 | Reserved_129 |
8625 Reserved_132 | Reserved_153
8628 when BS | HT | LF | VT | FF | CR |
8629 SO | SI | EM | FS | GS | RS |
8630 US | RI | MW | ST | PM
8633 when NUL | SOH | STX | ETX | EOT |
8634 ENQ | ACK | BEL | DLE | DC1 |
8635 DC2 | DC3 | DC4 | NAK | SYN |
8636 ETB | CAN | SUB | ESC | DEL |
8637 BPH | NBH | NEL | SSA | ESA |
8638 HTS | HTJ | VTS | PLD | PLU |
8639 SS2 | SS3 | DCS | PU1 | PU2 |
8640 STS | CCH | SPA | EPA | SOS |
8641 SCI | CSI | OSC | APC
8644 when Space
.. Tilde |
8645 No_Break_Space
.. LC_Y_Diaeresis
8647 -- Special case of soft hyphen in Ada 2005
8649 if C
= Character'Val (16#AD#
)
8650 and then Ada_Version
>= Ada_2005
8658 W
:= Int
'Max (W
, Wt
);
8662 -- Width for types derived from Standard.Boolean
8664 elsif R
= Standard_Boolean
then
8671 -- Width for integer types
8673 elsif Is_Integer_Type
(P_Type
) then
8674 T
:= UI_Max
(abs Lo
, abs Hi
);
8682 -- User declared enum type with discard names
8684 elsif Discard_Names
(R
) then
8686 -- If range is null, result is zero, that has already
8687 -- been dealt with, so what we need is the power of ten
8688 -- that accomodates the Pos of the largest value, which
8689 -- is the high bound of the range + one for the space.
8698 -- Only remaining possibility is user declared enum type
8699 -- with normal case of Discard_Names not active.
8702 pragma Assert
(Is_Enumeration_Type
(P_Type
));
8705 L
:= First_Literal
(P_Type
);
8706 while Present
(L
) loop
8708 -- Only pay attention to in range characters
8710 if Lo
<= Enumeration_Pos
(L
)
8711 and then Enumeration_Pos
(L
) <= Hi
8713 -- For Width case, use decoded name
8715 if Id
= Attribute_Width
then
8716 Get_Decoded_Name_String
(Chars
(L
));
8717 Wt
:= Nat
(Name_Len
);
8719 -- For Wide_[Wide_]Width, use encoded name, and
8720 -- then adjust for the encoding.
8723 Get_Name_String
(Chars
(L
));
8725 -- Character literals are always of length 3
8727 if Name_Buffer
(1) = 'Q' then
8730 -- Otherwise loop to adjust for upper/wide chars
8733 Wt
:= Nat
(Name_Len
);
8735 for J
in 1 .. Name_Len
loop
8736 if Name_Buffer
(J
) = 'U' then
8738 elsif Name_Buffer
(J
) = 'W' then
8745 W
:= Int
'Max (W
, Wt
);
8752 Fold_Uint
(N
, UI_From_Int
(W
), True);
8758 -- The following attributes denote functions that cannot be folded
8760 when Attribute_From_Any |
8762 Attribute_TypeCode
=>
8765 -- The following attributes can never be folded, and furthermore we
8766 -- should not even have entered the case statement for any of these.
8767 -- Note that in some cases, the values have already been folded as
8768 -- a result of the processing in Analyze_Attribute.
8770 when Attribute_Abort_Signal |
8773 Attribute_Address_Size |
8774 Attribute_Asm_Input |
8775 Attribute_Asm_Output |
8777 Attribute_Bit_Order |
8778 Attribute_Bit_Position |
8779 Attribute_Callable |
8782 Attribute_Code_Address |
8783 Attribute_Compiler_Version |
8785 Attribute_Default_Bit_Order |
8786 Attribute_Elaborated |
8787 Attribute_Elab_Body |
8788 Attribute_Elab_Spec |
8789 Attribute_Elab_Subp_Body |
8791 Attribute_External_Tag |
8792 Attribute_Fast_Math |
8793 Attribute_First_Bit |
8795 Attribute_Last_Bit |
8796 Attribute_Maximum_Alignment |
8799 Attribute_Partition_ID |
8800 Attribute_Pool_Address |
8801 Attribute_Position |
8802 Attribute_Priority |
8805 Attribute_Scalar_Storage_Order |
8806 Attribute_Simple_Storage_Pool |
8807 Attribute_Storage_Pool |
8808 Attribute_Storage_Size |
8809 Attribute_Storage_Unit |
8810 Attribute_Stub_Type |
8811 Attribute_System_Allocator_Alignment |
8813 Attribute_Target_Name |
8814 Attribute_Terminated |
8815 Attribute_To_Address |
8816 Attribute_Type_Key |
8817 Attribute_UET_Address |
8818 Attribute_Unchecked_Access |
8819 Attribute_Universal_Literal_String |
8820 Attribute_Unrestricted_Access |
8822 Attribute_Valid_Scalars |
8824 Attribute_Wchar_T_Size |
8825 Attribute_Wide_Value |
8826 Attribute_Wide_Wide_Value |
8827 Attribute_Word_Size |
8830 raise Program_Error
;
8833 -- At the end of the case, one more check. If we did a static evaluation
8834 -- so that the result is now a literal, then set Is_Static_Expression
8835 -- in the constant only if the prefix type is a static subtype. For
8836 -- non-static subtypes, the folding is still OK, but not static.
8838 -- An exception is the GNAT attribute Constrained_Array which is
8839 -- defined to be a static attribute in all cases.
8841 if Nkind_In
(N
, N_Integer_Literal
,
8843 N_Character_Literal
,
8845 or else (Is_Entity_Name
(N
)
8846 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
)
8848 Set_Is_Static_Expression
(N
, Static
);
8850 -- If this is still an attribute reference, then it has not been folded
8851 -- and that means that its expressions are in a non-static context.
8853 elsif Nkind
(N
) = N_Attribute_Reference
then
8856 -- Note: the else case not covered here are odd cases where the
8857 -- processing has transformed the attribute into something other
8858 -- than a constant. Nothing more to do in such cases.
8865 ------------------------------
8866 -- Is_Anonymous_Tagged_Base --
8867 ------------------------------
8869 function Is_Anonymous_Tagged_Base
8876 Anon
= Current_Scope
8877 and then Is_Itype
(Anon
)
8878 and then Associated_Node_For_Itype
(Anon
) = Parent
(Typ
);
8879 end Is_Anonymous_Tagged_Base
;
8881 --------------------------------
8882 -- Name_Implies_Lvalue_Prefix --
8883 --------------------------------
8885 function Name_Implies_Lvalue_Prefix
(Nam
: Name_Id
) return Boolean is
8886 pragma Assert
(Is_Attribute_Name
(Nam
));
8888 return Attribute_Name_Implies_Lvalue_Prefix
(Get_Attribute_Id
(Nam
));
8889 end Name_Implies_Lvalue_Prefix
;
8891 -----------------------
8892 -- Resolve_Attribute --
8893 -----------------------
8895 procedure Resolve_Attribute
(N
: Node_Id
; Typ
: Entity_Id
) is
8896 Loc
: constant Source_Ptr
:= Sloc
(N
);
8897 P
: constant Node_Id
:= Prefix
(N
);
8898 Aname
: constant Name_Id
:= Attribute_Name
(N
);
8899 Attr_Id
: constant Attribute_Id
:= Get_Attribute_Id
(Aname
);
8900 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
8901 Des_Btyp
: Entity_Id
;
8902 Index
: Interp_Index
;
8904 Nom_Subt
: Entity_Id
;
8906 procedure Accessibility_Message
;
8907 -- Error, or warning within an instance, if the static accessibility
8908 -- rules of 3.10.2 are violated.
8910 ---------------------------
8911 -- Accessibility_Message --
8912 ---------------------------
8914 procedure Accessibility_Message
is
8915 Indic
: Node_Id
:= Parent
(Parent
(N
));
8918 -- In an instance, this is a runtime check, but one we
8919 -- know will fail, so generate an appropriate warning.
8921 if In_Instance_Body
then
8923 ("??non-local pointer cannot point to local object", P
);
8925 ("\??Program_Error will be raised at run time", P
);
8927 Make_Raise_Program_Error
(Loc
,
8928 Reason
=> PE_Accessibility_Check_Failed
));
8933 Error_Msg_F
("non-local pointer cannot point to local object", P
);
8935 -- Check for case where we have a missing access definition
8937 if Is_Record_Type
(Current_Scope
)
8939 Nkind_In
(Parent
(N
), N_Discriminant_Association
,
8940 N_Index_Or_Discriminant_Constraint
)
8942 Indic
:= Parent
(Parent
(N
));
8943 while Present
(Indic
)
8944 and then Nkind
(Indic
) /= N_Subtype_Indication
8946 Indic
:= Parent
(Indic
);
8949 if Present
(Indic
) then
8951 ("\use an access definition for" &
8952 " the access discriminant of&",
8953 N
, Entity
(Subtype_Mark
(Indic
)));
8957 end Accessibility_Message
;
8959 -- Start of processing for Resolve_Attribute
8962 -- If error during analysis, no point in continuing, except for array
8963 -- types, where we get better recovery by using unconstrained indexes
8964 -- than nothing at all (see Check_Array_Type).
8967 and then Attr_Id
/= Attribute_First
8968 and then Attr_Id
/= Attribute_Last
8969 and then Attr_Id
/= Attribute_Length
8970 and then Attr_Id
/= Attribute_Range
8975 -- If attribute was universal type, reset to actual type
8977 if Etype
(N
) = Universal_Integer
8978 or else Etype
(N
) = Universal_Real
8983 -- Remaining processing depends on attribute
8991 -- For access attributes, if the prefix denotes an entity, it is
8992 -- interpreted as a name, never as a call. It may be overloaded,
8993 -- in which case resolution uses the profile of the context type.
8994 -- Otherwise prefix must be resolved.
8996 when Attribute_Access
8997 | Attribute_Unchecked_Access
8998 | Attribute_Unrestricted_Access
=>
9002 if Is_Variable
(P
) then
9003 Note_Possible_Modification
(P
, Sure
=> False);
9006 -- The following comes from a query by Adam Beneschan, concerning
9007 -- improper use of universal_access in equality tests involving
9008 -- anonymous access types. Another good reason for 'Ref, but
9009 -- for now disable the test, which breaks several filed tests.
9011 if Ekind
(Typ
) = E_Anonymous_Access_Type
9012 and then Nkind_In
(Parent
(N
), N_Op_Eq
, N_Op_Ne
)
9015 Error_Msg_N
("need unique type to resolve 'Access", N
);
9016 Error_Msg_N
("\qualify attribute with some access type", N
);
9019 if Is_Entity_Name
(P
) then
9020 if Is_Overloaded
(P
) then
9021 Get_First_Interp
(P
, Index
, It
);
9022 while Present
(It
.Nam
) loop
9023 if Type_Conformant
(Designated_Type
(Typ
), It
.Nam
) then
9024 Set_Entity
(P
, It
.Nam
);
9026 -- The prefix is definitely NOT overloaded anymore at
9027 -- this point, so we reset the Is_Overloaded flag to
9028 -- avoid any confusion when reanalyzing the node.
9030 Set_Is_Overloaded
(P
, False);
9031 Set_Is_Overloaded
(N
, False);
9032 Generate_Reference
(Entity
(P
), P
);
9036 Get_Next_Interp
(Index
, It
);
9039 -- If Prefix is a subprogram name, it is frozen by this
9042 -- If it is a type, there is nothing to resolve.
9043 -- If it is an object, complete its resolution.
9045 elsif Is_Overloadable
(Entity
(P
)) then
9047 -- Avoid insertion of freeze actions in spec expression mode
9049 if not In_Spec_Expression
then
9050 Freeze_Before
(N
, Entity
(P
));
9053 elsif Is_Type
(Entity
(P
)) then
9059 Error_Msg_Name_1
:= Aname
;
9061 if not Is_Entity_Name
(P
) then
9064 elsif Is_Overloadable
(Entity
(P
))
9065 and then Is_Abstract_Subprogram
(Entity
(P
))
9067 Error_Msg_F
("prefix of % attribute cannot be abstract", P
);
9068 Set_Etype
(N
, Any_Type
);
9070 elsif Convention
(Entity
(P
)) = Convention_Intrinsic
then
9071 if Ekind
(Entity
(P
)) = E_Enumeration_Literal
then
9073 ("prefix of % attribute cannot be enumeration literal",
9077 ("prefix of % attribute cannot be intrinsic", P
);
9080 Set_Etype
(N
, Any_Type
);
9083 -- Assignments, return statements, components of aggregates,
9084 -- generic instantiations will require convention checks if
9085 -- the type is an access to subprogram. Given that there will
9086 -- also be accessibility checks on those, this is where the
9087 -- checks can eventually be centralized ???
9089 if Ekind_In
(Btyp
, E_Access_Subprogram_Type
,
9090 E_Anonymous_Access_Subprogram_Type
,
9091 E_Access_Protected_Subprogram_Type
,
9092 E_Anonymous_Access_Protected_Subprogram_Type
)
9094 -- Deal with convention mismatch
9096 if Convention
(Designated_Type
(Btyp
)) /=
9097 Convention
(Entity
(P
))
9100 ("subprogram & has wrong convention", P
, Entity
(P
));
9102 ("\does not match convention of access type &",
9105 if not Has_Convention_Pragma
(Btyp
) then
9107 ("\probable missing pragma Convention for &",
9112 Check_Subtype_Conformant
9113 (New_Id
=> Entity
(P
),
9114 Old_Id
=> Designated_Type
(Btyp
),
9118 if Attr_Id
= Attribute_Unchecked_Access
then
9119 Error_Msg_Name_1
:= Aname
;
9121 ("attribute% cannot be applied to a subprogram", P
);
9123 elsif Aname
= Name_Unrestricted_Access
then
9124 null; -- Nothing to check
9126 -- Check the static accessibility rule of 3.10.2(32).
9127 -- This rule also applies within the private part of an
9128 -- instantiation. This rule does not apply to anonymous
9129 -- access-to-subprogram types in access parameters.
9131 elsif Attr_Id
= Attribute_Access
9132 and then not In_Instance_Body
9134 (Ekind
(Btyp
) = E_Access_Subprogram_Type
9135 or else Is_Local_Anonymous_Access
(Btyp
))
9137 and then Subprogram_Access_Level
(Entity
(P
)) >
9138 Type_Access_Level
(Btyp
)
9141 ("subprogram must not be deeper than access type", P
);
9143 -- Check the restriction of 3.10.2(32) that disallows the
9144 -- access attribute within a generic body when the ultimate
9145 -- ancestor of the type of the attribute is declared outside
9146 -- of the generic unit and the subprogram is declared within
9147 -- that generic unit. This includes any such attribute that
9148 -- occurs within the body of a generic unit that is a child
9149 -- of the generic unit where the subprogram is declared.
9151 -- The rule also prohibits applying the attribute when the
9152 -- access type is a generic formal access type (since the
9153 -- level of the actual type is not known). This restriction
9154 -- does not apply when the attribute type is an anonymous
9155 -- access-to-subprogram type. Note that this check was
9156 -- revised by AI-229, because the originally Ada 95 rule
9157 -- was too lax. The original rule only applied when the
9158 -- subprogram was declared within the body of the generic,
9159 -- which allowed the possibility of dangling references).
9160 -- The rule was also too strict in some case, in that it
9161 -- didn't permit the access to be declared in the generic
9162 -- spec, whereas the revised rule does (as long as it's not
9165 -- There are a couple of subtleties of the test for applying
9166 -- the check that are worth noting. First, we only apply it
9167 -- when the levels of the subprogram and access type are the
9168 -- same (the case where the subprogram is statically deeper
9169 -- was applied above, and the case where the type is deeper
9170 -- is always safe). Second, we want the check to apply
9171 -- within nested generic bodies and generic child unit
9172 -- bodies, but not to apply to an attribute that appears in
9173 -- the generic unit's specification. This is done by testing
9174 -- that the attribute's innermost enclosing generic body is
9175 -- not the same as the innermost generic body enclosing the
9176 -- generic unit where the subprogram is declared (we don't
9177 -- want the check to apply when the access attribute is in
9178 -- the spec and there's some other generic body enclosing
9179 -- generic). Finally, there's no point applying the check
9180 -- when within an instance, because any violations will have
9181 -- been caught by the compilation of the generic unit.
9183 -- Note that we relax this check in CodePeer mode for
9184 -- compatibility with legacy code, since CodePeer is an
9185 -- Ada source code analyzer, not a strict compiler.
9186 -- ??? Note that a better approach would be to have a
9187 -- separate switch to relax this rule, and enable this
9188 -- switch in CodePeer mode.
9190 elsif Attr_Id
= Attribute_Access
9191 and then not CodePeer_Mode
9192 and then not In_Instance
9193 and then Present
(Enclosing_Generic_Unit
(Entity
(P
)))
9194 and then Present
(Enclosing_Generic_Body
(N
))
9195 and then Enclosing_Generic_Body
(N
) /=
9196 Enclosing_Generic_Body
9197 (Enclosing_Generic_Unit
(Entity
(P
)))
9198 and then Subprogram_Access_Level
(Entity
(P
)) =
9199 Type_Access_Level
(Btyp
)
9200 and then Ekind
(Btyp
) /=
9201 E_Anonymous_Access_Subprogram_Type
9202 and then Ekind
(Btyp
) /=
9203 E_Anonymous_Access_Protected_Subprogram_Type
9205 -- The attribute type's ultimate ancestor must be
9206 -- declared within the same generic unit as the
9207 -- subprogram is declared. The error message is
9208 -- specialized to say "ancestor" for the case where the
9209 -- access type is not its own ancestor, since saying
9210 -- simply "access type" would be very confusing.
9212 if Enclosing_Generic_Unit
(Entity
(P
)) /=
9213 Enclosing_Generic_Unit
(Root_Type
(Btyp
))
9216 ("''Access attribute not allowed in generic body",
9219 if Root_Type
(Btyp
) = Btyp
then
9222 "access type & is declared outside " &
9223 "generic unit (RM 3.10.2(32))", N
, Btyp
);
9226 ("\because ancestor of " &
9227 "access type & is declared outside " &
9228 "generic unit (RM 3.10.2(32))", N
, Btyp
);
9232 ("\move ''Access to private part, or " &
9233 "(Ada 2005) use anonymous access type instead of &",
9236 -- If the ultimate ancestor of the attribute's type is
9237 -- a formal type, then the attribute is illegal because
9238 -- the actual type might be declared at a higher level.
9239 -- The error message is specialized to say "ancestor"
9240 -- for the case where the access type is not its own
9241 -- ancestor, since saying simply "access type" would be
9244 elsif Is_Generic_Type
(Root_Type
(Btyp
)) then
9245 if Root_Type
(Btyp
) = Btyp
then
9247 ("access type must not be a generic formal type",
9251 ("ancestor access type must not be a generic " &
9258 -- If this is a renaming, an inherited operation, or a
9259 -- subprogram instance, use the original entity. This may make
9260 -- the node type-inconsistent, so this transformation can only
9261 -- be done if the node will not be reanalyzed. In particular,
9262 -- if it is within a default expression, the transformation
9263 -- must be delayed until the default subprogram is created for
9264 -- it, when the enclosing subprogram is frozen.
9266 if Is_Entity_Name
(P
)
9267 and then Is_Overloadable
(Entity
(P
))
9268 and then Present
(Alias
(Entity
(P
)))
9269 and then Expander_Active
9272 New_Occurrence_Of
(Alias
(Entity
(P
)), Sloc
(P
)));
9275 elsif Nkind
(P
) = N_Selected_Component
9276 and then Is_Overloadable
(Entity
(Selector_Name
(P
)))
9278 -- Protected operation. If operation is overloaded, must
9279 -- disambiguate. Prefix that denotes protected object itself
9280 -- is resolved with its own type.
9282 if Attr_Id
= Attribute_Unchecked_Access
then
9283 Error_Msg_Name_1
:= Aname
;
9285 ("attribute% cannot be applied to protected operation", P
);
9288 Resolve
(Prefix
(P
));
9289 Generate_Reference
(Entity
(Selector_Name
(P
)), P
);
9291 elsif Is_Overloaded
(P
) then
9293 -- Use the designated type of the context to disambiguate
9294 -- Note that this was not strictly conformant to Ada 95,
9295 -- but was the implementation adopted by most Ada 95 compilers.
9296 -- The use of the context type to resolve an Access attribute
9297 -- reference is now mandated in AI-235 for Ada 2005.
9300 Index
: Interp_Index
;
9304 Get_First_Interp
(P
, Index
, It
);
9305 while Present
(It
.Typ
) loop
9306 if Covers
(Designated_Type
(Typ
), It
.Typ
) then
9307 Resolve
(P
, It
.Typ
);
9311 Get_Next_Interp
(Index
, It
);
9318 -- X'Access is illegal if X denotes a constant and the access type
9319 -- is access-to-variable. Same for 'Unchecked_Access. The rule
9320 -- does not apply to 'Unrestricted_Access. If the reference is a
9321 -- default-initialized aggregate component for a self-referential
9322 -- type the reference is legal.
9324 if not (Ekind
(Btyp
) = E_Access_Subprogram_Type
9325 or else Ekind
(Btyp
) = E_Anonymous_Access_Subprogram_Type
9326 or else (Is_Record_Type
(Btyp
)
9328 Present
(Corresponding_Remote_Type
(Btyp
)))
9329 or else Ekind
(Btyp
) = E_Access_Protected_Subprogram_Type
9330 or else Ekind
(Btyp
)
9331 = E_Anonymous_Access_Protected_Subprogram_Type
9332 or else Is_Access_Constant
(Btyp
)
9333 or else Is_Variable
(P
)
9334 or else Attr_Id
= Attribute_Unrestricted_Access
)
9336 if Is_Entity_Name
(P
)
9337 and then Is_Type
(Entity
(P
))
9339 -- Legality of a self-reference through an access
9340 -- attribute has been verified in Analyze_Access_Attribute.
9344 elsif Comes_From_Source
(N
) then
9345 Error_Msg_F
("access-to-variable designates constant", P
);
9349 Des_Btyp
:= Designated_Type
(Btyp
);
9351 if Ada_Version
>= Ada_2005
9352 and then Is_Incomplete_Type
(Des_Btyp
)
9354 -- Ada 2005 (AI-412): If the (sub)type is a limited view of an
9355 -- imported entity, and the non-limited view is visible, make
9356 -- use of it. If it is an incomplete subtype, use the base type
9359 if From_With_Type
(Des_Btyp
)
9360 and then Present
(Non_Limited_View
(Des_Btyp
))
9362 Des_Btyp
:= Non_Limited_View
(Des_Btyp
);
9364 elsif Ekind
(Des_Btyp
) = E_Incomplete_Subtype
then
9365 Des_Btyp
:= Etype
(Des_Btyp
);
9369 if (Attr_Id
= Attribute_Access
9371 Attr_Id
= Attribute_Unchecked_Access
)
9372 and then (Ekind
(Btyp
) = E_General_Access_Type
9373 or else Ekind
(Btyp
) = E_Anonymous_Access_Type
)
9375 -- Ada 2005 (AI-230): Check the accessibility of anonymous
9376 -- access types for stand-alone objects, record and array
9377 -- components, and return objects. For a component definition
9378 -- the level is the same of the enclosing composite type.
9380 if Ada_Version
>= Ada_2005
9381 and then (Is_Local_Anonymous_Access
(Btyp
)
9383 -- Handle cases where Btyp is the anonymous access
9384 -- type of an Ada 2012 stand-alone object.
9386 or else Nkind
(Associated_Node_For_Itype
(Btyp
)) =
9387 N_Object_Declaration
)
9389 Object_Access_Level
(P
) > Deepest_Type_Access_Level
(Btyp
)
9390 and then Attr_Id
= Attribute_Access
9392 -- In an instance, this is a runtime check, but one we
9393 -- know will fail, so generate an appropriate warning.
9395 if In_Instance_Body
then
9397 ("??non-local pointer cannot point to local object", P
);
9399 ("\??Program_Error will be raised at run time", P
);
9401 Make_Raise_Program_Error
(Loc
,
9402 Reason
=> PE_Accessibility_Check_Failed
));
9407 ("non-local pointer cannot point to local object", P
);
9411 if Is_Dependent_Component_Of_Mutable_Object
(P
) then
9413 ("illegal attribute for discriminant-dependent component",
9417 -- Check static matching rule of 3.10.2(27). Nominal subtype
9418 -- of the prefix must statically match the designated type.
9420 Nom_Subt
:= Etype
(P
);
9422 if Is_Constr_Subt_For_U_Nominal
(Nom_Subt
) then
9423 Nom_Subt
:= Base_Type
(Nom_Subt
);
9426 if Is_Tagged_Type
(Designated_Type
(Typ
)) then
9428 -- If the attribute is in the context of an access
9429 -- parameter, then the prefix is allowed to be of the
9430 -- class-wide type (by AI-127).
9432 if Ekind
(Typ
) = E_Anonymous_Access_Type
then
9433 if not Covers
(Designated_Type
(Typ
), Nom_Subt
)
9434 and then not Covers
(Nom_Subt
, Designated_Type
(Typ
))
9440 Desig
:= Designated_Type
(Typ
);
9442 if Is_Class_Wide_Type
(Desig
) then
9443 Desig
:= Etype
(Desig
);
9446 if Is_Anonymous_Tagged_Base
(Nom_Subt
, Desig
) then
9451 ("type of prefix: & not compatible",
9454 ("\with &, the expected designated type",
9455 P
, Designated_Type
(Typ
));
9460 elsif not Covers
(Designated_Type
(Typ
), Nom_Subt
)
9462 (not Is_Class_Wide_Type
(Designated_Type
(Typ
))
9463 and then Is_Class_Wide_Type
(Nom_Subt
))
9466 ("type of prefix: & is not covered", P
, Nom_Subt
);
9468 ("\by &, the expected designated type" &
9469 " (RM 3.10.2 (27))", P
, Designated_Type
(Typ
));
9472 if Is_Class_Wide_Type
(Designated_Type
(Typ
))
9473 and then Has_Discriminants
(Etype
(Designated_Type
(Typ
)))
9474 and then Is_Constrained
(Etype
(Designated_Type
(Typ
)))
9475 and then Designated_Type
(Typ
) /= Nom_Subt
9477 Apply_Discriminant_Check
9478 (N
, Etype
(Designated_Type
(Typ
)));
9481 -- Ada 2005 (AI-363): Require static matching when designated
9482 -- type has discriminants and a constrained partial view, since
9483 -- in general objects of such types are mutable, so we can't
9484 -- allow the access value to designate a constrained object
9485 -- (because access values must be assumed to designate mutable
9486 -- objects when designated type does not impose a constraint).
9488 elsif Subtypes_Statically_Match
(Des_Btyp
, Nom_Subt
) then
9491 elsif Has_Discriminants
(Designated_Type
(Typ
))
9492 and then not Is_Constrained
(Des_Btyp
)
9494 (Ada_Version
< Ada_2005
9496 not Effectively_Has_Constrained_Partial_View
9497 (Typ
=> Designated_Type
(Base_Type
(Typ
)),
9498 Scop
=> Current_Scope
))
9504 ("object subtype must statically match "
9505 & "designated subtype", P
);
9507 if Is_Entity_Name
(P
)
9508 and then Is_Array_Type
(Designated_Type
(Typ
))
9511 D
: constant Node_Id
:= Declaration_Node
(Entity
(P
));
9514 ("aliased object has explicit bounds??", D
);
9516 ("\declare without bounds (and with explicit "
9517 & "initialization)??", D
);
9519 ("\for use with unconstrained access??", D
);
9524 -- Check the static accessibility rule of 3.10.2(28). Note that
9525 -- this check is not performed for the case of an anonymous
9526 -- access type, since the access attribute is always legal
9527 -- in such a context.
9529 if Attr_Id
/= Attribute_Unchecked_Access
9531 Object_Access_Level
(P
) > Deepest_Type_Access_Level
(Btyp
)
9532 and then Ekind
(Btyp
) = E_General_Access_Type
9534 Accessibility_Message
;
9539 if Ekind_In
(Btyp
, E_Access_Protected_Subprogram_Type
,
9540 E_Anonymous_Access_Protected_Subprogram_Type
)
9542 if Is_Entity_Name
(P
)
9543 and then not Is_Protected_Type
(Scope
(Entity
(P
)))
9545 Error_Msg_F
("context requires a protected subprogram", P
);
9547 -- Check accessibility of protected object against that of the
9548 -- access type, but only on user code, because the expander
9549 -- creates access references for handlers. If the context is an
9550 -- anonymous_access_to_protected, there are no accessibility
9551 -- checks either. Omit check entirely for Unrestricted_Access.
9553 elsif Object_Access_Level
(P
) > Deepest_Type_Access_Level
(Btyp
)
9554 and then Comes_From_Source
(N
)
9555 and then Ekind
(Btyp
) = E_Access_Protected_Subprogram_Type
9556 and then Attr_Id
/= Attribute_Unrestricted_Access
9558 Accessibility_Message
;
9561 -- AI05-0225: If the context is not an access to protected
9562 -- function, the prefix must be a variable, given that it may
9563 -- be used subsequently in a protected call.
9565 elsif Nkind
(P
) = N_Selected_Component
9566 and then not Is_Variable
(Prefix
(P
))
9567 and then Ekind
(Entity
(Selector_Name
(P
))) /= E_Function
9570 ("target object of access to protected procedure "
9571 & "must be variable", N
);
9573 elsif Is_Entity_Name
(P
) then
9574 Check_Internal_Protected_Use
(N
, Entity
(P
));
9577 elsif Ekind_In
(Btyp
, E_Access_Subprogram_Type
,
9578 E_Anonymous_Access_Subprogram_Type
)
9579 and then Ekind
(Etype
(N
)) = E_Access_Protected_Subprogram_Type
9581 Error_Msg_F
("context requires a non-protected subprogram", P
);
9584 -- The context cannot be a pool-specific type, but this is a
9585 -- legality rule, not a resolution rule, so it must be checked
9586 -- separately, after possibly disambiguation (see AI-245).
9588 if Ekind
(Btyp
) = E_Access_Type
9589 and then Attr_Id
/= Attribute_Unrestricted_Access
9591 Wrong_Type
(N
, Typ
);
9594 -- The context may be a constrained access type (however ill-
9595 -- advised such subtypes might be) so in order to generate a
9596 -- constraint check when needed set the type of the attribute
9597 -- reference to the base type of the context.
9599 Set_Etype
(N
, Btyp
);
9601 -- Check for incorrect atomic/volatile reference (RM C.6(12))
9603 if Attr_Id
/= Attribute_Unrestricted_Access
then
9604 if Is_Atomic_Object
(P
)
9605 and then not Is_Atomic
(Designated_Type
(Typ
))
9608 ("access to atomic object cannot yield access-to-" &
9609 "non-atomic type", P
);
9611 elsif Is_Volatile_Object
(P
)
9612 and then not Is_Volatile
(Designated_Type
(Typ
))
9615 ("access to volatile object cannot yield access-to-" &
9616 "non-volatile type", P
);
9620 if Is_Entity_Name
(P
) then
9621 Set_Address_Taken
(Entity
(P
));
9623 end Access_Attribute
;
9629 -- Deal with resolving the type for Address attribute, overloading
9630 -- is not permitted here, since there is no context to resolve it.
9632 when Attribute_Address | Attribute_Code_Address
=>
9633 Address_Attribute
: begin
9635 -- To be safe, assume that if the address of a variable is taken,
9636 -- it may be modified via this address, so note modification.
9638 if Is_Variable
(P
) then
9639 Note_Possible_Modification
(P
, Sure
=> False);
9642 if Nkind
(P
) in N_Subexpr
9643 and then Is_Overloaded
(P
)
9645 Get_First_Interp
(P
, Index
, It
);
9646 Get_Next_Interp
(Index
, It
);
9648 if Present
(It
.Nam
) then
9649 Error_Msg_Name_1
:= Aname
;
9651 ("prefix of % attribute cannot be overloaded", P
);
9655 if not Is_Entity_Name
(P
)
9656 or else not Is_Overloadable
(Entity
(P
))
9658 if not Is_Task_Type
(Etype
(P
))
9659 or else Nkind
(P
) = N_Explicit_Dereference
9665 -- If this is the name of a derived subprogram, or that of a
9666 -- generic actual, the address is that of the original entity.
9668 if Is_Entity_Name
(P
)
9669 and then Is_Overloadable
(Entity
(P
))
9670 and then Present
(Alias
(Entity
(P
)))
9673 New_Occurrence_Of
(Alias
(Entity
(P
)), Sloc
(P
)));
9676 if Is_Entity_Name
(P
) then
9677 Set_Address_Taken
(Entity
(P
));
9680 if Nkind
(P
) = N_Slice
then
9682 -- Arr (X .. Y)'address is identical to Arr (X)'address,
9683 -- even if the array is packed and the slice itself is not
9684 -- addressable. Transform the prefix into an indexed component.
9686 -- Note that the transformation is safe only if we know that
9687 -- the slice is non-null. That is because a null slice can have
9688 -- an out of bounds index value.
9690 -- Right now, gigi blows up if given 'Address on a slice as a
9691 -- result of some incorrect freeze nodes generated by the front
9692 -- end, and this covers up that bug in one case, but the bug is
9693 -- likely still there in the cases not handled by this code ???
9695 -- It's not clear what 'Address *should* return for a null
9696 -- slice with out of bounds indexes, this might be worth an ARG
9699 -- One approach would be to do a length check unconditionally,
9700 -- and then do the transformation below unconditionally, but
9701 -- analyze with checks off, avoiding the problem of the out of
9702 -- bounds index. This approach would interpret the address of
9703 -- an out of bounds null slice as being the address where the
9704 -- array element would be if there was one, which is probably
9705 -- as reasonable an interpretation as any ???
9708 Loc
: constant Source_Ptr
:= Sloc
(P
);
9709 D
: constant Node_Id
:= Discrete_Range
(P
);
9713 if Is_Entity_Name
(D
)
9716 (Type_Low_Bound
(Entity
(D
)),
9717 Type_High_Bound
(Entity
(D
)))
9720 Make_Attribute_Reference
(Loc
,
9721 Prefix
=> (New_Occurrence_Of
(Entity
(D
), Loc
)),
9722 Attribute_Name
=> Name_First
);
9724 elsif Nkind
(D
) = N_Range
9725 and then Not_Null_Range
(Low_Bound
(D
), High_Bound
(D
))
9727 Lo
:= Low_Bound
(D
);
9733 if Present
(Lo
) then
9735 Make_Indexed_Component
(Loc
,
9736 Prefix
=> Relocate_Node
(Prefix
(P
)),
9737 Expressions
=> New_List
(Lo
)));
9739 Analyze_And_Resolve
(P
);
9743 end Address_Attribute
;
9749 -- Prefix of the AST_Entry attribute is an entry name which must
9750 -- not be resolved, since this is definitely not an entry call.
9752 when Attribute_AST_Entry
=>
9759 -- Prefix of Body_Version attribute can be a subprogram name which
9760 -- must not be resolved, since this is not a call.
9762 when Attribute_Body_Version
=>
9769 -- Prefix of Caller attribute is an entry name which must not
9770 -- be resolved, since this is definitely not an entry call.
9772 when Attribute_Caller
=>
9779 -- Shares processing with Address attribute
9785 -- If the prefix of the Count attribute is an entry name it must not
9786 -- be resolved, since this is definitely not an entry call. However,
9787 -- if it is an element of an entry family, the index itself may
9788 -- have to be resolved because it can be a general expression.
9790 when Attribute_Count
=>
9791 if Nkind
(P
) = N_Indexed_Component
9792 and then Is_Entity_Name
(Prefix
(P
))
9795 Indx
: constant Node_Id
:= First
(Expressions
(P
));
9796 Fam
: constant Entity_Id
:= Entity
(Prefix
(P
));
9798 Resolve
(Indx
, Entry_Index_Type
(Fam
));
9799 Apply_Range_Check
(Indx
, Entry_Index_Type
(Fam
));
9807 -- Prefix of the Elaborated attribute is a subprogram name which
9808 -- must not be resolved, since this is definitely not a call. Note
9809 -- that it is a library unit, so it cannot be overloaded here.
9811 when Attribute_Elaborated
=>
9818 -- Prefix of Enabled attribute is a check name, which must be treated
9819 -- specially and not touched by Resolve.
9821 when Attribute_Enabled
=>
9824 --------------------
9825 -- Mechanism_Code --
9826 --------------------
9828 -- Prefix of the Mechanism_Code attribute is a function name
9829 -- which must not be resolved. Should we check for overloaded ???
9831 when Attribute_Mechanism_Code
=>
9838 -- Most processing is done in sem_dist, after determining the
9839 -- context type. Node is rewritten as a conversion to a runtime call.
9841 when Attribute_Partition_ID
=>
9842 Process_Partition_Id
(N
);
9849 when Attribute_Pool_Address
=>
9856 -- We replace the Range attribute node with a range expression whose
9857 -- bounds are the 'First and 'Last attributes applied to the same
9858 -- prefix. The reason that we do this transformation here instead of
9859 -- in the expander is that it simplifies other parts of the semantic
9860 -- analysis which assume that the Range has been replaced; thus it
9861 -- must be done even when in semantic-only mode (note that the RM
9862 -- specifically mentions this equivalence, we take care that the
9863 -- prefix is only evaluated once).
9865 when Attribute_Range
=> Range_Attribute
:
9872 if not Is_Entity_Name
(P
)
9873 or else not Is_Type
(Entity
(P
))
9878 Dims
:= Expressions
(N
);
9881 Make_Attribute_Reference
(Loc
,
9883 Duplicate_Subexpr
(P
, Name_Req
=> True),
9884 Attribute_Name
=> Name_Last
,
9885 Expressions
=> Dims
);
9888 Make_Attribute_Reference
(Loc
,
9890 Attribute_Name
=> Name_First
,
9891 Expressions
=> (Dims
));
9893 -- Do not share the dimension indicator, if present. Even
9894 -- though it is a static constant, its source location
9895 -- may be modified when printing expanded code and node
9896 -- sharing will lead to chaos in Sprint.
9898 if Present
(Dims
) then
9899 Set_Expressions
(LB
,
9900 New_List
(New_Copy_Tree
(First
(Dims
))));
9903 -- If the original was marked as Must_Not_Freeze (see code
9904 -- in Sem_Ch3.Make_Index), then make sure the rewriting
9905 -- does not freeze either.
9907 if Must_Not_Freeze
(N
) then
9908 Set_Must_Not_Freeze
(HB
);
9909 Set_Must_Not_Freeze
(LB
);
9910 Set_Must_Not_Freeze
(Prefix
(HB
));
9911 Set_Must_Not_Freeze
(Prefix
(LB
));
9914 if Raises_Constraint_Error
(Prefix
(N
)) then
9916 -- Preserve Sloc of prefix in the new bounds, so that
9917 -- the posted warning can be removed if we are within
9918 -- unreachable code.
9920 Set_Sloc
(LB
, Sloc
(Prefix
(N
)));
9921 Set_Sloc
(HB
, Sloc
(Prefix
(N
)));
9924 Rewrite
(N
, Make_Range
(Loc
, LB
, HB
));
9925 Analyze_And_Resolve
(N
, Typ
);
9927 -- Ensure that the expanded range does not have side effects
9929 Force_Evaluation
(LB
);
9930 Force_Evaluation
(HB
);
9932 -- Normally after resolving attribute nodes, Eval_Attribute
9933 -- is called to do any possible static evaluation of the node.
9934 -- However, here since the Range attribute has just been
9935 -- transformed into a range expression it is no longer an
9936 -- attribute node and therefore the call needs to be avoided
9937 -- and is accomplished by simply returning from the procedure.
9940 end Range_Attribute
;
9946 -- We will only come here during the prescan of a spec expression
9947 -- containing a Result attribute. In that case the proper Etype has
9948 -- already been set, and nothing more needs to be done here.
9950 when Attribute_Result
=>
9957 -- Prefix must not be resolved in this case, since it is not a
9958 -- real entity reference. No action of any kind is require!
9960 when Attribute_UET_Address
=>
9963 ----------------------
9964 -- Unchecked_Access --
9965 ----------------------
9967 -- Processing is shared with Access
9969 -------------------------
9970 -- Unrestricted_Access --
9971 -------------------------
9973 -- Processing is shared with Access
9979 -- Apply range check. Note that we did not do this during the
9980 -- analysis phase, since we wanted Eval_Attribute to have a
9981 -- chance at finding an illegal out of range value.
9983 when Attribute_Val
=>
9985 -- Note that we do our own Eval_Attribute call here rather than
9986 -- use the common one, because we need to do processing after
9987 -- the call, as per above comment.
9991 -- Eval_Attribute may replace the node with a raise CE, or
9992 -- fold it to a constant. Obviously we only apply a scalar
9993 -- range check if this did not happen!
9995 if Nkind
(N
) = N_Attribute_Reference
9996 and then Attribute_Name
(N
) = Name_Val
9998 Apply_Scalar_Range_Check
(First
(Expressions
(N
)), Btyp
);
10007 -- Prefix of Version attribute can be a subprogram name which
10008 -- must not be resolved, since this is not a call.
10010 when Attribute_Version
=>
10013 ----------------------
10014 -- Other Attributes --
10015 ----------------------
10017 -- For other attributes, resolve prefix unless it is a type. If
10018 -- the attribute reference itself is a type name ('Base and 'Class)
10019 -- then this is only legal within a task or protected record.
10022 if not Is_Entity_Name
(P
)
10023 or else not Is_Type
(Entity
(P
))
10028 -- If the attribute reference itself is a type name ('Base,
10029 -- 'Class) then this is only legal within a task or protected
10030 -- record. What is this all about ???
10032 if Is_Entity_Name
(N
)
10033 and then Is_Type
(Entity
(N
))
10035 if Is_Concurrent_Type
(Entity
(N
))
10036 and then In_Open_Scopes
(Entity
(P
))
10041 ("invalid use of subtype name in expression or call", N
);
10045 -- For attributes whose argument may be a string, complete
10046 -- resolution of argument now. This avoids premature expansion
10047 -- (and the creation of transient scopes) before the attribute
10048 -- reference is resolved.
10051 when Attribute_Value
=>
10052 Resolve
(First
(Expressions
(N
)), Standard_String
);
10054 when Attribute_Wide_Value
=>
10055 Resolve
(First
(Expressions
(N
)), Standard_Wide_String
);
10057 when Attribute_Wide_Wide_Value
=>
10058 Resolve
(First
(Expressions
(N
)), Standard_Wide_Wide_String
);
10060 when others => null;
10063 -- If the prefix of the attribute is a class-wide type then it
10064 -- will be expanded into a dispatching call to a predefined
10065 -- primitive. Therefore we must check for potential violation
10066 -- of such restriction.
10068 if Is_Class_Wide_Type
(Etype
(P
)) then
10069 Check_Restriction
(No_Dispatching_Calls
, N
);
10073 -- Normally the Freezing is done by Resolve but sometimes the Prefix
10074 -- is not resolved, in which case the freezing must be done now.
10076 Freeze_Expression
(P
);
10078 -- Finally perform static evaluation on the attribute reference
10080 Analyze_Dimension
(N
);
10081 Eval_Attribute
(N
);
10082 end Resolve_Attribute
;
10084 --------------------------------
10085 -- Stream_Attribute_Available --
10086 --------------------------------
10088 function Stream_Attribute_Available
10090 Nam
: TSS_Name_Type
;
10091 Partial_View
: Node_Id
:= Empty
) return Boolean
10093 Etyp
: Entity_Id
:= Typ
;
10095 -- Start of processing for Stream_Attribute_Available
10098 -- We need some comments in this body ???
10100 if Has_Stream_Attribute_Definition
(Typ
, Nam
) then
10104 if Is_Class_Wide_Type
(Typ
) then
10105 return not Is_Limited_Type
(Typ
)
10106 or else Stream_Attribute_Available
(Etype
(Typ
), Nam
);
10109 if Nam
= TSS_Stream_Input
10110 and then Is_Abstract_Type
(Typ
)
10111 and then not Is_Class_Wide_Type
(Typ
)
10116 if not (Is_Limited_Type
(Typ
)
10117 or else (Present
(Partial_View
)
10118 and then Is_Limited_Type
(Partial_View
)))
10123 -- In Ada 2005, Input can invoke Read, and Output can invoke Write
10125 if Nam
= TSS_Stream_Input
10126 and then Ada_Version
>= Ada_2005
10127 and then Stream_Attribute_Available
(Etyp
, TSS_Stream_Read
)
10131 elsif Nam
= TSS_Stream_Output
10132 and then Ada_Version
>= Ada_2005
10133 and then Stream_Attribute_Available
(Etyp
, TSS_Stream_Write
)
10138 -- Case of Read and Write: check for attribute definition clause that
10139 -- applies to an ancestor type.
10141 while Etype
(Etyp
) /= Etyp
loop
10142 Etyp
:= Etype
(Etyp
);
10144 if Has_Stream_Attribute_Definition
(Etyp
, Nam
) then
10149 if Ada_Version
< Ada_2005
then
10151 -- In Ada 95 mode, also consider a non-visible definition
10154 Btyp
: constant Entity_Id
:= Implementation_Base_Type
(Typ
);
10157 and then Stream_Attribute_Available
10158 (Btyp
, Nam
, Partial_View
=> Typ
);
10163 end Stream_Attribute_Available
;