1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, 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 Aspects; use Aspects;
29 with Atree; use Atree;
30 with Casing; use Casing;
31 with Checks; use Checks;
32 with Debug; use Debug;
33 with Einfo; use Einfo;
34 with Elists; use Elists;
35 with Errout; use Errout;
37 with Exp_Dist; use Exp_Dist;
38 with Exp_Util; use Exp_Util;
39 with Expander; use Expander;
40 with Freeze; use Freeze;
41 with Gnatvsn; use Gnatvsn;
42 with Itypes; use Itypes;
44 with Lib.Xref; use Lib.Xref;
45 with Nlists; use Nlists;
46 with Nmake; use Nmake;
48 with Restrict; use Restrict;
49 with Rident; use Rident;
50 with Rtsfind; use Rtsfind;
53 with Sem_Aux; use Sem_Aux;
54 with Sem_Cat; use Sem_Cat;
55 with Sem_Ch6; use Sem_Ch6;
56 with Sem_Ch8; use Sem_Ch8;
57 with Sem_Ch10; use Sem_Ch10;
58 with Sem_Dim; use Sem_Dim;
59 with Sem_Dist; use Sem_Dist;
60 with Sem_Elab; use Sem_Elab;
61 with Sem_Elim; use Sem_Elim;
62 with Sem_Eval; use Sem_Eval;
63 with Sem_Prag; use Sem_Prag;
64 with Sem_Res; use Sem_Res;
65 with Sem_Type; use Sem_Type;
66 with Sem_Util; use Sem_Util;
68 with Stand; use Stand;
69 with Sinfo; use Sinfo;
70 with Sinput; use Sinput;
72 with Stringt; use Stringt;
74 with Stylesw; use Stylesw;
75 with Targparm; use Targparm;
76 with Ttypes; use Ttypes;
77 with Tbuild; use Tbuild;
78 with Uintp; use Uintp;
79 with Uname; use Uname;
80 with Urealp; use Urealp;
82 with System.CRC32; use System.CRC32;
84 package body Sem_Attr is
86 True_Value : constant Uint := Uint_1;
87 False_Value : constant Uint := Uint_0;
88 -- Synonyms to be used when these constants are used as Boolean values
90 Bad_Attribute : exception;
91 -- Exception raised if an error is detected during attribute processing,
92 -- used so that we can abandon the processing so we don't run into
93 -- trouble with cascaded errors.
95 -- The following array is the list of attributes defined in the Ada 83 RM.
96 -- In Ada 83 mode, these are the only recognized attributes. In other Ada
97 -- modes all these attributes are recognized, even if removed in Ada 95.
99 Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
102 Attribute_Alignment |
105 Attribute_Constrained |
112 Attribute_First_Bit |
118 Attribute_Leading_Part |
120 Attribute_Machine_Emax |
121 Attribute_Machine_Emin |
122 Attribute_Machine_Mantissa |
123 Attribute_Machine_Overflows |
124 Attribute_Machine_Radix |
125 Attribute_Machine_Rounds |
131 Attribute_Safe_Emax |
132 Attribute_Safe_Large |
133 Attribute_Safe_Small |
136 Attribute_Storage_Size |
138 Attribute_Terminated |
141 Attribute_Width => True,
144 -- The following array is the list of attributes defined in the Ada 2005
145 -- RM which are not defined in Ada 95. These are recognized in Ada 95 mode,
146 -- but in Ada 95 they are considered to be implementation defined.
148 Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'(
149 Attribute_Machine_Rounding |
152 Attribute_Stream_Size |
153 Attribute_Wide_Wide_Width => True,
156 -- The following array is the list of attributes defined in the Ada 2012
157 -- RM which are not defined in Ada 2005. These are recognized in Ada 95
158 -- and Ada 2005 modes, but are considered to be implementation defined.
160 Attribute_12 : constant Attribute_Class_Array := Attribute_Class_Array'(
161 Attribute_First_Valid |
162 Attribute_Has_Same_Storage |
163 Attribute_Last_Valid |
164 Attribute_Max_Alignment_For_Allocation => True,
167 -- The following array contains all attributes that imply a modification
168 -- of their prefixes or result in an access value. Such prefixes can be
169 -- considered as lvalues.
171 Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array :=
172 Attribute_Class_Array'(
177 Attribute_Unchecked_Access |
178 Attribute_Unrestricted_Access => True,
181 -----------------------
182 -- Local_Subprograms --
183 -----------------------
185 procedure Eval_Attribute (N : Node_Id);
186 -- Performs compile time evaluation of attributes where possible, leaving
187 -- the Is_Static_Expression/Raises_Constraint_Error flags appropriately
188 -- set, and replacing the node with a literal node if the value can be
189 -- computed at compile time. All static attribute references are folded,
190 -- as well as a number of cases of non-static attributes that can always
191 -- be computed at compile time (e.g. floating-point model attributes that
192 -- are applied to non-static subtypes). Of course in such cases, the
193 -- Is_Static_Expression flag will not be set on the resulting literal.
194 -- Note that the only required action of this procedure is to catch the
195 -- static expression cases as described in the RM. Folding of other cases
196 -- is done where convenient, but some additional non-static folding is in
197 -- Expand_N_Attribute_Reference in cases where this is more convenient.
199 function Is_Anonymous_Tagged_Base
201 Typ : Entity_Id) return Boolean;
202 -- For derived tagged types that constrain parent discriminants we build
203 -- an anonymous unconstrained base type. We need to recognize the relation
204 -- between the two when analyzing an access attribute for a constrained
205 -- component, before the full declaration for Typ has been analyzed, and
206 -- where therefore the prefix of the attribute does not match the enclosing
209 procedure Set_Boolean_Result (N : Node_Id; B : Boolean);
210 -- Rewrites node N with an occurrence of either Standard_False or
211 -- Standard_True, depending on the value of the parameter B. The
212 -- result is marked as a static expression.
214 function Statically_Denotes_Object (N : Node_Id) return Boolean;
215 -- Predicate used to check the legality of the prefix to 'Loop_Entry and
216 -- 'Old, when the prefix is not an entity name. Current RM specfies that
217 -- the prefix must be a direct or expanded name, but it has been proposed
218 -- that the prefix be allowed to be a selected component that does not
219 -- depend on a discriminant, or an indexed component with static indices.
220 -- Current code for this predicate implements this more permissive
223 -----------------------
224 -- Analyze_Attribute --
225 -----------------------
227 procedure Analyze_Attribute (N : Node_Id) is
228 Loc : constant Source_Ptr := Sloc (N);
229 Aname : constant Name_Id := Attribute_Name (N);
230 P : constant Node_Id := Prefix (N);
231 Exprs : constant List_Id := Expressions (N);
232 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
236 P_Type : Entity_Id := Empty;
237 -- Type of prefix after analysis
239 P_Base_Type : Entity_Id := Empty;
240 -- Base type of prefix after analysis
242 -----------------------
243 -- Local Subprograms --
244 -----------------------
246 procedure Address_Checks;
247 -- Semantic checks for valid use of Address attribute. This was made
248 -- a separate routine with the idea of using it for unrestricted access
249 -- which seems like it should follow the same rules, but that turned
250 -- out to be impractical. So now this is only used for Address.
252 procedure Analyze_Access_Attribute;
253 -- Used for Access, Unchecked_Access, Unrestricted_Access attributes.
254 -- Internally, Id distinguishes which of the three cases is involved.
256 procedure Analyze_Attribute_Old_Result
257 (Legal : out Boolean;
258 Spec_Id : out Entity_Id);
259 -- Common processing for attributes 'Old and 'Result. The routine checks
260 -- that the attribute appears in a postcondition-like aspect or pragma
261 -- associated with a suitable subprogram or a body. Flag Legal is set
262 -- when the above criteria are met. Spec_Id denotes the entity of the
263 -- subprogram [body] or Empty if the attribute is illegal.
265 procedure Analyze_Image_Attribute (Str_Typ : Entity_Id);
266 -- Common processing for attributes 'Img, 'Image, 'Wide_Image, and
267 -- 'Wide_Wide_Image. The routine checks that the prefix is valid and
268 -- sets the type of the attribute to the one specified by Str_Typ (e.g.
269 -- Standard_String for 'Image and Standard_Wide_String for 'Wide_Image).
271 procedure Bad_Attribute_For_Predicate;
272 -- Output error message for use of a predicate (First, Last, Range) not
273 -- allowed with a type that has predicates. If the type is a generic
274 -- actual, then the message is a warning, and we generate code to raise
275 -- program error with an appropriate reason. No error message is given
276 -- for internally generated uses of the attributes. This legality rule
277 -- only applies to scalar types.
279 procedure Check_Array_Or_Scalar_Type;
280 -- Common procedure used by First, Last, Range attribute to check
281 -- that the prefix is a constrained array or scalar type, or a name
282 -- of an array object, and that an argument appears only if appropriate
283 -- (i.e. only in the array case).
285 procedure Check_Array_Type;
286 -- Common semantic checks for all array attributes. Checks that the
287 -- prefix is a constrained array type or the name of an array object.
288 -- The error message for non-arrays is specialized appropriately.
290 procedure Check_Asm_Attribute;
291 -- Common semantic checks for Asm_Input and Asm_Output attributes
293 procedure Check_Component;
294 -- Common processing for Bit_Position, First_Bit, Last_Bit, and
295 -- Position. Checks prefix is an appropriate selected component.
297 procedure Check_Decimal_Fixed_Point_Type;
298 -- Check that prefix of attribute N is a decimal fixed-point type
300 procedure Check_Dereference;
301 -- If the prefix of attribute is an object of an access type, then
302 -- introduce an explicit dereference, and adjust P_Type accordingly.
304 procedure Check_Discrete_Type;
305 -- Verify that prefix of attribute N is a discrete type
308 -- Check that no attribute arguments are present
310 procedure Check_Either_E0_Or_E1;
311 -- Check that there are zero or one attribute arguments present
314 -- Check that exactly one attribute argument is present
317 -- Check that two attribute arguments are present
319 procedure Check_Enum_Image;
320 -- If the prefix type of 'Image is an enumeration type, set all its
321 -- literals as referenced, since the image function could possibly end
322 -- up referencing any of the literals indirectly. Same for Enum_Val.
323 -- Set the flag only if the reference is in the main code unit. Same
324 -- restriction when resolving 'Value; otherwise an improperly set
325 -- reference when analyzing an inlined body will lose a proper
326 -- warning on a useless with_clause.
328 procedure Check_First_Last_Valid;
329 -- Perform all checks for First_Valid and Last_Valid attributes
331 procedure Check_Fixed_Point_Type;
332 -- Verify that prefix of attribute N is a fixed type
334 procedure Check_Fixed_Point_Type_0;
335 -- Verify that prefix of attribute N is a fixed type and that
336 -- no attribute expressions are present.
338 procedure Check_Floating_Point_Type;
339 -- Verify that prefix of attribute N is a float type
341 procedure Check_Floating_Point_Type_0;
342 -- Verify that prefix of attribute N is a float type and that
343 -- no attribute expressions are present.
345 procedure Check_Floating_Point_Type_1;
346 -- Verify that prefix of attribute N is a float type and that
347 -- exactly one attribute expression is present.
349 procedure Check_Floating_Point_Type_2;
350 -- Verify that prefix of attribute N is a float type and that
351 -- two attribute expressions are present
353 procedure Check_SPARK_05_Restriction_On_Attribute;
354 -- Issue an error in formal mode because attribute N is allowed
356 procedure Check_Integer_Type;
357 -- Verify that prefix of attribute N is an integer type
359 procedure Check_Modular_Integer_Type;
360 -- Verify that prefix of attribute N is a modular integer type
362 procedure Check_Not_CPP_Type;
363 -- Check that P (the prefix of the attribute) is not an CPP type
364 -- for which no Ada predefined primitive is available.
366 procedure Check_Not_Incomplete_Type;
367 -- Check that P (the prefix of the attribute) is not an incomplete
368 -- type or a private type for which no full view has been given.
370 procedure Check_Object_Reference (P : Node_Id);
371 -- Check that P is an object reference
373 procedure Check_PolyORB_Attribute;
374 -- Validity checking for PolyORB/DSA attribute
376 procedure Check_Program_Unit;
377 -- Verify that prefix of attribute N is a program unit
379 procedure Check_Real_Type;
380 -- Verify that prefix of attribute N is fixed or float type
382 procedure Check_Scalar_Type;
383 -- Verify that prefix of attribute N is a scalar type
385 procedure Check_Standard_Prefix;
386 -- Verify that prefix of attribute N is package Standard. Also checks
387 -- that there are no arguments.
389 procedure Check_Stream_Attribute (Nam : TSS_Name_Type);
390 -- Validity checking for stream attribute. Nam is the TSS name of the
391 -- corresponding possible defined attribute function (e.g. for the
392 -- Read attribute, Nam will be TSS_Stream_Read).
394 procedure Check_System_Prefix;
395 -- Verify that prefix of attribute N is package System
397 procedure Check_Task_Prefix;
398 -- Verify that prefix of attribute N is a task or task type
400 procedure Check_Type;
401 -- Verify that the prefix of attribute N is a type
403 procedure Check_Unit_Name (Nod : Node_Id);
404 -- Check that Nod is of the form of a library unit name, i.e that
405 -- it is an identifier, or a selected component whose prefix is
406 -- itself of the form of a library unit name. Note that this is
407 -- quite different from Check_Program_Unit, since it only checks
408 -- the syntactic form of the name, not the semantic identity. This
409 -- is because it is used with attributes (Elab_Body, Elab_Spec and
410 -- Elaborated) which can refer to non-visible unit.
412 procedure Error_Attr (Msg : String; Error_Node : Node_Id);
413 pragma No_Return (Error_Attr);
414 procedure Error_Attr;
415 pragma No_Return (Error_Attr);
416 -- Posts error using Error_Msg_N at given node, sets type of attribute
417 -- node to Any_Type, and then raises Bad_Attribute to avoid any further
418 -- semantic processing. The message typically contains a % insertion
419 -- character which is replaced by the attribute name. The call with
420 -- no arguments is used when the caller has already generated the
421 -- required error messages.
423 procedure Error_Attr_P (Msg : String);
424 pragma No_Return (Error_Attr_P);
425 -- Like Error_Attr, but error is posted at the start of the prefix
427 procedure Legal_Formal_Attribute;
428 -- Common processing for attributes Definite and Has_Discriminants.
429 -- Checks that prefix is generic indefinite formal type.
431 procedure Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements;
432 -- Common processing for attributes Max_Alignment_For_Allocation and
433 -- Max_Size_In_Storage_Elements.
436 -- Common processing for attributes Max and Min
438 procedure Standard_Attribute (Val : Int);
439 -- Used to process attributes whose prefix is package Standard which
440 -- yield values of type Universal_Integer. The attribute reference
441 -- node is rewritten with an integer literal of the given value which
442 -- is marked as static.
444 procedure Uneval_Old_Msg;
445 -- Called when Loop_Entry or Old is used in a potentially unevaluated
446 -- expression. Generates appropriate message or warning depending on
447 -- the setting of Opt.Uneval_Old (or flags in an N_Aspect_Specification
448 -- node in the aspect case).
450 procedure Unexpected_Argument (En : Node_Id);
451 pragma No_Return (Unexpected_Argument);
452 -- Signal unexpected attribute argument (En is the argument), and then
453 -- raises Bad_Attribute to avoid any further semantic processing.
455 procedure Validate_Non_Static_Attribute_Function_Call;
456 -- Called when processing an attribute that is a function call to a
457 -- non-static function, i.e. an attribute function that either takes
458 -- non-scalar arguments or returns a non-scalar result. Verifies that
459 -- such a call does not appear in a preelaborable context.
465 procedure Address_Checks is
467 -- An Address attribute created by expansion is legal even when it
468 -- applies to other entity-denoting expressions.
470 if not Comes_From_Source (N) then
473 -- Address attribute on a protected object self reference is legal
475 elsif Is_Protected_Self_Reference (P) then
478 -- Address applied to an entity
480 elsif Is_Entity_Name (P) then
482 Ent : constant Entity_Id := Entity (P);
485 if Is_Subprogram (Ent) then
486 Set_Address_Taken (Ent);
487 Kill_Current_Values (Ent);
489 -- An Address attribute is accepted when generated by the
490 -- compiler for dispatching operation, and an error is
491 -- issued once the subprogram is frozen (to avoid confusing
492 -- errors about implicit uses of Address in the dispatch
493 -- table initialization).
495 if Has_Pragma_Inline_Always (Entity (P))
496 and then Comes_From_Source (P)
499 ("prefix of % attribute cannot be Inline_Always "
502 -- It is illegal to apply 'Address to an intrinsic
503 -- subprogram. This is now formalized in AI05-0095.
504 -- In an instance, an attempt to obtain 'Address of an
505 -- intrinsic subprogram (e.g the renaming of a predefined
506 -- operator that is an actual) raises Program_Error.
508 elsif Convention (Ent) = Convention_Intrinsic then
511 Make_Raise_Program_Error (Loc,
512 Reason => PE_Address_Of_Intrinsic));
515 Error_Msg_Name_1 := Aname;
517 ("cannot take % of intrinsic subprogram", N);
520 -- Issue an error if prefix denotes an eliminated subprogram
523 Check_For_Eliminated_Subprogram (P, Ent);
526 -- Object or label reference
528 elsif Is_Object (Ent) or else Ekind (Ent) = E_Label then
529 Set_Address_Taken (Ent);
531 -- Deal with No_Implicit_Aliasing restriction
533 if Restriction_Check_Required (No_Implicit_Aliasing) then
534 if not Is_Aliased_View (P) then
535 Check_Restriction (No_Implicit_Aliasing, P);
537 Check_No_Implicit_Aliasing (P);
541 -- If we have an address of an object, and the attribute
542 -- comes from source, then set the object as potentially
543 -- source modified. We do this because the resulting address
544 -- can potentially be used to modify the variable and we
545 -- might not detect this, leading to some junk warnings.
547 Set_Never_Set_In_Source (Ent, False);
549 -- Allow Address to be applied to task or protected type,
550 -- returning null address (what is that about???)
552 elsif (Is_Concurrent_Type (Etype (Ent))
553 and then Etype (Ent) = Base_Type (Ent))
554 or else Ekind (Ent) = E_Package
555 or else Is_Generic_Unit (Ent)
558 New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
560 -- Anything else is illegal
563 Error_Attr ("invalid prefix for % attribute", P);
569 elsif Is_Object_Reference (P) then
572 -- Subprogram called using dot notation
574 elsif Nkind (P) = N_Selected_Component
575 and then Is_Subprogram (Entity (Selector_Name (P)))
579 -- What exactly are we allowing here ??? and is this properly
580 -- documented in the sinfo documentation for this node ???
582 elsif Relaxed_RM_Semantics
583 and then Nkind (P) = N_Attribute_Reference
587 -- All other non-entity name cases are illegal
590 Error_Attr ("invalid prefix for % attribute", P);
594 ------------------------------
595 -- Analyze_Access_Attribute --
596 ------------------------------
598 procedure Analyze_Access_Attribute is
599 Acc_Type : Entity_Id;
604 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id;
605 -- Build an access-to-object type whose designated type is DT,
606 -- and whose Ekind is appropriate to the attribute type. The
607 -- type that is constructed is returned as the result.
609 procedure Build_Access_Subprogram_Type (P : Node_Id);
610 -- Build an access to subprogram whose designated type is the type of
611 -- the prefix. If prefix is overloaded, so is the node itself. The
612 -- result is stored in Acc_Type.
614 function OK_Self_Reference return Boolean;
615 -- An access reference whose prefix is a type can legally appear
616 -- within an aggregate, where it is obtained by expansion of
617 -- a defaulted aggregate. The enclosing aggregate that contains
618 -- the self-referenced is flagged so that the self-reference can
619 -- be expanded into a reference to the target object (see exp_aggr).
621 ------------------------------
622 -- Build_Access_Object_Type --
623 ------------------------------
625 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is
626 Typ : constant Entity_Id :=
628 (E_Access_Attribute_Type, Current_Scope, Loc, 'A');
630 Set_Etype (Typ, Typ);
632 Set_Associated_Node_For_Itype (Typ, N);
633 Set_Directly_Designated_Type (Typ, DT);
635 end Build_Access_Object_Type;
637 ----------------------------------
638 -- Build_Access_Subprogram_Type --
639 ----------------------------------
641 procedure Build_Access_Subprogram_Type (P : Node_Id) is
642 Index : Interp_Index;
645 procedure Check_Local_Access (E : Entity_Id);
646 -- Deal with possible access to local subprogram. If we have such
647 -- an access, we set a flag to kill all tracked values on any call
648 -- because this access value may be passed around, and any called
649 -- code might use it to access a local procedure which clobbers a
650 -- tracked value. If the scope is a loop or block, indicate that
651 -- value tracking is disabled for the enclosing subprogram.
653 function Get_Kind (E : Entity_Id) return Entity_Kind;
654 -- Distinguish between access to regular/protected subprograms
656 ------------------------
657 -- Check_Local_Access --
658 ------------------------
660 procedure Check_Local_Access (E : Entity_Id) is
662 if not Is_Library_Level_Entity (E) then
663 Set_Suppress_Value_Tracking_On_Call (Current_Scope);
664 Set_Suppress_Value_Tracking_On_Call
665 (Nearest_Dynamic_Scope (Current_Scope));
667 end Check_Local_Access;
673 function Get_Kind (E : Entity_Id) return Entity_Kind is
675 if Convention (E) = Convention_Protected then
676 return E_Access_Protected_Subprogram_Type;
678 return E_Access_Subprogram_Type;
682 -- Start of processing for Build_Access_Subprogram_Type
685 -- In the case of an access to subprogram, use the name of the
686 -- subprogram itself as the designated type. Type-checking in
687 -- this case compares the signatures of the designated types.
689 -- Note: This fragment of the tree is temporarily malformed
690 -- because the correct tree requires an E_Subprogram_Type entity
691 -- as the designated type. In most cases this designated type is
692 -- later overridden by the semantics with the type imposed by the
693 -- context during the resolution phase. In the specific case of
694 -- the expression Address!(Prim'Unrestricted_Access), used to
695 -- initialize slots of dispatch tables, this work will be done by
696 -- the expander (see Exp_Aggr).
698 -- The reason to temporarily add this kind of node to the tree
699 -- instead of a proper E_Subprogram_Type itype, is the following:
700 -- in case of errors found in the source file we report better
701 -- error messages. For example, instead of generating the
704 -- "expected access to subprogram with profile
705 -- defined at line X"
707 -- we currently generate:
709 -- "expected access to function Z defined at line X"
711 Set_Etype (N, Any_Type);
713 if not Is_Overloaded (P) then
714 Check_Local_Access (Entity (P));
716 if not Is_Intrinsic_Subprogram (Entity (P)) then
717 Acc_Type := Create_Itype (Get_Kind (Entity (P)), N);
718 Set_Is_Public (Acc_Type, False);
719 Set_Etype (Acc_Type, Acc_Type);
720 Set_Convention (Acc_Type, Convention (Entity (P)));
721 Set_Directly_Designated_Type (Acc_Type, Entity (P));
722 Set_Etype (N, Acc_Type);
723 Freeze_Before (N, Acc_Type);
727 Get_First_Interp (P, Index, It);
728 while Present (It.Nam) loop
729 Check_Local_Access (It.Nam);
731 if not Is_Intrinsic_Subprogram (It.Nam) then
732 Acc_Type := Create_Itype (Get_Kind (It.Nam), N);
733 Set_Is_Public (Acc_Type, False);
734 Set_Etype (Acc_Type, Acc_Type);
735 Set_Convention (Acc_Type, Convention (It.Nam));
736 Set_Directly_Designated_Type (Acc_Type, It.Nam);
737 Add_One_Interp (N, Acc_Type, Acc_Type);
738 Freeze_Before (N, Acc_Type);
741 Get_Next_Interp (Index, It);
745 -- Cannot be applied to intrinsic. Looking at the tests above,
746 -- the only way Etype (N) can still be set to Any_Type is if
747 -- Is_Intrinsic_Subprogram was True for some referenced entity.
749 if Etype (N) = Any_Type then
750 Error_Attr_P ("prefix of % attribute cannot be intrinsic");
752 end Build_Access_Subprogram_Type;
754 ----------------------
755 -- OK_Self_Reference --
756 ----------------------
758 function OK_Self_Reference return Boolean is
765 (Nkind (Par) = N_Component_Association
766 or else Nkind (Par) in N_Subexpr)
768 if Nkind_In (Par, N_Aggregate, N_Extension_Aggregate) then
769 if Etype (Par) = Typ then
770 Set_Has_Self_Reference (Par);
772 -- Check the context: the aggregate must be part of the
773 -- initialization of a type or component, or it is the
774 -- resulting expansion in an initialization procedure.
776 if Is_Init_Proc (Current_Scope) then
780 while Present (Par) loop
781 if Nkind (Par) = N_Full_Type_Declaration then
796 -- No enclosing aggregate, or not a self-reference
799 end OK_Self_Reference;
801 -- Start of processing for Analyze_Access_Attribute
804 Check_SPARK_05_Restriction_On_Attribute;
807 if Nkind (P) = N_Character_Literal then
809 ("prefix of % attribute cannot be enumeration literal");
812 -- Preserve relevant elaboration-related attributes of the context
813 -- which are no longer available or very expensive to recompute once
814 -- analysis, resolution, and expansion are over.
816 Mark_Elaboration_Attributes
822 -- Save the scenario for later examination by the ABE Processing
825 Record_Elaboration_Scenario (N);
827 -- Case of access to subprogram
829 if Is_Entity_Name (P) and then Is_Overloadable (Entity (P)) then
830 if Has_Pragma_Inline_Always (Entity (P)) then
832 ("prefix of % attribute cannot be Inline_Always subprogram");
834 elsif Aname = Name_Unchecked_Access then
835 Error_Attr ("attribute% cannot be applied to a subprogram", P);
838 -- Issue an error if the prefix denotes an eliminated subprogram
840 Check_For_Eliminated_Subprogram (P, Entity (P));
842 -- Check for obsolescent subprogram reference
844 Check_Obsolescent_2005_Entity (Entity (P), P);
846 -- Build the appropriate subprogram type
848 Build_Access_Subprogram_Type (P);
850 -- For P'Access or P'Unrestricted_Access, where P is a nested
851 -- subprogram, we might be passing P to another subprogram (but we
852 -- don't check that here), which might call P. P could modify
853 -- local variables, so we need to kill current values. It is
854 -- important not to do this for library-level subprograms, because
855 -- Kill_Current_Values is very inefficient in the case of library
856 -- level packages with lots of tagged types.
858 if Is_Library_Level_Entity (Entity (Prefix (N))) then
861 -- Do not kill values on nodes initializing dispatch tables
862 -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access)
863 -- is currently generated by the expander only for this
864 -- purpose. Done to keep the quality of warnings currently
865 -- generated by the compiler (otherwise any declaration of
866 -- a tagged type cleans constant indications from its scope).
868 elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
869 and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr)
871 Etype (Parent (N)) = RTE (RE_Size_Ptr))
872 and then Is_Dispatching_Operation
873 (Directly_Designated_Type (Etype (N)))
881 -- In the static elaboration model, treat the attribute reference
882 -- as a subprogram call for elaboration purposes. Suppress this
883 -- treatment under debug flag. In any case, we are all done.
885 if Legacy_Elaboration_Checks
886 and not Dynamic_Elaboration_Checks
887 and not Debug_Flag_Dot_UU
894 -- Component is an operation of a protected type
896 elsif Nkind (P) = N_Selected_Component
897 and then Is_Overloadable (Entity (Selector_Name (P)))
899 if Ekind (Entity (Selector_Name (P))) = E_Entry then
900 Error_Attr_P ("prefix of % attribute must be subprogram");
903 Build_Access_Subprogram_Type (Selector_Name (P));
907 -- Deal with incorrect reference to a type, but note that some
908 -- accesses are allowed: references to the current type instance,
909 -- or in Ada 2005 self-referential pointer in a default-initialized
912 if Is_Entity_Name (P) then
915 -- The reference may appear in an aggregate that has been expanded
916 -- into a loop. Locate scope of type definition, if any.
918 Scop := Current_Scope;
919 while Ekind (Scop) = E_Loop loop
920 Scop := Scope (Scop);
923 if Is_Type (Typ) then
925 -- OK if we are within the scope of a limited type
926 -- let's mark the component as having per object constraint
928 if Is_Anonymous_Tagged_Base (Scop, Typ) then
936 Q : Node_Id := Parent (N);
940 and then Nkind (Q) /= N_Component_Declaration
946 Set_Has_Per_Object_Constraint
947 (Defining_Identifier (Q), True);
951 if Nkind (P) = N_Expanded_Name then
953 ("current instance prefix must be a direct name", P);
956 -- If a current instance attribute appears in a component
957 -- constraint it must appear alone; other contexts (spec-
958 -- expressions, within a task body) are not subject to this
961 if not In_Spec_Expression
962 and then not Has_Completion (Scop)
964 Nkind_In (Parent (N), N_Discriminant_Association,
965 N_Index_Or_Discriminant_Constraint)
968 ("current instance attribute must appear alone", N);
971 if Is_CPP_Class (Root_Type (Typ)) then
973 ("??current instance unsupported for derivations of "
974 & "'C'P'P types", N);
977 -- OK if we are in initialization procedure for the type
978 -- in question, in which case the reference to the type
979 -- is rewritten as a reference to the current object.
981 elsif Ekind (Scop) = E_Procedure
982 and then Is_Init_Proc (Scop)
983 and then Etype (First_Formal (Scop)) = Typ
986 Make_Attribute_Reference (Loc,
987 Prefix => Make_Identifier (Loc, Name_uInit),
988 Attribute_Name => Name_Unrestricted_Access));
992 -- OK if a task type, this test needs sharpening up ???
994 elsif Is_Task_Type (Typ) then
997 -- OK if self-reference in an aggregate in Ada 2005, and
998 -- the reference comes from a copied default expression.
1000 -- Note that we check legality of self-reference even if the
1001 -- expression comes from source, e.g. when a single component
1002 -- association in an aggregate has a box association.
1004 elsif Ada_Version >= Ada_2005
1005 and then OK_Self_Reference
1009 -- OK if reference to current instance of a protected object
1011 elsif Is_Protected_Self_Reference (P) then
1014 -- Otherwise we have an error case
1017 Error_Attr ("% attribute cannot be applied to type", P);
1023 -- If we fall through, we have a normal access to object case
1025 -- Unrestricted_Access is (for now) legal wherever an allocator would
1026 -- be legal, so its Etype is set to E_Allocator. The expected type
1027 -- of the other attributes is a general access type, and therefore
1028 -- we label them with E_Access_Attribute_Type.
1030 if not Is_Overloaded (P) then
1031 Acc_Type := Build_Access_Object_Type (P_Type);
1032 Set_Etype (N, Acc_Type);
1036 Index : Interp_Index;
1039 Set_Etype (N, Any_Type);
1040 Get_First_Interp (P, Index, It);
1041 while Present (It.Typ) loop
1042 Acc_Type := Build_Access_Object_Type (It.Typ);
1043 Add_One_Interp (N, Acc_Type, Acc_Type);
1044 Get_Next_Interp (Index, It);
1049 -- Special cases when we can find a prefix that is an entity name
1058 if Is_Entity_Name (PP) then
1061 -- If we have an access to an object, and the attribute
1062 -- comes from source, then set the object as potentially
1063 -- source modified. We do this because the resulting access
1064 -- pointer can be used to modify the variable, and we might
1065 -- not detect this, leading to some junk warnings.
1067 -- We only do this for source references, since otherwise
1068 -- we can suppress warnings, e.g. from the unrestricted
1069 -- access generated for validity checks in -gnatVa mode.
1071 if Comes_From_Source (N) then
1072 Set_Never_Set_In_Source (Ent, False);
1075 -- Mark entity as address taken in the case of
1076 -- 'Unrestricted_Access or subprograms, and kill current
1079 if Aname = Name_Unrestricted_Access
1080 or else Is_Subprogram (Ent)
1082 Set_Address_Taken (Ent);
1085 Kill_Current_Values (Ent);
1088 elsif Nkind_In (PP, N_Selected_Component,
1089 N_Indexed_Component)
1098 end Analyze_Access_Attribute;
1100 ----------------------------------
1101 -- Analyze_Attribute_Old_Result --
1102 ----------------------------------
1104 procedure Analyze_Attribute_Old_Result
1105 (Legal : out Boolean;
1106 Spec_Id : out Entity_Id)
1108 procedure Check_Placement_In_Check (Prag : Node_Id);
1109 -- Verify that the attribute appears within pragma Check that mimics
1112 procedure Check_Placement_In_Contract_Cases (Prag : Node_Id);
1113 -- Verify that the attribute appears within a consequence of aspect
1114 -- or pragma Contract_Cases denoted by Prag.
1116 procedure Check_Placement_In_Test_Case (Prag : Node_Id);
1117 -- Verify that the attribute appears within the "Ensures" argument of
1118 -- aspect or pragma Test_Case denoted by Prag.
1122 Encl_Nod : Node_Id) return Boolean;
1123 -- Subsidiary to Check_Placemenet_In_XXX. Determine whether arbitrary
1124 -- node Nod is within enclosing node Encl_Nod.
1126 procedure Placement_Error;
1127 pragma No_Return (Placement_Error);
1128 -- Emit a general error when the attributes does not appear in a
1129 -- postcondition-like aspect or pragma, and then raises Bad_Attribute
1130 -- to avoid any further semantic processing.
1132 ------------------------------
1133 -- Check_Placement_In_Check --
1134 ------------------------------
1136 procedure Check_Placement_In_Check (Prag : Node_Id) is
1137 Args : constant List_Id := Pragma_Argument_Associations (Prag);
1138 Nam : constant Name_Id := Chars (Get_Pragma_Arg (First (Args)));
1141 -- The "Name" argument of pragma Check denotes a postcondition
1143 if Nam_In (Nam, Name_Post,
1150 -- Otherwise the placement of the attribute is illegal
1155 end Check_Placement_In_Check;
1157 ---------------------------------------
1158 -- Check_Placement_In_Contract_Cases --
1159 ---------------------------------------
1161 procedure Check_Placement_In_Contract_Cases (Prag : Node_Id) is
1167 -- Obtain the argument of the aspect or pragma
1169 if Nkind (Prag) = N_Aspect_Specification then
1172 Arg := First (Pragma_Argument_Associations (Prag));
1175 Cases := Expression (Arg);
1177 if Present (Component_Associations (Cases)) then
1178 CCase := First (Component_Associations (Cases));
1179 while Present (CCase) loop
1181 -- Detect whether the attribute appears within the
1182 -- consequence of the current contract case.
1184 if Nkind (CCase) = N_Component_Association
1185 and then Is_Within (N, Expression (CCase))
1194 -- Otherwise aspect or pragma Contract_Cases is either malformed
1195 -- or the attribute does not appear within a consequence.
1198 ("attribute % must appear in the consequence of a contract case",
1200 end Check_Placement_In_Contract_Cases;
1202 ----------------------------------
1203 -- Check_Placement_In_Test_Case --
1204 ----------------------------------
1206 procedure Check_Placement_In_Test_Case (Prag : Node_Id) is
1207 Arg : constant Node_Id :=
1210 Arg_Nam => Name_Ensures,
1211 From_Aspect => Nkind (Prag) = N_Aspect_Specification);
1214 -- Detect whether the attribute appears within the "Ensures"
1215 -- expression of aspect or pragma Test_Case.
1217 if Present (Arg) and then Is_Within (N, Arg) then
1222 ("attribute % must appear in the ensures expression of a "
1225 end Check_Placement_In_Test_Case;
1233 Encl_Nod : Node_Id) return Boolean
1239 while Present (Par) loop
1240 if Par = Encl_Nod then
1243 -- Prevent the search from going too far
1245 elsif Is_Body_Or_Package_Declaration (Par) then
1249 Par := Parent (Par);
1255 ---------------------
1256 -- Placement_Error --
1257 ---------------------
1259 procedure Placement_Error is
1261 if Aname = Name_Old then
1262 Error_Attr ("attribute % can only appear in postcondition", P);
1264 -- Specialize the error message for attribute 'Result
1268 ("attribute % can only appear in postcondition of function",
1271 end Placement_Error;
1277 Subp_Decl : Node_Id;
1279 -- Start of processing for Analyze_Attribute_Old_Result
1282 -- Assume that the attribute is illegal
1287 -- Traverse the parent chain to find the aspect or pragma where the
1288 -- attribute resides.
1291 while Present (Prag) loop
1292 if Nkind_In (Prag, N_Aspect_Specification, N_Pragma) then
1295 -- Prevent the search from going too far
1297 elsif Is_Body_Or_Package_Declaration (Prag) then
1301 Prag := Parent (Prag);
1304 -- The attribute is allowed to appear only in postcondition-like
1305 -- aspects or pragmas.
1307 if Nkind_In (Prag, N_Aspect_Specification, N_Pragma) then
1308 if Nkind (Prag) = N_Aspect_Specification then
1309 Prag_Nam := Chars (Identifier (Prag));
1311 Prag_Nam := Pragma_Name (Prag);
1314 if Prag_Nam = Name_Check then
1315 Check_Placement_In_Check (Prag);
1317 elsif Prag_Nam = Name_Contract_Cases then
1318 Check_Placement_In_Contract_Cases (Prag);
1320 -- Attribute 'Result is allowed to appear in aspect or pragma
1321 -- [Refined_]Depends (SPARK RM 6.1.5(11)).
1323 elsif Nam_In (Prag_Nam, Name_Depends, Name_Refined_Depends)
1324 and then Aname = Name_Result
1328 elsif Nam_In (Prag_Nam, Name_Post,
1335 elsif Prag_Nam = Name_Test_Case then
1336 Check_Placement_In_Test_Case (Prag);
1343 -- Otherwise the placement of the attribute is illegal
1350 -- Find the related subprogram subject to the aspect or pragma
1352 if Nkind (Prag) = N_Aspect_Specification then
1353 Subp_Decl := Parent (Prag);
1355 Subp_Decl := Find_Related_Declaration_Or_Body (Prag);
1358 -- The aspect or pragma where the attribute resides should be
1359 -- associated with a subprogram declaration or a body. If this is not
1360 -- the case, then the aspect or pragma is illegal. Return as analysis
1361 -- cannot be carried out. Note that it is legal to have the aspect
1362 -- appear on a subprogram renaming, when the renamed entity is an
1363 -- attribute reference.
1365 -- Generating C code the internally built nested _postcondition
1366 -- subprograms are inlined; after expanded, inlined aspects are
1367 -- located in the internal block generated by the frontend.
1369 if Nkind (Subp_Decl) = N_Block_Statement
1370 and then Modify_Tree_For_C
1371 and then In_Inlined_Body
1375 elsif not Nkind_In (Subp_Decl, N_Abstract_Subprogram_Declaration,
1376 N_Entry_Declaration,
1377 N_Expression_Function,
1378 N_Generic_Subprogram_Declaration,
1380 N_Subprogram_Body_Stub,
1381 N_Subprogram_Declaration,
1382 N_Subprogram_Renaming_Declaration)
1387 -- If we get here, then the attribute is legal
1390 Spec_Id := Unique_Defining_Entity (Subp_Decl);
1392 -- When generating C code, nested _postcondition subprograms are
1393 -- inlined by the front end to avoid problems (when unnested) with
1394 -- referenced itypes. Handle that here, since as part of inlining the
1395 -- expander nests subprogram within a dummy procedure named _parent
1396 -- (see Build_Postconditions_Procedure and Build_Body_To_Inline).
1397 -- Hence, in this context, the spec_id of _postconditions is the
1400 if Modify_Tree_For_C
1401 and then Chars (Spec_Id) = Name_uParent
1402 and then Chars (Scope (Spec_Id)) = Name_uPostconditions
1404 -- This situation occurs only when preanalyzing the inlined body
1406 pragma Assert (not Full_Analysis);
1408 Spec_Id := Scope (Spec_Id);
1409 pragma Assert (Is_Inlined (Spec_Id));
1411 end Analyze_Attribute_Old_Result;
1413 -----------------------------
1414 -- Analyze_Image_Attribute --
1415 -----------------------------
1417 procedure Analyze_Image_Attribute (Str_Typ : Entity_Id) is
1419 Check_SPARK_05_Restriction_On_Attribute;
1421 -- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for
1422 -- scalar types, so that the prefix can be an object, a named value,
1423 -- or a type, and there is no need for an argument in this case.
1425 if Attr_Id = Attribute_Img
1426 or else (Ada_Version > Ada_2005 and then Is_Object_Image (P))
1429 Set_Etype (N, Str_Typ);
1431 if Attr_Id = Attribute_Img and then not Is_Object_Image (P) then
1433 ("prefix of % attribute must be a scalar object name");
1437 Set_Etype (N, Str_Typ);
1439 -- Check that the prefix type is scalar - much in the same way as
1440 -- Check_Scalar_Type but with custom error messages to denote the
1441 -- variants of 'Image attributes.
1443 if Is_Entity_Name (P)
1444 and then Is_Type (Entity (P))
1445 and then Ekind (Entity (P)) = E_Incomplete_Type
1446 and then Present (Full_View (Entity (P)))
1448 P_Type := Full_View (Entity (P));
1449 Set_Entity (P, P_Type);
1452 if not Is_Entity_Name (P)
1453 or else not Is_Type (Entity (P))
1454 or else not Is_Scalar_Type (P_Type)
1456 if Ada_Version > Ada_2005 then
1458 ("prefix of % attribute must be a scalar type or a scalar "
1461 Error_Attr_P ("prefix of % attribute must be a scalar type");
1464 elsif Is_Protected_Self_Reference (P) then
1466 ("prefix of % attribute denotes current instance "
1467 & "(RM 9.4(21/2))");
1470 Resolve (E1, P_Base_Type);
1471 Validate_Non_Static_Attribute_Function_Call;
1476 -- Check restriction No_Fixed_IO. Note the check of Comes_From_Source
1477 -- to avoid giving a duplicate message for when Image attributes
1478 -- applied to object references get expanded into type-based Image
1481 if Restriction_Check_Required (No_Fixed_IO)
1482 and then Comes_From_Source (N)
1483 and then Is_Fixed_Point_Type (P_Type)
1485 Check_Restriction (No_Fixed_IO, P);
1487 end Analyze_Image_Attribute;
1489 ---------------------------------
1490 -- Bad_Attribute_For_Predicate --
1491 ---------------------------------
1493 procedure Bad_Attribute_For_Predicate is
1495 if Is_Scalar_Type (P_Type)
1496 and then Comes_From_Source (N)
1498 Error_Msg_Name_1 := Aname;
1499 Bad_Predicated_Subtype_Use
1500 ("type& has predicates, attribute % not allowed", N, P_Type);
1502 end Bad_Attribute_For_Predicate;
1504 --------------------------------
1505 -- Check_Array_Or_Scalar_Type --
1506 --------------------------------
1508 procedure Check_Array_Or_Scalar_Type is
1509 function In_Aspect_Specification return Boolean;
1510 -- A current instance of a type in an aspect specification is an
1511 -- object and not a type, and therefore cannot be of a scalar type
1512 -- in the prefix of one of the array attributes if the attribute
1513 -- reference is part of an aspect expression.
1515 -----------------------------
1516 -- In_Aspect_Specification --
1517 -----------------------------
1519 function In_Aspect_Specification return Boolean is
1524 while Present (P) loop
1525 if Nkind (P) = N_Aspect_Specification then
1526 return P_Type = Entity (P);
1528 elsif Nkind (P) in N_Declaration then
1536 end In_Aspect_Specification;
1543 -- Start of processing for Check_Array_Or_Scalar_Type
1546 -- Case of string literal or string literal subtype. These cases
1547 -- cannot arise from legal Ada code, but the expander is allowed
1548 -- to generate them. They require special handling because string
1549 -- literal subtypes do not have standard bounds (the whole idea
1550 -- of these subtypes is to avoid having to generate the bounds)
1552 if Ekind (P_Type) = E_String_Literal_Subtype then
1553 Set_Etype (N, Etype (First_Index (P_Base_Type)));
1558 elsif Is_Scalar_Type (P_Type) then
1561 if Present (E1) then
1562 Error_Attr ("invalid argument in % attribute", E1);
1564 elsif In_Aspect_Specification then
1566 ("prefix of % attribute cannot be the current instance of a "
1567 & "scalar type", P);
1570 Set_Etype (N, P_Base_Type);
1574 -- The following is a special test to allow 'First to apply to
1575 -- private scalar types if the attribute comes from generated
1576 -- code. This occurs in the case of Normalize_Scalars code.
1578 elsif Is_Private_Type (P_Type)
1579 and then Present (Full_View (P_Type))
1580 and then Is_Scalar_Type (Full_View (P_Type))
1581 and then not Comes_From_Source (N)
1583 Set_Etype (N, Implementation_Base_Type (P_Type));
1585 -- Array types other than string literal subtypes handled above
1590 -- We know prefix is an array type, or the name of an array
1591 -- object, and that the expression, if present, is static
1592 -- and within the range of the dimensions of the type.
1594 pragma Assert (Is_Array_Type (P_Type));
1595 Index := First_Index (P_Base_Type);
1599 -- First dimension assumed
1601 Set_Etype (N, Base_Type (Etype (Index)));
1604 Dims := UI_To_Int (Intval (E1));
1606 for J in 1 .. Dims - 1 loop
1610 Set_Etype (N, Base_Type (Etype (Index)));
1611 Set_Etype (E1, Standard_Integer);
1614 end Check_Array_Or_Scalar_Type;
1616 ----------------------
1617 -- Check_Array_Type --
1618 ----------------------
1620 procedure Check_Array_Type is
1622 -- Dimension number for array attributes
1625 -- If the type is a string literal type, then this must be generated
1626 -- internally, and no further check is required on its legality.
1628 if Ekind (P_Type) = E_String_Literal_Subtype then
1631 -- If the type is a composite, it is an illegal aggregate, no point
1634 elsif P_Type = Any_Composite then
1635 raise Bad_Attribute;
1638 -- Normal case of array type or subtype. Note that if the
1639 -- prefix is a current instance of a type declaration it
1640 -- appears within an aspect specification and is legal.
1642 Check_Either_E0_Or_E1;
1645 if Is_Array_Type (P_Type) then
1646 if not Is_Constrained (P_Type)
1647 and then Is_Entity_Name (P)
1648 and then Is_Type (Entity (P))
1649 and then not Is_Current_Instance (P)
1651 -- Note: we do not call Error_Attr here, since we prefer to
1652 -- continue, using the relevant index type of the array,
1653 -- even though it is unconstrained. This gives better error
1654 -- recovery behavior.
1656 Error_Msg_Name_1 := Aname;
1658 ("prefix for % attribute must be constrained array", P);
1661 -- The attribute reference freezes the type, and thus the
1662 -- component type, even if the attribute may not depend on the
1663 -- component. Diagnose arrays with incomplete components now.
1664 -- If the prefix is an access to array, this does not freeze
1665 -- the designated type.
1667 if Nkind (P) /= N_Explicit_Dereference then
1668 Check_Fully_Declared (Component_Type (P_Type), P);
1671 D := Number_Dimensions (P_Type);
1674 if Is_Private_Type (P_Type) then
1675 Error_Attr_P ("prefix for % attribute may not be private type");
1677 elsif Is_Access_Type (P_Type)
1678 and then Is_Array_Type (Designated_Type (P_Type))
1679 and then Is_Entity_Name (P)
1680 and then Is_Type (Entity (P))
1682 Error_Attr_P ("prefix of % attribute cannot be access type");
1684 elsif Attr_Id = Attribute_First
1686 Attr_Id = Attribute_Last
1688 Error_Attr ("invalid prefix for % attribute", P);
1691 Error_Attr_P ("prefix for % attribute must be array");
1695 if Present (E1) then
1696 Resolve (E1, Any_Integer);
1697 Set_Etype (E1, Standard_Integer);
1699 if not Is_OK_Static_Expression (E1)
1700 or else Raises_Constraint_Error (E1)
1702 Flag_Non_Static_Expr
1703 ("expression for dimension must be static!", E1);
1706 elsif UI_To_Int (Expr_Value (E1)) > D
1707 or else UI_To_Int (Expr_Value (E1)) < 1
1709 Error_Attr ("invalid dimension number for array type", E1);
1713 if (Style_Check and Style_Check_Array_Attribute_Index)
1714 and then Comes_From_Source (N)
1716 Style.Check_Array_Attribute_Index (N, E1, D);
1718 end Check_Array_Type;
1720 -------------------------
1721 -- Check_Asm_Attribute --
1722 -------------------------
1724 procedure Check_Asm_Attribute is
1729 -- Check first argument is static string expression
1731 Analyze_And_Resolve (E1, Standard_String);
1733 if Etype (E1) = Any_Type then
1736 elsif not Is_OK_Static_Expression (E1) then
1737 Flag_Non_Static_Expr
1738 ("constraint argument must be static string expression!", E1);
1742 -- Check second argument is right type
1744 Analyze_And_Resolve (E2, Entity (P));
1746 -- Note: that is all we need to do, we don't need to check
1747 -- that it appears in a correct context. The Ada type system
1748 -- will do that for us.
1750 end Check_Asm_Attribute;
1752 ---------------------
1753 -- Check_Component --
1754 ---------------------
1756 procedure Check_Component is
1760 if Nkind (P) /= N_Selected_Component
1762 (Ekind (Entity (Selector_Name (P))) /= E_Component
1764 Ekind (Entity (Selector_Name (P))) /= E_Discriminant)
1766 Error_Attr_P ("prefix for % attribute must be selected component");
1768 end Check_Component;
1770 ------------------------------------
1771 -- Check_Decimal_Fixed_Point_Type --
1772 ------------------------------------
1774 procedure Check_Decimal_Fixed_Point_Type is
1778 if not Is_Decimal_Fixed_Point_Type (P_Type) then
1779 Error_Attr_P ("prefix of % attribute must be decimal type");
1781 end Check_Decimal_Fixed_Point_Type;
1783 -----------------------
1784 -- Check_Dereference --
1785 -----------------------
1787 procedure Check_Dereference is
1790 -- Case of a subtype mark
1792 if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
1796 -- Case of an expression
1800 if Is_Access_Type (P_Type) then
1802 -- If there is an implicit dereference, then we must freeze the
1803 -- designated type of the access type, since the type of the
1804 -- referenced array is this type (see AI95-00106).
1806 -- As done elsewhere, freezing must not happen when preanalyzing
1807 -- a pre- or postcondition or a default value for an object or for
1808 -- a formal parameter.
1810 if not In_Spec_Expression then
1811 Freeze_Before (N, Designated_Type (P_Type));
1815 Make_Explicit_Dereference (Sloc (P),
1816 Prefix => Relocate_Node (P)));
1818 Analyze_And_Resolve (P);
1819 P_Type := Etype (P);
1821 if P_Type = Any_Type then
1822 raise Bad_Attribute;
1825 P_Base_Type := Base_Type (P_Type);
1827 end Check_Dereference;
1829 -------------------------
1830 -- Check_Discrete_Type --
1831 -------------------------
1833 procedure Check_Discrete_Type is
1837 if not Is_Discrete_Type (P_Type) then
1838 Error_Attr_P ("prefix of % attribute must be discrete type");
1840 end Check_Discrete_Type;
1846 procedure Check_E0 is
1848 if Present (E1) then
1849 Unexpected_Argument (E1);
1857 procedure Check_E1 is
1859 Check_Either_E0_Or_E1;
1863 -- Special-case attributes that are functions and that appear as
1864 -- the prefix of another attribute. Error is posted on parent.
1866 if Nkind (Parent (N)) = N_Attribute_Reference
1867 and then Nam_In (Attribute_Name (Parent (N)), Name_Address,
1871 Error_Msg_Name_1 := Attribute_Name (Parent (N));
1872 Error_Msg_N ("illegal prefix for % attribute", Parent (N));
1873 Set_Etype (Parent (N), Any_Type);
1874 Set_Entity (Parent (N), Any_Type);
1875 raise Bad_Attribute;
1878 Error_Attr ("missing argument for % attribute", N);
1887 procedure Check_E2 is
1890 Error_Attr ("missing arguments for % attribute (2 required)", N);
1892 Error_Attr ("missing argument for % attribute (2 required)", N);
1896 ---------------------------
1897 -- Check_Either_E0_Or_E1 --
1898 ---------------------------
1900 procedure Check_Either_E0_Or_E1 is
1902 if Present (E2) then
1903 Unexpected_Argument (E2);
1905 end Check_Either_E0_Or_E1;
1907 ----------------------
1908 -- Check_Enum_Image --
1909 ----------------------
1911 procedure Check_Enum_Image is
1915 -- When an enumeration type appears in an attribute reference, all
1916 -- literals of the type are marked as referenced. This must only be
1917 -- done if the attribute reference appears in the current source.
1918 -- Otherwise the information on references may differ between a
1919 -- normal compilation and one that performs inlining.
1921 if Is_Enumeration_Type (P_Base_Type)
1922 and then In_Extended_Main_Code_Unit (N)
1924 Lit := First_Literal (P_Base_Type);
1925 while Present (Lit) loop
1926 Set_Referenced (Lit);
1930 end Check_Enum_Image;
1932 ----------------------------
1933 -- Check_First_Last_Valid --
1934 ----------------------------
1936 procedure Check_First_Last_Valid is
1938 Check_Discrete_Type;
1940 -- Freeze the subtype now, so that the following test for predicates
1941 -- works (we set the predicates stuff up at freeze time)
1943 Insert_Actions (N, Freeze_Entity (P_Type, P));
1945 -- Now test for dynamic predicate
1947 if Has_Predicates (P_Type)
1948 and then not (Has_Static_Predicate (P_Type))
1951 ("prefix of % attribute may not have dynamic predicate");
1954 -- Check non-static subtype
1956 if not Is_OK_Static_Subtype (P_Type) then
1957 Error_Attr_P ("prefix of % attribute must be a static subtype");
1960 -- Test case for no values
1962 if Expr_Value (Type_Low_Bound (P_Type)) >
1963 Expr_Value (Type_High_Bound (P_Type))
1964 or else (Has_Predicates (P_Type)
1966 Is_Empty_List (Static_Discrete_Predicate (P_Type)))
1969 ("prefix of % attribute must be subtype with at least one "
1972 end Check_First_Last_Valid;
1974 ----------------------------
1975 -- Check_Fixed_Point_Type --
1976 ----------------------------
1978 procedure Check_Fixed_Point_Type is
1982 if not Is_Fixed_Point_Type (P_Type) then
1983 Error_Attr_P ("prefix of % attribute must be fixed point type");
1985 end Check_Fixed_Point_Type;
1987 ------------------------------
1988 -- Check_Fixed_Point_Type_0 --
1989 ------------------------------
1991 procedure Check_Fixed_Point_Type_0 is
1993 Check_Fixed_Point_Type;
1995 end Check_Fixed_Point_Type_0;
1997 -------------------------------
1998 -- Check_Floating_Point_Type --
1999 -------------------------------
2001 procedure Check_Floating_Point_Type is
2005 if not Is_Floating_Point_Type (P_Type) then
2006 Error_Attr_P ("prefix of % attribute must be float type");
2008 end Check_Floating_Point_Type;
2010 ---------------------------------
2011 -- Check_Floating_Point_Type_0 --
2012 ---------------------------------
2014 procedure Check_Floating_Point_Type_0 is
2016 Check_Floating_Point_Type;
2018 end Check_Floating_Point_Type_0;
2020 ---------------------------------
2021 -- Check_Floating_Point_Type_1 --
2022 ---------------------------------
2024 procedure Check_Floating_Point_Type_1 is
2026 Check_Floating_Point_Type;
2028 end Check_Floating_Point_Type_1;
2030 ---------------------------------
2031 -- Check_Floating_Point_Type_2 --
2032 ---------------------------------
2034 procedure Check_Floating_Point_Type_2 is
2036 Check_Floating_Point_Type;
2038 end Check_Floating_Point_Type_2;
2040 ------------------------
2041 -- Check_Integer_Type --
2042 ------------------------
2044 procedure Check_Integer_Type is
2048 if not Is_Integer_Type (P_Type) then
2049 Error_Attr_P ("prefix of % attribute must be integer type");
2051 end Check_Integer_Type;
2053 --------------------------------
2054 -- Check_Modular_Integer_Type --
2055 --------------------------------
2057 procedure Check_Modular_Integer_Type is
2061 if not Is_Modular_Integer_Type (P_Type) then
2063 ("prefix of % attribute must be modular integer type");
2065 end Check_Modular_Integer_Type;
2067 ------------------------
2068 -- Check_Not_CPP_Type --
2069 ------------------------
2071 procedure Check_Not_CPP_Type is
2073 if Is_Tagged_Type (Etype (P))
2074 and then Convention (Etype (P)) = Convention_CPP
2075 and then Is_CPP_Class (Root_Type (Etype (P)))
2078 ("invalid use of % attribute with 'C'P'P tagged type");
2080 end Check_Not_CPP_Type;
2082 -------------------------------
2083 -- Check_Not_Incomplete_Type --
2084 -------------------------------
2086 procedure Check_Not_Incomplete_Type is
2091 -- Ada 2005 (AI-50217, AI-326): If the prefix is an explicit
2092 -- dereference we have to check wrong uses of incomplete types
2093 -- (other wrong uses are checked at their freezing point).
2095 -- In Ada 2012, incomplete types can appear in subprogram
2096 -- profiles, but formals with incomplete types cannot be the
2097 -- prefix of attributes.
2099 -- Example 1: Limited-with
2101 -- limited with Pkg;
2103 -- type Acc is access Pkg.T;
2105 -- S : Integer := X.all'Size; -- ERROR
2108 -- Example 2: Tagged incomplete
2110 -- type T is tagged;
2111 -- type Acc is access all T;
2113 -- S : constant Integer := X.all'Size; -- ERROR
2114 -- procedure Q (Obj : Integer := X.all'Alignment); -- ERROR
2116 if Ada_Version >= Ada_2005
2117 and then Nkind (P) = N_Explicit_Dereference
2120 while Nkind (E) = N_Explicit_Dereference loop
2126 if From_Limited_With (Typ) then
2128 ("prefix of % attribute cannot be an incomplete type");
2130 -- If the prefix is an access type check the designated type
2132 elsif Is_Access_Type (Typ)
2133 and then Nkind (P) = N_Explicit_Dereference
2135 Typ := Directly_Designated_Type (Typ);
2138 if Is_Class_Wide_Type (Typ) then
2139 Typ := Root_Type (Typ);
2142 -- A legal use of a shadow entity occurs only when the unit where
2143 -- the non-limited view resides is imported via a regular with
2144 -- clause in the current body. Such references to shadow entities
2145 -- may occur in subprogram formals.
2147 if Is_Incomplete_Type (Typ)
2148 and then From_Limited_With (Typ)
2149 and then Present (Non_Limited_View (Typ))
2150 and then Is_Legal_Shadow_Entity_In_Body (Typ)
2152 Typ := Non_Limited_View (Typ);
2155 -- If still incomplete, it can be a local incomplete type, or a
2156 -- limited view whose scope is also a limited view.
2158 if Ekind (Typ) = E_Incomplete_Type then
2159 if not From_Limited_With (Typ)
2160 and then No (Full_View (Typ))
2163 ("prefix of % attribute cannot be an incomplete type");
2165 -- The limited view may be available indirectly through
2166 -- an intermediate unit. If the non-limited view is available
2167 -- the attribute reference is legal.
2169 elsif From_Limited_With (Typ)
2171 (No (Non_Limited_View (Typ))
2172 or else Is_Incomplete_Type (Non_Limited_View (Typ)))
2175 ("prefix of % attribute cannot be an incomplete type");
2179 -- Ada 2012 : formals in bodies may be incomplete, but no attribute
2182 elsif Is_Entity_Name (P)
2183 and then Is_Formal (Entity (P))
2184 and then Is_Incomplete_Type (Etype (Etype (P)))
2187 ("prefix of % attribute cannot be an incomplete type");
2190 if not Is_Entity_Name (P)
2191 or else not Is_Type (Entity (P))
2192 or else In_Spec_Expression
2196 Check_Fully_Declared (P_Type, P);
2198 end Check_Not_Incomplete_Type;
2200 ----------------------------
2201 -- Check_Object_Reference --
2202 ----------------------------
2204 procedure Check_Object_Reference (P : Node_Id) is
2208 -- If we need an object, and we have a prefix that is the name of a
2209 -- function entity, convert it into a function call.
2211 if Is_Entity_Name (P)
2212 and then Ekind (Entity (P)) = E_Function
2214 Rtyp := Etype (Entity (P));
2217 Make_Function_Call (Sloc (P),
2218 Name => Relocate_Node (P)));
2220 Analyze_And_Resolve (P, Rtyp);
2222 -- Otherwise we must have an object reference
2224 elsif not Is_Object_Reference (P) then
2225 Error_Attr_P ("prefix of % attribute must be object");
2227 end Check_Object_Reference;
2229 ----------------------------
2230 -- Check_PolyORB_Attribute --
2231 ----------------------------
2233 procedure Check_PolyORB_Attribute is
2235 Validate_Non_Static_Attribute_Function_Call;
2240 if Get_PCS_Name /= Name_PolyORB_DSA then
2242 ("attribute% requires the 'Poly'O'R'B 'P'C'S", N);
2244 end Check_PolyORB_Attribute;
2246 ------------------------
2247 -- Check_Program_Unit --
2248 ------------------------
2250 procedure Check_Program_Unit is
2252 if Is_Entity_Name (P) then
2254 K : constant Entity_Kind := Ekind (Entity (P));
2255 T : constant Entity_Id := Etype (Entity (P));
2258 if K in Subprogram_Kind
2259 or else K in Task_Kind
2260 or else K in Protected_Kind
2261 or else K = E_Package
2262 or else K in Generic_Unit_Kind
2263 or else (K = E_Variable
2267 Is_Protected_Type (T)))
2274 Error_Attr_P ("prefix of % attribute must be program unit");
2275 end Check_Program_Unit;
2277 ---------------------
2278 -- Check_Real_Type --
2279 ---------------------
2281 procedure Check_Real_Type is
2285 if not Is_Real_Type (P_Type) then
2286 Error_Attr_P ("prefix of % attribute must be real type");
2288 end Check_Real_Type;
2290 -----------------------
2291 -- Check_Scalar_Type --
2292 -----------------------
2294 procedure Check_Scalar_Type is
2298 if not Is_Scalar_Type (P_Type) then
2299 Error_Attr_P ("prefix of % attribute must be scalar type");
2301 end Check_Scalar_Type;
2303 ------------------------------------------
2304 -- Check_SPARK_05_Restriction_On_Attribute --
2305 ------------------------------------------
2307 procedure Check_SPARK_05_Restriction_On_Attribute is
2309 Error_Msg_Name_1 := Aname;
2310 Check_SPARK_05_Restriction ("attribute % is not allowed", P);
2311 end Check_SPARK_05_Restriction_On_Attribute;
2313 ---------------------------
2314 -- Check_Standard_Prefix --
2315 ---------------------------
2317 procedure Check_Standard_Prefix is
2321 if Nkind (P) /= N_Identifier or else Chars (P) /= Name_Standard then
2322 Error_Attr ("only allowed prefix for % attribute is Standard", P);
2324 end Check_Standard_Prefix;
2326 ----------------------------
2327 -- Check_Stream_Attribute --
2328 ----------------------------
2330 procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is
2334 In_Shared_Var_Procs : Boolean;
2335 -- True when compiling System.Shared_Storage.Shared_Var_Procs body.
2336 -- For this runtime package (always compiled in GNAT mode), we allow
2337 -- stream attributes references for limited types for the case where
2338 -- shared passive objects are implemented using stream attributes,
2339 -- which is the default in GNAT's persistent storage implementation.
2342 Validate_Non_Static_Attribute_Function_Call;
2344 -- With the exception of 'Input, Stream attributes are procedures,
2345 -- and can only appear at the position of procedure calls. We check
2346 -- for this here, before they are rewritten, to give a more precise
2349 if Nam = TSS_Stream_Input then
2352 elsif Is_List_Member (N)
2353 and then not Nkind_In (Parent (N), N_Procedure_Call_Statement,
2360 ("invalid context for attribute%, which is a procedure", N);
2364 Btyp := Implementation_Base_Type (P_Type);
2366 -- Stream attributes not allowed on limited types unless the
2367 -- attribute reference was generated by the expander (in which
2368 -- case the underlying type will be used, as described in Sinfo),
2369 -- or the attribute was specified explicitly for the type itself
2370 -- or one of its ancestors (taking visibility rules into account if
2371 -- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp
2372 -- (with no visibility restriction).
2375 Gen_Body : constant Node_Id := Enclosing_Generic_Body (N);
2377 if Present (Gen_Body) then
2378 In_Shared_Var_Procs :=
2379 Is_RTE (Corresponding_Spec (Gen_Body), RE_Shared_Var_Procs);
2381 In_Shared_Var_Procs := False;
2385 if (Comes_From_Source (N)
2386 and then not (In_Shared_Var_Procs or In_Instance))
2387 and then not Stream_Attribute_Available (P_Type, Nam)
2388 and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert)
2390 Error_Msg_Name_1 := Aname;
2392 if Is_Limited_Type (P_Type) then
2394 ("limited type& has no% attribute", P, P_Type);
2395 Explain_Limited_Type (P_Type, P);
2398 ("attribute% for type& is not available", P, P_Type);
2402 -- Check for no stream operations allowed from No_Tagged_Streams
2404 if Is_Tagged_Type (P_Type)
2405 and then Present (No_Tagged_Streams_Pragma (P_Type))
2407 Error_Msg_Sloc := Sloc (No_Tagged_Streams_Pragma (P_Type));
2409 ("no stream operations for & (No_Tagged_Streams #)", N, P_Type);
2413 -- Check restriction violations
2415 -- First check the No_Streams restriction, which prohibits the use
2416 -- of explicit stream attributes in the source program. We do not
2417 -- prevent the occurrence of stream attributes in generated code,
2418 -- for instance those generated implicitly for dispatching purposes.
2420 if Comes_From_Source (N) then
2421 Check_Restriction (No_Streams, P);
2424 -- AI05-0057: if restriction No_Default_Stream_Attributes is active,
2425 -- it is illegal to use a predefined elementary type stream attribute
2426 -- either by itself, or more importantly as part of the attribute
2427 -- subprogram for a composite type. However, if the broader
2428 -- restriction No_Streams is active, stream operations are not
2429 -- generated, and there is no error.
2431 if Restriction_Active (No_Default_Stream_Attributes)
2432 and then not Restriction_Active (No_Streams)
2438 if Nam = TSS_Stream_Input
2440 Nam = TSS_Stream_Read
2443 Type_Without_Stream_Operation (P_Type, TSS_Stream_Read);
2446 Type_Without_Stream_Operation (P_Type, TSS_Stream_Write);
2450 Check_Restriction (No_Default_Stream_Attributes, N);
2453 ("missing user-defined Stream Read or Write for type&",
2455 if not Is_Elementary_Type (P_Type) then
2457 ("\which is a component of type&", N, P_Type);
2463 -- Check special case of Exception_Id and Exception_Occurrence which
2464 -- are not allowed for restriction No_Exception_Registration.
2466 if Restriction_Check_Required (No_Exception_Registration)
2467 and then (Is_RTE (P_Type, RE_Exception_Id)
2469 Is_RTE (P_Type, RE_Exception_Occurrence))
2471 Check_Restriction (No_Exception_Registration, P);
2474 -- Here we must check that the first argument is an access type
2475 -- that is compatible with Ada.Streams.Root_Stream_Type'Class.
2477 Analyze_And_Resolve (E1);
2480 -- Note: the double call to Root_Type here is needed because the
2481 -- root type of a class-wide type is the corresponding type (e.g.
2482 -- X for X'Class, and we really want to go to the root.)
2484 if not Is_Access_Type (Etyp)
2485 or else Root_Type (Root_Type (Designated_Type (Etyp))) /=
2486 RTE (RE_Root_Stream_Type)
2489 ("expected access to Ada.Streams.Root_Stream_Type''Class", E1);
2492 -- Check that the second argument is of the right type if there is
2493 -- one (the Input attribute has only one argument so this is skipped)
2495 if Present (E2) then
2498 if Nam = TSS_Stream_Read
2499 and then not Is_OK_Variable_For_Out_Formal (E2)
2502 ("second argument of % attribute must be a variable", E2);
2505 Resolve (E2, P_Type);
2509 end Check_Stream_Attribute;
2511 -------------------------
2512 -- Check_System_Prefix --
2513 -------------------------
2515 procedure Check_System_Prefix is
2517 if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then
2518 Error_Attr ("only allowed prefix for % attribute is System", P);
2520 end Check_System_Prefix;
2522 -----------------------
2523 -- Check_Task_Prefix --
2524 -----------------------
2526 procedure Check_Task_Prefix is
2530 -- Ada 2005 (AI-345): Attribute 'Terminated can be applied to
2531 -- task interface class-wide types.
2533 if Is_Task_Type (Etype (P))
2534 or else (Is_Access_Type (Etype (P))
2535 and then Is_Task_Type (Designated_Type (Etype (P))))
2536 or else (Ada_Version >= Ada_2005
2537 and then Ekind (Etype (P)) = E_Class_Wide_Type
2538 and then Is_Interface (Etype (P))
2539 and then Is_Task_Interface (Etype (P)))
2544 if Ada_Version >= Ada_2005 then
2546 ("prefix of % attribute must be a task or a task " &
2547 "interface class-wide object");
2550 Error_Attr_P ("prefix of % attribute must be a task");
2553 end Check_Task_Prefix;
2559 -- The possibilities are an entity name denoting a type, or an
2560 -- attribute reference that denotes a type (Base or Class). If
2561 -- the type is incomplete, replace it with its full view.
2563 procedure Check_Type is
2565 if not Is_Entity_Name (P)
2566 or else not Is_Type (Entity (P))
2568 Error_Attr_P ("prefix of % attribute must be a type");
2570 elsif Is_Protected_Self_Reference (P) then
2572 ("prefix of % attribute denotes current instance "
2573 & "(RM 9.4(21/2))");
2575 elsif Ekind (Entity (P)) = E_Incomplete_Type
2576 and then Present (Full_View (Entity (P)))
2578 P_Type := Full_View (Entity (P));
2579 Set_Entity (P, P_Type);
2583 ---------------------
2584 -- Check_Unit_Name --
2585 ---------------------
2587 procedure Check_Unit_Name (Nod : Node_Id) is
2589 if Nkind (Nod) = N_Identifier then
2592 elsif Nkind_In (Nod, N_Selected_Component, N_Expanded_Name) then
2593 Check_Unit_Name (Prefix (Nod));
2595 if Nkind (Selector_Name (Nod)) = N_Identifier then
2600 Error_Attr ("argument for % attribute must be unit name", P);
2601 end Check_Unit_Name;
2607 procedure Error_Attr is
2609 Set_Etype (N, Any_Type);
2610 Set_Entity (N, Any_Type);
2611 raise Bad_Attribute;
2614 procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
2616 Error_Msg_Name_1 := Aname;
2617 Error_Msg_N (Msg, Error_Node);
2625 procedure Error_Attr_P (Msg : String) is
2627 Error_Msg_Name_1 := Aname;
2628 Error_Msg_F (Msg, P);
2632 ----------------------------
2633 -- Legal_Formal_Attribute --
2634 ----------------------------
2636 procedure Legal_Formal_Attribute is
2640 if not Is_Entity_Name (P)
2641 or else not Is_Type (Entity (P))
2643 Error_Attr_P ("prefix of % attribute must be generic type");
2645 elsif Is_Generic_Actual_Type (Entity (P))
2647 or else In_Inlined_Body
2651 elsif Is_Generic_Type (Entity (P)) then
2652 if Is_Definite_Subtype (Entity (P)) then
2654 ("prefix of % attribute must be indefinite generic type");
2659 ("prefix of % attribute must be indefinite generic type");
2662 Set_Etype (N, Standard_Boolean);
2663 end Legal_Formal_Attribute;
2665 ---------------------------------------------------------------
2666 -- Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements --
2667 ---------------------------------------------------------------
2669 procedure Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements is
2673 Check_Not_Incomplete_Type;
2674 Set_Etype (N, Universal_Integer);
2675 end Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements;
2681 procedure Min_Max is
2685 Resolve (E1, P_Base_Type);
2686 Resolve (E2, P_Base_Type);
2687 Set_Etype (N, P_Base_Type);
2689 -- Check for comparison on unordered enumeration type
2691 if Bad_Unordered_Enumeration_Reference (N, P_Base_Type) then
2692 Error_Msg_Sloc := Sloc (P_Base_Type);
2694 ("comparison on unordered enumeration type& declared#?U?",
2699 ------------------------
2700 -- Standard_Attribute --
2701 ------------------------
2703 procedure Standard_Attribute (Val : Int) is
2705 Check_Standard_Prefix;
2706 Rewrite (N, Make_Integer_Literal (Loc, Val));
2708 Set_Is_Static_Expression (N, True);
2709 end Standard_Attribute;
2711 --------------------
2712 -- Uneval_Old_Msg --
2713 --------------------
2715 procedure Uneval_Old_Msg is
2716 Uneval_Old_Setting : Character;
2720 -- If from aspect, then Uneval_Old_Setting comes from flags in the
2721 -- N_Aspect_Specification node that corresponds to the attribute.
2723 -- First find the pragma in which we appear (note that at this stage,
2724 -- even if we appeared originally within an aspect specification, we
2725 -- are now within the corresponding pragma).
2729 Prag := Parent (Prag);
2730 exit when No (Prag) or else Nkind (Prag) = N_Pragma;
2733 if Present (Prag) then
2734 if Uneval_Old_Accept (Prag) then
2735 Uneval_Old_Setting := 'A';
2736 elsif Uneval_Old_Warn (Prag) then
2737 Uneval_Old_Setting := 'W';
2739 Uneval_Old_Setting := 'E';
2742 -- If we did not find the pragma, that's odd, just use the setting
2743 -- from Opt.Uneval_Old. Perhaps this is due to a previous error?
2746 Uneval_Old_Setting := Opt.Uneval_Old;
2749 -- Processing depends on the setting of Uneval_Old
2751 case Uneval_Old_Setting is
2754 ("prefix of attribute % that is potentially "
2755 & "unevaluated must denote an entity");
2758 Error_Msg_Name_1 := Aname;
2760 ("??prefix of attribute % appears in potentially "
2761 & "unevaluated context, exception may be raised", P);
2767 raise Program_Error;
2771 -------------------------
2772 -- Unexpected Argument --
2773 -------------------------
2775 procedure Unexpected_Argument (En : Node_Id) is
2777 Error_Attr ("unexpected argument for % attribute", En);
2778 end Unexpected_Argument;
2780 -------------------------------------------------
2781 -- Validate_Non_Static_Attribute_Function_Call --
2782 -------------------------------------------------
2784 -- This function should be moved to Sem_Dist ???
2786 procedure Validate_Non_Static_Attribute_Function_Call is
2788 if In_Preelaborated_Unit
2789 and then not In_Subprogram_Or_Concurrent_Unit
2791 Flag_Non_Static_Expr
2792 ("non-static function call in preelaborated unit!", N);
2794 end Validate_Non_Static_Attribute_Function_Call;
2796 -- Start of processing for Analyze_Attribute
2799 -- Immediate return if unrecognized attribute (already diagnosed by
2800 -- parser, so there is nothing more that we need to do).
2802 if not Is_Attribute_Name (Aname) then
2803 raise Bad_Attribute;
2806 Check_Restriction_No_Use_Of_Attribute (N);
2808 -- Deal with Ada 83 issues
2810 if Comes_From_Source (N) then
2811 if not Attribute_83 (Attr_Id) then
2812 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
2813 Error_Msg_Name_1 := Aname;
2814 Error_Msg_N ("(Ada 83) attribute% is not standard??", N);
2817 if Attribute_Impl_Def (Attr_Id) then
2818 Check_Restriction (No_Implementation_Attributes, N);
2823 -- Deal with Ada 2005 attributes that are implementation attributes
2824 -- because they appear in a version of Ada before Ada 2005, and
2825 -- similarly for Ada 2012 attributes appearing in an earlier version.
2827 if (Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005)
2829 (Attribute_12 (Attr_Id) and then Ada_Version < Ada_2012)
2831 Check_Restriction (No_Implementation_Attributes, N);
2834 -- Remote access to subprogram type access attribute reference needs
2835 -- unanalyzed copy for tree transformation. The analyzed copy is used
2836 -- for its semantic information (whether prefix is a remote subprogram
2837 -- name), the unanalyzed copy is used to construct new subtree rooted
2838 -- with N_Aggregate which represents a fat pointer aggregate.
2840 if Aname = Name_Access then
2841 Discard_Node (Copy_Separate_Tree (N));
2844 -- Analyze prefix and exit if error in analysis. If the prefix is an
2845 -- incomplete type, use full view if available. Note that there are
2846 -- some attributes for which we do not analyze the prefix, since the
2847 -- prefix is not a normal name, or else needs special handling.
2849 if Aname /= Name_Elab_Body and then
2850 Aname /= Name_Elab_Spec and then
2851 Aname /= Name_Elab_Subp_Body and then
2852 Aname /= Name_Enabled and then
2856 P_Type := Etype (P);
2858 if Is_Entity_Name (P)
2859 and then Present (Entity (P))
2860 and then Is_Type (Entity (P))
2862 if Ekind (Entity (P)) = E_Incomplete_Type then
2863 P_Type := Get_Full_View (P_Type);
2864 Set_Entity (P, P_Type);
2865 Set_Etype (P, P_Type);
2867 elsif Entity (P) = Current_Scope
2868 and then Is_Record_Type (Entity (P))
2870 -- Use of current instance within the type. Verify that if the
2871 -- attribute appears within a constraint, it yields an access
2872 -- type, other uses are illegal.
2880 and then Nkind (Parent (Par)) /= N_Component_Definition
2882 Par := Parent (Par);
2886 and then Nkind (Par) = N_Subtype_Indication
2888 if Attr_Id /= Attribute_Access
2889 and then Attr_Id /= Attribute_Unchecked_Access
2890 and then Attr_Id /= Attribute_Unrestricted_Access
2893 ("in a constraint the current instance can only "
2894 & "be used with an access attribute", N);
2901 if P_Type = Any_Type then
2902 raise Bad_Attribute;
2905 P_Base_Type := Base_Type (P_Type);
2908 -- Analyze expressions that may be present, exiting if an error occurs
2915 E1 := First (Exprs);
2917 -- Skip analysis for case of Restriction_Set, we do not expect
2918 -- the argument to be analyzed in this case.
2920 if Aname /= Name_Restriction_Set then
2923 -- Check for missing/bad expression (result of previous error)
2925 if No (E1) or else Etype (E1) = Any_Type then
2926 raise Bad_Attribute;
2932 if Present (E2) then
2935 if Etype (E2) = Any_Type then
2936 raise Bad_Attribute;
2939 if Present (Next (E2)) then
2940 Unexpected_Argument (Next (E2));
2945 -- Cases where prefix must be resolvable by itself
2947 if Is_Overloaded (P)
2948 and then Aname /= Name_Access
2949 and then Aname /= Name_Address
2950 and then Aname /= Name_Code_Address
2951 and then Aname /= Name_Result
2952 and then Aname /= Name_Unchecked_Access
2954 -- The prefix must be resolvable by itself, without reference to the
2955 -- attribute. One case that requires special handling is a prefix
2956 -- that is a function name, where one interpretation may be a
2957 -- parameterless call. Entry attributes are handled specially below.
2959 if Is_Entity_Name (P)
2960 and then not Nam_In (Aname, Name_Count, Name_Caller)
2962 Check_Parameterless_Call (P);
2965 if Is_Overloaded (P) then
2967 -- Ada 2005 (AI-345): Since protected and task types have
2968 -- primitive entry wrappers, the attributes Count, and Caller
2969 -- require a context check
2971 if Nam_In (Aname, Name_Count, Name_Caller) then
2973 Count : Natural := 0;
2978 Get_First_Interp (P, I, It);
2979 while Present (It.Nam) loop
2980 if Comes_From_Source (It.Nam) then
2986 Get_Next_Interp (I, It);
2990 Error_Attr ("ambiguous prefix for % attribute", P);
2992 Set_Is_Overloaded (P, False);
2997 Error_Attr ("ambiguous prefix for % attribute", P);
3002 -- In SPARK, attributes of private types are only allowed if the full
3003 -- type declaration is visible.
3005 -- Note: the check for Present (Entity (P)) defends against some error
3006 -- conditions where the Entity field is not set.
3008 if Is_Entity_Name (P) and then Present (Entity (P))
3009 and then Is_Type (Entity (P))
3010 and then Is_Private_Type (P_Type)
3011 and then not In_Open_Scopes (Scope (P_Type))
3012 and then not In_Spec_Expression
3014 Check_SPARK_05_Restriction ("invisible attribute of type", N);
3017 -- Remaining processing depends on attribute
3021 -- Attributes related to Ada 2012 iterators. Attribute specifications
3022 -- exist for these, but they cannot be queried.
3024 when Attribute_Constant_Indexing
3025 | Attribute_Default_Iterator
3026 | Attribute_Implicit_Dereference
3027 | Attribute_Iterator_Element
3028 | Attribute_Iterable
3029 | Attribute_Variable_Indexing
3031 Error_Msg_N ("illegal attribute", N);
3033 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
3034 -- were already rejected by the parser. Thus they shouldn't appear here.
3036 when Internal_Attribute_Id =>
3037 raise Program_Error;
3043 when Attribute_Abort_Signal =>
3044 Check_Standard_Prefix;
3045 Rewrite (N, New_Occurrence_Of (Stand.Abort_Signal, Loc));
3052 when Attribute_Access =>
3053 Analyze_Access_Attribute;
3054 Check_Not_Incomplete_Type;
3060 when Attribute_Address =>
3063 Check_Not_Incomplete_Type;
3064 Set_Etype (N, RTE (RE_Address));
3070 when Attribute_Address_Size =>
3071 Standard_Attribute (System_Address_Size);
3077 when Attribute_Adjacent =>
3078 Check_Floating_Point_Type_2;
3079 Set_Etype (N, P_Base_Type);
3080 Resolve (E1, P_Base_Type);
3081 Resolve (E2, P_Base_Type);
3087 when Attribute_Aft =>
3088 Check_Fixed_Point_Type_0;
3089 Set_Etype (N, Universal_Integer);
3095 when Attribute_Alignment =>
3097 -- Don't we need more checking here, cf Size ???
3100 Check_Not_Incomplete_Type;
3102 Set_Etype (N, Universal_Integer);
3108 when Attribute_Asm_Input =>
3109 Check_Asm_Attribute;
3111 -- The back end may need to take the address of E2
3113 if Is_Entity_Name (E2) then
3114 Set_Address_Taken (Entity (E2));
3117 Set_Etype (N, RTE (RE_Asm_Input_Operand));
3123 when Attribute_Asm_Output =>
3124 Check_Asm_Attribute;
3126 if Etype (E2) = Any_Type then
3129 elsif Aname = Name_Asm_Output then
3130 if not Is_Variable (E2) then
3132 ("second argument for Asm_Output is not variable", E2);
3136 Note_Possible_Modification (E2, Sure => True);
3138 -- The back end may need to take the address of E2
3140 if Is_Entity_Name (E2) then
3141 Set_Address_Taken (Entity (E2));
3144 Set_Etype (N, RTE (RE_Asm_Output_Operand));
3146 -----------------------------
3147 -- Atomic_Always_Lock_Free --
3148 -----------------------------
3150 when Attribute_Atomic_Always_Lock_Free =>
3153 Set_Etype (N, Standard_Boolean);
3159 -- Note: when the base attribute appears in the context of a subtype
3160 -- mark, the analysis is done by Sem_Ch8.Find_Type, rather than by
3161 -- the following circuit.
3163 when Attribute_Base => Base : declare
3171 if Ada_Version >= Ada_95
3172 and then not Is_Scalar_Type (Typ)
3173 and then not Is_Generic_Type (Typ)
3175 Error_Attr_P ("prefix of Base attribute must be scalar type");
3177 elsif Sloc (Typ) = Standard_Location
3178 and then Base_Type (Typ) = Typ
3179 and then Warn_On_Redundant_Constructs
3181 Error_Msg_NE -- CODEFIX
3182 ("?r?redundant attribute, & is its own base type", N, Typ);
3185 if Nkind (Parent (N)) /= N_Attribute_Reference then
3186 Error_Msg_Name_1 := Aname;
3187 Check_SPARK_05_Restriction
3188 ("attribute% is only allowed as prefix of another attribute", P);
3191 Set_Etype (N, Base_Type (Entity (P)));
3192 Set_Entity (N, Base_Type (Entity (P)));
3193 Rewrite (N, New_Occurrence_Of (Entity (N), Loc));
3201 when Attribute_Bit =>
3204 if not Is_Object_Reference (P) then
3205 Error_Attr_P ("prefix for % attribute must be object");
3207 -- What about the access object cases ???
3213 Set_Etype (N, Universal_Integer);
3219 when Attribute_Bit_Order =>
3223 if not Is_Record_Type (P_Type) then
3224 Error_Attr_P ("prefix of % attribute must be record type");
3227 if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then
3229 New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
3232 New_Occurrence_Of (RTE (RE_Low_Order_First), Loc));
3235 Set_Etype (N, RTE (RE_Bit_Order));
3238 -- Reset incorrect indication of staticness
3240 Set_Is_Static_Expression (N, False);
3246 -- Note: in generated code, we can have a Bit_Position attribute
3247 -- applied to a (naked) record component (i.e. the prefix is an
3248 -- identifier that references an E_Component or E_Discriminant
3249 -- entity directly, and this is interpreted as expected by Gigi.
3250 -- The following code will not tolerate such usage, but when the
3251 -- expander creates this special case, it marks it as analyzed
3252 -- immediately and sets an appropriate type.
3254 when Attribute_Bit_Position =>
3255 if Comes_From_Source (N) then
3259 Set_Etype (N, Universal_Integer);
3265 when Attribute_Body_Version =>
3268 Set_Etype (N, RTE (RE_Version_String));
3274 when Attribute_Callable =>
3276 Set_Etype (N, Standard_Boolean);
3283 when Attribute_Caller => Caller : declare
3290 if Nkind_In (P, N_Identifier, N_Expanded_Name) then
3293 if not Is_Entry (Ent) then
3294 Error_Attr ("invalid entry name", N);
3298 Error_Attr ("invalid entry name", N);
3302 for J in reverse 0 .. Scope_Stack.Last loop
3303 S := Scope_Stack.Table (J).Entity;
3305 if S = Scope (Ent) then
3306 Error_Attr ("Caller must appear in matching accept or body", N);
3312 Set_Etype (N, RTE (RO_AT_Task_Id));
3319 when Attribute_Ceiling =>
3320 Check_Floating_Point_Type_1;
3321 Set_Etype (N, P_Base_Type);
3322 Resolve (E1, P_Base_Type);
3328 when Attribute_Class =>
3329 Check_Restriction (No_Dispatch, N);
3333 -- Applying Class to untagged incomplete type is obsolescent in Ada
3334 -- 2005. Note that we can't test Is_Tagged_Type here on P_Type, since
3335 -- this flag gets set by Find_Type in this situation.
3337 if Restriction_Check_Required (No_Obsolescent_Features)
3338 and then Ada_Version >= Ada_2005
3339 and then Ekind (P_Type) = E_Incomplete_Type
3342 DN : constant Node_Id := Declaration_Node (P_Type);
3344 if Nkind (DN) = N_Incomplete_Type_Declaration
3345 and then not Tagged_Present (DN)
3347 Check_Restriction (No_Obsolescent_Features, P);
3356 when Attribute_Code_Address =>
3359 if Nkind (P) = N_Attribute_Reference
3360 and then Nam_In (Attribute_Name (P), Name_Elab_Body, Name_Elab_Spec)
3364 elsif not Is_Entity_Name (P)
3365 or else (Ekind (Entity (P)) /= E_Function
3367 Ekind (Entity (P)) /= E_Procedure)
3369 Error_Attr ("invalid prefix for % attribute", P);
3370 Set_Address_Taken (Entity (P));
3372 -- Issue an error if the prefix denotes an eliminated subprogram
3375 Check_For_Eliminated_Subprogram (P, Entity (P));
3378 Set_Etype (N, RTE (RE_Address));
3380 ----------------------
3381 -- Compiler_Version --
3382 ----------------------
3384 when Attribute_Compiler_Version =>
3386 Check_Standard_Prefix;
3387 Rewrite (N, Make_String_Literal (Loc, "GNAT " & Gnat_Version_String));
3388 Analyze_And_Resolve (N, Standard_String);
3389 Set_Is_Static_Expression (N, True);
3391 --------------------
3392 -- Component_Size --
3393 --------------------
3395 when Attribute_Component_Size =>
3397 Set_Etype (N, Universal_Integer);
3399 -- Note: unlike other array attributes, unconstrained arrays are OK
3401 if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then
3411 when Attribute_Compose =>
3412 Check_Floating_Point_Type_2;
3413 Set_Etype (N, P_Base_Type);
3414 Resolve (E1, P_Base_Type);
3415 Resolve (E2, Any_Integer);
3421 when Attribute_Constrained =>
3423 Set_Etype (N, Standard_Boolean);
3425 -- Case from RM J.4(2) of constrained applied to private type
3427 if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
3428 Check_Restriction (No_Obsolescent_Features, P);
3430 if Warn_On_Obsolescent_Feature then
3432 ("constrained for private type is an obsolescent feature "
3433 & "(RM J.4)?j?", N);
3436 -- If we are within an instance, the attribute must be legal
3437 -- because it was valid in the generic unit. Ditto if this is
3438 -- an inlining of a function declared in an instance.
3440 if In_Instance or else In_Inlined_Body then
3443 -- For sure OK if we have a real private type itself, but must
3444 -- be completed, cannot apply Constrained to incomplete type.
3446 elsif Is_Private_Type (Entity (P)) then
3448 -- Note: this is one of the Annex J features that does not
3449 -- generate a warning from -gnatwj, since in fact it seems
3450 -- very useful, and is used in the GNAT runtime.
3452 Check_Not_Incomplete_Type;
3456 -- Normal (non-obsolescent case) of application to object of
3457 -- a discriminated type.
3460 Check_Object_Reference (P);
3462 -- If N does not come from source, then we allow the
3463 -- the attribute prefix to be of a private type whose
3464 -- full type has discriminants. This occurs in cases
3465 -- involving expanded calls to stream attributes.
3467 if not Comes_From_Source (N) then
3468 P_Type := Underlying_Type (P_Type);
3471 -- Must have discriminants or be an access type designating a type
3472 -- with discriminants. If it is a class-wide type it has unknown
3475 if Has_Discriminants (P_Type)
3476 or else Has_Unknown_Discriminants (P_Type)
3478 (Is_Access_Type (P_Type)
3479 and then Has_Discriminants (Designated_Type (P_Type)))
3483 -- The rule given in 3.7.2 is part of static semantics, but the
3484 -- intent is clearly that it be treated as a legality rule, and
3485 -- rechecked in the visible part of an instance. Nevertheless
3486 -- the intent also seems to be it should legally apply to the
3487 -- actual of a formal with unknown discriminants, regardless of
3488 -- whether the actual has discriminants, in which case the value
3489 -- of the attribute is determined using the J.4 rules. This choice
3490 -- seems the most useful, and is compatible with existing tests.
3492 elsif In_Instance then
3495 -- Also allow an object of a generic type if extensions allowed
3496 -- and allow this for any type at all. (this may be obsolete ???)
3498 elsif (Is_Generic_Type (P_Type)
3499 or else Is_Generic_Actual_Type (P_Type))
3500 and then Extensions_Allowed
3506 -- Fall through if bad prefix
3509 ("prefix of % attribute must be object of discriminated type");
3515 when Attribute_Copy_Sign =>
3516 Check_Floating_Point_Type_2;
3517 Set_Etype (N, P_Base_Type);
3518 Resolve (E1, P_Base_Type);
3519 Resolve (E2, P_Base_Type);
3525 when Attribute_Count => Count : declare
3533 if Nkind_In (P, N_Identifier, N_Expanded_Name) then
3536 if Ekind (Ent) /= E_Entry then
3537 Error_Attr ("invalid entry name", N);
3540 elsif Nkind (P) = N_Indexed_Component then
3541 if not Is_Entity_Name (Prefix (P))
3542 or else No (Entity (Prefix (P)))
3543 or else Ekind (Entity (Prefix (P))) /= E_Entry_Family
3545 if Nkind (Prefix (P)) = N_Selected_Component
3546 and then Present (Entity (Selector_Name (Prefix (P))))
3547 and then Ekind (Entity (Selector_Name (Prefix (P)))) =
3551 ("attribute % must apply to entry of current task", P);
3554 Error_Attr ("invalid entry family name", P);
3559 Ent := Entity (Prefix (P));
3562 elsif Nkind (P) = N_Selected_Component
3563 and then Present (Entity (Selector_Name (P)))
3564 and then Ekind (Entity (Selector_Name (P))) = E_Entry
3567 ("attribute % must apply to entry of current task", P);
3570 Error_Attr ("invalid entry name", N);
3574 for J in reverse 0 .. Scope_Stack.Last loop
3575 S := Scope_Stack.Table (J).Entity;
3577 if S = Scope (Ent) then
3578 if Nkind (P) = N_Expanded_Name then
3579 Tsk := Entity (Prefix (P));
3581 -- The prefix denotes either the task type, or else a
3582 -- single task whose task type is being analyzed.
3584 if (Is_Type (Tsk) and then Tsk = S)
3585 or else (not Is_Type (Tsk)
3586 and then Etype (Tsk) = S
3587 and then not (Comes_From_Source (S)))
3592 ("Attribute % must apply to entry of current task", N);
3598 elsif Ekind (Scope (Ent)) in Task_Kind
3599 and then not Ekind_In (S, E_Block,
3604 Error_Attr ("Attribute % cannot appear in inner unit", N);
3606 elsif Ekind (Scope (Ent)) = E_Protected_Type
3607 and then not Has_Completion (Scope (Ent))
3609 Error_Attr ("attribute % can only be used inside body", N);
3613 if Is_Overloaded (P) then
3615 Index : Interp_Index;
3619 Get_First_Interp (P, Index, It);
3620 while Present (It.Nam) loop
3621 if It.Nam = Ent then
3624 -- Ada 2005 (AI-345): Do not consider primitive entry
3625 -- wrappers generated for task or protected types.
3627 elsif Ada_Version >= Ada_2005
3628 and then not Comes_From_Source (It.Nam)
3633 Error_Attr ("ambiguous entry name", N);
3636 Get_Next_Interp (Index, It);
3641 Set_Etype (N, Universal_Integer);
3644 -----------------------
3645 -- Default_Bit_Order --
3646 -----------------------
3648 when Attribute_Default_Bit_Order => Default_Bit_Order : declare
3649 Target_Default_Bit_Order : System.Bit_Order;
3652 Check_Standard_Prefix;
3654 if Bytes_Big_Endian then
3655 Target_Default_Bit_Order := System.High_Order_First;
3657 Target_Default_Bit_Order := System.Low_Order_First;
3661 Make_Integer_Literal (Loc,
3662 UI_From_Int (System.Bit_Order'Pos (Target_Default_Bit_Order))));
3664 Set_Etype (N, Universal_Integer);
3665 Set_Is_Static_Expression (N);
3666 end Default_Bit_Order;
3668 ----------------------------------
3669 -- Default_Scalar_Storage_Order --
3670 ----------------------------------
3672 when Attribute_Default_Scalar_Storage_Order => Default_SSO : declare
3673 RE_Default_SSO : RE_Id;
3676 Check_Standard_Prefix;
3678 case Opt.Default_SSO is
3680 if Bytes_Big_Endian then
3681 RE_Default_SSO := RE_High_Order_First;
3683 RE_Default_SSO := RE_Low_Order_First;
3687 RE_Default_SSO := RE_High_Order_First;
3690 RE_Default_SSO := RE_Low_Order_First;
3693 raise Program_Error;
3696 Rewrite (N, New_Occurrence_Of (RTE (RE_Default_SSO), Loc));
3703 when Attribute_Definite =>
3704 Legal_Formal_Attribute;
3710 when Attribute_Delta =>
3711 Check_Fixed_Point_Type_0;
3712 Set_Etype (N, Universal_Real);
3718 when Attribute_Denorm =>
3719 Check_Floating_Point_Type_0;
3720 Set_Etype (N, Standard_Boolean);
3726 when Attribute_Deref =>
3729 Resolve (E1, RTE (RE_Address));
3730 Set_Etype (N, P_Type);
3732 ---------------------
3733 -- Descriptor_Size --
3734 ---------------------
3736 when Attribute_Descriptor_Size =>
3739 if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then
3740 Error_Attr_P ("prefix of attribute % must denote a type");
3743 Set_Etype (N, Universal_Integer);
3749 when Attribute_Digits =>
3753 if not Is_Floating_Point_Type (P_Type)
3754 and then not Is_Decimal_Fixed_Point_Type (P_Type)
3757 ("prefix of % attribute must be float or decimal type");
3760 Set_Etype (N, Universal_Integer);
3766 -- Also handles processing for Elab_Spec and Elab_Subp_Body
3768 when Attribute_Elab_Body
3769 | Attribute_Elab_Spec
3770 | Attribute_Elab_Subp_Body
3773 Check_Unit_Name (P);
3774 Set_Etype (N, Standard_Void_Type);
3776 -- We have to manually call the expander in this case to get
3777 -- the necessary expansion (normally attributes that return
3778 -- entities are not expanded).
3786 -- Shares processing with Elab_Body
3792 when Attribute_Elaborated =>
3794 Check_Unit_Name (P);
3795 Set_Etype (N, Standard_Boolean);
3801 when Attribute_Emax =>
3802 Check_Floating_Point_Type_0;
3803 Set_Etype (N, Universal_Integer);
3809 when Attribute_Enabled =>
3810 Check_Either_E0_Or_E1;
3812 if Present (E1) then
3813 if not Is_Entity_Name (E1) or else No (Entity (E1)) then
3814 Error_Msg_N ("entity name expected for Enabled attribute", E1);
3819 if Nkind (P) /= N_Identifier then
3820 Error_Msg_N ("identifier expected (check name)", P);
3821 elsif Get_Check_Id (Chars (P)) = No_Check_Id then
3822 Error_Msg_N ("& is not a recognized check name", P);
3825 Set_Etype (N, Standard_Boolean);
3831 when Attribute_Enum_Rep =>
3833 -- T'Enum_Rep (X) case
3835 if Present (E1) then
3837 Check_Discrete_Type;
3838 Resolve (E1, P_Base_Type);
3840 -- X'Enum_Rep case. X must be an object or enumeration literal
3841 -- (including an attribute reference), and it must be of a
3845 ((Is_Object_Reference (P)
3848 and then Ekind (Entity (P)) = E_Enumeration_Literal)
3849 or else Nkind (P) = N_Attribute_Reference)
3850 and then Is_Discrete_Type (Etype (P)))
3852 Error_Attr_P ("prefix of % attribute must be discrete object");
3855 Set_Etype (N, Universal_Integer);
3861 when Attribute_Enum_Val =>
3865 if not Is_Enumeration_Type (P_Type) then
3866 Error_Attr_P ("prefix of % attribute must be enumeration type");
3869 -- If the enumeration type has a standard representation, the effect
3870 -- is the same as 'Val, so rewrite the attribute as a 'Val.
3872 if not Has_Non_Standard_Rep (P_Base_Type) then
3874 Make_Attribute_Reference (Loc,
3875 Prefix => Relocate_Node (Prefix (N)),
3876 Attribute_Name => Name_Val,
3877 Expressions => New_List (Relocate_Node (E1))));
3878 Analyze_And_Resolve (N, P_Base_Type);
3880 -- Non-standard representation case (enumeration with holes)
3884 Resolve (E1, Any_Integer);
3885 Set_Etype (N, P_Base_Type);
3892 when Attribute_Epsilon =>
3893 Check_Floating_Point_Type_0;
3894 Set_Etype (N, Universal_Real);
3900 when Attribute_Exponent =>
3901 Check_Floating_Point_Type_1;
3902 Set_Etype (N, Universal_Integer);
3903 Resolve (E1, P_Base_Type);
3909 when Attribute_External_Tag =>
3913 Set_Etype (N, Standard_String);
3915 if not Is_Tagged_Type (P_Type) then
3916 Error_Attr_P ("prefix of % attribute must be tagged");
3923 when Attribute_Fast_Math =>
3924 Check_Standard_Prefix;
3925 Rewrite (N, New_Occurrence_Of (Boolean_Literals (Fast_Math), Loc));
3927 -----------------------
3928 -- Finalization_Size --
3929 -----------------------
3931 when Attribute_Finalization_Size =>
3934 -- The prefix denotes an object
3936 if Is_Object_Reference (P) then
3937 Check_Object_Reference (P);
3939 -- The prefix denotes a type
3941 elsif Is_Entity_Name (P) and then Is_Type (Entity (P)) then
3943 Check_Not_Incomplete_Type;
3945 -- Attribute 'Finalization_Size is not defined for class-wide
3946 -- types because it is not possible to know statically whether
3947 -- a definite type will have controlled components or not.
3949 if Is_Class_Wide_Type (Etype (P)) then
3951 ("prefix of % attribute cannot denote a class-wide type");
3954 -- The prefix denotes an illegal construct
3958 ("prefix of % attribute must be a definite type or an object");
3961 Set_Etype (N, Universal_Integer);
3967 when Attribute_First =>
3968 Check_Array_Or_Scalar_Type;
3969 Bad_Attribute_For_Predicate;
3975 when Attribute_First_Bit =>
3977 Set_Etype (N, Universal_Integer);
3983 when Attribute_First_Valid =>
3984 Check_First_Last_Valid;
3985 Set_Etype (N, P_Type);
3991 when Attribute_Fixed_Value =>
3993 Check_Fixed_Point_Type;
3994 Resolve (E1, Any_Integer);
3995 Set_Etype (N, P_Base_Type);
4001 when Attribute_Floor =>
4002 Check_Floating_Point_Type_1;
4003 Set_Etype (N, P_Base_Type);
4004 Resolve (E1, P_Base_Type);
4010 when Attribute_Fore =>
4011 Check_Fixed_Point_Type_0;
4012 Set_Etype (N, Universal_Integer);
4018 when Attribute_Fraction =>
4019 Check_Floating_Point_Type_1;
4020 Set_Etype (N, P_Base_Type);
4021 Resolve (E1, P_Base_Type);
4027 when Attribute_From_Any =>
4029 Check_PolyORB_Attribute;
4030 Set_Etype (N, P_Base_Type);
4032 -----------------------
4033 -- Has_Access_Values --
4034 -----------------------
4036 when Attribute_Has_Access_Values =>
4039 Set_Etype (N, Standard_Boolean);
4041 ----------------------
4042 -- Has_Same_Storage --
4043 ----------------------
4045 when Attribute_Has_Same_Storage =>
4048 -- The arguments must be objects of any type
4050 Analyze_And_Resolve (P);
4051 Analyze_And_Resolve (E1);
4052 Check_Object_Reference (P);
4053 Check_Object_Reference (E1);
4054 Set_Etype (N, Standard_Boolean);
4056 -----------------------
4057 -- Has_Tagged_Values --
4058 -----------------------
4060 when Attribute_Has_Tagged_Values =>
4063 Set_Etype (N, Standard_Boolean);
4065 -----------------------
4066 -- Has_Discriminants --
4067 -----------------------
4069 when Attribute_Has_Discriminants =>
4070 Legal_Formal_Attribute;
4076 when Attribute_Identity =>
4080 if Etype (P) = Standard_Exception_Type then
4081 Set_Etype (N, RTE (RE_Exception_Id));
4083 -- Ada 2005 (AI-345): Attribute 'Identity may be applied to task
4084 -- interface class-wide types.
4086 elsif Is_Task_Type (Etype (P))
4087 or else (Is_Access_Type (Etype (P))
4088 and then Is_Task_Type (Designated_Type (Etype (P))))
4089 or else (Ada_Version >= Ada_2005
4090 and then Ekind (Etype (P)) = E_Class_Wide_Type
4091 and then Is_Interface (Etype (P))
4092 and then Is_Task_Interface (Etype (P)))
4095 Set_Etype (N, RTE (RO_AT_Task_Id));
4098 if Ada_Version >= Ada_2005 then
4100 ("prefix of % attribute must be an exception, a task or a "
4101 & "task interface class-wide object");
4104 ("prefix of % attribute must be a task or an exception");
4112 when Attribute_Image =>
4113 if Is_Real_Type (P_Type) then
4114 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
4115 Error_Msg_Name_1 := Aname;
4117 ("(Ada 83) % attribute not allowed for real types", N);
4121 Analyze_Image_Attribute (Standard_String);
4127 when Attribute_Img =>
4128 Analyze_Image_Attribute (Standard_String);
4134 when Attribute_Input =>
4136 Check_Stream_Attribute (TSS_Stream_Input);
4137 Set_Etype (N, P_Base_Type);
4143 when Attribute_Integer_Value =>
4146 Resolve (E1, Any_Fixed);
4148 -- Signal an error if argument type is not a specific fixed-point
4149 -- subtype. An error has been signalled already if the argument
4150 -- was not of a fixed-point type.
4152 if Etype (E1) = Any_Fixed and then not Error_Posted (E1) then
4153 Error_Attr ("argument of % must be of a fixed-point type", E1);
4156 Set_Etype (N, P_Base_Type);
4162 when Attribute_Invalid_Value =>
4165 Set_Etype (N, P_Base_Type);
4166 Invalid_Value_Used := True;
4172 when Attribute_Large =>
4175 Set_Etype (N, Universal_Real);
4181 when Attribute_Last =>
4182 Check_Array_Or_Scalar_Type;
4183 Bad_Attribute_For_Predicate;
4189 when Attribute_Last_Bit =>
4191 Set_Etype (N, Universal_Integer);
4197 when Attribute_Last_Valid =>
4198 Check_First_Last_Valid;
4199 Set_Etype (N, P_Type);
4205 when Attribute_Leading_Part =>
4206 Check_Floating_Point_Type_2;
4207 Set_Etype (N, P_Base_Type);
4208 Resolve (E1, P_Base_Type);
4209 Resolve (E2, Any_Integer);
4215 when Attribute_Length =>
4217 Set_Etype (N, Universal_Integer);
4223 when Attribute_Library_Level =>
4226 if not Is_Entity_Name (P) then
4227 Error_Attr_P ("prefix of % attribute must be an entity name");
4230 if not Inside_A_Generic then
4231 Set_Boolean_Result (N,
4232 Is_Library_Level_Entity (Entity (P)));
4235 Set_Etype (N, Standard_Boolean);
4241 when Attribute_Lock_Free =>
4243 Set_Etype (N, Standard_Boolean);
4245 if not Is_Protected_Type (P_Type) then
4247 ("prefix of % attribute must be a protected object");
4254 when Attribute_Loop_Entry => Loop_Entry : declare
4255 procedure Check_References_In_Prefix (Loop_Id : Entity_Id);
4256 -- Inspect the prefix for any uses of entities declared within the
4257 -- related loop. Loop_Id denotes the loop identifier.
4259 --------------------------------
4260 -- Check_References_In_Prefix --
4261 --------------------------------
4263 procedure Check_References_In_Prefix (Loop_Id : Entity_Id) is
4264 Loop_Decl : constant Node_Id := Label_Construct (Parent (Loop_Id));
4266 function Check_Reference (Nod : Node_Id) return Traverse_Result;
4267 -- Determine whether a reference mentions an entity declared
4268 -- within the related loop.
4270 function Declared_Within (Nod : Node_Id) return Boolean;
4271 -- Determine whether Nod appears in the subtree of Loop_Decl
4273 ---------------------
4274 -- Check_Reference --
4275 ---------------------
4277 function Check_Reference (Nod : Node_Id) return Traverse_Result is
4279 if Nkind (Nod) = N_Identifier
4280 and then Present (Entity (Nod))
4281 and then Declared_Within (Declaration_Node (Entity (Nod)))
4284 ("prefix of attribute % cannot reference local entities",
4290 end Check_Reference;
4292 procedure Check_References is new Traverse_Proc (Check_Reference);
4294 ---------------------
4295 -- Declared_Within --
4296 ---------------------
4298 function Declared_Within (Nod : Node_Id) return Boolean is
4303 while Present (Stmt) loop
4304 if Stmt = Loop_Decl then
4307 -- Prevent the search from going too far
4309 elsif Is_Body_Or_Package_Declaration (Stmt) then
4313 Stmt := Parent (Stmt);
4317 end Declared_Within;
4319 -- Start of processing for Check_Prefix_For_Local_References
4322 Check_References (P);
4323 end Check_References_In_Prefix;
4327 Context : constant Node_Id := Parent (N);
4329 Encl_Loop : Node_Id := Empty;
4330 Encl_Prag : Node_Id := Empty;
4331 Loop_Id : Entity_Id := Empty;
4335 -- Start of processing for Loop_Entry
4340 -- Set the type of the attribute now to ensure the successful
4341 -- continuation of analysis even if the attribute is misplaced.
4343 Set_Etype (Attr, P_Type);
4345 -- Attribute 'Loop_Entry may appear in several flavors:
4347 -- * Prefix'Loop_Entry - in this form, the attribute applies to the
4348 -- nearest enclosing loop.
4350 -- * Prefix'Loop_Entry (Expr) - depending on what Expr denotes, the
4351 -- attribute may be related to a loop denoted by label Expr or
4352 -- the prefix may denote an array object and Expr may act as an
4353 -- indexed component.
4355 -- * Prefix'Loop_Entry (Expr1, ..., ExprN) - the attribute applies
4356 -- to the nearest enclosing loop, all expressions are part of
4357 -- an indexed component.
4359 -- * Prefix'Loop_Entry (Expr) (...) (...) - depending on what Expr
4360 -- denotes, the attribute may be related to a loop denoted by
4361 -- label Expr or the prefix may denote a multidimensional array
4362 -- array object and Expr along with the rest of the expressions
4363 -- may act as indexed components.
4365 -- Regardless of variations, the attribute reference does not have an
4366 -- expression list. Instead, all available expressions are stored as
4367 -- indexed components.
4369 -- When the attribute is part of an indexed component, find the first
4370 -- expression as it will determine the semantics of 'Loop_Entry.
4372 -- If the attribute is itself an index in an indexed component, i.e.
4373 -- a member of a list, the context itself is not relevant (the code
4374 -- below would lead to an infinite loop) and the attribute applies
4375 -- to the enclosing loop.
4377 if Nkind (Context) = N_Indexed_Component
4378 and then not Is_List_Member (N)
4380 E1 := First (Expressions (Context));
4383 -- The attribute reference appears in the following form:
4385 -- Prefix'Loop_Entry (Exp1, Expr2, ..., ExprN) [(...)]
4387 -- In this case, the loop name is omitted and no rewriting is
4390 if Present (E2) then
4393 -- The form of the attribute is:
4395 -- Prefix'Loop_Entry (Expr) [(...)]
4397 -- If Expr denotes a loop entry, the whole attribute and indexed
4398 -- component will have to be rewritten to reflect this relation.
4401 pragma Assert (Present (E1));
4403 -- Do not expand the expression as it may have side effects.
4404 -- Simply preanalyze to determine whether it is a loop name or
4407 Preanalyze_And_Resolve (E1);
4409 if Is_Entity_Name (E1)
4410 and then Present (Entity (E1))
4411 and then Ekind (Entity (E1)) = E_Loop
4413 Loop_Id := Entity (E1);
4415 -- Transform the attribute and enclosing indexed component
4417 Set_Expressions (N, Expressions (Context));
4418 Rewrite (Context, N);
4419 Set_Etype (Context, P_Type);
4426 -- The prefix must denote an object
4428 if not Is_Object_Reference (P) then
4429 Error_Attr_P ("prefix of attribute % must denote an object");
4432 -- The prefix cannot be of a limited type because the expansion of
4433 -- Loop_Entry must create a constant initialized by the evaluated
4436 if Is_Limited_View (Etype (P)) then
4437 Error_Attr_P ("prefix of attribute % cannot be limited");
4440 -- Climb the parent chain to verify the location of the attribute and
4441 -- find the enclosing loop.
4444 while Present (Stmt) loop
4446 -- Locate the corresponding enclosing pragma. Note that in the
4447 -- case of Assert[And_Cut] and Assume, we have already checked
4448 -- that the pragma appears in an appropriate loop location.
4450 if Nkind (Original_Node (Stmt)) = N_Pragma
4451 and then Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)),
4452 Name_Loop_Invariant,
4455 Name_Assert_And_Cut,
4458 Encl_Prag := Original_Node (Stmt);
4460 -- Locate the enclosing loop (if any). Note that Ada 2012 array
4461 -- iteration may be expanded into several nested loops, we are
4462 -- interested in the outermost one which has the loop identifier,
4463 -- and comes from source.
4465 elsif Nkind (Stmt) = N_Loop_Statement
4466 and then Present (Identifier (Stmt))
4467 and then Comes_From_Source (Original_Node (Stmt))
4468 and then Nkind (Original_Node (Stmt)) = N_Loop_Statement
4472 -- The original attribute reference may lack a loop name. Use
4473 -- the name of the enclosing loop because it is the related
4476 if No (Loop_Id) then
4477 Loop_Id := Entity (Identifier (Encl_Loop));
4482 -- Prevent the search from going too far
4484 elsif Is_Body_Or_Package_Declaration (Stmt) then
4488 Stmt := Parent (Stmt);
4491 -- Loop_Entry must appear within a Loop_Assertion pragma (Assert,
4492 -- Assert_And_Cut, Assume count as loop assertion pragmas for this
4493 -- purpose if they appear in an appropriate location in a loop,
4494 -- which was already checked by the top level pragma circuit).
4496 -- Loop_Entry also denotes a value and as such can appear within an
4497 -- expression that is an argument for another loop aspect. In that
4498 -- case it will have been expanded into the corresponding assignment.
4501 and then Nkind (Parent (N)) = N_Assignment_Statement
4502 and then not Comes_From_Source (Parent (N))
4506 elsif No (Encl_Prag) then
4507 Error_Attr ("attribute% must appear within appropriate pragma", N);
4510 -- A Loop_Entry that applies to a given loop statement must not
4511 -- appear within a body of accept statement, if this construct is
4512 -- itself enclosed by the given loop statement.
4514 for Index in reverse 0 .. Scope_Stack.Last loop
4515 Scop := Scope_Stack.Table (Index).Entity;
4517 if Ekind (Scop) = E_Loop and then Scop = Loop_Id then
4519 elsif Ekind_In (Scop, E_Block, E_Loop, E_Return_Statement) then
4523 ("attribute % cannot appear in body or accept statement", N);
4528 -- The prefix cannot mention entities declared within the related
4529 -- loop because they will not be visible once the prefix is moved
4530 -- outside the loop.
4532 Check_References_In_Prefix (Loop_Id);
4534 -- The prefix must denote a static entity if the pragma does not
4535 -- apply to the innermost enclosing loop statement, or if it appears
4536 -- within a potentially unevaluated epxression.
4538 if Is_Entity_Name (P)
4539 or else Nkind (Parent (P)) = N_Object_Renaming_Declaration
4540 or else Statically_Denotes_Object (P)
4544 elsif Present (Encl_Loop)
4545 and then Entity (Identifier (Encl_Loop)) /= Loop_Id
4548 ("prefix of attribute % that applies to outer loop must denote "
4551 elsif Is_Potentially_Unevaluated (P) then
4555 -- Replace the Loop_Entry attribute reference by its prefix if the
4556 -- related pragma is ignored. This transformation is OK with respect
4557 -- to typing because Loop_Entry's type is that of its prefix. This
4558 -- early transformation also avoids the generation of a useless loop
4561 if Present (Encl_Prag) and then Is_Ignored (Encl_Prag) then
4562 Rewrite (N, Relocate_Node (P));
4563 Preanalyze_And_Resolve (N);
4566 Preanalyze_And_Resolve (P);
4574 when Attribute_Machine =>
4575 Check_Floating_Point_Type_1;
4576 Set_Etype (N, P_Base_Type);
4577 Resolve (E1, P_Base_Type);
4583 when Attribute_Machine_Emax =>
4584 Check_Floating_Point_Type_0;
4585 Set_Etype (N, Universal_Integer);
4591 when Attribute_Machine_Emin =>
4592 Check_Floating_Point_Type_0;
4593 Set_Etype (N, Universal_Integer);
4595 ----------------------
4596 -- Machine_Mantissa --
4597 ----------------------
4599 when Attribute_Machine_Mantissa =>
4600 Check_Floating_Point_Type_0;
4601 Set_Etype (N, Universal_Integer);
4603 -----------------------
4604 -- Machine_Overflows --
4605 -----------------------
4607 when Attribute_Machine_Overflows =>
4610 Set_Etype (N, Standard_Boolean);
4616 when Attribute_Machine_Radix =>
4619 Set_Etype (N, Universal_Integer);
4621 ----------------------
4622 -- Machine_Rounding --
4623 ----------------------
4625 when Attribute_Machine_Rounding =>
4626 Check_Floating_Point_Type_1;
4627 Set_Etype (N, P_Base_Type);
4628 Resolve (E1, P_Base_Type);
4630 --------------------
4631 -- Machine_Rounds --
4632 --------------------
4634 when Attribute_Machine_Rounds =>
4637 Set_Etype (N, Standard_Boolean);
4643 when Attribute_Machine_Size =>
4646 Check_Not_Incomplete_Type;
4647 Set_Etype (N, Universal_Integer);
4653 when Attribute_Mantissa =>
4656 Set_Etype (N, Universal_Integer);
4662 when Attribute_Max =>
4665 ----------------------------------
4666 -- Max_Alignment_For_Allocation --
4667 ----------------------------------
4669 when Attribute_Max_Size_In_Storage_Elements =>
4670 Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements;
4672 ----------------------------------
4673 -- Max_Size_In_Storage_Elements --
4674 ----------------------------------
4676 when Attribute_Max_Alignment_For_Allocation =>
4677 Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements;
4679 -----------------------
4680 -- Maximum_Alignment --
4681 -----------------------
4683 when Attribute_Maximum_Alignment =>
4684 Standard_Attribute (Ttypes.Maximum_Alignment);
4686 --------------------
4687 -- Mechanism_Code --
4688 --------------------
4690 when Attribute_Mechanism_Code =>
4691 if not Is_Entity_Name (P)
4692 or else not Is_Subprogram (Entity (P))
4694 Error_Attr_P ("prefix of % attribute must be subprogram");
4697 Check_Either_E0_Or_E1;
4699 if Present (E1) then
4700 Resolve (E1, Any_Integer);
4701 Set_Etype (E1, Standard_Integer);
4703 if not Is_OK_Static_Expression (E1) then
4704 Flag_Non_Static_Expr
4705 ("expression for parameter number must be static!", E1);
4708 elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
4709 or else UI_To_Int (Intval (E1)) < 0
4711 Error_Attr ("invalid parameter number for % attribute", E1);
4715 Set_Etype (N, Universal_Integer);
4721 when Attribute_Min =>
4728 when Attribute_Mod =>
4730 -- Note: this attribute is only allowed in Ada 2005 mode, but
4731 -- we do not need to test that here, since Mod is only recognized
4732 -- as an attribute name in Ada 2005 mode during the parse.
4735 Check_Modular_Integer_Type;
4736 Resolve (E1, Any_Integer);
4737 Set_Etype (N, P_Base_Type);
4743 when Attribute_Model =>
4744 Check_Floating_Point_Type_1;
4745 Set_Etype (N, P_Base_Type);
4746 Resolve (E1, P_Base_Type);
4752 when Attribute_Model_Emin =>
4753 Check_Floating_Point_Type_0;
4754 Set_Etype (N, Universal_Integer);
4760 when Attribute_Model_Epsilon =>
4761 Check_Floating_Point_Type_0;
4762 Set_Etype (N, Universal_Real);
4764 --------------------
4765 -- Model_Mantissa --
4766 --------------------
4768 when Attribute_Model_Mantissa =>
4769 Check_Floating_Point_Type_0;
4770 Set_Etype (N, Universal_Integer);
4776 when Attribute_Model_Small =>
4777 Check_Floating_Point_Type_0;
4778 Set_Etype (N, Universal_Real);
4784 when Attribute_Modulus =>
4786 Check_Modular_Integer_Type;
4787 Set_Etype (N, Universal_Integer);
4789 --------------------
4790 -- Null_Parameter --
4791 --------------------
4793 when Attribute_Null_Parameter => Null_Parameter : declare
4794 Parnt : constant Node_Id := Parent (N);
4795 GParnt : constant Node_Id := Parent (Parnt);
4797 procedure Bad_Null_Parameter (Msg : String);
4798 -- Used if bad Null parameter attribute node is found. Issues
4799 -- given error message, and also sets the type to Any_Type to
4800 -- avoid blowups later on from dealing with a junk node.
4802 procedure Must_Be_Imported (Proc_Ent : Entity_Id);
4803 -- Called to check that Proc_Ent is imported subprogram
4805 ------------------------
4806 -- Bad_Null_Parameter --
4807 ------------------------
4809 procedure Bad_Null_Parameter (Msg : String) is
4811 Error_Msg_N (Msg, N);
4812 Set_Etype (N, Any_Type);
4813 end Bad_Null_Parameter;
4815 ----------------------
4816 -- Must_Be_Imported --
4817 ----------------------
4819 procedure Must_Be_Imported (Proc_Ent : Entity_Id) is
4820 Pent : constant Entity_Id := Ultimate_Alias (Proc_Ent);
4823 -- Ignore check if procedure not frozen yet (we will get
4824 -- another chance when the default parameter is reanalyzed)
4826 if not Is_Frozen (Pent) then
4829 elsif not Is_Imported (Pent) then
4831 ("Null_Parameter can only be used with imported subprogram");
4836 end Must_Be_Imported;
4838 -- Start of processing for Null_Parameter
4843 Set_Etype (N, P_Type);
4845 -- Case of attribute used as default expression
4847 if Nkind (Parnt) = N_Parameter_Specification then
4848 Must_Be_Imported (Defining_Entity (GParnt));
4850 -- Case of attribute used as actual for subprogram (positional)
4852 elsif Nkind (Parnt) in N_Subprogram_Call
4853 and then Is_Entity_Name (Name (Parnt))
4855 Must_Be_Imported (Entity (Name (Parnt)));
4857 -- Case of attribute used as actual for subprogram (named)
4859 elsif Nkind (Parnt) = N_Parameter_Association
4860 and then Nkind (GParnt) in N_Subprogram_Call
4861 and then Is_Entity_Name (Name (GParnt))
4863 Must_Be_Imported (Entity (Name (GParnt)));
4865 -- Not an allowed case
4869 ("Null_Parameter must be actual or default parameter");
4877 when Attribute_Object_Size =>
4880 Check_Not_Incomplete_Type;
4881 Set_Etype (N, Universal_Integer);
4887 when Attribute_Old => Old : declare
4888 procedure Check_References_In_Prefix (Subp_Id : Entity_Id);
4889 -- Inspect the contents of the prefix and detect illegal uses of a
4890 -- nested 'Old, attribute 'Result or a use of an entity declared in
4891 -- the related postcondition expression. Subp_Id is the subprogram to
4892 -- which the related postcondition applies.
4894 --------------------------------
4895 -- Check_References_In_Prefix --
4896 --------------------------------
4898 procedure Check_References_In_Prefix (Subp_Id : Entity_Id) is
4899 function Check_Reference (Nod : Node_Id) return Traverse_Result;
4900 -- Detect attribute 'Old, attribute 'Result of a use of an entity
4901 -- and perform the appropriate semantic check.
4903 ---------------------
4904 -- Check_Reference --
4905 ---------------------
4907 function Check_Reference (Nod : Node_Id) return Traverse_Result is
4909 -- Attributes 'Old and 'Result cannot appear in the prefix of
4910 -- another attribute 'Old.
4912 if Nkind (Nod) = N_Attribute_Reference
4913 and then Nam_In (Attribute_Name (Nod), Name_Old,
4916 Error_Msg_Name_1 := Attribute_Name (Nod);
4917 Error_Msg_Name_2 := Name_Old;
4919 ("attribute % cannot appear in the prefix of attribute %",
4923 -- Entities mentioned within the prefix of attribute 'Old must
4924 -- be global to the related postcondition. If this is not the
4925 -- case, then the scope of the local entity is nested within
4926 -- that of the subprogram.
4928 elsif Is_Entity_Name (Nod)
4929 and then Present (Entity (Nod))
4930 and then Scope_Within (Scope (Entity (Nod)), Subp_Id)
4933 ("prefix of attribute % cannot reference local entities",
4937 -- Otherwise keep inspecting the prefix
4942 end Check_Reference;
4944 procedure Check_References is new Traverse_Proc (Check_Reference);
4946 -- Start of processing for Check_References_In_Prefix
4949 Check_References (P);
4950 end Check_References_In_Prefix;
4955 Pref_Id : Entity_Id;
4956 Pref_Typ : Entity_Id;
4957 Spec_Id : Entity_Id;
4959 -- Start of processing for Old
4962 -- The attribute reference is a primary. If any expressions follow,
4963 -- then the attribute reference is an indexable object. Transform the
4964 -- attribute into an indexed component and analyze it.
4966 if Present (E1) then
4968 Make_Indexed_Component (Loc,
4970 Make_Attribute_Reference (Loc,
4971 Prefix => Relocate_Node (P),
4972 Attribute_Name => Name_Old),
4973 Expressions => Expressions (N)));
4978 Analyze_Attribute_Old_Result (Legal, Spec_Id);
4980 -- The aspect or pragma where attribute 'Old resides should be
4981 -- associated with a subprogram declaration or a body. If this is not
4982 -- the case, then the aspect or pragma is illegal. Return as analysis
4983 -- cannot be carried out.
4985 -- The exception to this rule is when generating C since in this case
4986 -- postconditions are inlined.
4989 and then Modify_Tree_For_C
4990 and then In_Inlined_Body
4992 Spec_Id := Entity (P);
4994 elsif not Legal then
4998 -- The prefix must be preanalyzed as the full analysis will take
4999 -- place during expansion.
5001 Preanalyze_And_Resolve (P);
5003 -- Ensure that the prefix does not contain attributes 'Old or 'Result
5005 Check_References_In_Prefix (Spec_Id);
5007 -- Set the type of the attribute now to prevent cascaded errors
5009 Pref_Typ := Etype (P);
5010 Set_Etype (N, Pref_Typ);
5014 if Is_Limited_Type (Pref_Typ) then
5015 Error_Attr ("attribute % cannot apply to limited objects", P);
5018 -- The prefix is a simple name
5020 if Is_Entity_Name (P) and then Present (Entity (P)) then
5021 Pref_Id := Entity (P);
5023 -- Emit a warning when the prefix is a constant. Note that the use
5024 -- of Error_Attr would reset the type of N to Any_Type even though
5025 -- this is a warning. Use Error_Msg_XXX instead.
5027 if Is_Constant_Object (Pref_Id) then
5028 Error_Msg_Name_1 := Name_Old;
5030 ("??attribute % applied to constant has no effect", P);
5033 -- Otherwise the prefix is not a simple name
5036 -- Ensure that the prefix of attribute 'Old is an entity when it
5037 -- is potentially unevaluated (6.1.1 (27/3)).
5039 if Is_Potentially_Unevaluated (N)
5040 and then not Statically_Denotes_Object (P)
5044 -- Detect a possible infinite recursion when the prefix denotes
5045 -- the related function.
5047 -- function Func (...) return ...
5048 -- with Post => Func'Old ...;
5050 -- The function may be specified in qualified form X.Y where X is
5051 -- a protected object and Y is a protected function. In that case
5052 -- ensure that the qualified form has an entity.
5054 elsif Nkind (P) = N_Function_Call
5055 and then Nkind (Name (P)) in N_Has_Entity
5057 Pref_Id := Entity (Name (P));
5059 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
5060 and then Pref_Id = Spec_Id
5062 Error_Msg_Warn := SPARK_Mode /= On;
5063 Error_Msg_N ("!possible infinite recursion<<", P);
5064 Error_Msg_N ("\!??Storage_Error ]<<", P);
5068 -- The prefix of attribute 'Old may refer to a component of a
5069 -- formal parameter. In this case its expansion may generate
5070 -- actual subtypes that are referenced in an inner context and
5071 -- that must be elaborated within the subprogram itself. If the
5072 -- prefix includes a function call, it may involve finalization
5073 -- actions that should be inserted when the attribute has been
5074 -- rewritten as a declaration. Create a declaration for the prefix
5075 -- and insert it at the start of the enclosing subprogram. This is
5076 -- an expansion activity that has to be performed now to prevent
5077 -- out-of-order issues.
5079 -- This expansion is both harmful and not needed in SPARK mode,
5080 -- since the formal verification back end relies on the types of
5081 -- nodes (hence is not robust w.r.t. a change to base type here),
5082 -- and does not suffer from the out-of-order issue described
5083 -- above. Thus, this expansion is skipped in SPARK mode.
5085 -- The expansion is not relevant for discrete types, which will
5086 -- not generate extra declarations, and where use of the base type
5087 -- may lead to spurious errors if context is a case.
5089 if not GNATprove_Mode then
5090 if not Is_Discrete_Type (Pref_Typ) then
5091 Pref_Typ := Base_Type (Pref_Typ);
5094 Set_Etype (N, Pref_Typ);
5095 Set_Etype (P, Pref_Typ);
5097 Analyze_Dimension (N);
5103 ----------------------
5104 -- Overlaps_Storage --
5105 ----------------------
5107 when Attribute_Overlaps_Storage =>
5110 -- Both arguments must be objects of any type
5112 Analyze_And_Resolve (P);
5113 Analyze_And_Resolve (E1);
5114 Check_Object_Reference (P);
5115 Check_Object_Reference (E1);
5116 Set_Etype (N, Standard_Boolean);
5122 when Attribute_Output =>
5124 Check_Stream_Attribute (TSS_Stream_Output);
5125 Set_Etype (N, Standard_Void_Type);
5126 Resolve (N, Standard_Void_Type);
5132 when Attribute_Partition_ID =>
5135 if P_Type /= Any_Type then
5136 if not Is_Library_Level_Entity (Entity (P)) then
5138 ("prefix of % attribute must be library-level entity");
5140 -- The defining entity of prefix should not be declared inside a
5141 -- Pure unit. RM E.1(8). Is_Pure was set during declaration.
5143 elsif Is_Entity_Name (P)
5144 and then Is_Pure (Entity (P))
5146 Error_Attr_P ("prefix of% attribute must not be declared pure");
5150 Set_Etype (N, Universal_Integer);
5152 -------------------------
5153 -- Passed_By_Reference --
5154 -------------------------
5156 when Attribute_Passed_By_Reference =>
5159 Set_Etype (N, Standard_Boolean);
5165 when Attribute_Pool_Address =>
5167 Set_Etype (N, RTE (RE_Address));
5173 when Attribute_Pos =>
5174 Check_Discrete_Type;
5177 if Is_Boolean_Type (P_Type) then
5178 Error_Msg_Name_1 := Aname;
5179 Error_Msg_Name_2 := Chars (P_Type);
5180 Check_SPARK_05_Restriction
5181 ("attribute% is not allowed for type%", P);
5184 Resolve (E1, P_Base_Type);
5185 Set_Etype (N, Universal_Integer);
5191 when Attribute_Position =>
5193 Set_Etype (N, Universal_Integer);
5199 when Attribute_Pred =>
5203 if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then
5204 Error_Msg_Name_1 := Aname;
5205 Error_Msg_Name_2 := Chars (P_Type);
5206 Check_SPARK_05_Restriction
5207 ("attribute% is not allowed for type%", P);
5210 Resolve (E1, P_Base_Type);
5211 Set_Etype (N, P_Base_Type);
5213 -- Since Pred works on the base type, we normally do no check for the
5214 -- floating-point case, since the base type is unconstrained. But we
5215 -- make an exception in Check_Float_Overflow mode.
5217 if Is_Floating_Point_Type (P_Type) then
5218 if not Range_Checks_Suppressed (P_Base_Type) then
5219 Set_Do_Range_Check (E1);
5222 -- If not modular type, test for overflow check required
5225 if not Is_Modular_Integer_Type (P_Type)
5226 and then not Range_Checks_Suppressed (P_Base_Type)
5228 Enable_Range_Check (E1);
5236 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5238 when Attribute_Priority =>
5239 if Ada_Version < Ada_2005 then
5240 Error_Attr ("% attribute is allowed only in Ada 2005 mode", P);
5245 Check_Restriction (No_Dynamic_Priorities, N);
5247 -- The prefix must be a protected object (AARM D.5.2 (2/2))
5251 if Is_Protected_Type (Etype (P))
5252 or else (Is_Access_Type (Etype (P))
5253 and then Is_Protected_Type (Designated_Type (Etype (P))))
5255 Resolve (P, Etype (P));
5257 Error_Attr_P ("prefix of % attribute must be a protected object");
5260 Set_Etype (N, Standard_Integer);
5262 -- Must be called from within a protected procedure or entry of the
5263 -- protected object.
5270 while S /= Etype (P)
5271 and then S /= Standard_Standard
5276 if S = Standard_Standard then
5277 Error_Attr ("the attribute % is only allowed inside protected "
5282 Validate_Non_Static_Attribute_Function_Call;
5288 when Attribute_Range =>
5289 Check_Array_Or_Scalar_Type;
5290 Bad_Attribute_For_Predicate;
5292 if Ada_Version = Ada_83
5293 and then Is_Scalar_Type (P_Type)
5294 and then Comes_From_Source (N)
5297 ("(Ada 83) % attribute not allowed for scalar type", P);
5304 when Attribute_Result => Result : declare
5305 function Denote_Same_Function
5306 (Pref_Id : Entity_Id;
5307 Spec_Id : Entity_Id) return Boolean;
5308 -- Determine whether the entity of the prefix Pref_Id denotes the
5309 -- same entity as that of the related subprogram Spec_Id.
5311 --------------------------
5312 -- Denote_Same_Function --
5313 --------------------------
5315 function Denote_Same_Function
5316 (Pref_Id : Entity_Id;
5317 Spec_Id : Entity_Id) return Boolean
5319 Over_Id : constant Entity_Id := Overridden_Operation (Spec_Id);
5320 Subp_Spec : constant Node_Id := Parent (Spec_Id);
5323 -- The prefix denotes the related subprogram
5325 if Pref_Id = Spec_Id then
5328 -- Account for a special case when attribute 'Result appears in
5329 -- the postcondition of a generic function.
5332 -- function Gen_Func return ...
5333 -- with Post => Gen_Func'Result ...;
5335 -- When the generic function is instantiated, the Chars field of
5336 -- the instantiated prefix still denotes the name of the generic
5337 -- function. Note that any preemptive transformation is impossible
5338 -- without a proper analysis. The structure of the wrapper package
5341 -- package Anon_Gen_Pack is
5342 -- <subtypes and renamings>
5343 -- function Subp_Decl return ...; -- (!)
5344 -- pragma Postcondition (Gen_Func'Result ...); -- (!)
5345 -- function Gen_Func ... renames Subp_Decl;
5346 -- end Anon_Gen_Pack;
5348 elsif Nkind (Subp_Spec) = N_Function_Specification
5349 and then Present (Generic_Parent (Subp_Spec))
5350 and then Ekind_In (Pref_Id, E_Generic_Function, E_Function)
5352 if Generic_Parent (Subp_Spec) = Pref_Id then
5355 elsif Present (Alias (Pref_Id))
5356 and then Alias (Pref_Id) = Spec_Id
5361 -- Account for a special case where a primitive of a tagged type
5362 -- inherits a class-wide postcondition from a parent type. In this
5363 -- case the prefix of attribute 'Result denotes the overriding
5366 elsif Present (Over_Id) and then Pref_Id = Over_Id then
5370 -- Otherwise the prefix does not denote the related subprogram
5373 end Denote_Same_Function;
5377 In_Inlined_C_Postcondition : constant Boolean :=
5379 and then In_Inlined_Body;
5382 Pref_Id : Entity_Id;
5383 Spec_Id : Entity_Id;
5385 -- Start of processing for Result
5388 -- The attribute reference is a primary. If any expressions follow,
5389 -- then the attribute reference is an indexable object. Transform the
5390 -- attribute into an indexed component and analyze it.
5392 if Present (E1) then
5394 Make_Indexed_Component (Loc,
5396 Make_Attribute_Reference (Loc,
5397 Prefix => Relocate_Node (P),
5398 Attribute_Name => Name_Result),
5399 Expressions => Expressions (N)));
5404 Analyze_Attribute_Old_Result (Legal, Spec_Id);
5406 -- The aspect or pragma where attribute 'Result resides should be
5407 -- associated with a subprogram declaration or a body. If this is not
5408 -- the case, then the aspect or pragma is illegal. Return as analysis
5409 -- cannot be carried out.
5411 -- The exception to this rule is when generating C since in this case
5412 -- postconditions are inlined.
5414 if No (Spec_Id) and then In_Inlined_C_Postcondition then
5415 Spec_Id := Entity (P);
5417 elsif not Legal then
5418 Error_Attr ("prefix of % attribute must be a function", P);
5422 -- Attribute 'Result is part of a _Postconditions procedure. There is
5423 -- no need to perform the semantic checks below as they were already
5424 -- verified when the attribute was analyzed in its original context.
5425 -- Instead, rewrite the attribute as a reference to formal parameter
5426 -- _Result of the _Postconditions procedure.
5428 if Chars (Spec_Id) = Name_uPostconditions
5430 (In_Inlined_C_Postcondition
5431 and then Nkind (Parent (Spec_Id)) = N_Block_Statement)
5433 Rewrite (N, Make_Identifier (Loc, Name_uResult));
5435 -- The type of formal parameter _Result is that of the function
5436 -- encapsulating the _Postconditions procedure. Resolution must
5437 -- be carried out against the function return type.
5439 Analyze_And_Resolve (N, Etype (Scope (Spec_Id)));
5441 -- Otherwise attribute 'Result appears in its original context and
5442 -- all semantic checks should be carried out.
5445 -- Verify the legality of the prefix. It must denotes the entity
5446 -- of the related [generic] function.
5448 if Is_Entity_Name (P) then
5449 Pref_Id := Entity (P);
5451 if Ekind_In (Pref_Id, E_Function, E_Generic_Function)
5452 and then Ekind (Spec_Id) = Ekind (Pref_Id)
5454 if Denote_Same_Function (Pref_Id, Spec_Id) then
5456 -- Correct the prefix of the attribute when the context
5457 -- is a generic function.
5459 if Pref_Id /= Spec_Id then
5460 Rewrite (P, New_Occurrence_Of (Spec_Id, Loc));
5464 Set_Etype (N, Etype (Spec_Id));
5466 -- Otherwise the prefix denotes some unrelated function
5469 Error_Msg_Name_2 := Chars (Spec_Id);
5471 ("incorrect prefix for attribute %, expected %", P);
5474 -- Otherwise the prefix denotes some other form of subprogram
5479 ("attribute % can only appear in postcondition of "
5483 -- Otherwise the prefix is illegal
5486 Error_Msg_Name_2 := Chars (Spec_Id);
5487 Error_Attr ("incorrect prefix for attribute %, expected %", P);
5496 when Attribute_Range_Length =>
5498 Check_Discrete_Type;
5499 Set_Etype (N, Universal_Integer);
5505 when Attribute_Reduce =>
5509 Stream : constant Node_Id := Prefix (N);
5512 if Nkind (Stream) /= N_Aggregate then
5513 -- Prefix is a name, as for other attributes.
5515 -- If the object is a function we asume that it is not
5516 -- overloaded. AI12-242 does not suggest a name resolution
5517 -- rule for that case, but we can suppose that the expected
5518 -- type of the reduction is the expected type of the component
5521 Analyze_And_Resolve (Stream);
5522 Typ := Etype (Stream);
5524 -- Verify that prefix can be iterated upon.
5526 if Is_Array_Type (Typ)
5527 or else Present (Find_Aspect (Typ, Aspect_Default_Iterator))
5528 or else Present (Find_Aspect (Typ, Aspect_Iterable))
5533 ("cannot apply reduce to object of type$", N, Typ);
5536 elsif Present (Expressions (Stream))
5537 or else No (Component_Associations (Stream))
5538 or else Nkind (First (Component_Associations (Stream))) /=
5539 N_Iterated_Component_Association
5542 ("Prefix of reduce must be an iterated component", N);
5547 Set_Etype (N, Etype (E2));
5554 when Attribute_Read =>
5556 Check_Stream_Attribute (TSS_Stream_Read);
5557 Set_Etype (N, Standard_Void_Type);
5558 Resolve (N, Standard_Void_Type);
5559 Note_Possible_Modification (E2, Sure => True);
5565 when Attribute_Ref =>
5569 if Nkind (P) /= N_Expanded_Name
5570 or else not Is_RTE (P_Type, RE_Address)
5572 Error_Attr_P ("prefix of % attribute must be System.Address");
5575 Analyze_And_Resolve (E1, Any_Integer);
5576 Set_Etype (N, RTE (RE_Address));
5582 when Attribute_Remainder =>
5583 Check_Floating_Point_Type_2;
5584 Set_Etype (N, P_Base_Type);
5585 Resolve (E1, P_Base_Type);
5586 Resolve (E2, P_Base_Type);
5588 ---------------------
5589 -- Restriction_Set --
5590 ---------------------
5592 when Attribute_Restriction_Set => Restriction_Set : declare
5595 Unam : Unit_Name_Type;
5600 Check_System_Prefix;
5602 -- No_Dependence case
5604 if Nkind (E1) = N_Parameter_Association then
5605 pragma Assert (Chars (Selector_Name (E1)) = Name_No_Dependence);
5606 U := Explicit_Actual_Parameter (E1);
5608 if not OK_No_Dependence_Unit_Name (U) then
5609 Set_Boolean_Result (N, False);
5613 -- See if there is an entry already in the table. That's the
5614 -- case in which we can return True.
5616 for J in No_Dependences.First .. No_Dependences.Last loop
5617 if Designate_Same_Unit (U, No_Dependences.Table (J).Unit)
5618 and then No_Dependences.Table (J).Warn = False
5620 Set_Boolean_Result (N, True);
5625 -- If not in the No_Dependence table, result is False
5627 Set_Boolean_Result (N, False);
5629 -- In this case, we must ensure that the binder will reject any
5630 -- other unit in the partition that sets No_Dependence for this
5631 -- unit. We do that by making an entry in the special table kept
5632 -- for this purpose (if the entry is not there already).
5634 Unam := Get_Spec_Name (Get_Unit_Name (U));
5636 for J in Restriction_Set_Dependences.First ..
5637 Restriction_Set_Dependences.Last
5639 if Restriction_Set_Dependences.Table (J) = Unam then
5644 Restriction_Set_Dependences.Append (Unam);
5646 -- Normal restriction case
5649 if Nkind (E1) /= N_Identifier then
5650 Set_Boolean_Result (N, False);
5651 Error_Attr ("attribute % requires restriction identifier", E1);
5654 R := Get_Restriction_Id (Process_Restriction_Synonyms (E1));
5656 if R = Not_A_Restriction_Id then
5657 Set_Boolean_Result (N, False);
5658 Error_Msg_Node_1 := E1;
5659 Error_Attr ("invalid restriction identifier &", E1);
5661 elsif R not in Partition_Boolean_Restrictions then
5662 Set_Boolean_Result (N, False);
5663 Error_Msg_Node_1 := E1;
5665 ("& is not a boolean partition-wide restriction", E1);
5668 if Restriction_Active (R) then
5669 Set_Boolean_Result (N, True);
5671 Check_Restriction (R, N);
5672 Set_Boolean_Result (N, False);
5676 end Restriction_Set;
5682 when Attribute_Round =>
5684 Check_Decimal_Fixed_Point_Type;
5685 Set_Etype (N, P_Base_Type);
5687 -- Because the context is universal_real (3.5.10(12)) it is a
5688 -- legal context for a universal fixed expression. This is the
5689 -- only attribute whose functional description involves U_R.
5691 if Etype (E1) = Universal_Fixed then
5693 Conv : constant Node_Id := Make_Type_Conversion (Loc,
5694 Subtype_Mark => New_Occurrence_Of (Universal_Real, Loc),
5695 Expression => Relocate_Node (E1));
5703 Resolve (E1, Any_Real);
5709 when Attribute_Rounding =>
5710 Check_Floating_Point_Type_1;
5711 Set_Etype (N, P_Base_Type);
5712 Resolve (E1, P_Base_Type);
5718 when Attribute_Safe_Emax =>
5719 Check_Floating_Point_Type_0;
5720 Set_Etype (N, Universal_Integer);
5726 when Attribute_Safe_First =>
5727 Check_Floating_Point_Type_0;
5728 Set_Etype (N, Universal_Real);
5734 when Attribute_Safe_Large =>
5737 Set_Etype (N, Universal_Real);
5743 when Attribute_Safe_Last =>
5744 Check_Floating_Point_Type_0;
5745 Set_Etype (N, Universal_Real);
5751 when Attribute_Safe_Small =>
5754 Set_Etype (N, Universal_Real);
5756 --------------------------
5757 -- Scalar_Storage_Order --
5758 --------------------------
5760 when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : declare
5761 Ent : Entity_Id := Empty;
5767 if not (Is_Record_Type (P_Type) or else Is_Array_Type (P_Type)) then
5769 -- The attribute applies to generic private types (in which case
5770 -- the legality rule is applied in the instance) as well as to
5771 -- composite types. For noncomposite types it always returns the
5772 -- default bit order for the target.
5773 -- Allowing formal private types was originally introduced in
5774 -- GNAT_Mode only, to compile instances of Sequential_IO, but
5775 -- users find it more generally useful in generic units.
5777 if not (Is_Generic_Type (P_Type) and then Is_Private_Type (P_Type))
5778 and then not In_Instance
5781 ("prefix of % attribute must be record or array type");
5783 elsif not Is_Generic_Type (P_Type) then
5784 if Bytes_Big_Endian then
5785 Ent := RTE (RE_High_Order_First);
5787 Ent := RTE (RE_Low_Order_First);
5791 elsif Bytes_Big_Endian xor Reverse_Storage_Order (P_Type) then
5792 Ent := RTE (RE_High_Order_First);
5795 Ent := RTE (RE_Low_Order_First);
5798 if Present (Ent) then
5799 Rewrite (N, New_Occurrence_Of (Ent, Loc));
5802 Set_Etype (N, RTE (RE_Bit_Order));
5805 -- Reset incorrect indication of staticness
5807 Set_Is_Static_Expression (N, False);
5808 end Scalar_Storage_Order;
5814 when Attribute_Scale =>
5816 Check_Decimal_Fixed_Point_Type;
5817 Set_Etype (N, Universal_Integer);
5823 when Attribute_Scaling =>
5824 Check_Floating_Point_Type_2;
5825 Set_Etype (N, P_Base_Type);
5826 Resolve (E1, P_Base_Type);
5832 when Attribute_Signed_Zeros =>
5833 Check_Floating_Point_Type_0;
5834 Set_Etype (N, Standard_Boolean);
5841 | Attribute_VADS_Size
5845 -- If prefix is parameterless function call, rewrite and resolve
5848 if Is_Entity_Name (P)
5849 and then Ekind (Entity (P)) = E_Function
5853 -- Similar processing for a protected function call
5855 elsif Nkind (P) = N_Selected_Component
5856 and then Ekind (Entity (Selector_Name (P))) = E_Function
5861 if Is_Object_Reference (P) then
5862 Check_Object_Reference (P);
5864 elsif Is_Entity_Name (P)
5865 and then (Is_Type (Entity (P))
5866 or else Ekind (Entity (P)) = E_Enumeration_Literal)
5870 elsif Nkind (P) = N_Type_Conversion
5871 and then not Comes_From_Source (P)
5875 -- Some other compilers allow dubious use of X'???'Size
5877 elsif Relaxed_RM_Semantics
5878 and then Nkind (P) = N_Attribute_Reference
5883 Error_Attr_P ("invalid prefix for % attribute");
5886 Check_Not_Incomplete_Type;
5888 Set_Etype (N, Universal_Integer);
5890 -- If we are processing pragmas Compile_Time_Warning and Compile_
5891 -- Time_Errors after the back end has been called and this occurrence
5892 -- of 'Size is known at compile time then it is safe to perform this
5893 -- evaluation. Needed to perform the static evaluation of the full
5894 -- boolean expression of these pragmas. Note that Known_RM_Size is
5895 -- sometimes True when Size_Known_At_Compile_Time is False, when the
5896 -- back end has computed it.
5898 if In_Compile_Time_Warning_Or_Error
5899 and then Is_Entity_Name (P)
5900 and then (Is_Type (Entity (P))
5901 or else Ekind (Entity (P)) = E_Enumeration_Literal)
5902 and then (Known_RM_Size (Entity (P))
5903 or else Size_Known_At_Compile_Time (Entity (P)))
5909 if Known_Static_RM_Size (Entity (P)) then
5910 Siz := RM_Size (Entity (P));
5912 Siz := Esize (Entity (P));
5915 Rewrite (N, Make_Integer_Literal (Sloc (N), Siz));
5924 when Attribute_Small =>
5927 Set_Etype (N, Universal_Real);
5933 when Attribute_Storage_Pool
5934 | Attribute_Simple_Storage_Pool
5938 if Is_Access_Type (P_Type) then
5939 if Ekind (P_Type) = E_Access_Subprogram_Type then
5941 ("cannot use % attribute for access-to-subprogram type");
5944 -- Set appropriate entity
5946 if Present (Associated_Storage_Pool (Root_Type (P_Type))) then
5947 Set_Entity (N, Associated_Storage_Pool (Root_Type (P_Type)));
5949 Set_Entity (N, RTE (RE_Global_Pool_Object));
5952 if Attr_Id = Attribute_Storage_Pool then
5953 if Present (Get_Rep_Pragma (Etype (Entity (N)),
5954 Name_Simple_Storage_Pool_Type))
5956 Error_Msg_Name_1 := Aname;
5957 Error_Msg_Warn := SPARK_Mode /= On;
5959 ("cannot use % attribute for type with simple storage "
5961 Error_Msg_N ("\Program_Error [<<", N);
5964 (N, Make_Raise_Program_Error
5965 (Sloc (N), Reason => PE_Explicit_Raise));
5968 Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
5970 -- In the Simple_Storage_Pool case, verify that the pool entity is
5971 -- actually of a simple storage pool type, and set the attribute's
5972 -- type to the pool object's type.
5975 if not Present (Get_Rep_Pragma (Etype (Entity (N)),
5976 Name_Simple_Storage_Pool_Type))
5979 ("cannot use % attribute for type without simple " &
5983 Set_Etype (N, Etype (Entity (N)));
5986 -- Validate_Remote_Access_To_Class_Wide_Type for attribute
5987 -- Storage_Pool since this attribute is not defined for such
5988 -- types (RM E.2.3(22)).
5990 Validate_Remote_Access_To_Class_Wide_Type (N);
5993 Error_Attr_P ("prefix of % attribute must be access type");
6000 when Attribute_Storage_Size =>
6003 if Is_Task_Type (P_Type) then
6004 Set_Etype (N, Universal_Integer);
6006 -- Use with tasks is an obsolescent feature
6008 Check_Restriction (No_Obsolescent_Features, P);
6010 elsif Is_Access_Type (P_Type) then
6011 if Ekind (P_Type) = E_Access_Subprogram_Type then
6013 ("cannot use % attribute for access-to-subprogram type");
6016 if Is_Entity_Name (P)
6017 and then Is_Type (Entity (P))
6020 Set_Etype (N, Universal_Integer);
6022 -- Validate_Remote_Access_To_Class_Wide_Type for attribute
6023 -- Storage_Size since this attribute is not defined for
6024 -- such types (RM E.2.3(22)).
6026 Validate_Remote_Access_To_Class_Wide_Type (N);
6028 -- The prefix is allowed to be an implicit dereference of an
6029 -- access value designating a task.
6033 Set_Etype (N, Universal_Integer);
6037 Error_Attr_P ("prefix of % attribute must be access or task type");
6044 when Attribute_Storage_Unit =>
6045 Standard_Attribute (Ttypes.System_Storage_Unit);
6051 when Attribute_Stream_Size =>
6055 if Is_Entity_Name (P)
6056 and then Is_Elementary_Type (Entity (P))
6058 Set_Etype (N, Universal_Integer);
6060 Error_Attr_P ("invalid prefix for % attribute");
6067 when Attribute_Stub_Type =>
6071 if Is_Remote_Access_To_Class_Wide_Type (Base_Type (P_Type)) then
6073 -- For a real RACW [sub]type, use corresponding stub type
6075 if not Is_Generic_Type (P_Type) then
6078 (Corresponding_Stub_Type (Base_Type (P_Type)), Loc));
6080 -- For a generic type (that has been marked as an RACW using the
6081 -- Remote_Access_Type aspect or pragma), use a generic RACW stub
6082 -- type. Note that if the actual is not a remote access type, the
6083 -- instantiation will fail.
6086 -- Note: we go to the underlying type here because the view
6087 -- returned by RTE (RE_RACW_Stub_Type) might be incomplete.
6091 (Underlying_Type (RTE (RE_RACW_Stub_Type)), Loc));
6096 ("prefix of% attribute must be remote access-to-class-wide");
6103 when Attribute_Succ =>
6107 if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then
6108 Error_Msg_Name_1 := Aname;
6109 Error_Msg_Name_2 := Chars (P_Type);
6110 Check_SPARK_05_Restriction
6111 ("attribute% is not allowed for type%", P);
6114 Resolve (E1, P_Base_Type);
6115 Set_Etype (N, P_Base_Type);
6117 -- Since Pred works on the base type, we normally do no check for the
6118 -- floating-point case, since the base type is unconstrained. But we
6119 -- make an exception in Check_Float_Overflow mode.
6121 if Is_Floating_Point_Type (P_Type) then
6122 if not Range_Checks_Suppressed (P_Base_Type) then
6123 Set_Do_Range_Check (E1);
6126 -- If not modular type, test for overflow check required
6129 if not Is_Modular_Integer_Type (P_Type)
6130 and then not Range_Checks_Suppressed (P_Base_Type)
6132 Enable_Range_Check (E1);
6136 --------------------------------
6137 -- System_Allocator_Alignment --
6138 --------------------------------
6140 when Attribute_System_Allocator_Alignment =>
6141 Standard_Attribute (Ttypes.System_Allocator_Alignment);
6147 when Attribute_Tag =>
6151 if not Is_Tagged_Type (P_Type) then
6152 Error_Attr_P ("prefix of % attribute must be tagged");
6154 -- Next test does not apply to generated code why not, and what does
6155 -- the illegal reference mean???
6157 elsif Is_Object_Reference (P)
6158 and then not Is_Class_Wide_Type (P_Type)
6159 and then Comes_From_Source (N)
6162 ("% attribute can only be applied to objects " &
6163 "of class - wide type");
6166 -- The prefix cannot be an incomplete type. However, references to
6167 -- 'Tag can be generated when expanding interface conversions, and
6170 if Comes_From_Source (N) then
6171 Check_Not_Incomplete_Type;
6174 -- Set appropriate type
6176 Set_Etype (N, RTE (RE_Tag));
6182 when Attribute_Target_Name => Target_Name : declare
6183 TN : constant String := Sdefault.Target_Name.all;
6187 Check_Standard_Prefix;
6191 if TN (TL) = '/' or else TN (TL) = '\' then
6196 Make_String_Literal (Loc,
6197 Strval => TN (TN'First .. TL)));
6198 Analyze_And_Resolve (N, Standard_String);
6199 Set_Is_Static_Expression (N, True);
6206 when Attribute_Terminated =>
6208 Set_Etype (N, Standard_Boolean);
6215 when Attribute_To_Address => To_Address : declare
6220 Check_System_Prefix;
6222 Generate_Reference (RTE (RE_Address), P);
6223 Analyze_And_Resolve (E1, Any_Integer);
6224 Set_Etype (N, RTE (RE_Address));
6225 Set_Is_Static_Expression (N, Is_Static_Expression (E1));
6227 -- OK static expression case, check range and set appropriate type
6229 if Is_OK_Static_Expression (E1) then
6230 Val := Expr_Value (E1);
6232 if Val < -(2 ** UI_From_Int (Standard'Address_Size - 1))
6234 Val > 2 ** UI_From_Int (Standard'Address_Size) - 1
6236 Error_Attr ("address value out of range for % attribute", E1);
6239 -- In most cases the expression is a numeric literal or some other
6240 -- address expression, but if it is a declared constant it may be
6241 -- of a compatible type that must be left on the node.
6243 if Is_Entity_Name (E1) then
6246 -- Set type to universal integer if negative
6249 Set_Etype (E1, Universal_Integer);
6251 -- Otherwise set type to Unsigned_64 to accommodate max values
6254 Set_Etype (E1, Standard_Unsigned_64);
6263 when Attribute_To_Any =>
6265 Check_PolyORB_Attribute;
6266 Set_Etype (N, RTE (RE_Any));
6272 when Attribute_Truncation =>
6273 Check_Floating_Point_Type_1;
6274 Resolve (E1, P_Base_Type);
6275 Set_Etype (N, P_Base_Type);
6281 when Attribute_Type_Class =>
6284 Check_Not_Incomplete_Type;
6285 Set_Etype (N, RTE (RE_Type_Class));
6291 when Attribute_TypeCode =>
6293 Check_PolyORB_Attribute;
6294 Set_Etype (N, RTE (RE_TypeCode));
6300 when Attribute_Type_Key => Type_Key : declare
6301 Full_Name : constant String_Id :=
6302 Fully_Qualified_Name_String (Entity (P));
6305 -- The computed signature for the type
6308 -- To simplify the handling of mutually recursive types, follow a
6309 -- single dereference link in a composite type.
6311 procedure Compute_Type_Key (T : Entity_Id);
6312 -- Create a CRC integer from the declaration of the type. For a
6313 -- composite type, fold in the representation of its components in
6314 -- recursive fashion. We use directly the source representation of
6315 -- the types involved.
6317 ----------------------
6318 -- Compute_Type_Key --
6319 ----------------------
6321 procedure Compute_Type_Key (T : Entity_Id) is
6322 Buffer : Source_Buffer_Ptr;
6326 SFI : Source_File_Index;
6328 procedure Process_One_Declaration;
6329 -- Update CRC with the characters of one type declaration, or a
6330 -- representation pragma that applies to the type.
6332 -----------------------------
6333 -- Process_One_Declaration --
6334 -----------------------------
6336 procedure Process_One_Declaration is
6338 -- Scan type declaration, skipping blanks
6340 for Ptr in P_Min .. P_Max loop
6341 if Buffer (Ptr) /= ' ' then
6342 System.CRC32.Update (CRC, Buffer (Ptr));
6345 end Process_One_Declaration;
6347 -- Start of processing for Compute_Type_Key
6350 if Is_Itype (T) then
6354 -- If the type is declared in Standard, there is no source, so
6355 -- just use its name.
6357 if Scope (T) = Standard_Standard then
6359 Name : constant String := Get_Name_String (Chars (T));
6361 for J in Name'Range loop
6362 System.CRC32.Update (CRC, Name (J));
6369 Sloc_Range (Enclosing_Declaration (T), P_Min, P_Max);
6370 SFI := Get_Source_File_Index (P_Min);
6371 pragma Assert (SFI = Get_Source_File_Index (P_Max));
6372 Buffer := Source_Text (SFI);
6374 Process_One_Declaration;
6376 -- Recurse on relevant component types
6378 if Is_Array_Type (T) then
6379 Compute_Type_Key (Component_Type (T));
6381 elsif Is_Access_Type (T) then
6384 Compute_Type_Key (Designated_Type (T));
6387 elsif Is_Derived_Type (T) then
6388 Compute_Type_Key (Etype (T));
6390 elsif Is_Record_Type (T) then
6394 Comp := First_Component (T);
6395 while Present (Comp) loop
6396 Compute_Type_Key (Etype (Comp));
6397 Next_Component (Comp);
6402 if Is_First_Subtype (T) then
6404 -- Fold in representation aspects for the type, which appear in
6405 -- the same source buffer. If the representation aspects are in
6406 -- a different source file, then skip them; they apply to some
6407 -- other type, perhaps one we're derived from.
6409 Rep := First_Rep_Item (T);
6411 while Present (Rep) loop
6412 if Comes_From_Source (Rep) then
6413 Sloc_Range (Rep, P_Min, P_Max);
6415 if SFI = Get_Source_File_Index (P_Min) then
6416 pragma Assert (SFI = Get_Source_File_Index (P_Max));
6417 Process_One_Declaration;
6421 Rep := Next_Rep_Item (Rep);
6424 end Compute_Type_Key;
6426 -- Start of processing for Type_Key
6435 -- Copy all characters in Full_Name but the trailing NUL
6437 for J in 1 .. String_Length (Full_Name) - 1 loop
6438 Store_String_Char (Get_String_Char (Full_Name, Pos (J)));
6441 -- Compute CRC and convert it to string one character at a time, so
6442 -- as not to use Image within the compiler.
6445 Compute_Type_Key (Entity (P));
6447 if not Is_Frozen (Entity (P)) then
6448 Error_Msg_N ("premature usage of Type_Key?", N);
6452 Store_String_Char (Character'Val (48 + (CRC rem 10)));
6456 Rewrite (N, Make_String_Literal (Loc, End_String));
6457 Analyze_And_Resolve (N, Standard_String);
6460 -----------------------
6461 -- Unbiased_Rounding --
6462 -----------------------
6464 when Attribute_Unbiased_Rounding =>
6465 Check_Floating_Point_Type_1;
6466 Set_Etype (N, P_Base_Type);
6467 Resolve (E1, P_Base_Type);
6469 ----------------------
6470 -- Unchecked_Access --
6471 ----------------------
6473 when Attribute_Unchecked_Access =>
6474 if Comes_From_Source (N) then
6475 Check_Restriction (No_Unchecked_Access, N);
6478 Analyze_Access_Attribute;
6479 Check_Not_Incomplete_Type;
6481 -------------------------
6482 -- Unconstrained_Array --
6483 -------------------------
6485 when Attribute_Unconstrained_Array =>
6488 Check_Not_Incomplete_Type;
6489 Set_Etype (N, Standard_Boolean);
6490 Set_Is_Static_Expression (N, True);
6492 ------------------------------
6493 -- Universal_Literal_String --
6494 ------------------------------
6496 -- This is a GNAT specific attribute whose prefix must be a named
6497 -- number where the expression is either a single numeric literal,
6498 -- or a numeric literal immediately preceded by a minus sign. The
6499 -- result is equivalent to a string literal containing the text of
6500 -- the literal as it appeared in the source program with a possible
6501 -- leading minus sign.
6503 when Attribute_Universal_Literal_String =>
6506 if not Is_Entity_Name (P)
6507 or else Ekind (Entity (P)) not in Named_Kind
6509 Error_Attr_P ("prefix for % attribute must be named number");
6516 Src : Source_Buffer_Ptr;
6519 Expr := Original_Node (Expression (Parent (Entity (P))));
6521 if Nkind (Expr) = N_Op_Minus then
6523 Expr := Original_Node (Right_Opnd (Expr));
6528 if not Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) then
6530 ("named number for % attribute must be simple literal", N);
6533 -- Build string literal corresponding to source literal text
6538 Store_String_Char (Get_Char_Code ('-'));
6542 Src := Source_Text (Get_Source_File_Index (S));
6544 while Src (S) /= ';' and then Src (S) /= ' ' loop
6545 Store_String_Char (Get_Char_Code (Src (S)));
6549 -- Now we rewrite the attribute with the string literal
6552 Make_String_Literal (Loc, End_String));
6554 Set_Is_Static_Expression (N, True);
6558 -------------------------
6559 -- Unrestricted_Access --
6560 -------------------------
6562 -- This is a GNAT specific attribute which is like Access except that
6563 -- all scope checks and checks for aliased views are omitted. It is
6564 -- documented as being equivalent to the use of the Address attribute
6565 -- followed by an unchecked conversion to the target access type.
6567 when Attribute_Unrestricted_Access =>
6569 -- If from source, deal with relevant restrictions
6571 if Comes_From_Source (N) then
6572 Check_Restriction (No_Unchecked_Access, N);
6574 if Nkind (P) in N_Has_Entity
6575 and then Present (Entity (P))
6576 and then Is_Object (Entity (P))
6578 Check_Restriction (No_Implicit_Aliasing, N);
6582 if Is_Entity_Name (P) then
6583 Set_Address_Taken (Entity (P));
6586 -- It might seem reasonable to call Address_Checks here to apply the
6587 -- same set of semantic checks that we enforce for 'Address (after
6588 -- all we document Unrestricted_Access as being equivalent to the
6589 -- use of Address followed by an Unchecked_Conversion). However, if
6590 -- we do enable these checks, we get multiple failures in both the
6591 -- compiler run-time and in our regression test suite, so we leave
6592 -- out these checks for now. To be investigated further some time???
6596 -- Now complete analysis using common access processing
6598 Analyze_Access_Attribute;
6604 when Attribute_Update => Update : declare
6605 Common_Typ : Entity_Id;
6606 -- The common type of a multiple component update for a record
6608 Comps : Elist_Id := No_Elist;
6609 -- A list used in the resolution of a record update. It contains the
6610 -- entities of all record components processed so far.
6612 procedure Analyze_Array_Component_Update (Assoc : Node_Id);
6613 -- Analyze and resolve array_component_association Assoc against the
6614 -- index of array type P_Type.
6616 procedure Analyze_Record_Component_Update (Comp : Node_Id);
6617 -- Analyze and resolve record_component_association Comp against
6618 -- record type P_Type.
6620 ------------------------------------
6621 -- Analyze_Array_Component_Update --
6622 ------------------------------------
6624 procedure Analyze_Array_Component_Update (Assoc : Node_Id) is
6628 Index_Typ : Entity_Id;
6632 -- The current association contains a sequence of indexes denoting
6633 -- an element of a multidimensional array:
6635 -- (Index_1, ..., Index_N)
6637 -- Examine each individual index and resolve it against the proper
6638 -- index type of the array.
6640 if Nkind (First (Choices (Assoc))) = N_Aggregate then
6641 Expr := First (Choices (Assoc));
6642 while Present (Expr) loop
6644 -- The use of others is illegal (SPARK RM 4.4.1(12))
6646 if Nkind (Expr) = N_Others_Choice then
6648 ("others choice not allowed in attribute %", Expr);
6650 -- Otherwise analyze and resolve all indexes
6653 Index := First (Expressions (Expr));
6654 Index_Typ := First_Index (P_Type);
6655 while Present (Index) and then Present (Index_Typ) loop
6656 Analyze_And_Resolve (Index, Etype (Index_Typ));
6658 Next_Index (Index_Typ);
6661 -- Detect a case where the association either lacks an
6662 -- index or contains an extra index.
6664 if Present (Index) or else Present (Index_Typ) then
6666 ("dimension mismatch in index list", Assoc);
6673 -- The current association denotes either a single component or a
6674 -- range of components of a one dimensional array:
6678 -- Resolve the index or its high and low bounds (if range) against
6679 -- the proper index type of the array.
6682 Index := First (Choices (Assoc));
6683 Index_Typ := First_Index (P_Type);
6685 if Present (Next_Index (Index_Typ)) then
6686 Error_Msg_N ("too few subscripts in array reference", Assoc);
6689 while Present (Index) loop
6691 -- The use of others is illegal (SPARK RM 4.4.1(12))
6693 if Nkind (Index) = N_Others_Choice then
6695 ("others choice not allowed in attribute %", Index);
6697 -- The index denotes a range of elements
6699 elsif Nkind (Index) = N_Range then
6700 Low := Low_Bound (Index);
6701 High := High_Bound (Index);
6703 Analyze_And_Resolve (Low, Etype (Index_Typ));
6704 Analyze_And_Resolve (High, Etype (Index_Typ));
6706 -- Add a range check to ensure that the bounds of the
6707 -- range are within the index type when this cannot be
6708 -- determined statically.
6710 if not Is_OK_Static_Expression (Low) then
6711 Set_Do_Range_Check (Low);
6714 if not Is_OK_Static_Expression (High) then
6715 Set_Do_Range_Check (High);
6718 -- Otherwise the index denotes a single element
6721 Analyze_And_Resolve (Index, Etype (Index_Typ));
6723 -- Add a range check to ensure that the index is within
6724 -- the index type when it is not possible to determine
6727 if not Is_OK_Static_Expression (Index) then
6728 Set_Do_Range_Check (Index);
6735 end Analyze_Array_Component_Update;
6737 -------------------------------------
6738 -- Analyze_Record_Component_Update --
6739 -------------------------------------
6741 procedure Analyze_Record_Component_Update (Comp : Node_Id) is
6742 Comp_Name : constant Name_Id := Chars (Comp);
6743 Base_Typ : Entity_Id;
6744 Comp_Or_Discr : Entity_Id;
6747 -- Find the discriminant or component whose name corresponds to
6748 -- Comp. A simple character comparison is sufficient because all
6749 -- visible names within a record type are unique.
6751 Comp_Or_Discr := First_Entity (P_Type);
6752 while Present (Comp_Or_Discr) loop
6753 if Chars (Comp_Or_Discr) = Comp_Name then
6755 -- Decorate the component reference by setting its entity
6756 -- and type for resolution purposes.
6758 Set_Entity (Comp, Comp_Or_Discr);
6759 Set_Etype (Comp, Etype (Comp_Or_Discr));
6763 Comp_Or_Discr := Next_Entity (Comp_Or_Discr);
6766 -- Diagnose an illegal reference
6768 if Present (Comp_Or_Discr) then
6769 if Ekind (Comp_Or_Discr) = E_Discriminant then
6771 ("attribute % may not modify record discriminants", Comp);
6773 else pragma Assert (Ekind (Comp_Or_Discr) = E_Component);
6774 if Contains (Comps, Comp_Or_Discr) then
6775 Error_Msg_N ("component & already updated", Comp);
6777 -- Mark this component as processed
6780 Append_New_Elmt (Comp_Or_Discr, Comps);
6784 -- The update aggregate mentions an entity that does not belong to
6788 Error_Msg_N ("& is not a component of aggregate subtype", Comp);
6791 -- Verify the consistency of types when the current component is
6792 -- part of a miltiple component update.
6794 -- Comp_1, ..., Comp_N => <value>
6796 if Present (Etype (Comp)) then
6797 Base_Typ := Base_Type (Etype (Comp));
6799 -- Save the type of the first component reference as the
6800 -- remaning references (if any) must resolve to this type.
6802 if No (Common_Typ) then
6803 Common_Typ := Base_Typ;
6805 elsif Base_Typ /= Common_Typ then
6807 ("components in choice list must have same type", Comp);
6810 end Analyze_Record_Component_Update;
6817 -- Start of processing for Update
6822 if not Is_Object_Reference (P) then
6823 Error_Attr_P ("prefix of attribute % must denote an object");
6825 elsif not Is_Array_Type (P_Type)
6826 and then not Is_Record_Type (P_Type)
6828 Error_Attr_P ("prefix of attribute % must be a record or array");
6830 elsif Is_Limited_View (P_Type) then
6831 Error_Attr ("prefix of attribute % cannot be limited", N);
6833 elsif Nkind (E1) /= N_Aggregate then
6834 Error_Attr ("attribute % requires component association list", N);
6837 -- Inspect the update aggregate, looking at all the associations and
6838 -- choices. Perform the following checks:
6840 -- 1) Legality of "others" in all cases
6841 -- 2) Legality of <>
6842 -- 3) Component legality for arrays
6843 -- 4) Component legality for records
6845 -- The remaining checks are performed on the expanded attribute
6847 Assoc := First (Component_Associations (E1));
6848 while Present (Assoc) loop
6850 -- The use of <> is illegal (SPARK RM 4.4.1(1))
6852 if Box_Present (Assoc) then
6854 ("default initialization not allowed in attribute %", Assoc);
6856 -- Otherwise process the association
6859 Analyze (Expression (Assoc));
6861 if Is_Array_Type (P_Type) then
6862 Analyze_Array_Component_Update (Assoc);
6864 elsif Is_Record_Type (P_Type) then
6866 -- Reset the common type used in a multiple component update
6867 -- as we are processing the contents of a new association.
6869 Common_Typ := Empty;
6871 Comp := First (Choices (Assoc));
6872 while Present (Comp) loop
6873 if Nkind (Comp) = N_Identifier then
6874 Analyze_Record_Component_Update (Comp);
6876 -- The use of others is illegal (SPARK RM 4.4.1(5))
6878 elsif Nkind (Comp) = N_Others_Choice then
6880 ("others choice not allowed in attribute %", Comp);
6882 -- The name of a record component cannot appear in any
6887 ("name should be identifier or OTHERS", Comp);
6898 -- The type of attribute 'Update is that of the prefix
6900 Set_Etype (N, P_Type);
6902 Sem_Warn.Warn_On_Suspicious_Update (N);
6909 when Attribute_Val =>
6911 Check_Discrete_Type;
6913 if Is_Boolean_Type (P_Type) then
6914 Error_Msg_Name_1 := Aname;
6915 Error_Msg_Name_2 := Chars (P_Type);
6916 Check_SPARK_05_Restriction
6917 ("attribute% is not allowed for type%", P);
6920 -- Note, we need a range check in general, but we wait for the
6921 -- Resolve call to do this, since we want to let Eval_Attribute
6922 -- have a chance to find an static illegality first.
6924 Resolve (E1, Any_Integer);
6925 Set_Etype (N, P_Base_Type);
6931 when Attribute_Valid => Valid : declare
6932 Pred_Func : constant Entity_Id := Predicate_Function (P_Type);
6937 -- Ignore check for object if we have a 'Valid reference generated
6938 -- by the expanded code, since in some cases valid checks can occur
6939 -- on items that are names, but are not objects (e.g. attributes).
6941 if Comes_From_Source (N) then
6942 Check_Object_Reference (P);
6944 if not Is_Scalar_Type (P_Type) then
6945 Error_Attr_P ("object for % attribute must be of scalar type");
6948 -- If the attribute appears within the subtype's own predicate
6949 -- function, then issue a warning that this will cause infinite
6952 if Present (Pred_Func) and then Current_Scope = Pred_Func then
6953 Error_Msg_N ("attribute Valid requires a predicate check??", N);
6954 Error_Msg_N ("\and will result in infinite recursion??", N);
6958 Set_Etype (N, Standard_Boolean);
6965 when Attribute_Valid_Scalars => Valid_Scalars : declare
6969 if Comes_From_Source (N) then
6970 Check_Object_Reference (P);
6972 -- Do not emit any diagnostics related to private types to avoid
6973 -- disclosing the structure of the type.
6975 if Is_Private_Type (P_Type) then
6977 -- Attribute 'Valid_Scalars is not supported on private tagged
6978 -- types due to a code generation issue. Is_Visible_Component
6979 -- does not allow for a component of a private tagged type to
6980 -- be successfully retrieved.
6982 -- Do not use Error_Attr_P because this bypasses any subsequent
6983 -- processing and leaves the attribute with type Any_Type. This
6984 -- in turn prevents the proper expansion of the attribute into
6987 if Is_Tagged_Type (P_Type) then
6988 Error_Msg_Name_1 := Aname;
6989 Error_Msg_N ("??effects of attribute % are ignored", N);
6992 -- Otherwise the type is not private
6995 if not Scalar_Part_Present (P_Type) then
6996 Error_Msg_Name_1 := Aname;
6998 ("??attribute % always True, no scalars to check", P);
6999 Set_Boolean_Result (N, True);
7002 -- Attribute 'Valid_Scalars is illegal on unchecked union types
7003 -- because it is not always guaranteed that the components are
7004 -- retrievable based on whether the discriminants are inferable
7006 if Has_Unchecked_Union (P_Type) then
7008 ("attribute % not allowed for Unchecked_Union type");
7013 Set_Etype (N, Standard_Boolean);
7020 when Attribute_Value =>
7021 Check_SPARK_05_Restriction_On_Attribute;
7025 -- Case of enumeration type
7027 -- When an enumeration type appears in an attribute reference, all
7028 -- literals of the type are marked as referenced. This must only be
7029 -- done if the attribute reference appears in the current source.
7030 -- Otherwise the information on references may differ between a
7031 -- normal compilation and one that performs inlining.
7033 if Is_Enumeration_Type (P_Type)
7034 and then In_Extended_Main_Code_Unit (N)
7036 Check_Restriction (No_Enumeration_Maps, N);
7038 -- Mark all enumeration literals as referenced, since the use of
7039 -- the Value attribute can implicitly reference any of the
7040 -- literals of the enumeration base type.
7043 Ent : Entity_Id := First_Literal (P_Base_Type);
7045 while Present (Ent) loop
7046 Set_Referenced (Ent);
7052 -- Set Etype before resolving expression because expansion of
7053 -- expression may require enclosing type. Note that the type
7054 -- returned by 'Value is the base type of the prefix type.
7056 Set_Etype (N, P_Base_Type);
7057 Validate_Non_Static_Attribute_Function_Call;
7059 -- Check restriction No_Fixed_IO
7061 if Restriction_Check_Required (No_Fixed_IO)
7062 and then Is_Fixed_Point_Type (P_Type)
7064 Check_Restriction (No_Fixed_IO, P);
7071 when Attribute_Value_Size =>
7074 Check_Not_Incomplete_Type;
7075 Set_Etype (N, Universal_Integer);
7081 when Attribute_Version =>
7084 Set_Etype (N, RTE (RE_Version_String));
7090 when Attribute_Wchar_T_Size =>
7091 Standard_Attribute (Interfaces_Wchar_T_Size);
7097 when Attribute_Wide_Image =>
7098 Analyze_Image_Attribute (Standard_Wide_String);
7100 ---------------------
7101 -- Wide_Wide_Image --
7102 ---------------------
7104 when Attribute_Wide_Wide_Image =>
7105 Analyze_Image_Attribute (Standard_Wide_Wide_String);
7111 when Attribute_Wide_Value =>
7112 Check_SPARK_05_Restriction_On_Attribute;
7116 -- Set Etype before resolving expression because expansion
7117 -- of expression may require enclosing type.
7119 Set_Etype (N, P_Type);
7120 Validate_Non_Static_Attribute_Function_Call;
7122 -- Check restriction No_Fixed_IO
7124 if Restriction_Check_Required (No_Fixed_IO)
7125 and then Is_Fixed_Point_Type (P_Type)
7127 Check_Restriction (No_Fixed_IO, P);
7130 ---------------------
7131 -- Wide_Wide_Value --
7132 ---------------------
7134 when Attribute_Wide_Wide_Value =>
7138 -- Set Etype before resolving expression because expansion
7139 -- of expression may require enclosing type.
7141 Set_Etype (N, P_Type);
7142 Validate_Non_Static_Attribute_Function_Call;
7144 -- Check restriction No_Fixed_IO
7146 if Restriction_Check_Required (No_Fixed_IO)
7147 and then Is_Fixed_Point_Type (P_Type)
7149 Check_Restriction (No_Fixed_IO, P);
7152 ---------------------
7153 -- Wide_Wide_Width --
7154 ---------------------
7156 when Attribute_Wide_Wide_Width =>
7159 Set_Etype (N, Universal_Integer);
7165 when Attribute_Wide_Width =>
7166 Check_SPARK_05_Restriction_On_Attribute;
7169 Set_Etype (N, Universal_Integer);
7175 when Attribute_Width =>
7176 Check_SPARK_05_Restriction_On_Attribute;
7179 Set_Etype (N, Universal_Integer);
7185 when Attribute_Word_Size =>
7186 Standard_Attribute (System_Word_Size);
7192 when Attribute_Write =>
7194 Check_Stream_Attribute (TSS_Stream_Write);
7195 Set_Etype (N, Standard_Void_Type);
7196 Resolve (N, Standard_Void_Type);
7200 -- In SPARK certain attributes (see below) depend on Tasking_State.
7201 -- Ensure that the entity is available for gnat2why by loading it.
7202 -- See SPARK RM 9(18) for the relevant rule.
7204 if GNATprove_Mode then
7210 when Attribute_Callable
7213 | Attribute_Terminated
7215 Unused := RTE (RE_Tasking_State);
7223 -- All errors raise Bad_Attribute, so that we get out before any further
7224 -- damage occurs when an error is detected (for example, if we check for
7225 -- one attribute expression, and the check succeeds, we want to be able
7226 -- to proceed securely assuming that an expression is in fact present.
7228 -- Note: we set the attribute analyzed in this case to prevent any
7229 -- attempt at reanalysis which could generate spurious error msgs.
7232 when Bad_Attribute =>
7234 Set_Etype (N, Any_Type);
7236 end Analyze_Attribute;
7238 --------------------
7239 -- Eval_Attribute --
7240 --------------------
7242 procedure Eval_Attribute (N : Node_Id) is
7243 Loc : constant Source_Ptr := Sloc (N);
7244 Aname : constant Name_Id := Attribute_Name (N);
7245 Id : constant Attribute_Id := Get_Attribute_Id (Aname);
7246 P : constant Node_Id := Prefix (N);
7248 C_Type : constant Entity_Id := Etype (N);
7249 -- The type imposed by the context
7252 -- First expression, or Empty if none
7255 -- Second expression, or Empty if none
7257 P_Entity : Entity_Id;
7258 -- Entity denoted by prefix
7261 -- The type of the prefix
7263 P_Base_Type : Entity_Id;
7264 -- The base type of the prefix type
7266 P_Root_Type : Entity_Id;
7267 -- The root type of the prefix type
7269 Static : Boolean := False;
7270 -- True if the result is Static. This is set by the general processing
7271 -- to true if the prefix is static, and all expressions are static. It
7272 -- can be reset as processing continues for particular attributes. This
7273 -- flag can still be True if the reference raises a constraint error.
7274 -- Is_Static_Expression (N) is set to follow this value as it is set
7275 -- and we could always reference this, but it is convenient to have a
7276 -- simple short name to use, since it is frequently referenced.
7278 Lo_Bound, Hi_Bound : Node_Id;
7279 -- Expressions for low and high bounds of type or array index referenced
7280 -- by First, Last, or Length attribute for array, set by Set_Bounds.
7283 -- Constraint error node used if we have an attribute reference has
7284 -- an argument that raises a constraint error. In this case we replace
7285 -- the attribute with a raise constraint_error node. This is important
7286 -- processing, since otherwise gigi might see an attribute which it is
7287 -- unprepared to deal with.
7289 procedure Check_Concurrent_Discriminant (Bound : Node_Id);
7290 -- If Bound is a reference to a discriminant of a task or protected type
7291 -- occurring within the object's body, rewrite attribute reference into
7292 -- a reference to the corresponding discriminal. Use for the expansion
7293 -- of checks against bounds of entry family index subtypes.
7295 procedure Check_Expressions;
7296 -- In case where the attribute is not foldable, the expressions, if
7297 -- any, of the attribute, are in a non-static context. This procedure
7298 -- performs the required additional checks.
7300 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean;
7301 -- Determines if the given type has compile time known bounds. Note
7302 -- that we enter the case statement even in cases where the prefix
7303 -- type does NOT have known bounds, so it is important to guard any
7304 -- attempt to evaluate both bounds with a call to this function.
7306 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint);
7307 -- This procedure is called when the attribute N has a non-static
7308 -- but compile time known value given by Val. It includes the
7309 -- necessary checks for out of range values.
7311 function Fore_Value return Nat;
7312 -- Computes the Fore value for the current attribute prefix, which is
7313 -- known to be a static fixed-point type. Used by Fore and Width.
7315 function Mantissa return Uint;
7316 -- Returns the Mantissa value for the prefix type
7318 procedure Set_Bounds;
7319 -- Used for First, Last and Length attributes applied to an array or
7320 -- array subtype. Sets the variables Lo_Bound and Hi_Bound to the low
7321 -- and high bound expressions for the index referenced by the attribute
7322 -- designator (i.e. the first index if no expression is present, and the
7323 -- N'th index if the value N is present as an expression). Also used for
7324 -- First and Last of scalar types and for First_Valid and Last_Valid.
7325 -- Static is reset to False if the type or index type is not statically
7328 function Statically_Denotes_Entity (N : Node_Id) return Boolean;
7329 -- Verify that the prefix of a potentially static array attribute
7330 -- satisfies the conditions of 4.9 (14).
7332 -----------------------------------
7333 -- Check_Concurrent_Discriminant --
7334 -----------------------------------
7336 procedure Check_Concurrent_Discriminant (Bound : Node_Id) is
7338 -- The concurrent (task or protected) type
7341 if Nkind (Bound) = N_Identifier
7342 and then Ekind (Entity (Bound)) = E_Discriminant
7343 and then Is_Concurrent_Record_Type (Scope (Entity (Bound)))
7345 Tsk := Corresponding_Concurrent_Type (Scope (Entity (Bound)));
7347 if In_Open_Scopes (Tsk) and then Has_Completion (Tsk) then
7349 -- Find discriminant of original concurrent type, and use
7350 -- its current discriminal, which is the renaming within
7351 -- the task/protected body.
7355 (Find_Body_Discriminal (Entity (Bound)), Loc));
7358 end Check_Concurrent_Discriminant;
7360 -----------------------
7361 -- Check_Expressions --
7362 -----------------------
7364 procedure Check_Expressions is
7368 while Present (E) loop
7369 Check_Non_Static_Context (E);
7372 end Check_Expressions;
7374 ----------------------------------
7375 -- Compile_Time_Known_Attribute --
7376 ----------------------------------
7378 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint) is
7379 T : constant Entity_Id := Etype (N);
7382 Fold_Uint (N, Val, False);
7384 -- Check that result is in bounds of the type if it is static
7386 if Is_In_Range (N, T, Assume_Valid => False) then
7389 elsif Is_Out_Of_Range (N, T) then
7390 Apply_Compile_Time_Constraint_Error
7391 (N, "value not in range of}??", CE_Range_Check_Failed);
7393 elsif not Range_Checks_Suppressed (T) then
7394 Enable_Range_Check (N);
7397 Set_Do_Range_Check (N, False);
7399 end Compile_Time_Known_Attribute;
7401 -------------------------------
7402 -- Compile_Time_Known_Bounds --
7403 -------------------------------
7405 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean is
7408 Compile_Time_Known_Value (Type_Low_Bound (Typ))
7410 Compile_Time_Known_Value (Type_High_Bound (Typ));
7411 end Compile_Time_Known_Bounds;
7417 -- Note that the Fore calculation is based on the actual values
7418 -- of the bounds, and does not take into account possible rounding.
7420 function Fore_Value return Nat is
7421 Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type));
7422 Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type));
7423 Small : constant Ureal := Small_Value (P_Type);
7424 Lo_Real : constant Ureal := Lo * Small;
7425 Hi_Real : constant Ureal := Hi * Small;
7430 -- Bounds are given in terms of small units, so first compute
7431 -- proper values as reals.
7433 T := UR_Max (abs Lo_Real, abs Hi_Real);
7436 -- Loop to compute proper value if more than one digit required
7438 while T >= Ureal_10 loop
7450 -- Table of mantissa values accessed by function Computed using
7453 -- T'Mantissa = integer next above (D * log(10)/log(2)) + 1)
7455 -- where D is T'Digits (RM83 3.5.7)
7457 Mantissa_Value : constant array (Nat range 1 .. 40) of Nat := (
7499 function Mantissa return Uint is
7502 UI_From_Int (Mantissa_Value (UI_To_Int (Digits_Value (P_Type))));
7509 procedure Set_Bounds is
7515 -- For a string literal subtype, we have to construct the bounds.
7516 -- Valid Ada code never applies attributes to string literals, but
7517 -- it is convenient to allow the expander to generate attribute
7518 -- references of this type (e.g. First and Last applied to a string
7521 -- Note that the whole point of the E_String_Literal_Subtype is to
7522 -- avoid this construction of bounds, but the cases in which we
7523 -- have to materialize them are rare enough that we don't worry.
7525 -- The low bound is simply the low bound of the base type. The
7526 -- high bound is computed from the length of the string and this
7529 if Ekind (P_Type) = E_String_Literal_Subtype then
7530 Ityp := Etype (First_Index (Base_Type (P_Type)));
7531 Lo_Bound := Type_Low_Bound (Ityp);
7534 Make_Integer_Literal (Sloc (P),
7536 Expr_Value (Lo_Bound) + String_Literal_Length (P_Type) - 1);
7538 Set_Parent (Hi_Bound, P);
7539 Analyze_And_Resolve (Hi_Bound, Etype (Lo_Bound));
7542 -- For non-array case, just get bounds of scalar type
7544 elsif Is_Scalar_Type (P_Type) then
7547 -- For a fixed-point type, we must freeze to get the attributes
7548 -- of the fixed-point type set now so we can reference them.
7550 if Is_Fixed_Point_Type (P_Type)
7551 and then not Is_Frozen (Base_Type (P_Type))
7552 and then Compile_Time_Known_Value (Type_Low_Bound (P_Type))
7553 and then Compile_Time_Known_Value (Type_High_Bound (P_Type))
7555 Freeze_Fixed_Point_Type (Base_Type (P_Type));
7558 -- For array case, get type of proper index
7564 Ndim := UI_To_Int (Expr_Value (E1));
7567 Indx := First_Index (P_Type);
7568 for J in 1 .. Ndim - 1 loop
7572 -- If no index type, get out (some other error occurred, and
7573 -- we don't have enough information to complete the job).
7581 Ityp := Etype (Indx);
7584 -- A discrete range in an index constraint is allowed to be a
7585 -- subtype indication. This is syntactically a pain, but should
7586 -- not propagate to the entity for the corresponding index subtype.
7587 -- After checking that the subtype indication is legal, the range
7588 -- of the subtype indication should be transfered to the entity.
7589 -- The attributes for the bounds should remain the simple retrievals
7590 -- that they are now.
7592 Lo_Bound := Type_Low_Bound (Ityp);
7593 Hi_Bound := Type_High_Bound (Ityp);
7595 -- If subtype is non-static, result is definitely non-static
7597 if not Is_Static_Subtype (Ityp) then
7599 Set_Is_Static_Expression (N, False);
7601 -- Subtype is static, does it raise CE?
7603 elsif not Is_OK_Static_Subtype (Ityp) then
7604 Set_Raises_Constraint_Error (N);
7608 -------------------------------
7609 -- Statically_Denotes_Entity --
7610 -------------------------------
7612 function Statically_Denotes_Entity (N : Node_Id) return Boolean is
7616 if not Is_Entity_Name (N) then
7623 Nkind (Parent (E)) /= N_Object_Renaming_Declaration
7624 or else Statically_Denotes_Entity (Renamed_Object (E));
7625 end Statically_Denotes_Entity;
7627 -- Start of processing for Eval_Attribute
7630 -- The To_Address attribute can be static, but it cannot be evaluated at
7631 -- compile time, so just return.
7633 if Id = Attribute_To_Address then
7637 -- Initialize result as non-static, will be reset if appropriate
7639 Set_Is_Static_Expression (N, False);
7641 -- Acquire first two expressions (at the moment, no attributes take more
7642 -- than two expressions in any case).
7644 if Present (Expressions (N)) then
7645 E1 := First (Expressions (N));
7652 -- Special processing for Enabled attribute. This attribute has a very
7653 -- special prefix, and the easiest way to avoid lots of special checks
7654 -- to protect this special prefix from causing trouble is to deal with
7655 -- this attribute immediately and be done with it.
7657 if Id = Attribute_Enabled then
7659 -- We skip evaluation if the expander is not active. This is not just
7660 -- an optimization. It is of key importance that we not rewrite the
7661 -- attribute in a generic template, since we want to pick up the
7662 -- setting of the check in the instance, Testing Expander_Active
7663 -- might seem an easy way of doing this, but we need to account for
7664 -- ASIS needs, so check explicitly for a generic context.
7666 if not Inside_A_Generic then
7668 C : constant Check_Id := Get_Check_Id (Chars (P));
7673 if C in Predefined_Check_Id then
7674 R := Scope_Suppress.Suppress (C);
7676 R := Is_Check_Suppressed (Empty, C);
7680 R := Is_Check_Suppressed (Entity (E1), C);
7683 Rewrite (N, New_Occurrence_Of (Boolean_Literals (not R), Loc));
7690 -- Attribute 'Img applied to a static enumeration value is static, and
7691 -- we will do the folding right here (things get confused if we let this
7692 -- case go through the normal circuitry).
7694 if Attribute_Name (N) = Name_Img
7695 and then Is_Entity_Name (P)
7696 and then Is_Enumeration_Type (Etype (Entity (P)))
7697 and then Is_OK_Static_Expression (P)
7700 Lit : constant Entity_Id := Expr_Value_E (P);
7705 Get_Unqualified_Decoded_Name_String (Chars (Lit));
7706 Set_Casing (All_Upper_Case);
7707 Store_String_Chars (Name_Buffer (1 .. Name_Len));
7710 Rewrite (N, Make_String_Literal (Loc, Strval => Str));
7711 Analyze_And_Resolve (N, Standard_String);
7712 Set_Is_Static_Expression (N, True);
7718 -- Special processing for cases where the prefix is an object. For this
7719 -- purpose, a string literal counts as an object (attributes of string
7720 -- literals can only appear in generated code).
7722 if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then
7724 -- For Component_Size, the prefix is an array object, and we apply
7725 -- the attribute to the type of the object. This is allowed for both
7726 -- unconstrained and constrained arrays, since the bounds have no
7727 -- influence on the value of this attribute.
7729 if Id = Attribute_Component_Size then
7730 P_Entity := Etype (P);
7732 -- For Enum_Rep, evaluation depends on the nature of the prefix and
7733 -- the optional argument.
7735 elsif Id = Attribute_Enum_Rep then
7736 if Is_Entity_Name (P) then
7739 Enum_Expr : Node_Id;
7740 -- The enumeration-type expression of interest
7745 if Ekind_In (Entity (P), E_Constant,
7746 E_Enumeration_Literal)
7750 -- Enum_Type'Enum_Rep (E1) case
7752 elsif Is_Enumeration_Type (Entity (P)) then
7755 -- Otherwise the attribute must be expanded into a
7756 -- conversion and evaluated at run time.
7763 -- We can fold if the expression is an enumeration
7764 -- literal, or if it denotes a constant whose value
7765 -- is known at compile time.
7767 if Nkind (Enum_Expr) in N_Has_Entity
7768 and then (Ekind (Entity (Enum_Expr)) =
7769 E_Enumeration_Literal
7771 (Ekind (Entity (Enum_Expr)) = E_Constant
7772 and then Nkind (Parent (Entity (Enum_Expr))) =
7773 N_Object_Declaration
7774 and then Compile_Time_Known_Value
7775 (Expression (Parent (Entity (P))))))
7777 P_Entity := Etype (P);
7784 -- Otherwise the attribute is illegal, do not attempt to perform
7785 -- any kind of folding.
7791 -- For First and Last, the prefix is an array object, and we apply
7792 -- the attribute to the type of the array, but we need a constrained
7793 -- type for this, so we use the actual subtype if available.
7795 elsif Id = Attribute_First or else
7796 Id = Attribute_Last or else
7797 Id = Attribute_Length
7800 AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P);
7803 if Present (AS) and then Is_Constrained (AS) then
7806 -- If we have an unconstrained type we cannot fold
7814 -- For Size, give size of object if available, otherwise we
7815 -- cannot fold Size.
7817 elsif Id = Attribute_Size then
7818 if Is_Entity_Name (P)
7819 and then Known_Esize (Entity (P))
7821 Compile_Time_Known_Attribute (N, Esize (Entity (P)));
7829 -- For Alignment, give size of object if available, otherwise we
7830 -- cannot fold Alignment.
7832 elsif Id = Attribute_Alignment then
7833 if Is_Entity_Name (P)
7834 and then Known_Alignment (Entity (P))
7836 Fold_Uint (N, Alignment (Entity (P)), Static);
7844 -- For Lock_Free, we apply the attribute to the type of the object.
7845 -- This is allowed since we have already verified that the type is a
7848 elsif Id = Attribute_Lock_Free then
7849 P_Entity := Etype (P);
7851 -- No other attributes for objects are folded
7858 -- Cases where P is not an object. Cannot do anything if P is not the
7859 -- name of an entity.
7861 elsif not Is_Entity_Name (P) then
7865 -- Otherwise get prefix entity
7868 P_Entity := Entity (P);
7871 -- If we are asked to evaluate an attribute where the prefix is a
7872 -- non-frozen generic actual type whose RM_Size is still set to zero,
7873 -- then abandon the effort.
7875 if Is_Type (P_Entity)
7876 and then (not Is_Frozen (P_Entity)
7877 and then Is_Generic_Actual_Type (P_Entity)
7878 and then RM_Size (P_Entity) = 0)
7880 -- However, the attribute Unconstrained_Array must be evaluated,
7881 -- since it is documented to be a static attribute (and can for
7882 -- example appear in a Compile_Time_Warning pragma). The frozen
7883 -- status of the type does not affect its evaluation.
7885 and then Id /= Attribute_Unconstrained_Array
7890 -- At this stage P_Entity is the entity to which the attribute
7891 -- is to be applied. This is usually simply the entity of the
7892 -- prefix, except in some cases of attributes for objects, where
7893 -- as described above, we apply the attribute to the object type.
7895 -- Here is where we make sure that static attributes are properly
7896 -- marked as such. These are attributes whose prefix is a static
7897 -- scalar subtype, whose result is scalar, and whose arguments, if
7898 -- present, are static scalar expressions. Note that such references
7899 -- are static expressions even if they raise Constraint_Error.
7901 -- For example, Boolean'Pos (1/0 = 0) is a static expression, even
7902 -- though evaluating it raises constraint error. This means that a
7903 -- declaration like:
7905 -- X : constant := (if True then 1 else Boolean'Pos (1/0 = 0));
7907 -- is legal, since here this expression appears in a statically
7908 -- unevaluated position, so it does not actually raise an exception.
7910 -- T'Descriptor_Size is never static, even if T is static.
7912 if Is_Scalar_Type (P_Entity)
7913 and then (not Is_Generic_Type (P_Entity))
7914 and then Is_Static_Subtype (P_Entity)
7915 and then Is_Scalar_Type (Etype (N))
7918 or else (Is_Static_Expression (E1)
7919 and then Is_Scalar_Type (Etype (E1))))
7922 or else (Is_Static_Expression (E2)
7923 and then Is_Scalar_Type (Etype (E1))))
7924 and then Id /= Attribute_Descriptor_Size
7927 Set_Is_Static_Expression (N, True);
7930 -- First foldable possibility is a scalar or array type (RM 4.9(7))
7931 -- that is not generic (generic types are eliminated by RM 4.9(25)).
7932 -- Note we allow non-static non-generic types at this stage as further
7935 if Is_Type (P_Entity)
7936 and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity))
7937 and then (not Is_Generic_Type (P_Entity))
7941 -- Second foldable possibility is an array object (RM 4.9(8))
7943 elsif Ekind_In (P_Entity, E_Variable, E_Constant)
7944 and then Is_Array_Type (Etype (P_Entity))
7945 and then (not Is_Generic_Type (Etype (P_Entity)))
7947 P_Type := Etype (P_Entity);
7949 -- If the entity is an array constant with an unconstrained nominal
7950 -- subtype then get the type from the initial value. If the value has
7951 -- been expanded into assignments, there is no expression and the
7952 -- attribute reference remains dynamic.
7954 -- We could do better here and retrieve the type ???
7956 if Ekind (P_Entity) = E_Constant
7957 and then not Is_Constrained (P_Type)
7959 if No (Constant_Value (P_Entity)) then
7962 P_Type := Etype (Constant_Value (P_Entity));
7966 -- Definite must be folded if the prefix is not a generic type, that
7967 -- is to say if we are within an instantiation. Same processing applies
7968 -- to the GNAT attributes Atomic_Always_Lock_Free, Has_Discriminants,
7969 -- Lock_Free, Type_Class, Has_Tagged_Value, and Unconstrained_Array.
7971 elsif (Id = Attribute_Atomic_Always_Lock_Free or else
7972 Id = Attribute_Definite or else
7973 Id = Attribute_Has_Access_Values or else
7974 Id = Attribute_Has_Discriminants or else
7975 Id = Attribute_Has_Tagged_Values or else
7976 Id = Attribute_Lock_Free or else
7977 Id = Attribute_Type_Class or else
7978 Id = Attribute_Unconstrained_Array or else
7979 Id = Attribute_Max_Alignment_For_Allocation)
7980 and then not Is_Generic_Type (P_Entity)
7984 -- We can fold 'Size applied to a type if the size is known (as happens
7985 -- for a size from an attribute definition clause). At this stage, this
7986 -- can happen only for types (e.g. record types) for which the size is
7987 -- always non-static. We exclude generic types from consideration (since
7988 -- they have bogus sizes set within templates).
7990 elsif Id = Attribute_Size
7991 and then Is_Type (P_Entity)
7992 and then (not Is_Generic_Type (P_Entity))
7993 and then Known_Static_RM_Size (P_Entity)
7995 Compile_Time_Known_Attribute (N, RM_Size (P_Entity));
7998 -- We can fold 'Alignment applied to a type if the alignment is known
7999 -- (as happens for an alignment from an attribute definition clause).
8000 -- At this stage, this can happen only for types (e.g. record types) for
8001 -- which the size is always non-static. We exclude generic types from
8002 -- consideration (since they have bogus sizes set within templates).
8004 elsif Id = Attribute_Alignment
8005 and then Is_Type (P_Entity)
8006 and then (not Is_Generic_Type (P_Entity))
8007 and then Known_Alignment (P_Entity)
8009 Compile_Time_Known_Attribute (N, Alignment (P_Entity));
8012 -- If this is an access attribute that is known to fail accessibility
8013 -- check, rewrite accordingly.
8015 elsif Attribute_Name (N) = Name_Access
8016 and then Raises_Constraint_Error (N)
8019 Make_Raise_Program_Error (Loc,
8020 Reason => PE_Accessibility_Check_Failed));
8021 Set_Etype (N, C_Type);
8024 -- No other cases are foldable (they certainly aren't static, and at
8025 -- the moment we don't try to fold any cases other than the ones above).
8032 -- If either attribute or the prefix is Any_Type, then propagate
8033 -- Any_Type to the result and don't do anything else at all.
8035 if P_Type = Any_Type
8036 or else (Present (E1) and then Etype (E1) = Any_Type)
8037 or else (Present (E2) and then Etype (E2) = Any_Type)
8039 Set_Etype (N, Any_Type);
8043 -- Scalar subtype case. We have not yet enforced the static requirement
8044 -- of (RM 4.9(7)) and we don't intend to just yet, since there are cases
8045 -- of non-static attribute references (e.g. S'Digits for a non-static
8046 -- floating-point type, which we can compute at compile time).
8048 -- Note: this folding of non-static attributes is not simply a case of
8049 -- optimization. For many of the attributes affected, Gigi cannot handle
8050 -- the attribute and depends on the front end having folded them away.
8052 -- Note: although we don't require staticness at this stage, we do set
8053 -- the Static variable to record the staticness, for easy reference by
8054 -- those attributes where it matters (e.g. Succ and Pred), and also to
8055 -- be used to ensure that non-static folded things are not marked as
8056 -- being static (a check that is done right at the end).
8058 P_Root_Type := Root_Type (P_Type);
8059 P_Base_Type := Base_Type (P_Type);
8061 -- If the root type or base type is generic, then we cannot fold. This
8062 -- test is needed because subtypes of generic types are not always
8063 -- marked as being generic themselves (which seems odd???)
8065 if Is_Generic_Type (P_Root_Type)
8066 or else Is_Generic_Type (P_Base_Type)
8071 if Is_Scalar_Type (P_Type) then
8072 if not Is_Static_Subtype (P_Type) then
8074 Set_Is_Static_Expression (N, False);
8075 elsif not Is_OK_Static_Subtype (P_Type) then
8076 Set_Raises_Constraint_Error (N);
8079 -- Array case. We enforce the constrained requirement of (RM 4.9(7-8))
8080 -- since we can't do anything with unconstrained arrays. In addition,
8081 -- only the First, Last and Length attributes are possibly static.
8083 -- Atomic_Always_Lock_Free, Definite, Has_Access_Values,
8084 -- Has_Discriminants, Has_Tagged_Values, Lock_Free, Type_Class, and
8085 -- Unconstrained_Array are again exceptions, because they apply as well
8086 -- to unconstrained types.
8088 -- In addition Component_Size is an exception since it is possibly
8089 -- foldable, even though it is never static, and it does apply to
8090 -- unconstrained arrays. Furthermore, it is essential to fold this
8091 -- in the packed case, since otherwise the value will be incorrect.
8093 elsif Id = Attribute_Atomic_Always_Lock_Free or else
8094 Id = Attribute_Definite or else
8095 Id = Attribute_Has_Access_Values or else
8096 Id = Attribute_Has_Discriminants or else
8097 Id = Attribute_Has_Tagged_Values or else
8098 Id = Attribute_Lock_Free or else
8099 Id = Attribute_Type_Class or else
8100 Id = Attribute_Unconstrained_Array or else
8101 Id = Attribute_Component_Size
8104 Set_Is_Static_Expression (N, False);
8106 elsif Id /= Attribute_Max_Alignment_For_Allocation then
8107 if not Is_Constrained (P_Type)
8108 or else (Id /= Attribute_First and then
8109 Id /= Attribute_Last and then
8110 Id /= Attribute_Length)
8116 -- The rules in (RM 4.9(7,8)) require a static array, but as in the
8117 -- scalar case, we hold off on enforcing staticness, since there are
8118 -- cases which we can fold at compile time even though they are not
8119 -- static (e.g. 'Length applied to a static index, even though other
8120 -- non-static indexes make the array type non-static). This is only
8121 -- an optimization, but it falls out essentially free, so why not.
8122 -- Again we compute the variable Static for easy reference later
8123 -- (note that no array attributes are static in Ada 83).
8125 -- We also need to set Static properly for subsequent legality checks
8126 -- which might otherwise accept non-static constants in contexts
8127 -- where they are not legal.
8130 Ada_Version >= Ada_95 and then Statically_Denotes_Entity (P);
8131 Set_Is_Static_Expression (N, Static);
8137 Nod := First_Index (P_Type);
8139 -- The expression is static if the array type is constrained
8140 -- by given bounds, and not by an initial expression. Constant
8141 -- strings are static in any case.
8143 if Root_Type (P_Type) /= Standard_String then
8145 Static and then not Is_Constr_Subt_For_U_Nominal (P_Type);
8146 Set_Is_Static_Expression (N, Static);
8149 while Present (Nod) loop
8150 if not Is_Static_Subtype (Etype (Nod)) then
8152 Set_Is_Static_Expression (N, False);
8154 elsif not Is_OK_Static_Subtype (Etype (Nod)) then
8155 Set_Raises_Constraint_Error (N);
8157 Set_Is_Static_Expression (N, False);
8160 -- If however the index type is generic, or derived from
8161 -- one, attributes cannot be folded.
8163 if Is_Generic_Type (Root_Type (Etype (Nod)))
8164 and then Id /= Attribute_Component_Size
8174 -- Check any expressions that are present. Note that these expressions,
8175 -- depending on the particular attribute type, are either part of the
8176 -- attribute designator, or they are arguments in a case where the
8177 -- attribute reference returns a function. In the latter case, the
8178 -- rule in (RM 4.9(22)) applies and in particular requires the type
8179 -- of the expressions to be scalar in order for the attribute to be
8180 -- considered to be static.
8188 while Present (E) loop
8190 -- If expression is not static, then the attribute reference
8191 -- result certainly cannot be static.
8193 if not Is_Static_Expression (E) then
8195 Set_Is_Static_Expression (N, False);
8198 if Raises_Constraint_Error (E) then
8199 Set_Raises_Constraint_Error (N);
8202 -- If the result is not known at compile time, or is not of
8203 -- a scalar type, then the result is definitely not static,
8204 -- so we can quit now.
8206 if not Compile_Time_Known_Value (E)
8207 or else not Is_Scalar_Type (Etype (E))
8209 -- An odd special case, if this is a Pos attribute, this
8210 -- is where we need to apply a range check since it does
8211 -- not get done anywhere else.
8213 if Id = Attribute_Pos then
8214 if Is_Integer_Type (Etype (E)) then
8215 Apply_Range_Check (E, Etype (N));
8222 -- If the expression raises a constraint error, then so does
8223 -- the attribute reference. We keep going in this case because
8224 -- we are still interested in whether the attribute reference
8225 -- is static even if it is not static.
8227 elsif Raises_Constraint_Error (E) then
8228 Set_Raises_Constraint_Error (N);
8234 if Raises_Constraint_Error (Prefix (N)) then
8235 Set_Is_Static_Expression (N, False);
8240 -- Deal with the case of a static attribute reference that raises
8241 -- constraint error. The Raises_Constraint_Error flag will already
8242 -- have been set, and the Static flag shows whether the attribute
8243 -- reference is static. In any case we certainly can't fold such an
8244 -- attribute reference.
8246 -- Note that the rewriting of the attribute node with the constraint
8247 -- error node is essential in this case, because otherwise Gigi might
8248 -- blow up on one of the attributes it never expects to see.
8250 -- The constraint_error node must have the type imposed by the context,
8251 -- to avoid spurious errors in the enclosing expression.
8253 if Raises_Constraint_Error (N) then
8255 Make_Raise_Constraint_Error (Sloc (N),
8256 Reason => CE_Range_Check_Failed);
8257 Set_Etype (CE_Node, Etype (N));
8258 Set_Raises_Constraint_Error (CE_Node);
8260 Rewrite (N, Relocate_Node (CE_Node));
8261 Set_Raises_Constraint_Error (N, True);
8265 -- At this point we have a potentially foldable attribute reference.
8266 -- If Static is set, then the attribute reference definitely obeys
8267 -- the requirements in (RM 4.9(7,8,22)), and it definitely can be
8268 -- folded. If Static is not set, then the attribute may or may not
8269 -- be foldable, and the individual attribute processing routines
8270 -- test Static as required in cases where it makes a difference.
8272 -- In the case where Static is not set, we do know that all the
8273 -- expressions present are at least known at compile time (we assumed
8274 -- above that if this was not the case, then there was no hope of static
8275 -- evaluation). However, we did not require that the bounds of the
8276 -- prefix type be compile time known, let alone static). That's because
8277 -- there are many attributes that can be computed at compile time on
8278 -- non-static subtypes, even though such references are not static
8281 -- For VAX float, the root type is an IEEE type. So make sure to use the
8282 -- base type instead of the root-type for floating point attributes.
8286 -- Attributes related to Ada 2012 iterators; nothing to evaluate for
8289 when Attribute_Constant_Indexing
8290 | Attribute_Default_Iterator
8291 | Attribute_Implicit_Dereference
8292 | Attribute_Iterator_Element
8293 | Attribute_Iterable
8295 | Attribute_Variable_Indexing
8299 -- Internal attributes used to deal with Ada 2012 delayed aspects.
8300 -- These were already rejected by the parser. Thus they shouldn't
8303 when Internal_Attribute_Id =>
8304 raise Program_Error;
8310 when Attribute_Adjacent =>
8314 (P_Base_Type, Expr_Value_R (E1), Expr_Value_R (E2)),
8321 when Attribute_Aft =>
8322 Fold_Uint (N, Aft_Value (P_Type), Static);
8328 when Attribute_Alignment => Alignment_Block : declare
8329 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
8332 -- Fold if alignment is set and not otherwise
8334 if Known_Alignment (P_TypeA) then
8335 Fold_Uint (N, Alignment (P_TypeA), Static);
8337 end Alignment_Block;
8339 -----------------------------
8340 -- Atomic_Always_Lock_Free --
8341 -----------------------------
8343 -- Atomic_Always_Lock_Free attribute is a Boolean, thus no need to fold
8346 when Attribute_Atomic_Always_Lock_Free => Atomic_Always_Lock_Free :
8348 V : constant Entity_Id :=
8350 (Support_Atomic_Primitives_On_Target
8351 and then Support_Atomic_Primitives (P_Type));
8354 Rewrite (N, New_Occurrence_Of (V, Loc));
8356 -- Analyze and resolve as boolean. Note that this attribute is a
8357 -- static attribute in GNAT.
8359 Analyze_And_Resolve (N, Standard_Boolean);
8361 Set_Is_Static_Expression (N);
8362 end Atomic_Always_Lock_Free;
8368 -- Bit can never be folded
8370 when Attribute_Bit =>
8377 -- Body_version can never be static
8379 when Attribute_Body_Version =>
8386 when Attribute_Ceiling =>
8388 (N, Eval_Fat.Ceiling (P_Base_Type, Expr_Value_R (E1)), Static);
8390 --------------------
8391 -- Component_Size --
8392 --------------------
8394 when Attribute_Component_Size =>
8395 if Known_Static_Component_Size (P_Type) then
8396 Fold_Uint (N, Component_Size (P_Type), Static);
8403 when Attribute_Compose =>
8406 Eval_Fat.Compose (P_Base_Type, Expr_Value_R (E1), Expr_Value (E2)),
8413 -- Constrained is never folded for now, there may be cases that
8414 -- could be handled at compile time. To be looked at later.
8416 when Attribute_Constrained =>
8418 -- The expander might fold it and set the static flag accordingly,
8419 -- but with expansion disabled (as in ASIS), it remains as an
8420 -- attribute reference, and this reference is not static.
8422 Set_Is_Static_Expression (N, False);
8428 when Attribute_Copy_Sign =>
8432 (P_Base_Type, Expr_Value_R (E1), Expr_Value_R (E2)),
8439 when Attribute_Definite =>
8440 Rewrite (N, New_Occurrence_Of (
8441 Boolean_Literals (Is_Definite_Subtype (P_Entity)), Loc));
8442 Analyze_And_Resolve (N, Standard_Boolean);
8448 when Attribute_Delta =>
8449 Fold_Ureal (N, Delta_Value (P_Type), True);
8455 when Attribute_Denorm =>
8457 (N, UI_From_Int (Boolean'Pos (Has_Denormals (P_Type))), Static);
8459 ---------------------
8460 -- Descriptor_Size --
8461 ---------------------
8463 when Attribute_Descriptor_Size =>
8470 when Attribute_Digits =>
8471 Fold_Uint (N, Digits_Value (P_Type), Static);
8477 when Attribute_Emax =>
8479 -- Ada 83 attribute is defined as (RM83 3.5.8)
8481 -- T'Emax = 4 * T'Mantissa
8483 Fold_Uint (N, 4 * Mantissa, Static);
8489 when Attribute_Enum_Rep => Enum_Rep : declare
8493 -- The attribute appears in the form:
8495 -- Enum_Typ'Enum_Rep (Const)
8496 -- Enum_Typ'Enum_Rep (Enum_Lit)
8498 if Present (E1) then
8501 -- Otherwise the prefix denotes a constant or enumeration literal:
8504 -- Enum_Lit'Enum_Rep
8510 -- For an enumeration type with a non-standard representation use
8511 -- the Enumeration_Rep field of the proper constant. Note that this
8512 -- will not work for types Character/Wide_[Wide-]Character, since no
8513 -- real entities are created for the enumeration literals, but that
8514 -- does not matter since these two types do not have non-standard
8515 -- representations anyway.
8517 if Is_Enumeration_Type (P_Type)
8518 and then Has_Non_Standard_Rep (P_Type)
8520 Fold_Uint (N, Enumeration_Rep (Expr_Value_E (Val)), Static);
8522 -- For enumeration types with standard representations and all other
8523 -- cases (i.e. all integer and modular types), Enum_Rep is equivalent
8527 Fold_Uint (N, Expr_Value (Val), Static);
8535 when Attribute_Enum_Val => Enum_Val : declare
8539 -- We have something like Enum_Type'Enum_Val (23), so search for a
8540 -- corresponding value in the list of Enum_Rep values for the type.
8542 Lit := First_Literal (P_Base_Type);
8544 if Enumeration_Rep (Lit) = Expr_Value (E1) then
8545 Fold_Uint (N, Enumeration_Pos (Lit), Static);
8552 Apply_Compile_Time_Constraint_Error
8553 (N, "no representation value matches",
8554 CE_Range_Check_Failed,
8555 Warn => not Static);
8565 when Attribute_Epsilon =>
8567 -- Ada 83 attribute is defined as (RM83 3.5.8)
8569 -- T'Epsilon = 2.0**(1 - T'Mantissa)
8571 Fold_Ureal (N, Ureal_2 ** (1 - Mantissa), True);
8577 when Attribute_Exponent =>
8579 Eval_Fat.Exponent (P_Base_Type, Expr_Value_R (E1)), Static);
8581 -----------------------
8582 -- Finalization_Size --
8583 -----------------------
8585 when Attribute_Finalization_Size =>
8592 when Attribute_First =>
8595 if Compile_Time_Known_Value (Lo_Bound) then
8596 if Is_Real_Type (P_Type) then
8597 Fold_Ureal (N, Expr_Value_R (Lo_Bound), Static);
8599 Fold_Uint (N, Expr_Value (Lo_Bound), Static);
8603 Check_Concurrent_Discriminant (Lo_Bound);
8610 when Attribute_First_Valid =>
8611 if Has_Predicates (P_Type)
8612 and then Has_Static_Predicate (P_Type)
8615 FirstN : constant Node_Id :=
8616 First (Static_Discrete_Predicate (P_Type));
8618 if Nkind (FirstN) = N_Range then
8619 Fold_Uint (N, Expr_Value (Low_Bound (FirstN)), Static);
8621 Fold_Uint (N, Expr_Value (FirstN), Static);
8627 Fold_Uint (N, Expr_Value (Lo_Bound), Static);
8634 when Attribute_Fixed_Value =>
8641 when Attribute_Floor =>
8643 (N, Eval_Fat.Floor (P_Base_Type, Expr_Value_R (E1)), Static);
8649 when Attribute_Fore =>
8650 if Compile_Time_Known_Bounds (P_Type) then
8651 Fold_Uint (N, UI_From_Int (Fore_Value), Static);
8658 when Attribute_Fraction =>
8660 (N, Eval_Fat.Fraction (P_Base_Type, Expr_Value_R (E1)), Static);
8662 -----------------------
8663 -- Has_Access_Values --
8664 -----------------------
8666 when Attribute_Has_Access_Values =>
8667 Rewrite (N, New_Occurrence_Of
8668 (Boolean_Literals (Has_Access_Values (P_Root_Type)), Loc));
8669 Analyze_And_Resolve (N, Standard_Boolean);
8671 -----------------------
8672 -- Has_Discriminants --
8673 -----------------------
8675 when Attribute_Has_Discriminants =>
8676 Rewrite (N, New_Occurrence_Of (
8677 Boolean_Literals (Has_Discriminants (P_Entity)), Loc));
8678 Analyze_And_Resolve (N, Standard_Boolean);
8680 ----------------------
8681 -- Has_Same_Storage --
8682 ----------------------
8684 when Attribute_Has_Same_Storage =>
8687 -----------------------
8688 -- Has_Tagged_Values --
8689 -----------------------
8691 when Attribute_Has_Tagged_Values =>
8692 Rewrite (N, New_Occurrence_Of
8693 (Boolean_Literals (Has_Tagged_Component (P_Root_Type)), Loc));
8694 Analyze_And_Resolve (N, Standard_Boolean);
8700 when Attribute_Identity =>
8707 -- Image is a scalar attribute, but is never static, because it is
8708 -- not a static function (having a non-scalar argument (RM 4.9(22))
8709 -- However, we can constant-fold the image of an enumeration literal
8710 -- if names are available.
8712 when Attribute_Image =>
8713 if Is_Entity_Name (E1)
8714 and then Ekind (Entity (E1)) = E_Enumeration_Literal
8715 and then not Discard_Names (First_Subtype (Etype (E1)))
8716 and then not Global_Discard_Names
8719 Lit : constant Entity_Id := Entity (E1);
8723 Get_Unqualified_Decoded_Name_String (Chars (Lit));
8724 Set_Casing (All_Upper_Case);
8725 Store_String_Chars (Name_Buffer (1 .. Name_Len));
8727 Rewrite (N, Make_String_Literal (Loc, Strval => Str));
8728 Analyze_And_Resolve (N, Standard_String);
8729 Set_Is_Static_Expression (N, False);
8737 -- We never try to fold Integer_Value (though perhaps we could???)
8739 when Attribute_Integer_Value =>
8746 -- Invalid_Value is a scalar attribute that is never static, because
8747 -- the value is by design out of range.
8749 when Attribute_Invalid_Value =>
8756 when Attribute_Large =>
8758 -- For fixed-point, we use the identity:
8760 -- T'Large = (2.0**T'Mantissa - 1.0) * T'Small
8762 if Is_Fixed_Point_Type (P_Type) then
8764 Make_Op_Multiply (Loc,
8766 Make_Op_Subtract (Loc,
8770 Make_Real_Literal (Loc, Ureal_2),
8772 Make_Attribute_Reference (Loc,
8774 Attribute_Name => Name_Mantissa)),
8775 Right_Opnd => Make_Real_Literal (Loc, Ureal_1)),
8778 Make_Real_Literal (Loc, Small_Value (Entity (P)))));
8780 Analyze_And_Resolve (N, C_Type);
8782 -- Floating-point (Ada 83 compatibility)
8785 -- Ada 83 attribute is defined as (RM83 3.5.8)
8787 -- T'Large = 2.0**T'Emax * (1.0 - 2.0**(-T'Mantissa))
8791 -- T'Emax = 4 * T'Mantissa
8795 Ureal_2 ** (4 * Mantissa) * (Ureal_1 - Ureal_2 ** (-Mantissa)),
8803 when Attribute_Lock_Free => Lock_Free : declare
8804 V : constant Entity_Id := Boolean_Literals (Uses_Lock_Free (P_Type));
8807 Rewrite (N, New_Occurrence_Of (V, Loc));
8809 -- Analyze and resolve as boolean. Note that this attribute is a
8810 -- static attribute in GNAT.
8812 Analyze_And_Resolve (N, Standard_Boolean);
8814 Set_Is_Static_Expression (N);
8821 when Attribute_Last =>
8824 if Compile_Time_Known_Value (Hi_Bound) then
8825 if Is_Real_Type (P_Type) then
8826 Fold_Ureal (N, Expr_Value_R (Hi_Bound), Static);
8828 Fold_Uint (N, Expr_Value (Hi_Bound), Static);
8832 Check_Concurrent_Discriminant (Hi_Bound);
8839 when Attribute_Last_Valid =>
8840 if Has_Predicates (P_Type)
8841 and then Has_Static_Predicate (P_Type)
8844 LastN : constant Node_Id :=
8845 Last (Static_Discrete_Predicate (P_Type));
8847 if Nkind (LastN) = N_Range then
8848 Fold_Uint (N, Expr_Value (High_Bound (LastN)), Static);
8850 Fold_Uint (N, Expr_Value (LastN), Static);
8856 Fold_Uint (N, Expr_Value (Hi_Bound), Static);
8863 when Attribute_Leading_Part =>
8866 Eval_Fat.Leading_Part
8867 (P_Base_Type, Expr_Value_R (E1), Expr_Value (E2)),
8874 when Attribute_Length => Length : declare
8878 -- If any index type is a formal type, or derived from one, the
8879 -- bounds are not static. Treating them as static can produce
8880 -- spurious warnings or improper constant folding.
8882 Ind := First_Index (P_Type);
8883 while Present (Ind) loop
8884 if Is_Generic_Type (Root_Type (Etype (Ind))) then
8893 -- For two compile time values, we can compute length
8895 if Compile_Time_Known_Value (Lo_Bound)
8896 and then Compile_Time_Known_Value (Hi_Bound)
8899 UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))),
8903 -- One more case is where Hi_Bound and Lo_Bound are compile-time
8904 -- comparable, and we can figure out the difference between them.
8907 Diff : aliased Uint;
8911 Compile_Time_Compare
8912 (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
8915 Fold_Uint (N, Uint_1, Static);
8918 Fold_Uint (N, Uint_0, Static);
8921 if Diff /= No_Uint then
8922 Fold_Uint (N, Diff + 1, Static);
8935 -- Loop_Entry acts as an alias of a constant initialized to the prefix
8936 -- of the said attribute at the point of entry into the related loop. As
8937 -- such, the attribute reference does not need to be evaluated because
8938 -- the prefix is the one that is evaluted.
8940 when Attribute_Loop_Entry =>
8947 when Attribute_Machine =>
8951 (P_Base_Type, Expr_Value_R (E1), Eval_Fat.Round, N),
8958 when Attribute_Machine_Emax =>
8959 Fold_Uint (N, Machine_Emax_Value (P_Type), Static);
8965 when Attribute_Machine_Emin =>
8966 Fold_Uint (N, Machine_Emin_Value (P_Type), Static);
8968 ----------------------
8969 -- Machine_Mantissa --
8970 ----------------------
8972 when Attribute_Machine_Mantissa =>
8973 Fold_Uint (N, Machine_Mantissa_Value (P_Type), Static);
8975 -----------------------
8976 -- Machine_Overflows --
8977 -----------------------
8979 when Attribute_Machine_Overflows =>
8981 -- Always true for fixed-point
8983 if Is_Fixed_Point_Type (P_Type) then
8984 Fold_Uint (N, True_Value, Static);
8986 -- Floating point case
8990 UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)),
8998 when Attribute_Machine_Radix =>
8999 if Is_Fixed_Point_Type (P_Type) then
9000 if Is_Decimal_Fixed_Point_Type (P_Type)
9001 and then Machine_Radix_10 (P_Type)
9003 Fold_Uint (N, Uint_10, Static);
9005 Fold_Uint (N, Uint_2, Static);
9008 -- All floating-point type always have radix 2
9011 Fold_Uint (N, Uint_2, Static);
9014 ----------------------
9015 -- Machine_Rounding --
9016 ----------------------
9018 -- Note: for the folding case, it is fine to treat Machine_Rounding
9019 -- exactly the same way as Rounding, since this is one of the allowed
9020 -- behaviors, and performance is not an issue here. It might be a bit
9021 -- better to give the same result as it would give at run time, even
9022 -- though the non-determinism is certainly permitted.
9024 when Attribute_Machine_Rounding =>
9026 (N, Eval_Fat.Rounding (P_Base_Type, Expr_Value_R (E1)), Static);
9028 --------------------
9029 -- Machine_Rounds --
9030 --------------------
9032 when Attribute_Machine_Rounds =>
9034 -- Always False for fixed-point
9036 if Is_Fixed_Point_Type (P_Type) then
9037 Fold_Uint (N, False_Value, Static);
9039 -- Else yield proper floating-point result
9043 (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)),
9051 -- Note: Machine_Size is identical to Object_Size
9053 when Attribute_Machine_Size => Machine_Size : declare
9054 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
9057 if Known_Esize (P_TypeA) then
9058 Fold_Uint (N, Esize (P_TypeA), Static);
9066 when Attribute_Mantissa =>
9068 -- Fixed-point mantissa
9070 if Is_Fixed_Point_Type (P_Type) then
9072 -- Compile time foldable case
9074 if Compile_Time_Known_Value (Type_Low_Bound (P_Type))
9076 Compile_Time_Known_Value (Type_High_Bound (P_Type))
9078 -- The calculation of the obsolete Ada 83 attribute Mantissa
9079 -- is annoying, because of AI00143, quoted here:
9081 -- !question 84-01-10
9083 -- Consider the model numbers for F:
9085 -- type F is delta 1.0 range -7.0 .. 8.0;
9087 -- The wording requires that F'MANTISSA be the SMALLEST
9088 -- integer number for which each bound of the specified
9089 -- range is either a model number or lies at most small
9090 -- distant from a model number. This means F'MANTISSA
9091 -- is required to be 3 since the range -7.0 .. 7.0 fits
9092 -- in 3 signed bits, and 8 is "at most" 1.0 from a model
9093 -- number, namely, 7. Is this analysis correct? Note that
9094 -- this implies the upper bound of the range is not
9095 -- represented as a model number.
9097 -- !response 84-03-17
9099 -- The analysis is correct. The upper and lower bounds for
9100 -- a fixed point type can lie outside the range of model
9111 LBound := Expr_Value_R (Type_Low_Bound (P_Type));
9112 UBound := Expr_Value_R (Type_High_Bound (P_Type));
9113 Bound := UR_Max (UR_Abs (LBound), UR_Abs (UBound));
9114 Max_Man := UR_Trunc (Bound / Small_Value (P_Type));
9116 -- If the Bound is exactly a model number, i.e. a multiple
9117 -- of Small, then we back it off by one to get the integer
9118 -- value that must be representable.
9120 if Small_Value (P_Type) * Max_Man = Bound then
9121 Max_Man := Max_Man - 1;
9124 -- Now find corresponding size = Mantissa value
9127 while 2 ** Siz < Max_Man loop
9131 Fold_Uint (N, Siz, Static);
9135 -- The case of dynamic bounds cannot be evaluated at compile
9136 -- time. Instead we use a runtime routine (see Exp_Attr).
9141 -- Floating-point Mantissa
9144 Fold_Uint (N, Mantissa, Static);
9151 when Attribute_Max =>
9152 if Is_Real_Type (P_Type) then
9154 (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
9156 Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static);
9159 ----------------------------------
9160 -- Max_Alignment_For_Allocation --
9161 ----------------------------------
9163 -- Max_Alignment_For_Allocation is usually the Alignment. However,
9164 -- arrays are allocated with dope, so we need to take into account both
9165 -- the alignment of the array, which comes from the component alignment,
9166 -- and the alignment of the dope. Also, if the alignment is unknown, we
9167 -- use the max (it's OK to be pessimistic).
9169 when Attribute_Max_Alignment_For_Allocation => Max_Align : declare
9170 A : Uint := UI_From_Int (Ttypes.Maximum_Alignment);
9172 if Known_Alignment (P_Type)
9173 and then (not Is_Array_Type (P_Type) or else Alignment (P_Type) > A)
9175 A := Alignment (P_Type);
9178 Fold_Uint (N, A, Static);
9181 ----------------------------------
9182 -- Max_Size_In_Storage_Elements --
9183 ----------------------------------
9185 -- Max_Size_In_Storage_Elements is simply the Size rounded up to a
9186 -- Storage_Unit boundary. We can fold any cases for which the size
9187 -- is known by the front end.
9189 when Attribute_Max_Size_In_Storage_Elements =>
9190 if Known_Esize (P_Type) then
9192 (Esize (P_Type) + System_Storage_Unit - 1) /
9193 System_Storage_Unit,
9197 --------------------
9198 -- Mechanism_Code --
9199 --------------------
9201 when Attribute_Mechanism_Code => Mechanism_Code : declare
9203 Mech : Mechanism_Type;
9208 Mech := Mechanism (P_Entity);
9211 Val := UI_To_Int (Expr_Value (E1));
9213 Formal := First_Formal (P_Entity);
9214 for J in 1 .. Val - 1 loop
9215 Next_Formal (Formal);
9218 Mech := Mechanism (Formal);
9222 Fold_Uint (N, UI_From_Int (Int (-Mech)), Static);
9230 when Attribute_Min =>
9231 if Is_Real_Type (P_Type) then
9233 (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
9236 (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static);
9243 when Attribute_Mod =>
9245 (N, UI_Mod (Expr_Value (E1), Modulus (P_Base_Type)), Static);
9251 when Attribute_Model =>
9253 (N, Eval_Fat.Model (P_Base_Type, Expr_Value_R (E1)), Static);
9259 when Attribute_Model_Emin =>
9260 Fold_Uint (N, Model_Emin_Value (P_Base_Type), Static);
9266 when Attribute_Model_Epsilon =>
9267 Fold_Ureal (N, Model_Epsilon_Value (P_Base_Type), Static);
9269 --------------------
9270 -- Model_Mantissa --
9271 --------------------
9273 when Attribute_Model_Mantissa =>
9274 Fold_Uint (N, Model_Mantissa_Value (P_Base_Type), Static);
9280 when Attribute_Model_Small =>
9281 Fold_Ureal (N, Model_Small_Value (P_Base_Type), Static);
9287 when Attribute_Modulus =>
9288 Fold_Uint (N, Modulus (P_Type), Static);
9290 --------------------
9291 -- Null_Parameter --
9292 --------------------
9294 -- Cannot fold, we know the value sort of, but the whole point is
9295 -- that there is no way to talk about this imaginary value except
9296 -- by using the attribute, so we leave it the way it is.
9298 when Attribute_Null_Parameter =>
9305 -- The Object_Size attribute for a type returns the Esize of the
9306 -- type and can be folded if this value is known.
9308 when Attribute_Object_Size => Object_Size : declare
9309 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
9312 if Known_Esize (P_TypeA) then
9313 Fold_Uint (N, Esize (P_TypeA), Static);
9317 ----------------------
9318 -- Overlaps_Storage --
9319 ----------------------
9321 when Attribute_Overlaps_Storage =>
9324 -------------------------
9325 -- Passed_By_Reference --
9326 -------------------------
9328 -- Scalar types are never passed by reference
9330 when Attribute_Passed_By_Reference =>
9331 Fold_Uint (N, False_Value, Static);
9337 when Attribute_Pos =>
9338 Fold_Uint (N, Expr_Value (E1), Static);
9344 when Attribute_Pred =>
9346 -- Floating-point case
9348 if Is_Floating_Point_Type (P_Type) then
9350 (N, Eval_Fat.Pred (P_Base_Type, Expr_Value_R (E1)), Static);
9354 elsif Is_Fixed_Point_Type (P_Type) then
9356 (N, Expr_Value_R (E1) - Small_Value (P_Type), True);
9358 -- Modular integer case (wraps)
9360 elsif Is_Modular_Integer_Type (P_Type) then
9361 Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type), Static);
9363 -- Other scalar cases
9366 pragma Assert (Is_Scalar_Type (P_Type));
9368 if Is_Enumeration_Type (P_Type)
9369 and then Expr_Value (E1) =
9370 Expr_Value (Type_Low_Bound (P_Base_Type))
9372 Apply_Compile_Time_Constraint_Error
9373 (N, "Pred of `&''First`",
9374 CE_Overflow_Check_Failed,
9376 Warn => not Static);
9382 Fold_Uint (N, Expr_Value (E1) - 1, Static);
9389 -- No processing required, because by this stage, Range has been
9390 -- replaced by First .. Last, so this branch can never be taken.
9392 when Attribute_Range =>
9393 raise Program_Error;
9399 when Attribute_Range_Length => Range_Length : declare
9400 Diff : aliased Uint;
9405 -- Can fold if both bounds are compile time known
9407 if Compile_Time_Known_Value (Hi_Bound)
9408 and then Compile_Time_Known_Value (Lo_Bound)
9412 (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1),
9416 -- One more case is where Hi_Bound and Lo_Bound are compile-time
9417 -- comparable, and we can figure out the difference between them.
9419 case Compile_Time_Compare
9420 (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
9423 Fold_Uint (N, Uint_1, Static);
9426 Fold_Uint (N, Uint_0, Static);
9429 if Diff /= No_Uint then
9430 Fold_Uint (N, Diff + 1, Static);
9442 when Attribute_Ref =>
9443 Fold_Uint (N, Expr_Value (E1), Static);
9449 when Attribute_Remainder => Remainder : declare
9450 X : constant Ureal := Expr_Value_R (E1);
9451 Y : constant Ureal := Expr_Value_R (E2);
9454 if UR_Is_Zero (Y) then
9455 Apply_Compile_Time_Constraint_Error
9456 (N, "division by zero in Remainder",
9457 CE_Overflow_Check_Failed,
9458 Warn => not Static);
9464 Fold_Ureal (N, Eval_Fat.Remainder (P_Base_Type, X, Y), Static);
9471 when Attribute_Restriction_Set =>
9472 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
9473 Set_Is_Static_Expression (N);
9479 when Attribute_Round => Round : declare
9484 -- First we get the (exact result) in units of small
9486 Sr := Expr_Value_R (E1) / Small_Value (C_Type);
9488 -- Now round that exactly to an integer
9490 Si := UR_To_Uint (Sr);
9492 -- Finally the result is obtained by converting back to real
9494 Fold_Ureal (N, Si * Small_Value (C_Type), Static);
9501 when Attribute_Rounding =>
9503 (N, Eval_Fat.Rounding (P_Base_Type, Expr_Value_R (E1)), Static);
9509 when Attribute_Safe_Emax =>
9510 Fold_Uint (N, Safe_Emax_Value (P_Type), Static);
9516 when Attribute_Safe_First =>
9517 Fold_Ureal (N, Safe_First_Value (P_Type), Static);
9523 when Attribute_Safe_Large =>
9524 if Is_Fixed_Point_Type (P_Type) then
9526 (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static);
9528 Fold_Ureal (N, Safe_Last_Value (P_Type), Static);
9535 when Attribute_Safe_Last =>
9536 Fold_Ureal (N, Safe_Last_Value (P_Type), Static);
9542 when Attribute_Safe_Small =>
9544 -- In Ada 95, the old Ada 83 attribute Safe_Small is redundant
9545 -- for fixed-point, since is the same as Small, but we implement
9546 -- it for backwards compatibility.
9548 if Is_Fixed_Point_Type (P_Type) then
9549 Fold_Ureal (N, Small_Value (P_Type), Static);
9551 -- Ada 83 Safe_Small for floating-point cases
9554 Fold_Ureal (N, Model_Small_Value (P_Type), Static);
9561 when Attribute_Scale =>
9562 Fold_Uint (N, Scale_Value (P_Type), Static);
9568 when Attribute_Scaling =>
9572 (P_Base_Type, Expr_Value_R (E1), Expr_Value (E2)),
9579 when Attribute_Signed_Zeros =>
9581 (N, UI_From_Int (Boolean'Pos (Has_Signed_Zeros (P_Type))), Static);
9587 -- Size attribute returns the RM size. All scalar types can be folded,
9588 -- as well as any types for which the size is known by the front end,
9589 -- including any type for which a size attribute is specified. This is
9590 -- one of the places where it is annoying that a size of zero means two
9591 -- things (zero size for scalars, unspecified size for non-scalars).
9594 | Attribute_VADS_Size
9597 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
9600 if Is_Scalar_Type (P_TypeA)
9601 or else RM_Size (P_TypeA) /= Uint_0
9605 if Id = Attribute_VADS_Size or else Use_VADS_Size then
9607 S : constant Node_Id := Size_Clause (P_TypeA);
9610 -- If a size clause applies, then use the size from it.
9611 -- This is one of the rare cases where we can use the
9612 -- Size_Clause field for a subtype when Has_Size_Clause
9613 -- is False. Consider:
9615 -- type x is range 1 .. 64;
9616 -- for x'size use 12;
9617 -- subtype y is x range 0 .. 3;
9619 -- Here y has a size clause inherited from x, but
9620 -- normally it does not apply, and y'size is 2. However,
9621 -- y'VADS_Size is indeed 12 and not 2.
9624 and then Is_OK_Static_Expression (Expression (S))
9626 Fold_Uint (N, Expr_Value (Expression (S)), Static);
9628 -- If no size is specified, then we simply use the object
9629 -- size in the VADS_Size case (e.g. Natural'Size is equal
9630 -- to Integer'Size, not one less).
9633 Fold_Uint (N, Esize (P_TypeA), Static);
9637 -- Normal case (Size) in which case we want the RM_Size
9640 Fold_Uint (N, RM_Size (P_TypeA), Static);
9649 when Attribute_Small =>
9651 -- The floating-point case is present only for Ada 83 compatibility.
9652 -- Note that strictly this is an illegal addition, since we are
9653 -- extending an Ada 95 defined attribute, but we anticipate an
9654 -- ARG ruling that will permit this.
9656 if Is_Floating_Point_Type (P_Type) then
9658 -- Ada 83 attribute is defined as (RM83 3.5.8)
9660 -- T'Small = 2.0**(-T'Emax - 1)
9664 -- T'Emax = 4 * T'Mantissa
9666 Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1), Static);
9668 -- Normal Ada 95 fixed-point case
9671 Fold_Ureal (N, Small_Value (P_Type), True);
9678 when Attribute_Stream_Size =>
9685 when Attribute_Succ =>
9686 -- Floating-point case
9688 if Is_Floating_Point_Type (P_Type) then
9690 (N, Eval_Fat.Succ (P_Base_Type, Expr_Value_R (E1)), Static);
9694 elsif Is_Fixed_Point_Type (P_Type) then
9695 Fold_Ureal (N, Expr_Value_R (E1) + Small_Value (P_Type), Static);
9697 -- Modular integer case (wraps)
9699 elsif Is_Modular_Integer_Type (P_Type) then
9700 Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type), Static);
9702 -- Other scalar cases
9705 pragma Assert (Is_Scalar_Type (P_Type));
9707 if Is_Enumeration_Type (P_Type)
9708 and then Expr_Value (E1) =
9709 Expr_Value (Type_High_Bound (P_Base_Type))
9711 Apply_Compile_Time_Constraint_Error
9712 (N, "Succ of `&''Last`",
9713 CE_Overflow_Check_Failed,
9715 Warn => not Static);
9720 Fold_Uint (N, Expr_Value (E1) + 1, Static);
9728 when Attribute_Truncation =>
9731 Eval_Fat.Truncation (P_Base_Type, Expr_Value_R (E1)),
9738 when Attribute_Type_Class => Type_Class : declare
9739 Typ : constant Entity_Id := Underlying_Type (P_Base_Type);
9743 if Is_Descendant_Of_Address (Typ) then
9744 Id := RE_Type_Class_Address;
9746 elsif Is_Enumeration_Type (Typ) then
9747 Id := RE_Type_Class_Enumeration;
9749 elsif Is_Integer_Type (Typ) then
9750 Id := RE_Type_Class_Integer;
9752 elsif Is_Fixed_Point_Type (Typ) then
9753 Id := RE_Type_Class_Fixed_Point;
9755 elsif Is_Floating_Point_Type (Typ) then
9756 Id := RE_Type_Class_Floating_Point;
9758 elsif Is_Array_Type (Typ) then
9759 Id := RE_Type_Class_Array;
9761 elsif Is_Record_Type (Typ) then
9762 Id := RE_Type_Class_Record;
9764 elsif Is_Access_Type (Typ) then
9765 Id := RE_Type_Class_Access;
9767 elsif Is_Task_Type (Typ) then
9768 Id := RE_Type_Class_Task;
9770 -- We treat protected types like task types. It would make more
9771 -- sense to have another enumeration value, but after all the
9772 -- whole point of this feature is to be exactly DEC compatible,
9773 -- and changing the type Type_Class would not meet this requirement.
9775 elsif Is_Protected_Type (Typ) then
9776 Id := RE_Type_Class_Task;
9778 -- Not clear if there are any other possibilities, but if there
9779 -- are, then we will treat them as the address case.
9782 Id := RE_Type_Class_Address;
9785 Rewrite (N, New_Occurrence_Of (RTE (Id), Loc));
9788 -----------------------
9789 -- Unbiased_Rounding --
9790 -----------------------
9792 when Attribute_Unbiased_Rounding =>
9795 Eval_Fat.Unbiased_Rounding (P_Base_Type, Expr_Value_R (E1)),
9798 -------------------------
9799 -- Unconstrained_Array --
9800 -------------------------
9802 when Attribute_Unconstrained_Array => Unconstrained_Array : declare
9803 Typ : constant Entity_Id := Underlying_Type (P_Type);
9806 Rewrite (N, New_Occurrence_Of (
9808 Is_Array_Type (P_Type)
9809 and then not Is_Constrained (Typ)), Loc));
9811 -- Analyze and resolve as boolean, note that this attribute is
9812 -- a static attribute in GNAT.
9814 Analyze_And_Resolve (N, Standard_Boolean);
9816 Set_Is_Static_Expression (N, True);
9817 end Unconstrained_Array;
9819 -- Attribute Update is never static
9821 when Attribute_Update =>
9828 -- Processing is shared with Size
9834 when Attribute_Val =>
9835 if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type))
9837 Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type))
9839 Apply_Compile_Time_Constraint_Error
9840 (N, "Val expression out of range",
9841 CE_Range_Check_Failed,
9842 Warn => not Static);
9848 Fold_Uint (N, Expr_Value (E1), Static);
9855 -- The Value_Size attribute for a type returns the RM size of the type.
9856 -- This an always be folded for scalar types, and can also be folded for
9857 -- non-scalar types if the size is set. This is one of the places where
9858 -- it is annoying that a size of zero means two things!
9860 when Attribute_Value_Size => Value_Size : declare
9861 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
9864 if Is_Scalar_Type (P_TypeA) or else RM_Size (P_TypeA) /= Uint_0 then
9865 Fold_Uint (N, RM_Size (P_TypeA), Static);
9873 -- Version can never be static
9875 when Attribute_Version =>
9882 -- Wide_Image is a scalar attribute, but is never static, because it
9883 -- is not a static function (having a non-scalar argument (RM 4.9(22))
9885 when Attribute_Wide_Image =>
9888 ---------------------
9889 -- Wide_Wide_Image --
9890 ---------------------
9892 -- Wide_Wide_Image is a scalar attribute but is never static, because it
9893 -- is not a static function (having a non-scalar argument (RM 4.9(22)).
9895 when Attribute_Wide_Wide_Image =>
9898 ---------------------
9899 -- Wide_Wide_Width --
9900 ---------------------
9902 -- Processing for Wide_Wide_Width is combined with Width
9908 -- Processing for Wide_Width is combined with Width
9914 -- This processing also handles the case of Wide_[Wide_]Width
9916 when Attribute_Width
9917 | Attribute_Wide_Width
9918 | Attribute_Wide_Wide_Width
9920 if Compile_Time_Known_Bounds (P_Type) then
9922 -- Floating-point types
9924 if Is_Floating_Point_Type (P_Type) then
9926 -- Width is zero for a null range (RM 3.5 (38))
9928 if Expr_Value_R (Type_High_Bound (P_Type)) <
9929 Expr_Value_R (Type_Low_Bound (P_Type))
9931 Fold_Uint (N, Uint_0, Static);
9934 -- For floating-point, we have +N.dddE+nnn where length
9935 -- of ddd is determined by type'Digits - 1, but is one
9936 -- if Digits is one (RM 3.5 (33)).
9938 -- nnn is set to 2 for Short_Float and Float (32 bit
9939 -- floats), and 3 for Long_Float and Long_Long_Float.
9940 -- For machines where Long_Long_Float is the IEEE
9941 -- extended precision type, the exponent takes 4 digits.
9945 Int'Max (2, UI_To_Int (Digits_Value (P_Type)));
9948 if Esize (P_Type) <= 32 then
9950 elsif Esize (P_Type) = 64 then
9956 Fold_Uint (N, UI_From_Int (Len), Static);
9960 -- Fixed-point types
9962 elsif Is_Fixed_Point_Type (P_Type) then
9964 -- Width is zero for a null range (RM 3.5 (38))
9966 if Expr_Value (Type_High_Bound (P_Type)) <
9967 Expr_Value (Type_Low_Bound (P_Type))
9969 Fold_Uint (N, Uint_0, Static);
9971 -- The non-null case depends on the specific real type
9974 -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34))
9977 (N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type),
9985 R : constant Entity_Id := Root_Type (P_Type);
9986 Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type));
9987 Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type));
10000 -- Width for types derived from Standard.Character
10001 -- and Standard.Wide_[Wide_]Character.
10003 elsif Is_Standard_Character_Type (P_Type) then
10006 -- Set W larger if needed
10008 for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop
10010 -- All wide characters look like Hex_hhhhhhhh
10014 -- No need to compute this more than once
10019 C := Character'Val (J);
10021 -- Test for all cases where Character'Image
10022 -- yields an image that is longer than three
10023 -- characters. First the cases of Reserved_xxx
10024 -- names (length = 12).
10101 when Space .. Tilde
10102 | No_Break_Space .. LC_Y_Diaeresis
10104 -- Special case of soft hyphen in Ada 2005
10106 if C = Character'Val (16#AD#)
10107 and then Ada_Version >= Ada_2005
10115 W := Int'Max (W, Wt);
10119 -- Width for types derived from Standard.Boolean
10121 elsif R = Standard_Boolean then
10128 -- Width for integer types
10130 elsif Is_Integer_Type (P_Type) then
10131 T := UI_Max (abs Lo, abs Hi);
10139 -- User declared enum type with discard names
10141 elsif Discard_Names (R) then
10143 -- If range is null, result is zero, that has already
10144 -- been dealt with, so what we need is the power of ten
10145 -- that accommodates the Pos of the largest value, which
10146 -- is the high bound of the range + one for the space.
10155 -- Only remaining possibility is user declared enum type
10156 -- with normal case of Discard_Names not active.
10159 pragma Assert (Is_Enumeration_Type (P_Type));
10162 L := First_Literal (P_Type);
10163 while Present (L) loop
10165 -- Only pay attention to in range characters
10167 if Lo <= Enumeration_Pos (L)
10168 and then Enumeration_Pos (L) <= Hi
10170 -- For Width case, use decoded name
10172 if Id = Attribute_Width then
10173 Get_Decoded_Name_String (Chars (L));
10174 Wt := Nat (Name_Len);
10176 -- For Wide_[Wide_]Width, use encoded name, and
10177 -- then adjust for the encoding.
10180 Get_Name_String (Chars (L));
10182 -- Character literals are always of length 3
10184 if Name_Buffer (1) = 'Q' then
10187 -- Otherwise loop to adjust for upper/wide chars
10190 Wt := Nat (Name_Len);
10192 for J in 1 .. Name_Len loop
10193 if Name_Buffer (J) = 'U' then
10195 elsif Name_Buffer (J) = 'W' then
10202 W := Int'Max (W, Wt);
10209 Fold_Uint (N, UI_From_Int (W), Static);
10214 -- The following attributes denote functions that cannot be folded
10216 when Attribute_From_Any
10218 | Attribute_TypeCode
10222 -- The following attributes can never be folded, and furthermore we
10223 -- should not even have entered the case statement for any of these.
10224 -- Note that in some cases, the values have already been folded as
10225 -- a result of the processing in Analyze_Attribute or earlier in
10228 when Attribute_Abort_Signal
10230 | Attribute_Address
10231 | Attribute_Address_Size
10232 | Attribute_Asm_Input
10233 | Attribute_Asm_Output
10235 | Attribute_Bit_Order
10236 | Attribute_Bit_Position
10237 | Attribute_Callable
10240 | Attribute_Code_Address
10241 | Attribute_Compiler_Version
10243 | Attribute_Default_Bit_Order
10244 | Attribute_Default_Scalar_Storage_Order
10246 | Attribute_Elaborated
10247 | Attribute_Elab_Body
10248 | Attribute_Elab_Spec
10249 | Attribute_Elab_Subp_Body
10250 | Attribute_Enabled
10251 | Attribute_External_Tag
10252 | Attribute_Fast_Math
10253 | Attribute_First_Bit
10256 | Attribute_Last_Bit
10257 | Attribute_Library_Level
10258 | Attribute_Maximum_Alignment
10261 | Attribute_Partition_ID
10262 | Attribute_Pool_Address
10263 | Attribute_Position
10264 | Attribute_Priority
10267 | Attribute_Scalar_Storage_Order
10268 | Attribute_Simple_Storage_Pool
10269 | Attribute_Storage_Pool
10270 | Attribute_Storage_Size
10271 | Attribute_Storage_Unit
10272 | Attribute_Stub_Type
10273 | Attribute_System_Allocator_Alignment
10275 | Attribute_Target_Name
10276 | Attribute_Terminated
10277 | Attribute_To_Address
10278 | Attribute_Type_Key
10279 | Attribute_Unchecked_Access
10280 | Attribute_Universal_Literal_String
10281 | Attribute_Unrestricted_Access
10283 | Attribute_Valid_Scalars
10285 | Attribute_Wchar_T_Size
10286 | Attribute_Wide_Value
10287 | Attribute_Wide_Wide_Value
10288 | Attribute_Word_Size
10291 raise Program_Error;
10294 -- At the end of the case, one more check. If we did a static evaluation
10295 -- so that the result is now a literal, then set Is_Static_Expression
10296 -- in the constant only if the prefix type is a static subtype. For
10297 -- non-static subtypes, the folding is still OK, but not static.
10299 -- An exception is the GNAT attribute Constrained_Array which is
10300 -- defined to be a static attribute in all cases.
10302 if Nkind_In (N, N_Integer_Literal,
10304 N_Character_Literal,
10306 or else (Is_Entity_Name (N)
10307 and then Ekind (Entity (N)) = E_Enumeration_Literal)
10309 Set_Is_Static_Expression (N, Static);
10311 -- If this is still an attribute reference, then it has not been folded
10312 -- and that means that its expressions are in a non-static context.
10314 elsif Nkind (N) = N_Attribute_Reference then
10317 -- Note: the else case not covered here are odd cases where the
10318 -- processing has transformed the attribute into something other
10319 -- than a constant. Nothing more to do in such cases.
10324 end Eval_Attribute;
10326 ------------------------------
10327 -- Is_Anonymous_Tagged_Base --
10328 ------------------------------
10330 function Is_Anonymous_Tagged_Base
10332 Typ : Entity_Id) return Boolean
10336 Anon = Current_Scope
10337 and then Is_Itype (Anon)
10338 and then Associated_Node_For_Itype (Anon) = Parent (Typ);
10339 end Is_Anonymous_Tagged_Base;
10341 --------------------------------
10342 -- Name_Implies_Lvalue_Prefix --
10343 --------------------------------
10345 function Name_Implies_Lvalue_Prefix (Nam : Name_Id) return Boolean is
10346 pragma Assert (Is_Attribute_Name (Nam));
10348 return Attribute_Name_Implies_Lvalue_Prefix (Get_Attribute_Id (Nam));
10349 end Name_Implies_Lvalue_Prefix;
10351 -----------------------
10352 -- Resolve_Attribute --
10353 -----------------------
10355 procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is
10356 Loc : constant Source_Ptr := Sloc (N);
10357 P : constant Node_Id := Prefix (N);
10358 Aname : constant Name_Id := Attribute_Name (N);
10359 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
10360 Btyp : constant Entity_Id := Base_Type (Typ);
10361 Des_Btyp : Entity_Id;
10362 Index : Interp_Index;
10364 Nom_Subt : Entity_Id;
10366 procedure Accessibility_Message;
10367 -- Error, or warning within an instance, if the static accessibility
10368 -- rules of 3.10.2 are violated.
10370 function Declared_Within_Generic_Unit
10371 (Entity : Entity_Id;
10372 Generic_Unit : Node_Id) return Boolean;
10373 -- Returns True if Declared_Entity is declared within the declarative
10374 -- region of Generic_Unit; otherwise returns False.
10376 ---------------------------
10377 -- Accessibility_Message --
10378 ---------------------------
10380 procedure Accessibility_Message is
10381 Indic : Node_Id := Parent (Parent (N));
10384 -- In an instance, this is a runtime check, but one we
10385 -- know will fail, so generate an appropriate warning.
10387 if In_Instance_Body then
10388 Error_Msg_Warn := SPARK_Mode /= On;
10390 ("non-local pointer cannot point to local object<<", P);
10391 Error_Msg_F ("\Program_Error [<<", P);
10393 Make_Raise_Program_Error (Loc,
10394 Reason => PE_Accessibility_Check_Failed));
10395 Set_Etype (N, Typ);
10399 Error_Msg_F ("non-local pointer cannot point to local object", P);
10401 -- Check for case where we have a missing access definition
10403 if Is_Record_Type (Current_Scope)
10405 Nkind_In (Parent (N), N_Discriminant_Association,
10406 N_Index_Or_Discriminant_Constraint)
10408 Indic := Parent (Parent (N));
10409 while Present (Indic)
10410 and then Nkind (Indic) /= N_Subtype_Indication
10412 Indic := Parent (Indic);
10415 if Present (Indic) then
10417 ("\use an access definition for" &
10418 " the access discriminant of&",
10419 N, Entity (Subtype_Mark (Indic)));
10423 end Accessibility_Message;
10425 ----------------------------------
10426 -- Declared_Within_Generic_Unit --
10427 ----------------------------------
10429 function Declared_Within_Generic_Unit
10430 (Entity : Entity_Id;
10431 Generic_Unit : Node_Id) return Boolean
10433 Generic_Encloser : Node_Id := Enclosing_Generic_Unit (Entity);
10436 while Present (Generic_Encloser) loop
10437 if Generic_Encloser = Generic_Unit then
10441 -- We have to step to the scope of the generic's entity, because
10442 -- otherwise we'll just get back the same generic.
10444 Generic_Encloser :=
10445 Enclosing_Generic_Unit
10446 (Scope (Defining_Entity (Generic_Encloser)));
10450 end Declared_Within_Generic_Unit;
10452 -- Start of processing for Resolve_Attribute
10455 -- If error during analysis, no point in continuing, except for array
10456 -- types, where we get better recovery by using unconstrained indexes
10457 -- than nothing at all (see Check_Array_Type).
10459 if Error_Posted (N)
10460 and then Attr_Id /= Attribute_First
10461 and then Attr_Id /= Attribute_Last
10462 and then Attr_Id /= Attribute_Length
10463 and then Attr_Id /= Attribute_Range
10468 -- If attribute was universal type, reset to actual type
10470 if Etype (N) = Universal_Integer
10471 or else Etype (N) = Universal_Real
10473 Set_Etype (N, Typ);
10476 -- Remaining processing depends on attribute
10484 -- For access attributes, if the prefix denotes an entity, it is
10485 -- interpreted as a name, never as a call. It may be overloaded,
10486 -- in which case resolution uses the profile of the context type.
10487 -- Otherwise prefix must be resolved.
10489 when Attribute_Access
10490 | Attribute_Unchecked_Access
10491 | Attribute_Unrestricted_Access
10493 -- Note possible modification if we have a variable
10495 if Is_Variable (P) then
10497 PN : constant Node_Id := Parent (N);
10500 Note : Boolean := True;
10501 -- Skip this for the case of Unrestricted_Access occuring in
10502 -- the context of a Valid check, since this otherwise leads
10503 -- to a missed warning (the Valid check does not really
10504 -- modify!) If this case, Note will be reset to False.
10506 -- Skip it as well if the type is an Access_To_Constant,
10507 -- given that no use of the value can modify the prefix.
10510 if Attr_Id = Attribute_Unrestricted_Access
10511 and then Nkind (PN) = N_Function_Call
10515 if Nkind (Nm) = N_Expanded_Name
10516 and then Chars (Nm) = Name_Valid
10517 and then Nkind (Prefix (Nm)) = N_Identifier
10518 and then Chars (Prefix (Nm)) = Name_Attr_Long_Float
10523 elsif Is_Access_Constant (Typ) then
10528 Note_Possible_Modification (P, Sure => False);
10533 -- The following comes from a query concerning improper use of
10534 -- universal_access in equality tests involving anonymous access
10535 -- types. Another good reason for 'Ref, but for now disable the
10536 -- test, which breaks several filed tests???
10538 if Ekind (Typ) = E_Anonymous_Access_Type
10539 and then Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne)
10542 Error_Msg_N ("need unique type to resolve 'Access", N);
10543 Error_Msg_N ("\qualify attribute with some access type", N);
10546 -- Case where prefix is an entity name
10548 if Is_Entity_Name (P) then
10550 -- Deal with case where prefix itself is overloaded
10552 if Is_Overloaded (P) then
10553 Get_First_Interp (P, Index, It);
10554 while Present (It.Nam) loop
10555 if Type_Conformant (Designated_Type (Typ), It.Nam) then
10556 Set_Entity (P, It.Nam);
10558 -- The prefix is definitely NOT overloaded anymore at
10559 -- this point, so we reset the Is_Overloaded flag to
10560 -- avoid any confusion when reanalyzing the node.
10562 Set_Is_Overloaded (P, False);
10563 Set_Is_Overloaded (N, False);
10564 Generate_Reference (Entity (P), P);
10568 Get_Next_Interp (Index, It);
10571 -- If Prefix is a subprogram name, this reference freezes,
10572 -- but not if within spec expression mode. The profile of
10573 -- the subprogram is not frozen at this point.
10575 if not In_Spec_Expression then
10576 Freeze_Before (N, Entity (P), Do_Freeze_Profile => False);
10579 -- If it is a type, there is nothing to resolve.
10580 -- If it is a subprogram, do not freeze its profile.
10581 -- If it is an object, complete its resolution.
10583 elsif Is_Overloadable (Entity (P)) then
10584 if not In_Spec_Expression then
10585 Freeze_Before (N, Entity (P), Do_Freeze_Profile => False);
10588 -- Nothing to do if prefix is a type name
10590 elsif Is_Type (Entity (P)) then
10593 -- Otherwise non-overloaded other case, resolve the prefix
10599 -- Some further error checks
10601 Error_Msg_Name_1 := Aname;
10603 if not Is_Entity_Name (P) then
10606 elsif Is_Overloadable (Entity (P))
10607 and then Is_Abstract_Subprogram (Entity (P))
10609 Error_Msg_F ("prefix of % attribute cannot be abstract", P);
10610 Set_Etype (N, Any_Type);
10612 elsif Ekind (Entity (P)) = E_Enumeration_Literal then
10614 ("prefix of % attribute cannot be enumeration literal", P);
10615 Set_Etype (N, Any_Type);
10617 -- An attempt to take 'Access of a function that renames an
10618 -- enumeration literal. Issue a specialized error message.
10620 elsif Ekind (Entity (P)) = E_Function
10621 and then Present (Alias (Entity (P)))
10622 and then Ekind (Alias (Entity (P))) = E_Enumeration_Literal
10625 ("prefix of % attribute cannot be function renaming "
10626 & "an enumeration literal", P);
10627 Set_Etype (N, Any_Type);
10629 elsif Convention (Entity (P)) = Convention_Intrinsic then
10630 Error_Msg_F ("prefix of % attribute cannot be intrinsic", P);
10631 Set_Etype (N, Any_Type);
10634 -- Assignments, return statements, components of aggregates,
10635 -- generic instantiations will require convention checks if
10636 -- the type is an access to subprogram. Given that there will
10637 -- also be accessibility checks on those, this is where the
10638 -- checks can eventually be centralized ???
10640 if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type,
10641 E_Access_Subprogram_Type,
10642 E_Anonymous_Access_Protected_Subprogram_Type,
10643 E_Anonymous_Access_Subprogram_Type)
10645 -- Deal with convention mismatch
10647 if Convention (Designated_Type (Btyp)) /=
10648 Convention (Entity (P))
10650 -- The rule in 6.3.1 (8) deserves a special error
10653 if Convention (Btyp) = Convention_Intrinsic
10654 and then Nkind (Parent (N)) = N_Procedure_Call_Statement
10655 and then Is_Entity_Name (Name (Parent (N)))
10656 and then Inside_A_Generic
10659 Subp : constant Entity_Id :=
10660 Entity (Name (Parent (N)));
10662 if Convention (Subp) = Convention_Intrinsic then
10664 ("?subprogram and its formal access "
10665 & "parameters have convention Intrinsic",
10668 ("actual cannot be access attribute", N);
10674 ("subprogram & has wrong convention", P, Entity (P));
10675 Error_Msg_Sloc := Sloc (Btyp);
10676 Error_Msg_FE ("\does not match & declared#", P, Btyp);
10679 if not Is_Itype (Btyp)
10680 and then not Has_Convention_Pragma (Btyp)
10683 ("\probable missing pragma Convention for &",
10688 Check_Subtype_Conformant
10689 (New_Id => Entity (P),
10690 Old_Id => Designated_Type (Btyp),
10694 if Attr_Id = Attribute_Unchecked_Access then
10695 Error_Msg_Name_1 := Aname;
10697 ("attribute% cannot be applied to a subprogram", P);
10699 elsif Aname = Name_Unrestricted_Access then
10700 null; -- Nothing to check
10702 -- Check the static accessibility rule of 3.10.2(32).
10703 -- This rule also applies within the private part of an
10704 -- instantiation. This rule does not apply to anonymous
10705 -- access-to-subprogram types in access parameters.
10707 elsif Attr_Id = Attribute_Access
10708 and then not In_Instance_Body
10710 (Ekind (Btyp) = E_Access_Subprogram_Type
10711 or else Is_Local_Anonymous_Access (Btyp))
10712 and then Subprogram_Access_Level (Entity (P)) >
10713 Type_Access_Level (Btyp)
10716 ("subprogram must not be deeper than access type", P);
10718 -- Check the restriction of 3.10.2(32) that disallows the
10719 -- access attribute within a generic body when the ultimate
10720 -- ancestor of the type of the attribute is declared outside
10721 -- of the generic unit and the subprogram is declared within
10722 -- that generic unit. This includes any such attribute that
10723 -- occurs within the body of a generic unit that is a child
10724 -- of the generic unit where the subprogram is declared.
10726 -- The rule also prohibits applying the attribute when the
10727 -- access type is a generic formal access type (since the
10728 -- level of the actual type is not known). This restriction
10729 -- does not apply when the attribute type is an anonymous
10730 -- access-to-subprogram type. Note that this check was
10731 -- revised by AI-229, because the original Ada 95 rule
10732 -- was too lax. The original rule only applied when the
10733 -- subprogram was declared within the body of the generic,
10734 -- which allowed the possibility of dangling references).
10735 -- The rule was also too strict in some cases, in that it
10736 -- didn't permit the access to be declared in the generic
10737 -- spec, whereas the revised rule does (as long as it's not
10740 -- There are a couple of subtleties of the test for applying
10741 -- the check that are worth noting. First, we only apply it
10742 -- when the levels of the subprogram and access type are the
10743 -- same (the case where the subprogram is statically deeper
10744 -- was applied above, and the case where the type is deeper
10745 -- is always safe). Second, we want the check to apply
10746 -- within nested generic bodies and generic child unit
10747 -- bodies, but not to apply to an attribute that appears in
10748 -- the generic unit's specification. This is done by testing
10749 -- that the attribute's innermost enclosing generic body is
10750 -- not the same as the innermost generic body enclosing the
10751 -- generic unit where the subprogram is declared (we don't
10752 -- want the check to apply when the access attribute is in
10753 -- the spec and there's some other generic body enclosing
10754 -- generic). Finally, there's no point applying the check
10755 -- when within an instance, because any violations will have
10756 -- been caught by the compilation of the generic unit.
10758 -- We relax this check in Relaxed_RM_Semantics mode for
10759 -- compatibility with legacy code for use by Ada source
10760 -- code analyzers (e.g. CodePeer).
10762 elsif Attr_Id = Attribute_Access
10763 and then not Relaxed_RM_Semantics
10764 and then not In_Instance
10765 and then Present (Enclosing_Generic_Unit (Entity (P)))
10766 and then Present (Enclosing_Generic_Body (N))
10767 and then Enclosing_Generic_Body (N) /=
10768 Enclosing_Generic_Body
10769 (Enclosing_Generic_Unit (Entity (P)))
10770 and then Subprogram_Access_Level (Entity (P)) =
10771 Type_Access_Level (Btyp)
10772 and then Ekind (Btyp) /=
10773 E_Anonymous_Access_Subprogram_Type
10774 and then Ekind (Btyp) /=
10775 E_Anonymous_Access_Protected_Subprogram_Type
10777 -- The attribute type's ultimate ancestor must be
10778 -- declared within the same generic unit as the
10779 -- subprogram is declared (including within another
10780 -- nested generic unit). The error message is
10781 -- specialized to say "ancestor" for the case where the
10782 -- access type is not its own ancestor, since saying
10783 -- simply "access type" would be very confusing.
10785 if not Declared_Within_Generic_Unit
10787 Enclosing_Generic_Unit (Entity (P)))
10790 ("''Access attribute not allowed in generic body",
10793 if Root_Type (Btyp) = Btyp then
10796 "access type & is declared outside " &
10797 "generic unit (RM 3.10.2(32))", N, Btyp);
10800 ("\because ancestor of " &
10801 "access type & is declared outside " &
10802 "generic unit (RM 3.10.2(32))", N, Btyp);
10806 ("\move ''Access to private part, or " &
10807 "(Ada 2005) use anonymous access type instead of &",
10810 -- If the ultimate ancestor of the attribute's type is
10811 -- a formal type, then the attribute is illegal because
10812 -- the actual type might be declared at a higher level.
10813 -- The error message is specialized to say "ancestor"
10814 -- for the case where the access type is not its own
10815 -- ancestor, since saying simply "access type" would be
10818 elsif Is_Generic_Type (Root_Type (Btyp)) then
10819 if Root_Type (Btyp) = Btyp then
10821 ("access type must not be a generic formal type",
10825 ("ancestor access type must not be a generic " &
10832 -- If this is a renaming, an inherited operation, or a
10833 -- subprogram instance, use the original entity. This may make
10834 -- the node type-inconsistent, so this transformation can only
10835 -- be done if the node will not be reanalyzed. In particular,
10836 -- if it is within a default expression, the transformation
10837 -- must be delayed until the default subprogram is created for
10838 -- it, when the enclosing subprogram is frozen.
10840 if Is_Entity_Name (P)
10841 and then Is_Overloadable (Entity (P))
10842 and then Present (Alias (Entity (P)))
10843 and then Expander_Active
10846 New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
10849 elsif Nkind (P) = N_Selected_Component
10850 and then Is_Overloadable (Entity (Selector_Name (P)))
10852 -- Protected operation. If operation is overloaded, must
10853 -- disambiguate. Prefix that denotes protected object itself
10854 -- is resolved with its own type.
10856 if Attr_Id = Attribute_Unchecked_Access then
10857 Error_Msg_Name_1 := Aname;
10859 ("attribute% cannot be applied to protected operation", P);
10862 Resolve (Prefix (P));
10863 Generate_Reference (Entity (Selector_Name (P)), P);
10865 -- Implement check implied by 3.10.2 (18.1/2) : F.all'access is
10866 -- statically illegal if F is an anonymous access to subprogram.
10868 elsif Nkind (P) = N_Explicit_Dereference
10869 and then Is_Entity_Name (Prefix (P))
10870 and then Ekind (Etype (Entity (Prefix (P)))) =
10871 E_Anonymous_Access_Subprogram_Type
10873 Error_Msg_N ("anonymous access to subprogram "
10874 & "has deeper accessibility than any master", P);
10876 elsif Is_Overloaded (P) then
10878 -- Use the designated type of the context to disambiguate
10879 -- Note that this was not strictly conformant to Ada 95,
10880 -- but was the implementation adopted by most Ada 95 compilers.
10881 -- The use of the context type to resolve an Access attribute
10882 -- reference is now mandated in AI-235 for Ada 2005.
10885 Index : Interp_Index;
10889 Get_First_Interp (P, Index, It);
10890 while Present (It.Typ) loop
10891 if Covers (Designated_Type (Typ), It.Typ) then
10892 Resolve (P, It.Typ);
10896 Get_Next_Interp (Index, It);
10903 -- X'Access is illegal if X denotes a constant and the access type
10904 -- is access-to-variable. Same for 'Unchecked_Access. The rule
10905 -- does not apply to 'Unrestricted_Access. If the reference is a
10906 -- default-initialized aggregate component for a self-referential
10907 -- type the reference is legal.
10909 if not (Ekind (Btyp) = E_Access_Subprogram_Type
10910 or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
10911 or else (Is_Record_Type (Btyp)
10913 Present (Corresponding_Remote_Type (Btyp)))
10914 or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type
10915 or else Ekind (Btyp)
10916 = E_Anonymous_Access_Protected_Subprogram_Type
10917 or else Is_Access_Constant (Btyp)
10918 or else Is_Variable (P)
10919 or else Attr_Id = Attribute_Unrestricted_Access)
10921 if Is_Entity_Name (P)
10922 and then Is_Type (Entity (P))
10924 -- Legality of a self-reference through an access
10925 -- attribute has been verified in Analyze_Access_Attribute.
10929 elsif Comes_From_Source (N) then
10930 Error_Msg_F ("access-to-variable designates constant", P);
10934 Des_Btyp := Designated_Type (Btyp);
10936 if Ada_Version >= Ada_2005
10937 and then Is_Incomplete_Type (Des_Btyp)
10939 -- Ada 2005 (AI-412): If the (sub)type is a limited view of an
10940 -- imported entity, and the non-limited view is visible, make
10941 -- use of it. If it is an incomplete subtype, use the base type
10944 if From_Limited_With (Des_Btyp)
10945 and then Present (Non_Limited_View (Des_Btyp))
10947 Des_Btyp := Non_Limited_View (Des_Btyp);
10949 elsif Ekind (Des_Btyp) = E_Incomplete_Subtype then
10950 Des_Btyp := Etype (Des_Btyp);
10954 if (Attr_Id = Attribute_Access
10956 Attr_Id = Attribute_Unchecked_Access)
10957 and then (Ekind (Btyp) = E_General_Access_Type
10958 or else Ekind (Btyp) = E_Anonymous_Access_Type)
10960 -- Ada 2005 (AI-230): Check the accessibility of anonymous
10961 -- access types for stand-alone objects, record and array
10962 -- components, and return objects. For a component definition
10963 -- the level is the same of the enclosing composite type.
10965 if Ada_Version >= Ada_2005
10966 and then (Is_Local_Anonymous_Access (Btyp)
10968 -- Handle cases where Btyp is the anonymous access
10969 -- type of an Ada 2012 stand-alone object.
10971 or else Nkind (Associated_Node_For_Itype (Btyp)) =
10972 N_Object_Declaration)
10974 Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp)
10975 and then Attr_Id = Attribute_Access
10977 -- In an instance, this is a runtime check, but one we know
10978 -- will fail, so generate an appropriate warning. As usual,
10979 -- this kind of warning is an error in SPARK mode.
10981 if In_Instance_Body then
10982 Error_Msg_Warn := SPARK_Mode /= On;
10984 ("non-local pointer cannot point to local object<<", P);
10985 Error_Msg_F ("\Program_Error [<<", P);
10988 Make_Raise_Program_Error (Loc,
10989 Reason => PE_Accessibility_Check_Failed));
10990 Set_Etype (N, Typ);
10994 ("non-local pointer cannot point to local object", P);
10998 if Is_Dependent_Component_Of_Mutable_Object (P) then
11000 ("illegal attribute for discriminant-dependent component",
11004 -- Check static matching rule of 3.10.2(27). Nominal subtype
11005 -- of the prefix must statically match the designated type.
11007 Nom_Subt := Etype (P);
11009 if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then
11010 Nom_Subt := Base_Type (Nom_Subt);
11013 if Is_Tagged_Type (Designated_Type (Typ)) then
11015 -- If the attribute is in the context of an access
11016 -- parameter, then the prefix is allowed to be of
11017 -- the class-wide type (by AI-127).
11019 if Ekind (Typ) = E_Anonymous_Access_Type then
11020 if not Covers (Designated_Type (Typ), Nom_Subt)
11021 and then not Covers (Nom_Subt, Designated_Type (Typ))
11027 Desig := Designated_Type (Typ);
11029 if Is_Class_Wide_Type (Desig) then
11030 Desig := Etype (Desig);
11033 if Is_Anonymous_Tagged_Base (Nom_Subt, Desig) then
11038 ("type of prefix: & not compatible",
11041 ("\with &, the expected designated type",
11042 P, Designated_Type (Typ));
11047 elsif not Covers (Designated_Type (Typ), Nom_Subt)
11049 (not Is_Class_Wide_Type (Designated_Type (Typ))
11050 and then Is_Class_Wide_Type (Nom_Subt))
11053 ("type of prefix: & is not covered", P, Nom_Subt);
11055 ("\by &, the expected designated type" &
11056 " (RM 3.10.2 (27))", P, Designated_Type (Typ));
11059 if Is_Class_Wide_Type (Designated_Type (Typ))
11060 and then Has_Discriminants (Etype (Designated_Type (Typ)))
11061 and then Is_Constrained (Etype (Designated_Type (Typ)))
11062 and then Designated_Type (Typ) /= Nom_Subt
11064 Apply_Discriminant_Check
11065 (N, Etype (Designated_Type (Typ)));
11068 -- Ada 2005 (AI-363): Require static matching when designated
11069 -- type has discriminants and a constrained partial view, since
11070 -- in general objects of such types are mutable, so we can't
11071 -- allow the access value to designate a constrained object
11072 -- (because access values must be assumed to designate mutable
11073 -- objects when designated type does not impose a constraint).
11075 elsif Subtypes_Statically_Match (Des_Btyp, Nom_Subt) then
11078 elsif Has_Discriminants (Designated_Type (Typ))
11079 and then not Is_Constrained (Des_Btyp)
11081 (Ada_Version < Ada_2005
11083 not Object_Type_Has_Constrained_Partial_View
11084 (Typ => Designated_Type (Base_Type (Typ)),
11085 Scop => Current_Scope))
11091 ("object subtype must statically match "
11092 & "designated subtype", P);
11094 if Is_Entity_Name (P)
11095 and then Is_Array_Type (Designated_Type (Typ))
11098 D : constant Node_Id := Declaration_Node (Entity (P));
11101 ("aliased object has explicit bounds??", D);
11103 ("\declare without bounds (and with explicit "
11104 & "initialization)??", D);
11106 ("\for use with unconstrained access??", D);
11111 -- Check the static accessibility rule of 3.10.2(28). Note that
11112 -- this check is not performed for the case of an anonymous
11113 -- access type, since the access attribute is always legal
11114 -- in such a context.
11116 if Attr_Id /= Attribute_Unchecked_Access
11117 and then Ekind (Btyp) = E_General_Access_Type
11119 Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp)
11121 Accessibility_Message;
11126 if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type,
11127 E_Anonymous_Access_Protected_Subprogram_Type)
11129 if Is_Entity_Name (P)
11130 and then not Is_Protected_Type (Scope (Entity (P)))
11132 Error_Msg_F ("context requires a protected subprogram", P);
11134 -- Check accessibility of protected object against that of the
11135 -- access type, but only on user code, because the expander
11136 -- creates access references for handlers. If the context is an
11137 -- anonymous_access_to_protected, there are no accessibility
11138 -- checks either. Omit check entirely for Unrestricted_Access.
11140 elsif Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp)
11141 and then Comes_From_Source (N)
11142 and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type
11143 and then Attr_Id /= Attribute_Unrestricted_Access
11145 Accessibility_Message;
11148 -- AI05-0225: If the context is not an access to protected
11149 -- function, the prefix must be a variable, given that it may
11150 -- be used subsequently in a protected call.
11152 elsif Nkind (P) = N_Selected_Component
11153 and then not Is_Variable (Prefix (P))
11154 and then Ekind (Entity (Selector_Name (P))) /= E_Function
11157 ("target object of access to protected procedure "
11158 & "must be variable", N);
11160 elsif Is_Entity_Name (P) then
11161 Check_Internal_Protected_Use (N, Entity (P));
11164 elsif Ekind_In (Btyp, E_Access_Subprogram_Type,
11165 E_Anonymous_Access_Subprogram_Type)
11166 and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type
11168 Error_Msg_F ("context requires a non-protected subprogram", P);
11171 -- The context cannot be a pool-specific type, but this is a
11172 -- legality rule, not a resolution rule, so it must be checked
11173 -- separately, after possibly disambiguation (see AI-245).
11175 if Ekind (Btyp) = E_Access_Type
11176 and then Attr_Id /= Attribute_Unrestricted_Access
11178 Wrong_Type (N, Typ);
11181 -- The context may be a constrained access type (however ill-
11182 -- advised such subtypes might be) so in order to generate a
11183 -- constraint check we need to set the type of the attribute
11184 -- reference to the base type of the context.
11186 Set_Etype (N, Btyp);
11188 -- Check for incorrect atomic/volatile reference (RM C.6(12))
11190 if Attr_Id /= Attribute_Unrestricted_Access then
11191 if Is_Atomic_Object (P)
11192 and then not Is_Atomic (Designated_Type (Typ))
11195 ("access to atomic object cannot yield access-to-" &
11196 "non-atomic type", P);
11198 elsif Is_Volatile_Object (P)
11199 and then not Is_Volatile (Designated_Type (Typ))
11202 ("access to volatile object cannot yield access-to-" &
11203 "non-volatile type", P);
11207 -- Check for aliased view. We allow a nonaliased prefix when in
11208 -- an instance because the prefix may have been a tagged formal
11209 -- object, which is defined to be aliased even when the actual
11210 -- might not be (other instance cases will have been caught in
11211 -- the generic). Similarly, within an inlined body we know that
11212 -- the attribute is legal in the original subprogram, therefore
11213 -- legal in the expansion.
11215 if not (Is_Entity_Name (P)
11216 and then Is_Overloadable (Entity (P)))
11217 and then not (Nkind (P) = N_Selected_Component
11219 Is_Overloadable (Entity (Selector_Name (P))))
11220 and then not Is_Aliased_View (Original_Node (P))
11221 and then not In_Instance
11222 and then not In_Inlined_Body
11223 and then Comes_From_Source (N)
11225 -- Here we have a non-aliased view. This is illegal unless we
11226 -- have the case of Unrestricted_Access, where for now we allow
11227 -- this (we will reject later if expected type is access to an
11228 -- unconstrained array with a thin pointer).
11230 -- No need for an error message on a generated access reference
11231 -- for the controlling argument in a dispatching call: error
11232 -- will be reported when resolving the call.
11234 if Attr_Id /= Attribute_Unrestricted_Access then
11235 Error_Msg_N ("prefix of % attribute must be aliased", P);
11237 -- Check for unrestricted access where expected type is a thin
11238 -- pointer to an unconstrained array.
11240 elsif Has_Size_Clause (Typ)
11241 and then RM_Size (Typ) = System_Address_Size
11244 DT : constant Entity_Id := Designated_Type (Typ);
11246 if Is_Array_Type (DT)
11247 and then not Is_Constrained (DT)
11250 ("illegal use of Unrestricted_Access attribute", P);
11252 ("\attempt to generate thin pointer to unaliased "
11259 -- Mark that address of entity is taken in case of
11260 -- 'Unrestricted_Access or in case of a subprogram.
11262 if Is_Entity_Name (P)
11263 and then (Attr_Id = Attribute_Unrestricted_Access
11264 or else Is_Subprogram (Entity (P)))
11266 Set_Address_Taken (Entity (P));
11269 -- Deal with possible elaboration check
11271 if Is_Entity_Name (P) and then Is_Subprogram (Entity (P)) then
11273 Subp_Id : constant Entity_Id := Entity (P);
11274 Scop : constant Entity_Id := Scope (Subp_Id);
11275 Subp_Decl : constant Node_Id :=
11276 Unit_Declaration_Node (Subp_Id);
11277 Flag_Id : Entity_Id;
11278 Subp_Body : Node_Id;
11280 -- If the access has been taken and the body of the subprogram
11281 -- has not been see yet, indirect calls must be protected with
11282 -- elaboration checks. We have the proper elaboration machinery
11283 -- for subprograms declared in packages, but within a block or
11284 -- a subprogram the body will appear in the same declarative
11285 -- part, and we must insert a check in the eventual body itself
11286 -- using the elaboration flag that we generate now. The check
11287 -- is then inserted when the body is expanded. This processing
11288 -- is not needed for a stand alone expression function because
11289 -- the internally generated spec and body are always inserted
11290 -- as a pair in the same declarative list.
11294 and then Comes_From_Source (Subp_Id)
11295 and then Comes_From_Source (N)
11296 and then In_Open_Scopes (Scop)
11297 and then Ekind_In (Scop, E_Block, E_Procedure, E_Function)
11298 and then not Has_Completion (Subp_Id)
11299 and then No (Elaboration_Entity (Subp_Id))
11300 and then Nkind (Subp_Decl) = N_Subprogram_Declaration
11301 and then Nkind (Original_Node (Subp_Decl)) /=
11302 N_Expression_Function
11304 -- Create elaboration variable for it
11306 Flag_Id := Make_Temporary (Loc, 'E');
11307 Set_Elaboration_Entity (Subp_Id, Flag_Id);
11308 Set_Is_Frozen (Flag_Id);
11310 -- Insert declaration for flag after subprogram
11311 -- declaration. Note that attribute reference may
11312 -- appear within a nested scope.
11314 Insert_After_And_Analyze (Subp_Decl,
11315 Make_Object_Declaration (Loc,
11316 Defining_Identifier => Flag_Id,
11317 Object_Definition =>
11318 New_Occurrence_Of (Standard_Short_Integer, Loc),
11320 Make_Integer_Literal (Loc, Uint_0)));
11322 -- The above sets the Scope of the flag entity to the
11323 -- current scope, in which the attribute appears, but
11324 -- the flag declaration has been inserted after that
11325 -- of Subp_Id, so the scope of the flag is the same as
11326 -- that of Subp_Id. This is relevant when unnesting,
11327 -- where processing depends on correct scope setting.
11329 Set_Scope (Flag_Id, Scop);
11332 -- Taking the 'Access of an expression function freezes its
11333 -- expression (RM 13.14 10.3/3). This does not apply to an
11334 -- expression function that acts as a completion because the
11335 -- generated body is immediately analyzed and the expression
11336 -- is automatically frozen.
11338 if Is_Expression_Function (Subp_Id)
11339 and then Present (Corresponding_Body (Subp_Decl))
11342 Unit_Declaration_Node (Corresponding_Body (Subp_Decl));
11344 -- The body has already been analyzed when the expression
11345 -- function acts as a completion.
11347 if Analyzed (Subp_Body) then
11350 -- Attribute 'Access may appear within the generated body
11351 -- of the expression function subject to the attribute:
11353 -- function F is (... F'Access ...);
11355 -- If the expression function is on the scope stack, then
11356 -- the body is currently being analyzed. Do not reanalyze
11357 -- it because this will lead to infinite recursion.
11359 elsif In_Open_Scopes (Subp_Id) then
11362 -- If reference to the expression function appears in an
11363 -- inner scope, for example as an actual in an instance,
11364 -- this is not a freeze point either.
11366 elsif Scope (Subp_Id) /= Current_Scope then
11369 -- Analyze the body of the expression function to freeze
11370 -- the expression. This takes care of the case where the
11371 -- 'Access is part of dispatch table initialization and
11372 -- the generated body of the expression function has not
11373 -- been analyzed yet.
11376 Analyze (Subp_Body);
11386 -- Deal with resolving the type for Address attribute, overloading
11387 -- is not permitted here, since there is no context to resolve it.
11389 when Attribute_Address
11390 | Attribute_Code_Address
11392 -- To be safe, assume that if the address of a variable is taken,
11393 -- it may be modified via this address, so note modification.
11395 if Is_Variable (P) then
11396 Note_Possible_Modification (P, Sure => False);
11399 if Nkind (P) in N_Subexpr
11400 and then Is_Overloaded (P)
11402 Get_First_Interp (P, Index, It);
11403 Get_Next_Interp (Index, It);
11405 if Present (It.Nam) then
11406 Error_Msg_Name_1 := Aname;
11408 ("prefix of % attribute cannot be overloaded", P);
11412 if not Is_Entity_Name (P)
11413 or else not Is_Overloadable (Entity (P))
11415 if not Is_Task_Type (Etype (P))
11416 or else Nkind (P) = N_Explicit_Dereference
11422 -- If this is the name of a derived subprogram, or that of a
11423 -- generic actual, the address is that of the original entity.
11425 if Is_Entity_Name (P)
11426 and then Is_Overloadable (Entity (P))
11427 and then Present (Alias (Entity (P)))
11430 New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
11433 if Is_Entity_Name (P) then
11434 Set_Address_Taken (Entity (P));
11437 if Nkind (P) = N_Slice then
11439 -- Arr (X .. Y)'address is identical to Arr (X)'address,
11440 -- even if the array is packed and the slice itself is not
11441 -- addressable. Transform the prefix into an indexed component.
11443 -- Note that the transformation is safe only if we know that
11444 -- the slice is non-null. That is because a null slice can have
11445 -- an out of bounds index value.
11447 -- Right now, gigi blows up if given 'Address on a slice as a
11448 -- result of some incorrect freeze nodes generated by the front
11449 -- end, and this covers up that bug in one case, but the bug is
11450 -- likely still there in the cases not handled by this code ???
11452 -- It's not clear what 'Address *should* return for a null
11453 -- slice with out of bounds indexes, this might be worth an ARG
11456 -- One approach would be to do a length check unconditionally,
11457 -- and then do the transformation below unconditionally, but
11458 -- analyze with checks off, avoiding the problem of the out of
11459 -- bounds index. This approach would interpret the address of
11460 -- an out of bounds null slice as being the address where the
11461 -- array element would be if there was one, which is probably
11462 -- as reasonable an interpretation as any ???
11465 Loc : constant Source_Ptr := Sloc (P);
11466 D : constant Node_Id := Discrete_Range (P);
11470 if Is_Entity_Name (D)
11473 (Type_Low_Bound (Entity (D)),
11474 Type_High_Bound (Entity (D)))
11477 Make_Attribute_Reference (Loc,
11478 Prefix => (New_Occurrence_Of (Entity (D), Loc)),
11479 Attribute_Name => Name_First);
11481 elsif Nkind (D) = N_Range
11482 and then Not_Null_Range (Low_Bound (D), High_Bound (D))
11484 Lo := Low_Bound (D);
11490 if Present (Lo) then
11492 Make_Indexed_Component (Loc,
11493 Prefix => Relocate_Node (Prefix (P)),
11494 Expressions => New_List (Lo)));
11496 Analyze_And_Resolve (P);
11505 -- Prefix of Body_Version attribute can be a subprogram name which
11506 -- must not be resolved, since this is not a call.
11508 when Attribute_Body_Version =>
11515 -- Prefix of Caller attribute is an entry name which must not
11516 -- be resolved, since this is definitely not an entry call.
11518 when Attribute_Caller =>
11525 -- Shares processing with Address attribute
11531 -- If the prefix of the Count attribute is an entry name it must not
11532 -- be resolved, since this is definitely not an entry call. However,
11533 -- if it is an element of an entry family, the index itself may
11534 -- have to be resolved because it can be a general expression.
11536 when Attribute_Count =>
11537 if Nkind (P) = N_Indexed_Component
11538 and then Is_Entity_Name (Prefix (P))
11541 Indx : constant Node_Id := First (Expressions (P));
11542 Fam : constant Entity_Id := Entity (Prefix (P));
11544 Resolve (Indx, Entry_Index_Type (Fam));
11545 Apply_Range_Check (Indx, Entry_Index_Type (Fam));
11553 -- Prefix of the Elaborated attribute is a subprogram name which
11554 -- must not be resolved, since this is definitely not a call. Note
11555 -- that it is a library unit, so it cannot be overloaded here.
11557 when Attribute_Elaborated =>
11564 -- Prefix of Enabled attribute is a check name, which must be treated
11565 -- specially and not touched by Resolve.
11567 when Attribute_Enabled =>
11574 -- Do not resolve the prefix of Loop_Entry, instead wait until the
11575 -- attribute has been expanded (see Expand_Loop_Entry_Attributes).
11576 -- The delay ensures that any generated checks or temporaries are
11577 -- inserted before the relocated prefix.
11579 when Attribute_Loop_Entry =>
11582 --------------------
11583 -- Mechanism_Code --
11584 --------------------
11586 -- Prefix of the Mechanism_Code attribute is a function name
11587 -- which must not be resolved. Should we check for overloaded ???
11589 when Attribute_Mechanism_Code =>
11596 -- Most processing is done in sem_dist, after determining the
11597 -- context type. Node is rewritten as a conversion to a runtime call.
11599 when Attribute_Partition_ID =>
11600 Process_Partition_Id (N);
11607 when Attribute_Pool_Address =>
11614 -- We replace the Range attribute node with a range expression whose
11615 -- bounds are the 'First and 'Last attributes applied to the same
11616 -- prefix. The reason that we do this transformation here instead of
11617 -- in the expander is that it simplifies other parts of the semantic
11618 -- analysis which assume that the Range has been replaced; thus it
11619 -- must be done even when in semantic-only mode (note that the RM
11620 -- specifically mentions this equivalence, we take care that the
11621 -- prefix is only evaluated once).
11623 when Attribute_Range => Range_Attribute : declare
11629 if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then
11632 -- If the prefix is a function call returning on the secondary
11633 -- stack, we must make sure to mark/release the stack.
11635 if Nkind (P) = N_Function_Call
11636 and then Nkind (Parent (N)) = N_Loop_Parameter_Specification
11637 and then Requires_Transient_Scope (Etype (P))
11639 Set_Uses_Sec_Stack (Scope (Current_Scope));
11643 Dims := Expressions (N);
11646 Make_Attribute_Reference (Loc,
11647 Prefix => Duplicate_Subexpr (P, Name_Req => True),
11648 Attribute_Name => Name_Last,
11649 Expressions => Dims);
11652 Make_Attribute_Reference (Loc,
11654 Attribute_Name => Name_First,
11655 Expressions => (Dims));
11657 -- Do not share the dimension indicator, if present. Even though
11658 -- it is a static constant, its source location may be modified
11659 -- when printing expanded code and node sharing will lead to chaos
11662 if Present (Dims) then
11663 Set_Expressions (LB, New_List (New_Copy_Tree (First (Dims))));
11666 -- If the original was marked as Must_Not_Freeze (see code in
11667 -- Sem_Ch3.Make_Index), then make sure the rewriting does not
11670 if Must_Not_Freeze (N) then
11671 Set_Must_Not_Freeze (HB);
11672 Set_Must_Not_Freeze (LB);
11673 Set_Must_Not_Freeze (Prefix (HB));
11674 Set_Must_Not_Freeze (Prefix (LB));
11677 if Raises_Constraint_Error (Prefix (N)) then
11679 -- Preserve Sloc of prefix in the new bounds, so that the
11680 -- posted warning can be removed if we are within unreachable
11683 Set_Sloc (LB, Sloc (Prefix (N)));
11684 Set_Sloc (HB, Sloc (Prefix (N)));
11687 Rewrite (N, Make_Range (Loc, LB, HB));
11688 Analyze_And_Resolve (N, Typ);
11690 -- Ensure that the expanded range does not have side effects
11692 Force_Evaluation (LB);
11693 Force_Evaluation (HB);
11695 -- Normally after resolving attribute nodes, Eval_Attribute
11696 -- is called to do any possible static evaluation of the node.
11697 -- However, here since the Range attribute has just been
11698 -- transformed into a range expression it is no longer an
11699 -- attribute node and therefore the call needs to be avoided
11700 -- and is accomplished by simply returning from the procedure.
11703 end Range_Attribute;
11709 when Attribute_Reduce =>
11711 E1 : constant Node_Id := First (Expressions (N));
11712 E2 : constant Node_Id := Next (E1);
11713 Op : Entity_Id := Empty;
11715 Index : Interp_Index;
11717 function Proper_Op (Op : Entity_Id) return Boolean;
11723 function Proper_Op (Op : Entity_Id) return Boolean is
11724 F1, F2 : Entity_Id;
11727 F1 := First_Formal (Op);
11731 F2 := Next_Formal (F1);
11733 or else Present (Next_Formal (F2))
11738 (Ekind (Op) = E_Operator
11739 and then Scope (Op) = Standard_Standard)
11740 or else Covers (Typ, Etype (Op));
11747 if Is_Overloaded (E1) then
11748 Get_First_Interp (E1, Index, It);
11749 while Present (It.Nam) loop
11750 if Proper_Op (It.Nam) then
11752 Set_Entity (E1, Op);
11756 Get_Next_Interp (Index, It);
11759 elsif Proper_Op (Entity (E1)) then
11761 Set_Etype (N, Typ);
11765 Error_Msg_N ("No visible function for reduction", E1);
11773 -- We will only come here during the prescan of a spec expression
11774 -- containing a Result attribute. In that case the proper Etype has
11775 -- already been set, and nothing more needs to be done here.
11777 when Attribute_Result =>
11780 ----------------------
11781 -- Unchecked_Access --
11782 ----------------------
11784 -- Processing is shared with Access
11786 -------------------------
11787 -- Unrestricted_Access --
11788 -------------------------
11790 -- Processing is shared with Access
11796 -- Resolve aggregate components in component associations
11798 when Attribute_Update => Update : declare
11799 Aggr : constant Node_Id := First (Expressions (N));
11800 Typ : constant Entity_Id := Etype (Prefix (N));
11806 -- Set the Etype of the aggregate to that of the prefix, even
11807 -- though the aggregate may not be a proper representation of a
11808 -- value of the type (missing or duplicated associations, etc.)
11809 -- Complete resolution of the prefix. Note that in Ada 2012 it
11810 -- can be a qualified expression that is e.g. an aggregate.
11812 Set_Etype (Aggr, Typ);
11813 Resolve (Prefix (N), Typ);
11815 -- For an array type, resolve expressions with the component type
11816 -- of the array, and apply constraint checks when needed.
11818 if Is_Array_Type (Typ) then
11819 Assoc := First (Component_Associations (Aggr));
11820 while Present (Assoc) loop
11821 Expr := Expression (Assoc);
11822 Resolve (Expr, Component_Type (Typ));
11824 -- For scalar array components set Do_Range_Check when
11825 -- needed. Constraint checking on non-scalar components
11826 -- is done in Aggregate_Constraint_Checks, but only if
11827 -- full analysis is enabled. These flags are not set in
11828 -- the front-end in GnatProve mode.
11830 if Is_Scalar_Type (Component_Type (Typ))
11831 and then not Is_OK_Static_Expression (Expr)
11832 and then not Range_Checks_Suppressed (Component_Type (Typ))
11834 if Is_Entity_Name (Expr)
11835 and then Etype (Expr) = Component_Type (Typ)
11840 Set_Do_Range_Check (Expr);
11844 -- The choices in the association are static constants,
11845 -- or static aggregates each of whose components belongs
11846 -- to the proper index type. However, they must also
11847 -- belong to the index subtype (s) of the prefix, which
11848 -- may be a subtype (e.g. given by a slice).
11850 -- Choices may also be identifiers with no staticness
11851 -- requirements, in which case they must resolve to the
11860 C := First (Choices (Assoc));
11861 while Present (C) loop
11862 Indx := First_Index (Etype (Prefix (N)));
11864 if Nkind (C) /= N_Aggregate then
11865 Analyze_And_Resolve (C, Etype (Indx));
11866 Apply_Constraint_Check (C, Etype (Indx));
11867 Check_Non_Static_Context (C);
11870 C_E := First (Expressions (C));
11871 while Present (C_E) loop
11872 Analyze_And_Resolve (C_E, Etype (Indx));
11873 Apply_Constraint_Check (C_E, Etype (Indx));
11874 Check_Non_Static_Context (C_E);
11888 -- For a record type, use type of each component, which is
11889 -- recorded during analysis.
11892 Assoc := First (Component_Associations (Aggr));
11893 while Present (Assoc) loop
11894 Comp := First (Choices (Assoc));
11895 Expr := Expression (Assoc);
11897 if Nkind (Comp) /= N_Others_Choice
11898 and then not Error_Posted (Comp)
11900 Resolve (Expr, Etype (Entity (Comp)));
11902 if Is_Scalar_Type (Etype (Entity (Comp)))
11903 and then not Is_OK_Static_Expression (Expr)
11904 and then not Range_Checks_Suppressed
11905 (Etype (Entity (Comp)))
11907 Set_Do_Range_Check (Expr);
11920 -- Apply range check. Note that we did not do this during the
11921 -- analysis phase, since we wanted Eval_Attribute to have a
11922 -- chance at finding an illegal out of range value.
11924 when Attribute_Val =>
11926 -- Note that we do our own Eval_Attribute call here rather than
11927 -- use the common one, because we need to do processing after
11928 -- the call, as per above comment.
11930 Eval_Attribute (N);
11932 -- Eval_Attribute may replace the node with a raise CE, or
11933 -- fold it to a constant. Obviously we only apply a scalar
11934 -- range check if this did not happen.
11936 if Nkind (N) = N_Attribute_Reference
11937 and then Attribute_Name (N) = Name_Val
11939 Apply_Scalar_Range_Check (First (Expressions (N)), Btyp);
11948 -- Prefix of Version attribute can be a subprogram name which
11949 -- must not be resolved, since this is not a call.
11951 when Attribute_Version =>
11954 ----------------------
11955 -- Other Attributes --
11956 ----------------------
11958 -- For other attributes, resolve prefix unless it is a type. If
11959 -- the attribute reference itself is a type name ('Base and 'Class)
11960 -- then this is only legal within a task or protected record.
11963 if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then
11967 -- If the attribute reference itself is a type name ('Base,
11968 -- 'Class) then this is only legal within a task or protected
11969 -- record. What is this all about ???
11971 if Is_Entity_Name (N) and then Is_Type (Entity (N)) then
11972 if Is_Concurrent_Type (Entity (N))
11973 and then In_Open_Scopes (Entity (P))
11978 ("invalid use of subtype name in expression or call", N);
11982 -- For attributes whose argument may be a string, complete
11983 -- resolution of argument now. This avoids premature expansion
11984 -- (and the creation of transient scopes) before the attribute
11985 -- reference is resolved.
11988 when Attribute_Value =>
11989 Resolve (First (Expressions (N)), Standard_String);
11991 when Attribute_Wide_Value =>
11992 Resolve (First (Expressions (N)), Standard_Wide_String);
11994 when Attribute_Wide_Wide_Value =>
11995 Resolve (First (Expressions (N)), Standard_Wide_Wide_String);
11997 when others => null;
12000 -- If the prefix of the attribute is a class-wide type then it
12001 -- will be expanded into a dispatching call to a predefined
12002 -- primitive. Therefore we must check for potential violation
12003 -- of such restriction.
12005 if Is_Class_Wide_Type (Etype (P)) then
12006 Check_Restriction (No_Dispatching_Calls, N);
12010 -- Mark use clauses of the original prefix if the attribute is applied
12013 if Nkind (Original_Node (P)) in N_Has_Entity
12014 and then Present (Entity (Original_Node (P)))
12016 Mark_Use_Clauses (Original_Node (P));
12019 -- Normally the Freezing is done by Resolve but sometimes the Prefix
12020 -- is not resolved, in which case the freezing must be done now.
12022 -- For an elaboration check on a subprogram, we do not freeze its type.
12023 -- It may be declared in an unrelated scope, in particular in the case
12024 -- of a generic function whose type may remain unelaborated.
12026 if Attr_Id = Attribute_Elaborated then
12029 -- Should this be restricted to Expander_Active???
12032 Freeze_Expression (P);
12035 -- Finally perform static evaluation on the attribute reference
12037 Analyze_Dimension (N);
12038 Eval_Attribute (N);
12039 end Resolve_Attribute;
12041 ------------------------
12042 -- Set_Boolean_Result --
12043 ------------------------
12045 procedure Set_Boolean_Result (N : Node_Id; B : Boolean) is
12046 Loc : constant Source_Ptr := Sloc (N);
12049 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
12051 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
12053 end Set_Boolean_Result;
12055 -------------------------------
12056 -- Statically_Denotes_Object --
12057 -------------------------------
12059 function Statically_Denotes_Object (N : Node_Id) return Boolean is
12063 if Is_Entity_Name (N) then
12066 elsif Nkind (N) = N_Selected_Component
12067 and then Statically_Denotes_Object (Prefix (N))
12068 and then Present (Entity (Selector_Name (N)))
12071 Sel_Id : constant Entity_Id := Entity (Selector_Name (N));
12072 Comp_Decl : constant Node_Id := Parent (Sel_Id);
12075 if Depends_On_Discriminant (Sel_Id) then
12078 elsif Nkind (Parent (Parent (Comp_Decl))) = N_Variant then
12086 elsif Nkind (N) = N_Indexed_Component
12087 and then Statically_Denotes_Object (Prefix (N))
12088 and then Is_Constrained (Etype (Prefix (N)))
12090 Indx := First (Expressions (N));
12091 while Present (Indx) loop
12092 if not Compile_Time_Known_Value (Indx)
12093 or else Do_Range_Check (Indx)
12106 end Statically_Denotes_Object;
12108 --------------------------------
12109 -- Stream_Attribute_Available --
12110 --------------------------------
12112 function Stream_Attribute_Available
12114 Nam : TSS_Name_Type;
12115 Partial_View : Node_Id := Empty) return Boolean
12117 Etyp : Entity_Id := Typ;
12119 -- Start of processing for Stream_Attribute_Available
12122 -- We need some comments in this body ???
12124 if Has_Stream_Attribute_Definition (Typ, Nam) then
12128 if Is_Class_Wide_Type (Typ) then
12129 return not Is_Limited_Type (Typ)
12130 or else Stream_Attribute_Available (Etype (Typ), Nam);
12133 if Nam = TSS_Stream_Input
12134 and then Is_Abstract_Type (Typ)
12135 and then not Is_Class_Wide_Type (Typ)
12140 if not (Is_Limited_Type (Typ)
12141 or else (Present (Partial_View)
12142 and then Is_Limited_Type (Partial_View)))
12147 -- In Ada 2005, Input can invoke Read, and Output can invoke Write
12149 if Nam = TSS_Stream_Input
12150 and then Ada_Version >= Ada_2005
12151 and then Stream_Attribute_Available (Etyp, TSS_Stream_Read)
12155 elsif Nam = TSS_Stream_Output
12156 and then Ada_Version >= Ada_2005
12157 and then Stream_Attribute_Available (Etyp, TSS_Stream_Write)
12162 -- Case of Read and Write: check for attribute definition clause that
12163 -- applies to an ancestor type.
12165 while Etype (Etyp) /= Etyp loop
12166 Etyp := Etype (Etyp);
12168 if Has_Stream_Attribute_Definition (Etyp, Nam) then
12173 if Ada_Version < Ada_2005 then
12175 -- In Ada 95 mode, also consider a non-visible definition
12178 Btyp : constant Entity_Id := Implementation_Base_Type (Typ);
12181 and then Stream_Attribute_Available
12182 (Btyp, Nam, Partial_View => Typ);
12187 end Stream_Attribute_Available;