Skip various cmp-mem-const tests on lp64 hppa*-*-*
[official-gcc.git] / gcc / ada / sem_attr.adb
blobf52103f28ddce5fd715c93fb6917f4e1d6c5a59d
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ A T T R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
28 with Accessibility; use Accessibility;
29 with Aspects; use Aspects;
30 with Atree; use Atree;
31 with Casing; use Casing;
32 with Checks; use Checks;
33 with Debug; use Debug;
34 with Einfo; use Einfo;
35 with Einfo.Entities; use Einfo.Entities;
36 with Einfo.Utils; use Einfo.Utils;
37 with Elists; use Elists;
38 with Errout; use Errout;
39 with Eval_Fat;
40 with Exp_Dist; use Exp_Dist;
41 with Exp_Util; use Exp_Util;
42 with Expander; use Expander;
43 with Freeze; use Freeze;
44 with Ghost; use Ghost;
45 with Gnatvsn; use Gnatvsn;
46 with Itypes; use Itypes;
47 with Lib; use Lib;
48 with Lib.Xref; use Lib.Xref;
49 with Nlists; use Nlists;
50 with Nmake; use Nmake;
51 with Opt; use Opt;
52 with Restrict; use Restrict;
53 with Rident; use Rident;
54 with Rtsfind; use Rtsfind;
55 with Sdefault;
56 with Sem; use Sem;
57 with Sem_Aggr; use Sem_Aggr;
58 with Sem_Aux; use Sem_Aux;
59 with Sem_Cat; use Sem_Cat;
60 with Sem_Ch6; use Sem_Ch6;
61 with Sem_Ch8; use Sem_Ch8;
62 with Sem_Ch10; use Sem_Ch10;
63 with Sem_Dim; use Sem_Dim;
64 with Sem_Dist; use Sem_Dist;
65 with Sem_Elab; use Sem_Elab;
66 with Sem_Elim; use Sem_Elim;
67 with Sem_Eval; use Sem_Eval;
68 with Sem_Prag; use Sem_Prag;
69 with Sem_Res; use Sem_Res;
70 with Sem_Type; use Sem_Type;
71 with Sem_Util; use Sem_Util;
72 with Sem_Warn;
73 with Stand; use Stand;
74 with Sinfo; use Sinfo;
75 with Sinfo.Nodes; use Sinfo.Nodes;
76 with Sinfo.Utils; use Sinfo.Utils;
77 with Sinput; use Sinput;
78 with System;
79 with Stringt; use Stringt;
80 with Strub; use Strub;
81 with Style;
82 with Stylesw; use Stylesw;
83 with Targparm; use Targparm;
84 with Ttypes; use Ttypes;
85 with Tbuild; use Tbuild;
86 with Uintp; use Uintp;
87 with Uname; use Uname;
88 with Urealp; use Urealp;
89 with Warnsw; use Warnsw;
91 with System.CRC32; use System.CRC32;
93 package body Sem_Attr is
95 True_Value : constant Uint := Uint_1;
96 False_Value : constant Uint := Uint_0;
97 -- Synonyms to be used when these constants are used as Boolean values
99 Bad_Attribute : exception;
100 -- Exception raised if an error is detected during attribute processing,
101 -- used so that we can abandon the processing so we don't run into
102 -- trouble with cascaded errors.
104 -- The following array is the list of attributes defined in the Ada 83 RM.
105 -- In Ada 83 mode, these are the only recognized attributes. In other Ada
106 -- modes all these attributes are recognized, even if removed in Ada 95.
108 Attribute_83 : constant Attribute_Set :=
109 (Attribute_Address |
110 Attribute_Aft |
111 Attribute_Alignment |
112 Attribute_Base |
113 Attribute_Callable |
114 Attribute_Constrained |
115 Attribute_Count |
116 Attribute_Delta |
117 Attribute_Digits |
118 Attribute_Emax |
119 Attribute_Epsilon |
120 Attribute_First |
121 Attribute_First_Bit |
122 Attribute_Fore |
123 Attribute_Image |
124 Attribute_Large |
125 Attribute_Last |
126 Attribute_Last_Bit |
127 Attribute_Leading_Part |
128 Attribute_Length |
129 Attribute_Machine_Emax |
130 Attribute_Machine_Emin |
131 Attribute_Machine_Mantissa |
132 Attribute_Machine_Overflows |
133 Attribute_Machine_Radix |
134 Attribute_Machine_Rounds |
135 Attribute_Mantissa |
136 Attribute_Pos |
137 Attribute_Position |
138 Attribute_Pred |
139 Attribute_Range |
140 Attribute_Safe_Emax |
141 Attribute_Safe_Large |
142 Attribute_Safe_Small |
143 Attribute_Size |
144 Attribute_Small |
145 Attribute_Storage_Size |
146 Attribute_Succ |
147 Attribute_Terminated |
148 Attribute_Val |
149 Attribute_Value |
150 Attribute_Width => True,
151 others => False);
153 -- The following array is the list of attributes defined in the Ada 2005
154 -- RM which are not defined in Ada 95. These are recognized in Ada 95 mode,
155 -- but in Ada 95 they are considered to be implementation defined.
157 Attribute_05 : constant Attribute_Set :=
158 (Attribute_Machine_Rounding |
159 Attribute_Mod |
160 Attribute_Priority |
161 Attribute_Stream_Size |
162 Attribute_Wide_Wide_Width => True,
163 others => False);
165 -- The following array is the list of attributes defined in the Ada 2012
166 -- RM which are not defined in Ada 2005. These are recognized in Ada 95
167 -- and Ada 2005 modes, but are considered to be implementation defined.
169 Attribute_12 : constant Attribute_Set :=
170 (Attribute_First_Valid |
171 Attribute_Has_Same_Storage |
172 Attribute_Last_Valid |
173 Attribute_Max_Alignment_For_Allocation => True,
174 others => False);
176 -- The following array is the list of attributes defined in the Ada 2022
177 -- RM which are not defined in Ada 2012. These are recognized in Ada
178 -- 95/2005/2012 modes, but are considered to be implementation defined.
180 Attribute_22 : constant Attribute_Set :=
181 (Attribute_Enum_Rep |
182 Attribute_Enum_Val |
183 Attribute_Index |
184 Attribute_Preelaborable_Initialization => True,
185 others => False);
187 -- The following array contains all attributes that imply a modification
188 -- of their prefixes or result in an access value. Such prefixes can be
189 -- considered as lvalues.
191 Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Set :=
192 (Attribute_Access |
193 Attribute_Address |
194 Attribute_Input |
195 Attribute_Read |
196 Attribute_Unchecked_Access |
197 Attribute_Unrestricted_Access => True,
198 others => False);
200 -----------------------
201 -- Local_Subprograms --
202 -----------------------
204 procedure Eval_Attribute (N : Node_Id);
205 -- Performs compile time evaluation of attributes where possible, leaving
206 -- the Is_Static_Expression/Raises_Constraint_Error flags appropriately
207 -- set, and replacing the node with a literal node if the value can be
208 -- computed at compile time. All static attribute references are folded,
209 -- as well as a number of cases of non-static attributes that can always
210 -- be computed at compile time (e.g. floating-point model attributes that
211 -- are applied to non-static subtypes). Of course in such cases, the
212 -- Is_Static_Expression flag will not be set on the resulting literal.
213 -- Note that the only required action of this procedure is to catch the
214 -- static expression cases as described in the RM. Folding of other cases
215 -- is done where convenient, but some additional non-static folding is in
216 -- Expand_N_Attribute_Reference in cases where this is more convenient.
218 function Is_Anonymous_Tagged_Base
219 (Anon : Entity_Id;
220 Typ : Entity_Id) return Boolean;
221 -- For derived tagged types that constrain parent discriminants we build
222 -- an anonymous unconstrained base type. We need to recognize the relation
223 -- between the two when analyzing an access attribute for a constrained
224 -- component, before the full declaration for Typ has been analyzed, and
225 -- where therefore the prefix of the attribute does not match the enclosing
226 -- scope.
228 procedure Set_Boolean_Result (N : Node_Id; B : Boolean);
229 -- Rewrites node N with an occurrence of either Standard_False or
230 -- Standard_True, depending on the value of the parameter B. The
231 -- result is marked as a static expression.
233 -----------------------
234 -- Analyze_Attribute --
235 -----------------------
237 procedure Analyze_Attribute (N : Node_Id) is
238 Loc : constant Source_Ptr := Sloc (N);
239 Aname : constant Name_Id := Attribute_Name (N);
240 Exprs : constant List_Id := Expressions (N);
241 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
242 P_Old : constant Node_Id := Prefix (N);
244 P : Node_Id := P_Old;
245 E1 : Node_Id;
246 E2 : Node_Id;
248 P_Type : Entity_Id := Empty;
249 -- Type of prefix after analysis
251 P_Base_Type : Entity_Id := Empty;
252 -- Base type of prefix after analysis
254 -----------------------
255 -- Local Subprograms --
256 -----------------------
258 procedure Address_Checks;
259 -- Semantic checks for valid use of Address attribute. This was made
260 -- a separate routine with the idea of using it for unrestricted access
261 -- which seems like it should follow the same rules, but that turned
262 -- out to be impractical. So now this is only used for Address.
264 procedure Analyze_Access_Attribute;
265 -- Used for Access, Unchecked_Access, Unrestricted_Access attributes.
266 -- Internally, Id distinguishes which of the three cases is involved.
268 procedure Analyze_Attribute_Old_Result
269 (Legal : out Boolean;
270 Spec_Id : out Entity_Id);
271 -- Common processing for attributes 'Old and 'Result. The routine checks
272 -- that the attribute appears in a postcondition-like aspect or pragma
273 -- associated with a suitable subprogram or a body. Flag Legal is set
274 -- when the above criteria are met. Spec_Id denotes the entity of the
275 -- subprogram [body] or Empty if the attribute is illegal.
277 procedure Analyze_Image_Attribute (Str_Typ : Entity_Id);
278 -- Common processing for attributes 'Img, 'Image, 'Wide_Image, and
279 -- 'Wide_Wide_Image. The routine checks that the prefix is valid and
280 -- sets the type of the attribute to the one specified by Str_Typ (e.g.
281 -- Standard_String for 'Image and Standard_Wide_String for 'Wide_Image).
283 procedure Analyze_Index_Attribute
284 (Legal : out Boolean;
285 Spec_Id : out Entity_Id);
286 -- Processing for attribute 'Index. It checks that the attribute appears
287 -- in a pre/postcondition-like aspect or pragma associated with an entry
288 -- family. Flag Legal is set when the above criteria are met. Spec_Id
289 -- denotes the entity of the wrapper of the entry family or Empty if
290 -- the attribute is illegal.
292 procedure Bad_Attribute_For_Predicate;
293 -- Output error message for use of a predicate (First, Last, Range) not
294 -- allowed with a type that has predicates. If the type is a generic
295 -- actual, then the message is a warning, and we generate code to raise
296 -- program error with an appropriate reason. No error message is given
297 -- for internally generated uses of the attributes. This legality rule
298 -- only applies to scalar types.
300 procedure Check_Array_Or_Scalar_Type;
301 -- Common procedure used by First, Last, Range attribute to check
302 -- that the prefix is a constrained array or scalar type, or a name
303 -- of an array object, and that an argument appears only if appropriate
304 -- (i.e. only in the array case).
306 procedure Check_Array_Type;
307 -- Common semantic checks for all array attributes. Checks that the
308 -- prefix is a constrained array type or the name of an array object.
309 -- The error message for non-arrays is specialized appropriately.
311 procedure Check_Asm_Attribute;
312 -- Common semantic checks for Asm_Input and Asm_Output attributes
314 procedure Check_Component;
315 -- Common processing for Bit_Position, First_Bit, Last_Bit, and
316 -- Position. Checks prefix is an appropriate selected component.
318 procedure Check_Decimal_Fixed_Point_Type;
319 -- Check that prefix of attribute N is a decimal fixed-point type
321 procedure Check_Dereference;
322 -- If the prefix of attribute is an object of an access type, then
323 -- introduce an explicit dereference, and adjust P_Type accordingly.
325 procedure Check_Discrete_Type;
326 -- Verify that prefix of attribute N is a discrete type
328 procedure Check_E0;
329 -- Check that no attribute arguments are present
331 procedure Check_Either_E0_Or_E1;
332 -- Check that there are zero or one attribute arguments present
334 procedure Check_E1;
335 -- Check that exactly one attribute argument is present
337 procedure Check_E2;
338 -- Check that two attribute arguments are present
340 procedure Check_Enum_Image (Check_Enumeration_Maps : Boolean := False);
341 -- Common processing for the Image and Value family of attributes,
342 -- including their Wide and Wide_Wide versions, Enum_Val, Img,
343 -- and Valid_Value.
345 -- If the prefix type of an attribute is an enumeration type, set all
346 -- its literals as referenced, since the attribute function can
347 -- indirectly reference any of the literals. Set the referenced flag
348 -- only if the attribute is in the main code unit; otherwise an
349 -- improperly set reference when analyzing an inlined body will lose a
350 -- proper warning on a useless with_clause.
352 -- If Check_Enumeration_Maps is True, then the attribute expansion
353 -- requires enumeration maps, so check whether restriction
354 -- No_Enumeration_Maps is active.
356 procedure Check_First_Last_Valid;
357 -- Perform all checks for First_Valid and Last_Valid attributes
359 procedure Check_Fixed_Point_Type;
360 -- Verify that prefix of attribute N is a fixed type
362 procedure Check_Fixed_Point_Type_0;
363 -- Verify that prefix of attribute N is a fixed type and that
364 -- no attribute expressions are present.
366 procedure Check_Floating_Point_Type;
367 -- Verify that prefix of attribute N is a float type
369 procedure Check_Floating_Point_Type_0;
370 -- Verify that prefix of attribute N is a float type and that
371 -- no attribute expressions are present.
373 procedure Check_Floating_Point_Type_1;
374 -- Verify that prefix of attribute N is a float type and that
375 -- exactly one attribute expression is present.
377 procedure Check_Floating_Point_Type_2;
378 -- Verify that prefix of attribute N is a float type and that
379 -- two attribute expressions are present.
381 procedure Check_Integer_Type;
382 -- Verify that prefix of attribute N is an integer type
384 procedure Check_Modular_Integer_Type;
385 -- Verify that prefix of attribute N is a modular integer type
387 procedure Check_Not_CPP_Type;
388 -- Check that P (the prefix of the attribute) is not an CPP type
389 -- for which no Ada predefined primitive is available.
391 procedure Check_Not_Incomplete_Type;
392 -- Check that P (the prefix of the attribute) is not an incomplete
393 -- type or a private type for which no full view has been given.
395 procedure Check_Object_Reference (P : Node_Id);
396 -- Check that P is an object reference
398 procedure Check_PolyORB_Attribute;
399 -- Validity checking for PolyORB/DSA attribute
401 procedure Check_Program_Unit;
402 -- Verify that prefix of attribute N is a program unit
404 procedure Check_Real_Type;
405 -- Verify that prefix of attribute N is fixed or float type
407 procedure Check_Enumeration_Type;
408 -- Verify that prefix of attribute N is an enumeration type
410 procedure Check_Scalar_Type;
411 -- Verify that prefix of attribute N is a scalar type
413 procedure Check_Standard_Prefix;
414 -- Verify that prefix of attribute N is package Standard. Also checks
415 -- that there are no arguments.
417 procedure Check_Stream_Attribute (Nam : TSS_Name_Type);
418 -- Validity checking for stream attribute. Nam is the TSS name of the
419 -- corresponding possible defined attribute function (e.g. for the
420 -- Read attribute, Nam will be TSS_Stream_Read).
422 procedure Check_Put_Image_Attribute;
423 -- Validity checking for Put_Image attribute
425 procedure Check_System_Prefix;
426 -- Verify that prefix of attribute N is package System
428 procedure Check_Task_Prefix;
429 -- Verify that prefix of attribute N is a task or task type
431 procedure Check_Type;
432 -- Verify that the prefix of attribute N is a type
434 procedure Check_Unit_Name (Nod : Node_Id);
435 -- Check that Nod is of the form of a library unit name, i.e that
436 -- it is an identifier, or a selected component whose prefix is
437 -- itself of the form of a library unit name. Note that this is
438 -- quite different from Check_Program_Unit, since it only checks
439 -- the syntactic form of the name, not the semantic identity. This
440 -- is because it is used with attributes (Elab_Body, Elab_Spec and
441 -- Elaborated) which can refer to non-visible unit.
443 procedure Error_Attr (Msg : String; Error_Node : Node_Id);
444 pragma No_Return (Error_Attr);
445 procedure Error_Attr;
446 pragma No_Return (Error_Attr);
447 -- Posts error using Error_Msg_N at given node, sets type of attribute
448 -- node to Any_Type, and then raises Bad_Attribute to avoid any further
449 -- semantic processing. The message typically contains a % insertion
450 -- character which is replaced by the attribute name. The call with
451 -- no arguments is used when the caller has already generated the
452 -- required error messages.
454 procedure Error_Attr_P (Msg : String; Msg_Cont : String := "");
455 pragma No_Return (Error_Attr_P);
456 -- Like Error_Attr, but error is posted at the start of the prefix. The
457 -- second message Msg_Cont is useful to issue a continuation message
458 -- before raising Bad_Attribute.
460 procedure Legal_Formal_Attribute;
461 -- Common processing for attributes Definite and Has_Discriminants.
462 -- Checks that prefix is generic indefinite formal type.
464 procedure Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements;
465 -- Common processing for attributes Max_Alignment_For_Allocation and
466 -- Max_Size_In_Storage_Elements.
468 procedure Min_Max;
469 -- Common processing for attributes Max and Min
471 procedure Standard_Attribute (Val : Int);
472 -- Used to process attributes whose prefix is package Standard which
473 -- yield values of type Universal_Integer. The attribute reference
474 -- node is rewritten with an integer literal of the given value which
475 -- is marked as static.
477 procedure Uneval_Old_Msg;
478 -- Called when Loop_Entry or Old is used in a potentially unevaluated
479 -- expression. Generates appropriate message or warning depending on
480 -- the setting of Opt.Uneval_Old (or flags in an N_Aspect_Specification
481 -- node in the aspect case).
483 procedure Unexpected_Argument (En : Node_Id);
484 pragma No_Return (Unexpected_Argument);
485 -- Signal unexpected attribute argument (En is the argument), and then
486 -- raises Bad_Attribute to avoid any further semantic processing.
488 procedure Validate_Non_Static_Attribute_Function_Call;
489 -- Called when processing an attribute that is a function call to a
490 -- non-static function, i.e. an attribute function that either takes
491 -- non-scalar arguments or returns a non-scalar result. Verifies that
492 -- such a call does not appear in a preelaborable context.
494 --------------------
495 -- Address_Checks --
496 --------------------
498 procedure Address_Checks is
499 begin
500 -- An Address attribute created by expansion is legal even when it
501 -- applies to other entity-denoting expressions.
503 if not Comes_From_Source (N) then
504 return;
506 -- Address attribute on a protected object self reference is legal
508 elsif Is_Protected_Self_Reference (P) then
509 return;
511 -- Address applied to an entity
513 elsif Is_Entity_Name (P) then
514 declare
515 Ent : constant Entity_Id := Entity (P);
517 begin
518 if Is_Subprogram (Ent) then
519 Set_Address_Taken (Ent);
521 -- An Address attribute is accepted when generated by the
522 -- compiler for dispatching operation, and an error is
523 -- issued once the subprogram is frozen (to avoid confusing
524 -- errors about implicit uses of Address in the dispatch
525 -- table initialization).
527 if Has_Pragma_Inline_Always (Entity (P))
528 and then Comes_From_Source (P)
529 then
530 Error_Attr_P
531 ("prefix of % attribute cannot be Inline_Always "
532 & "subprogram");
534 -- It is illegal to apply 'Address to an intrinsic
535 -- subprogram. This is now formalized in AI05-0095.
536 -- In an instance, an attempt to obtain 'Address of an
537 -- intrinsic subprogram (e.g the renaming of a predefined
538 -- operator that is an actual) raises Program_Error.
540 elsif Convention (Ent) = Convention_Intrinsic then
541 if In_Instance then
542 Rewrite (N,
543 Make_Raise_Program_Error (Loc,
544 Reason => PE_Address_Of_Intrinsic));
546 else
547 Error_Msg_Name_1 := Aname;
548 Error_Msg_N
549 ("cannot take % of intrinsic subprogram", N);
550 end if;
552 -- Issue an error if prefix denotes an eliminated subprogram
554 else
555 Check_For_Eliminated_Subprogram (P, Ent);
556 end if;
558 -- Object or label reference
560 elsif Is_Object_Reference (P) or else Ekind (Ent) = E_Label then
561 Set_Address_Taken (Ent);
563 -- Deal with No_Implicit_Aliasing restriction
565 if Restriction_Check_Required (No_Implicit_Aliasing) then
566 if not Is_Aliased_View (P) then
567 Check_Restriction (No_Implicit_Aliasing, P);
568 else
569 Check_No_Implicit_Aliasing (P);
570 end if;
571 end if;
573 -- If we have an address of an object, and the attribute
574 -- comes from source, then set the object as potentially
575 -- source modified. We do this because the resulting address
576 -- can potentially be used to modify the variable and we
577 -- might not detect this, leading to some junk warnings.
579 Set_Never_Set_In_Source (Ent, False);
581 -- Allow Address to be applied to task or protected type,
582 -- returning null address (what is that about???)
584 elsif (Is_Concurrent_Type (Etype (Ent))
585 and then Etype (Ent) = Base_Type (Ent))
586 or else Ekind (Ent) = E_Package
587 or else Is_Generic_Unit (Ent)
588 then
589 Rewrite (N,
590 New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
592 -- Anything else is illegal
594 else
595 Error_Attr ("invalid prefix for % attribute", P);
596 end if;
597 end;
599 -- Object is OK
601 elsif Is_Object_Reference (P) then
602 return;
604 -- Subprogram called using dot notation
606 elsif Nkind (P) = N_Selected_Component
607 and then Is_Subprogram (Entity (Selector_Name (P)))
608 then
609 return;
611 -- What exactly are we allowing here ??? and is this properly
612 -- documented in the sinfo documentation for this node ???
614 elsif Relaxed_RM_Semantics
615 and then Nkind (P) = N_Attribute_Reference
616 then
617 return;
619 -- All other non-entity name cases are illegal
621 else
622 Error_Attr ("invalid prefix for % attribute", P);
623 end if;
624 end Address_Checks;
626 ------------------------------
627 -- Analyze_Access_Attribute --
628 ------------------------------
630 procedure Analyze_Access_Attribute is
631 Acc_Type : Entity_Id;
633 Scop : Entity_Id;
634 Typ : Entity_Id;
636 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id;
637 -- Build an access-to-object type whose designated type is DT,
638 -- and whose Ekind is appropriate to the attribute type. The
639 -- type that is constructed is returned as the result.
641 procedure Build_Access_Subprogram_Type (P : Node_Id);
642 -- Build an access to subprogram whose designated type is the type of
643 -- the prefix. If prefix is overloaded, so is the node itself. The
644 -- result is stored in Acc_Type.
646 function OK_Self_Reference return Boolean;
647 -- An access reference whose prefix is a type can legally appear
648 -- within an aggregate, where it is obtained by expansion of
649 -- a defaulted aggregate. The enclosing aggregate that contains
650 -- the self-referenced is flagged so that the self-reference can
651 -- be expanded into a reference to the target object (see exp_aggr).
653 ------------------------------
654 -- Build_Access_Object_Type --
655 ------------------------------
657 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is
658 Typ : constant Entity_Id :=
659 New_Internal_Entity
660 (E_Access_Attribute_Type, Current_Scope, Loc, 'A');
661 begin
662 Set_Etype (Typ, Typ);
663 Set_Is_Itype (Typ);
664 Set_Associated_Node_For_Itype (Typ, N);
665 Set_Directly_Designated_Type (Typ, DT);
666 return Typ;
667 end Build_Access_Object_Type;
669 ----------------------------------
670 -- Build_Access_Subprogram_Type --
671 ----------------------------------
673 procedure Build_Access_Subprogram_Type (P : Node_Id) is
674 Index : Interp_Index;
675 It : Interp;
677 procedure Check_Local_Access (E : Entity_Id);
678 -- Deal with possible access to local subprogram. If we have such
679 -- an access, we set a flag to kill all tracked values on any call
680 -- because this access value may be passed around, and any called
681 -- code might use it to access a local procedure which clobbers a
682 -- tracked value. If the scope is a loop or block, indicate that
683 -- value tracking is disabled for the enclosing subprogram.
685 function Get_Convention (E : Entity_Id) return Convention_Id;
686 function Get_Kind (E : Entity_Id) return Entity_Kind;
687 -- Distinguish between access to regular/protected subprograms
689 ------------------------
690 -- Check_Local_Access --
691 ------------------------
693 procedure Check_Local_Access (E : Entity_Id) is
694 begin
695 if not Is_Library_Level_Entity (E) then
696 Set_Suppress_Value_Tracking_On_Call (Current_Scope);
697 Set_Suppress_Value_Tracking_On_Call
698 (Nearest_Dynamic_Scope (Current_Scope));
699 end if;
700 end Check_Local_Access;
702 --------------------
703 -- Get_Convention --
704 --------------------
706 function Get_Convention (E : Entity_Id) return Convention_Id is
707 begin
708 -- Restrict handling by_protected_procedure access subprograms
709 -- to source entities; required to avoid building access to
710 -- subprogram types with convention protected when building
711 -- dispatch tables.
713 if Comes_From_Source (P)
714 and then Is_By_Protected_Procedure (E)
715 then
716 return Convention_Protected;
717 else
718 return Convention (E);
719 end if;
720 end Get_Convention;
722 --------------
723 -- Get_Kind --
724 --------------
726 function Get_Kind (E : Entity_Id) return Entity_Kind is
727 begin
728 if Get_Convention (E) = Convention_Protected then
729 return E_Access_Protected_Subprogram_Type;
730 else
731 return E_Access_Subprogram_Type;
732 end if;
733 end Get_Kind;
735 -- Start of processing for Build_Access_Subprogram_Type
737 begin
738 -- In the case of an access to subprogram, use the name of the
739 -- subprogram itself as the designated type. Type-checking in
740 -- this case compares the signatures of the designated types.
742 -- Note: This fragment of the tree is temporarily malformed
743 -- because the correct tree requires an E_Subprogram_Type entity
744 -- as the designated type. In most cases this designated type is
745 -- later overridden by the semantics with the type imposed by the
746 -- context during the resolution phase. In the specific case of
747 -- the expression Address!(Prim'Unrestricted_Access), used to
748 -- initialize slots of dispatch tables, this work will be done by
749 -- the expander (see Exp_Aggr).
751 -- The reason to temporarily add this kind of node to the tree
752 -- instead of a proper E_Subprogram_Type itype, is the following:
753 -- in case of errors found in the source file we report better
754 -- error messages. For example, instead of generating the
755 -- following error:
757 -- "expected access to subprogram with profile
758 -- defined at line X"
760 -- we currently generate:
762 -- "expected access to function Z defined at line X"
764 Set_Etype (N, Any_Type);
766 if not Is_Overloaded (P) then
767 Check_Local_Access (Entity (P));
769 if not Is_Intrinsic_Subprogram (Entity (P)) then
770 Acc_Type := Create_Itype (Get_Kind (Entity (P)), N);
771 Set_Is_Public (Acc_Type, False);
772 Set_Etype (Acc_Type, Acc_Type);
773 Set_Convention (Acc_Type, Get_Convention (Entity (P)));
774 Set_Directly_Designated_Type (Acc_Type, Entity (P));
775 Set_Etype (N, Acc_Type);
776 Freeze_Before (N, Acc_Type);
777 end if;
779 else
780 Get_First_Interp (P, Index, It);
781 while Present (It.Nam) loop
782 Check_Local_Access (It.Nam);
784 if not Is_Intrinsic_Subprogram (It.Nam) then
785 Acc_Type := Create_Itype (Get_Kind (It.Nam), N);
786 Set_Is_Public (Acc_Type, False);
787 Set_Etype (Acc_Type, Acc_Type);
788 Set_Convention (Acc_Type, Get_Convention (It.Nam));
789 Set_Directly_Designated_Type (Acc_Type, It.Nam);
790 Add_One_Interp (N, Acc_Type, Acc_Type);
791 Freeze_Before (N, Acc_Type);
792 end if;
794 Get_Next_Interp (Index, It);
795 end loop;
796 end if;
798 -- Cannot be applied to intrinsic. Looking at the tests above,
799 -- the only way Etype (N) can still be set to Any_Type is if
800 -- Is_Intrinsic_Subprogram was True for some referenced entity.
802 if Etype (N) = Any_Type then
803 Error_Attr_P ("prefix of % attribute cannot be intrinsic");
804 end if;
805 end Build_Access_Subprogram_Type;
807 ----------------------
808 -- OK_Self_Reference --
809 ----------------------
811 function OK_Self_Reference return Boolean is
812 Par : Node_Id;
814 begin
815 -- If N does not come from source, the reference is assumed to be
816 -- valid.
818 if not Comes_From_Source (N) then
819 return True;
820 end if;
822 Par := Parent (N);
823 while Present (Par)
824 and then
825 (Nkind (Par) = N_Component_Association
826 or else Nkind (Par) in N_Subexpr)
827 loop
828 if Nkind (Par) in N_Aggregate | N_Extension_Aggregate then
829 if Etype (Par) = Typ then
830 Set_Has_Self_Reference (Par);
832 -- Check the context: the aggregate must be part of the
833 -- initialization of a type or component, or it is the
834 -- resulting expansion in an initialization procedure.
836 if Is_Init_Proc (Current_Scope) then
837 return True;
838 else
839 Par := Parent (Par);
840 while Present (Par) loop
841 if Nkind (Par) = N_Full_Type_Declaration then
842 return True;
843 end if;
845 Par := Parent (Par);
846 end loop;
847 end if;
849 return False;
850 end if;
851 end if;
853 Par := Parent (Par);
854 end loop;
856 -- No enclosing aggregate, or not a self-reference
858 return False;
859 end OK_Self_Reference;
861 -- Start of processing for Analyze_Access_Attribute
863 begin
864 -- Access and Unchecked_Access are illegal in declare_expressions,
865 -- according to the RM. We also make the GNAT Unrestricted_Access
866 -- attribute illegal if it comes from source.
868 if In_Declare_Expr > 0
869 and then (Attr_Id /= Attribute_Unrestricted_Access
870 or else Comes_From_Source (N))
871 then
872 Error_Attr ("% attribute cannot occur in a declare_expression", N);
873 end if;
875 Check_E0;
877 if Nkind (P) = N_Character_Literal then
878 Error_Attr_P
879 ("prefix of % attribute cannot be enumeration literal");
880 end if;
882 -- Preserve relevant elaboration-related attributes of the context
883 -- which are no longer available or very expensive to recompute once
884 -- analysis, resolution, and expansion are over.
886 Mark_Elaboration_Attributes
887 (N_Id => N,
888 Checks => True,
889 Modes => True,
890 Warnings => True);
892 -- Save the scenario for later examination by the ABE Processing
893 -- phase.
895 Record_Elaboration_Scenario (N);
897 -- Case of access to subprogram
899 if Is_Entity_Name (P) and then Is_Overloadable (Entity (P)) then
900 if Has_Pragma_Inline_Always (Entity (P)) then
901 Error_Attr_P
902 ("prefix of % attribute cannot be Inline_Always subprogram");
904 elsif Aname = Name_Unchecked_Access then
905 Error_Attr ("attribute% cannot be applied to a subprogram", P);
906 end if;
908 -- Issue an error if the prefix denotes an eliminated subprogram
910 Check_For_Eliminated_Subprogram (P, Entity (P));
912 -- Check for obsolescent subprogram reference
914 Check_Obsolescent_2005_Entity (Entity (P), P);
916 -- Build the appropriate subprogram type
918 Build_Access_Subprogram_Type (P);
920 -- For P'Access or P'Unrestricted_Access, where P is a nested
921 -- subprogram, we might be passing P to another subprogram (but we
922 -- don't check that here), which might call P. P could modify
923 -- local variables, so we need to kill current values. It is
924 -- important not to do this for library-level subprograms, because
925 -- Kill_Current_Values is very inefficient in the case of library
926 -- level packages with lots of tagged types.
928 if Is_Library_Level_Entity (Entity (Prefix (N))) then
929 null;
931 -- Do not kill values on nodes initializing dispatch tables
932 -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access)
933 -- is currently generated by the expander only for this
934 -- purpose. Done to keep the quality of warnings currently
935 -- generated by the compiler (otherwise any declaration of
936 -- a tagged type cleans constant indications from its scope).
938 elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
939 and then (Is_RTE (Etype (Parent (N)), RE_Prim_Ptr)
940 or else
941 Is_RTE (Etype (Parent (N)), RE_Size_Ptr))
942 and then Is_Dispatching_Operation
943 (Directly_Designated_Type (Etype (N)))
944 then
945 null;
947 else
948 Kill_Current_Values;
949 end if;
951 -- In the static elaboration model, treat the attribute reference
952 -- as a subprogram call for elaboration purposes. Suppress this
953 -- treatment under debug flag. In any case, we are all done.
955 if Legacy_Elaboration_Checks
956 and not Dynamic_Elaboration_Checks
957 and not Debug_Flag_Dot_UU
958 then
959 Check_Elab_Call (N);
960 end if;
962 return;
964 -- Component is an operation of a protected type
966 elsif Nkind (P) = N_Selected_Component
967 and then Is_Overloadable (Entity (Selector_Name (P)))
968 then
969 if Ekind (Entity (Selector_Name (P))) = E_Entry then
970 Error_Attr_P ("prefix of % attribute must be subprogram");
971 end if;
973 Build_Access_Subprogram_Type (Selector_Name (P));
974 return;
975 end if;
977 -- Deal with incorrect reference to a type, but note that some
978 -- accesses are allowed: references to the current type instance,
979 -- or in Ada 2005 self-referential pointer in a default-initialized
980 -- aggregate.
982 if Is_Entity_Name (P) then
983 Typ := Entity (P);
985 -- The reference may appear in an aggregate that has been expanded
986 -- into a loop. Locate scope of type definition, if any.
988 Scop := Current_Scope;
989 while Ekind (Scop) = E_Loop loop
990 Scop := Scope (Scop);
991 end loop;
993 if Is_Type (Typ) then
995 -- OK if we are within the scope of a limited type
996 -- let's mark the component as having per object constraint
998 if Is_Anonymous_Tagged_Base (Scop, Typ) then
999 Typ := Scop;
1000 Set_Entity (P, Typ);
1001 Set_Etype (P, Typ);
1002 end if;
1004 -- A current instance typically appears immediately within
1005 -- the type declaration, but may be nested within an internally
1006 -- generated temporary scope - as for an aggregate of a
1007 -- discriminated component.
1009 if Typ = Scop
1010 or else (In_Open_Scopes (Typ)
1011 and then not Comes_From_Source (Scop))
1012 then
1013 declare
1014 Q : Node_Id := Parent (N);
1016 begin
1017 while Present (Q)
1018 and then Nkind (Q) /= N_Component_Declaration
1019 loop
1020 Q := Parent (Q);
1021 end loop;
1023 if Present (Q) then
1024 Set_Has_Per_Object_Constraint
1025 (Defining_Identifier (Q), True);
1026 end if;
1027 end;
1029 if Nkind (P) = N_Expanded_Name then
1030 Error_Msg_F
1031 ("current instance prefix must be a direct name", P);
1032 end if;
1034 -- If a current instance attribute appears in a component
1035 -- constraint it must appear alone; other contexts (spec-
1036 -- expressions, within a task body) are not subject to this
1037 -- restriction.
1039 if not In_Spec_Expression
1040 and then not Has_Completion (Scop)
1041 and then
1042 Nkind (Parent (N)) not in
1043 N_Discriminant_Association |
1044 N_Index_Or_Discriminant_Constraint
1045 then
1046 Error_Msg_N
1047 ("current instance attribute must appear alone", N);
1048 end if;
1050 if Is_CPP_Class (Root_Type (Typ)) then
1051 Error_Msg_N
1052 ("??current instance unsupported for derivations of "
1053 & "'C'P'P types", N);
1054 end if;
1056 -- OK if we are in initialization procedure for the type
1057 -- in question, in which case the reference to the type
1058 -- is rewritten as a reference to the current object.
1060 elsif Ekind (Scop) = E_Procedure
1061 and then Is_Init_Proc (Scop)
1062 and then Etype (First_Formal (Scop)) = Typ
1063 then
1064 Rewrite (N,
1065 Make_Attribute_Reference (Loc,
1066 Prefix => Make_Identifier (Loc, Name_uInit),
1067 Attribute_Name => Name_Unrestricted_Access));
1068 Analyze (N);
1069 return;
1071 -- OK if current task.
1073 elsif Is_Task_Type (Typ)
1074 and then In_Open_Scopes (Typ)
1075 then
1076 null;
1078 -- OK if self-reference in an aggregate in Ada 2005, and
1079 -- the reference comes from a copied default expression.
1081 -- Note that we check legality of self-reference even if the
1082 -- expression comes from source, e.g. when a single component
1083 -- association in an aggregate has a box association.
1085 elsif Ada_Version >= Ada_2005 and then OK_Self_Reference then
1086 null;
1088 -- OK if reference to current instance of a protected object
1090 elsif Is_Protected_Self_Reference (P) then
1091 null;
1093 -- Otherwise we have an error case
1095 else
1096 Error_Attr ("% attribute cannot be applied to type", P);
1097 end if;
1098 end if;
1099 end if;
1101 -- If we fall through, we have a normal access to object case
1103 -- Unrestricted_Access is (for now) legal wherever an allocator would
1104 -- be legal, so its Etype is set to E_Allocator. The expected type
1105 -- of the other attributes is a general access type, and therefore
1106 -- we label them with E_Access_Attribute_Type.
1108 if not Is_Overloaded (P) then
1109 Acc_Type := Build_Access_Object_Type (P_Type);
1110 Set_Etype (N, Acc_Type);
1112 else
1113 declare
1114 Index : Interp_Index;
1115 It : Interp;
1116 begin
1117 Set_Etype (N, Any_Type);
1118 Get_First_Interp (P, Index, It);
1119 while Present (It.Typ) loop
1120 Acc_Type := Build_Access_Object_Type (It.Typ);
1121 Add_One_Interp (N, Acc_Type, Acc_Type);
1122 Get_Next_Interp (Index, It);
1123 end loop;
1124 end;
1125 end if;
1127 -- Special cases when we can find a prefix that is an entity name
1129 declare
1130 PP : Node_Id;
1131 Ent : Entity_Id;
1133 begin
1134 PP := P;
1135 loop
1136 if Is_Entity_Name (PP) then
1137 Ent := Entity (PP);
1139 -- If we have an access to an object, and the attribute
1140 -- comes from source, then set the object as potentially
1141 -- source modified. We do this because the resulting access
1142 -- pointer can be used to modify the variable, and we might
1143 -- not detect this, leading to some junk warnings.
1145 -- We do this only for source references, since otherwise
1146 -- we can suppress warnings, e.g. from the unrestricted
1147 -- access generated for validity checks in -gnatVa mode.
1149 if Comes_From_Source (N) then
1150 Set_Never_Set_In_Source (Ent, False);
1151 end if;
1153 -- Mark entity as address taken in the case of
1154 -- 'Unrestricted_Access or subprograms, and kill current
1155 -- values.
1157 if Aname = Name_Unrestricted_Access
1158 or else Is_Subprogram (Ent)
1159 then
1160 Set_Address_Taken (Ent);
1161 end if;
1163 Kill_Current_Values (Ent);
1164 exit;
1166 elsif Nkind (PP) in N_Selected_Component | N_Indexed_Component
1167 then
1168 PP := Prefix (PP);
1170 else
1171 exit;
1172 end if;
1173 end loop;
1174 end;
1175 end Analyze_Access_Attribute;
1177 ----------------------------------
1178 -- Analyze_Attribute_Old_Result --
1179 ----------------------------------
1181 procedure Analyze_Attribute_Old_Result
1182 (Legal : out Boolean;
1183 Spec_Id : out Entity_Id)
1185 procedure Check_Placement_In_Check (Prag : Node_Id);
1186 -- Verify that the attribute appears within pragma Check that mimics
1187 -- a postcondition.
1189 procedure Check_Placement_In_Contract_Cases (Prag : Node_Id);
1190 -- Verify that the attribute appears within a consequence of aspect
1191 -- or pragma Contract_Cases denoted by Prag.
1193 procedure Check_Placement_In_Test_Case (Prag : Node_Id);
1194 -- Verify that the attribute appears within the "Ensures" argument of
1195 -- aspect or pragma Test_Case denoted by Prag.
1197 function Is_Within
1198 (Nod : Node_Id;
1199 Encl_Nod : Node_Id) return Boolean;
1200 -- Subsidiary to Check_Placement_In_XXX. Determine whether arbitrary
1201 -- node Nod is within enclosing node Encl_Nod.
1203 procedure Placement_Error;
1204 pragma No_Return (Placement_Error);
1205 -- Emit a general error when the attributes does not appear in a
1206 -- postcondition-like aspect or pragma, and then raises Bad_Attribute
1207 -- to avoid any further semantic processing.
1209 ------------------------------
1210 -- Check_Placement_In_Check --
1211 ------------------------------
1213 procedure Check_Placement_In_Check (Prag : Node_Id) is
1214 Args : constant List_Id := Pragma_Argument_Associations (Prag);
1215 Nam : constant Name_Id := Chars (Get_Pragma_Arg (First (Args)));
1217 begin
1218 -- The "Name" argument of pragma Check denotes a postcondition
1220 if Nam in Name_Post
1221 | Name_Post_Class
1222 | Name_Postcondition
1223 | Name_Refined_Post
1224 then
1225 null;
1227 -- Otherwise the placement of the attribute is illegal
1229 else
1230 Placement_Error;
1231 end if;
1232 end Check_Placement_In_Check;
1234 ---------------------------------------
1235 -- Check_Placement_In_Contract_Cases --
1236 ---------------------------------------
1238 procedure Check_Placement_In_Contract_Cases (Prag : Node_Id) is
1239 Arg : Node_Id;
1240 Cases : Node_Id;
1241 CCase : Node_Id;
1243 begin
1244 -- Obtain the argument of the aspect or pragma
1246 if Nkind (Prag) = N_Aspect_Specification then
1247 Arg := Prag;
1248 else
1249 Arg := First (Pragma_Argument_Associations (Prag));
1250 end if;
1252 Cases := Expression (Arg);
1254 if Present (Component_Associations (Cases)) then
1255 CCase := First (Component_Associations (Cases));
1256 while Present (CCase) loop
1258 -- Detect whether the attribute appears within the
1259 -- consequence of the current contract case.
1261 if Nkind (CCase) = N_Component_Association
1262 and then Is_Within (N, Expression (CCase))
1263 then
1264 return;
1265 end if;
1267 Next (CCase);
1268 end loop;
1269 end if;
1271 -- Otherwise aspect or pragma Contract_Cases is either malformed
1272 -- or the attribute does not appear within a consequence.
1274 Error_Attr
1275 ("attribute % must appear in the consequence of a contract case",
1277 end Check_Placement_In_Contract_Cases;
1279 ----------------------------------
1280 -- Check_Placement_In_Test_Case --
1281 ----------------------------------
1283 procedure Check_Placement_In_Test_Case (Prag : Node_Id) is
1284 Arg : constant Node_Id :=
1285 Test_Case_Arg
1286 (Prag => Prag,
1287 Arg_Nam => Name_Ensures,
1288 From_Aspect => Nkind (Prag) = N_Aspect_Specification);
1290 begin
1291 -- Detect whether the attribute appears within the "Ensures"
1292 -- expression of aspect or pragma Test_Case.
1294 if Present (Arg) and then Is_Within (N, Arg) then
1295 null;
1297 else
1298 Error_Attr
1299 ("attribute % must appear in the ensures expression of a "
1300 & "test case", P);
1301 end if;
1302 end Check_Placement_In_Test_Case;
1304 ---------------
1305 -- Is_Within --
1306 ---------------
1308 function Is_Within
1309 (Nod : Node_Id;
1310 Encl_Nod : Node_Id) return Boolean
1312 Par : Node_Id;
1314 begin
1315 Par := Nod;
1316 while Present (Par) loop
1317 if Par = Encl_Nod then
1318 return True;
1320 -- Prevent the search from going too far
1322 elsif Is_Body_Or_Package_Declaration (Par) then
1323 exit;
1324 end if;
1326 Par := Parent (Par);
1327 end loop;
1329 return False;
1330 end Is_Within;
1332 ---------------------
1333 -- Placement_Error --
1334 ---------------------
1336 procedure Placement_Error is
1337 begin
1338 if Aname = Name_Old then
1339 Error_Attr ("attribute % can only appear in postcondition", P);
1341 -- Specialize the error message for attribute 'Result
1343 else
1344 Error_Attr
1345 ("attribute % can only appear in postcondition of function",
1347 end if;
1348 end Placement_Error;
1350 -- Local variables
1352 Prag : Node_Id;
1353 Prag_Nam : Name_Id;
1354 Subp_Decl : Node_Id;
1356 -- Start of processing for Analyze_Attribute_Old_Result
1358 begin
1359 -- Assume that the attribute is illegal
1361 Legal := False;
1362 Spec_Id := Empty;
1364 -- Skip processing during preanalysis of class-wide preconditions and
1365 -- postconditions since at this stage the expression is not installed
1366 -- yet on its definite context.
1368 if Inside_Class_Condition_Preanalysis then
1369 Legal := True;
1371 -- Search for the subprogram that has this class-wide condition;
1372 -- required to avoid reporting spurious errors since the current
1373 -- scope may not be appropriate because the attribute may be
1374 -- referenced from the inner scope of, for example, quantified
1375 -- expressions.
1377 -- Although the expression is not installed on its definite
1378 -- context, we know that the subprogram has been placed in the
1379 -- scope stack by Preanalyze_Condition; we also know that it is
1380 -- not a generic subprogram since class-wide pre/postconditions
1381 -- can only be applied for primitive operations of tagged types.
1383 if Is_Subprogram (Current_Scope) then
1384 Spec_Id := Current_Scope;
1385 else
1386 Spec_Id := Enclosing_Subprogram (Current_Scope);
1387 end if;
1389 pragma Assert (Is_Dispatching_Operation (Spec_Id));
1390 return;
1391 end if;
1393 -- Traverse the parent chain to find the aspect or pragma where the
1394 -- attribute resides.
1396 Prag := N;
1397 while Present (Prag) loop
1398 if Nkind (Prag) in N_Aspect_Specification | N_Pragma then
1399 exit;
1401 -- Prevent the search from going too far
1403 elsif Is_Body_Or_Package_Declaration (Prag) then
1404 exit;
1405 end if;
1407 Prag := Parent (Prag);
1408 end loop;
1410 -- The attribute is allowed to appear only in postcondition-like
1411 -- aspects or pragmas.
1413 if Nkind (Prag) in N_Aspect_Specification | N_Pragma then
1414 if Nkind (Prag) = N_Aspect_Specification then
1415 Prag_Nam := Chars (Identifier (Prag));
1416 else
1417 Prag_Nam := Pragma_Name (Prag);
1418 end if;
1420 if Prag_Nam = Name_Check then
1421 Check_Placement_In_Check (Prag);
1423 elsif Prag_Nam = Name_Contract_Cases then
1424 Check_Placement_In_Contract_Cases (Prag);
1426 -- Attributes 'Old and 'Result are allowed to appear in
1427 -- consequence of aspect or pragma Exceptional_Cases. We already
1428 -- examined the exception_choice part of contract syntax, so we
1429 -- can accept all remaining occurrences within the pragma.
1431 elsif Prag_Nam = Name_Exceptional_Cases then
1432 null;
1434 -- Attribute 'Result is allowed to appear in aspect or pragma
1435 -- [Refined_]Depends (SPARK RM 6.1.5(11)).
1437 elsif Prag_Nam in Name_Depends | Name_Refined_Depends
1438 and then Aname = Name_Result
1439 then
1440 null;
1442 -- Attribute 'Result is allowed to appear in aspect
1443 -- Relaxed_Initialization (SPARK RM 6.10).
1445 elsif Prag_Nam = Name_Relaxed_Initialization
1446 and then Aname = Name_Result
1447 then
1448 null;
1450 elsif Prag_Nam in Name_Post
1451 | Name_Post_Class
1452 | Name_Postcondition
1453 | Name_Refined_Post
1454 then
1455 null;
1457 elsif Prag_Nam = Name_Test_Case then
1458 Check_Placement_In_Test_Case (Prag);
1460 else
1461 Placement_Error;
1462 end if;
1464 -- 'Old attribute reference ok in a _Wrapped_Statements procedure
1466 elsif Nkind (Prag) = N_Subprogram_Body
1467 and then Ekind (Defining_Entity (Prag)) in Subprogram_Kind
1468 and then Present (Wrapped_Statements (Defining_Entity (Prag)))
1469 then
1470 null;
1472 -- Otherwise the placement of the attribute is illegal
1474 else
1475 Placement_Error;
1476 end if;
1478 -- Find the related subprogram subject to the aspect or pragma
1480 if Nkind (Prag) = N_Aspect_Specification then
1481 Subp_Decl := Parent (Prag);
1482 elsif Nkind (Prag) = N_Subprogram_Body then
1483 Subp_Decl := Prag;
1484 else
1485 Subp_Decl := Find_Related_Declaration_Or_Body (Prag);
1486 end if;
1488 -- 'Old objects appear in block and extended return statements as
1489 -- part of the expansion of contract wrappers.
1491 if Nkind (Subp_Decl) in N_Block_Statement
1492 | N_Extended_Return_Statement
1493 then
1494 Subp_Decl := Parent (Parent (Subp_Decl));
1495 end if;
1497 -- The aspect or pragma where the attribute resides should be
1498 -- associated with a subprogram declaration or a body. If this is not
1499 -- the case, then the aspect or pragma is illegal. Return as analysis
1500 -- cannot be carried out. Note that it is legal to have the aspect
1501 -- appear on a subprogram renaming, when the renamed entity is an
1502 -- attribute reference.
1504 -- Generating C code the internally built nested _postcondition
1505 -- subprograms are inlined; after expanded, inlined aspects are
1506 -- located in the internal block generated by the frontend.
1508 if Nkind (Subp_Decl) = N_Block_Statement
1509 and then Modify_Tree_For_C
1510 and then In_Inlined_Body
1511 then
1512 null;
1514 elsif Nkind (Subp_Decl) not in N_Abstract_Subprogram_Declaration
1515 | N_Entry_Declaration
1516 | N_Expression_Function
1517 | N_Full_Type_Declaration
1518 | N_Generic_Subprogram_Declaration
1519 | N_Subprogram_Body
1520 | N_Subprogram_Body_Stub
1521 | N_Subprogram_Declaration
1522 | N_Subprogram_Renaming_Declaration
1523 then
1524 return;
1525 end if;
1527 -- If we get here, then the attribute is legal
1529 Legal := True;
1530 Spec_Id := Unique_Defining_Entity (Subp_Decl);
1532 -- When generating C code, nested _postcondition subprograms are
1533 -- inlined by the front end to avoid problems (when unnested) with
1534 -- referenced itypes. Handle that here, since as part of inlining the
1535 -- expander nests subprogram within a dummy procedure named _parent
1536 -- (see Build_Postconditions_Procedure and Build_Body_To_Inline).
1537 -- Hence, in this context, the spec_id of _postconditions is the
1538 -- enclosing scope.
1540 if Modify_Tree_For_C
1541 and then Chars (Spec_Id) = Name_uParent
1542 and then Chars (Scope (Spec_Id)) = Name_uWrapped_Statements
1543 then
1544 -- This situation occurs only when analyzing the body-to-inline
1546 pragma Assert (Inside_A_Generic);
1548 Spec_Id := Scope (Spec_Id);
1549 pragma Assert (Is_Inlined (Spec_Id));
1550 end if;
1551 end Analyze_Attribute_Old_Result;
1553 -----------------------------
1554 -- Analyze_Image_Attribute --
1555 -----------------------------
1557 procedure Analyze_Image_Attribute (Str_Typ : Entity_Id) is
1558 procedure Check_Image_Type (Image_Type : Entity_Id);
1559 -- Check that Image_Type is legal as the type of a prefix of 'Image.
1560 -- Legality depends on the Ada language version.
1562 ----------------------
1563 -- Check_Image_Type --
1564 ----------------------
1566 procedure Check_Image_Type (Image_Type : Entity_Id) is
1567 begin
1568 -- Image_Type may be empty in case of another error detected,
1569 -- or if an N_Raise_xxx_Error node is a parent of N.
1571 if Ada_Version < Ada_2022
1572 and then Present (Image_Type)
1573 and then not Is_Scalar_Type (Image_Type)
1574 then
1575 Error_Msg_Ada_2022_Feature ("nonscalar ''Image", Sloc (P));
1576 Error_Attr;
1577 end if;
1578 end Check_Image_Type;
1580 -- Start of processing for Analyze_Image_Attribute
1582 begin
1583 -- AI12-0124: The ARG has adopted the GNAT semantics of 'Img for
1584 -- scalar types, so that the prefix can be an object, a named value,
1585 -- or a type. If the prefix is an object, there is no argument.
1587 if Is_Object_Image (P) then
1588 Check_E0;
1589 Set_Etype (N, Str_Typ);
1590 Check_Image_Type (Etype (P));
1592 if Attr_Id /= Attribute_Img then
1593 Error_Msg_Ada_2012_Feature ("|Object''Image", Sloc (P));
1594 end if;
1595 else
1596 Check_E1;
1597 Set_Etype (N, Str_Typ);
1599 pragma Assert (Is_Entity_Name (P) and then Is_Type (Entity (P)));
1601 if Ekind (Entity (P)) = E_Incomplete_Type
1602 and then Present (Full_View (Entity (P)))
1603 then
1604 P_Type := Full_View (Entity (P));
1605 P_Base_Type := Base_Type (P_Type);
1606 Set_Entity (P, P_Type);
1607 end if;
1609 Check_Image_Type (P_Type);
1610 Resolve (E1, P_Base_Type);
1611 Validate_Non_Static_Attribute_Function_Call;
1612 end if;
1614 Check_Enum_Image (Check_Enumeration_Maps => True);
1616 -- Check restriction No_Fixed_IO. Note the check of Comes_From_Source
1617 -- to avoid giving a duplicate message for when Image attributes
1618 -- applied to object references get expanded into type-based Image
1619 -- attributes.
1621 if Restriction_Check_Required (No_Fixed_IO)
1622 and then Comes_From_Source (N)
1623 and then Is_Fixed_Point_Type (P_Type)
1624 then
1625 Check_Restriction (No_Fixed_IO, P);
1626 end if;
1627 end Analyze_Image_Attribute;
1629 -----------------------------
1630 -- Analyze_Index_Attribute --
1631 -----------------------------
1633 procedure Analyze_Index_Attribute
1634 (Legal : out Boolean;
1635 Spec_Id : out Entity_Id)
1637 procedure Check_Placement_In_Check (Prag : Node_Id);
1638 -- Verify that the attribute appears within pragma Check that mimics
1639 -- a postcondition.
1641 procedure Placement_Error;
1642 pragma No_Return (Placement_Error);
1643 -- Emit a general error when the attributes does not appear in a
1644 -- precondition or postcondition aspect or pragma, and then raises
1645 -- Bad_Attribute to avoid any further semantic processing.
1647 ------------------------------
1648 -- Check_Placement_In_Check --
1649 ------------------------------
1651 procedure Check_Placement_In_Check (Prag : Node_Id) is
1652 Args : constant List_Id := Pragma_Argument_Associations (Prag);
1653 Nam : constant Name_Id := Chars (Get_Pragma_Arg (First (Args)));
1655 begin
1656 -- The "Name" argument of pragma Check denotes a precondition or
1657 -- postcondition.
1659 if Nam in Name_Post
1660 | Name_Postcondition
1661 | Name_Pre
1662 | Name_Precondition
1663 | Name_Refined_Post
1664 then
1665 null;
1667 -- Otherwise the placement of the attribute is illegal
1669 else
1670 Placement_Error;
1671 end if;
1672 end Check_Placement_In_Check;
1674 ---------------------
1675 -- Placement_Error --
1676 ---------------------
1678 procedure Placement_Error is
1679 begin
1680 Error_Attr
1681 ("attribute % can only appear in pre- or postcondition", P);
1682 end Placement_Error;
1684 -- Local variables
1686 Prag : Node_Id;
1687 Prag_Nam : Name_Id;
1688 Subp_Decl : Node_Id;
1690 -- Start of processing for Analyze_Index_Attribute
1692 begin
1693 -- Assume that the attribute is illegal
1695 Legal := False;
1696 Spec_Id := Empty;
1698 -- Skip processing during preanalysis of class-wide preconditions and
1699 -- postconditions since at this stage the expression is not installed
1700 -- yet on its definite context.
1702 if Inside_Class_Condition_Preanalysis then
1703 Legal := True;
1704 Spec_Id := Current_Scope;
1705 return;
1706 end if;
1708 -- Traverse the parent chain to find the aspect or pragma where the
1709 -- attribute resides.
1711 Prag := N;
1712 while Present (Prag) loop
1713 if Nkind (Prag) in N_Aspect_Specification | N_Pragma then
1714 exit;
1716 -- Prevent the search from going too far
1718 elsif Is_Body_Or_Package_Declaration (Prag) then
1719 exit;
1720 end if;
1722 Prag := Parent (Prag);
1723 end loop;
1725 -- The attribute is allowed to appear only in precondition and
1726 -- postcondition-like aspects or pragmas.
1728 if Nkind (Prag) in N_Aspect_Specification | N_Pragma then
1729 if Nkind (Prag) = N_Aspect_Specification then
1730 Prag_Nam := Chars (Identifier (Prag));
1731 else
1732 Prag_Nam := Pragma_Name (Prag);
1733 end if;
1735 if Prag_Nam = Name_Check then
1736 Check_Placement_In_Check (Prag);
1738 elsif Prag_Nam in Name_Post
1739 | Name_Postcondition
1740 | Name_Pre
1741 | Name_Precondition
1742 | Name_Refined_Post
1743 then
1744 null;
1746 else
1747 Placement_Error;
1748 end if;
1750 -- Otherwise the placement of the attribute is illegal
1752 else
1753 Placement_Error;
1754 end if;
1756 -- Find the related subprogram subject to the aspect or pragma
1758 if Nkind (Prag) = N_Aspect_Specification then
1759 Subp_Decl := Parent (Prag);
1760 else
1761 Subp_Decl := Find_Related_Declaration_Or_Body (Prag);
1762 end if;
1764 -- The aspect or pragma where the attribute resides should be
1765 -- associated with a subprogram declaration or a body since the
1766 -- analysis of pre-/postconditions of entry and entry families is
1767 -- performed in their wrapper subprogram. If this is not the case,
1768 -- then the aspect or pragma is illegal and no further analysis is
1769 -- required.
1771 if Nkind (Subp_Decl) not in N_Subprogram_Body
1772 | N_Subprogram_Declaration
1773 then
1774 return;
1775 end if;
1777 Spec_Id := Unique_Defining_Entity (Subp_Decl);
1779 -- If we get here and Spec_Id denotes the entity of the entry wrapper
1780 -- (or the postcondition procedure of the entry wrapper) then the
1781 -- attribute is legal.
1783 if Is_Entry_Wrapper (Spec_Id) then
1784 Legal := True;
1786 elsif Chars (Spec_Id) = Name_uWrapped_Statements
1787 and then Is_Entry_Wrapper (Scope (Spec_Id))
1788 then
1789 Spec_Id := Scope (Spec_Id);
1790 Legal := True;
1792 -- Otherwise the attribute is illegal and we return Empty
1794 else
1795 Spec_Id := Empty;
1796 end if;
1797 end Analyze_Index_Attribute;
1799 ---------------------------------
1800 -- Bad_Attribute_For_Predicate --
1801 ---------------------------------
1803 procedure Bad_Attribute_For_Predicate is
1804 begin
1805 if Is_Scalar_Type (P_Type)
1806 and then Comes_From_Source (N)
1807 then
1808 Error_Msg_Name_1 := Aname;
1809 Bad_Predicated_Subtype_Use
1810 ("type& has predicates, attribute % not allowed", N, P_Type);
1811 end if;
1812 end Bad_Attribute_For_Predicate;
1814 --------------------------------
1815 -- Check_Array_Or_Scalar_Type --
1816 --------------------------------
1818 procedure Check_Array_Or_Scalar_Type is
1819 function In_Aspect_Specification return Boolean;
1820 -- A current instance of a type in an aspect specification is an
1821 -- object and not a type, and therefore cannot be of a scalar type
1822 -- in the prefix of one of the array attributes if the attribute
1823 -- reference is part of an aspect expression.
1825 -----------------------------
1826 -- In_Aspect_Specification --
1827 -----------------------------
1829 function In_Aspect_Specification return Boolean is
1830 P : Node_Id;
1832 begin
1833 P := Parent (N);
1834 while Present (P) loop
1835 if Nkind (P) = N_Aspect_Specification then
1836 return P_Type = Entity (P);
1838 elsif Nkind (P) in N_Declaration then
1839 return False;
1840 end if;
1842 P := Parent (P);
1843 end loop;
1845 return False;
1846 end In_Aspect_Specification;
1848 -- Local variables
1850 Index : Entity_Id;
1852 -- Start of processing for Check_Array_Or_Scalar_Type
1854 begin
1855 -- Case of string literal or string literal subtype. These cases
1856 -- cannot arise from legal Ada code, but the expander is allowed
1857 -- to generate them. They require special handling because string
1858 -- literal subtypes do not have standard bounds (the whole idea
1859 -- of these subtypes is to avoid having to generate the bounds)
1861 if Ekind (P_Type) = E_String_Literal_Subtype then
1862 Set_Etype (N, Etype (First_Index (P_Base_Type)));
1863 return;
1865 -- Scalar types
1867 elsif Is_Scalar_Type (P_Type) then
1868 Check_Type;
1870 if Present (E1) then
1871 Error_Attr ("invalid argument in % attribute", E1);
1873 elsif In_Aspect_Specification then
1874 Error_Attr
1875 ("prefix of % attribute cannot be the current instance of a "
1876 & "scalar type", P);
1878 else
1879 Set_Etype (N, P_Base_Type);
1880 return;
1881 end if;
1883 -- The following is a special test to allow 'First to apply to
1884 -- private scalar types if the attribute comes from generated
1885 -- code. This occurs in the case of Normalize_Scalars code.
1887 elsif Is_Private_Type (P_Type)
1888 and then Present (Full_View (P_Type))
1889 and then Is_Scalar_Type (Full_View (P_Type))
1890 and then not Comes_From_Source (N)
1891 then
1892 Set_Etype (N, Implementation_Base_Type (P_Type));
1894 -- Array types other than string literal subtypes handled above
1896 else
1897 Check_Array_Type;
1899 -- We know prefix is an array type, or the name of an array
1900 -- object, and that the expression, if present, is static
1901 -- and within the range of the dimensions of the type.
1903 pragma Assert (Is_Array_Type (P_Type));
1904 Index := First_Index (P_Base_Type);
1906 if No (E1) then
1908 -- First dimension assumed
1910 Set_Etype (N, Base_Type (Etype (Index)));
1912 else
1913 declare
1914 Udims : constant Uint := Expr_Value (E1);
1915 Dims : constant Int := UI_To_Int (Udims);
1916 begin
1917 for J in 1 .. Dims - 1 loop
1918 Next_Index (Index);
1919 end loop;
1920 end;
1922 Set_Etype (N, Base_Type (Etype (Index)));
1923 end if;
1924 end if;
1925 end Check_Array_Or_Scalar_Type;
1927 ----------------------
1928 -- Check_Array_Type --
1929 ----------------------
1931 procedure Check_Array_Type is
1932 D : Pos;
1933 -- Dimension number for array attributes
1935 begin
1936 -- If the type is a string literal type, then this must be generated
1937 -- internally, and no further check is required on its legality.
1939 if Ekind (P_Type) = E_String_Literal_Subtype then
1940 return;
1942 -- If the type is a composite, it is an illegal aggregate, no point
1943 -- in going on.
1945 elsif P_Type = Any_Composite then
1946 raise Bad_Attribute;
1947 end if;
1949 -- Normal case of array type or subtype. Note that if the
1950 -- prefix is a current instance of a type declaration it
1951 -- appears within an aspect specification and is legal.
1953 Check_Either_E0_Or_E1;
1954 Check_Dereference;
1956 if Is_Array_Type (P_Type) then
1957 if not Is_Constrained (P_Type)
1958 and then Is_Entity_Name (P)
1959 and then Is_Type (Entity (P))
1960 and then not Is_Current_Instance (P)
1961 then
1962 -- Note: we do not call Error_Attr here, since we prefer to
1963 -- continue, using the relevant index type of the array,
1964 -- even though it is unconstrained. This gives better error
1965 -- recovery behavior.
1967 Error_Msg_Name_1 := Aname;
1968 Error_Msg_F
1969 ("prefix for % attribute must be constrained array", P);
1970 end if;
1972 -- The attribute reference freezes the type, and thus the
1973 -- component type, even if the attribute may not depend on the
1974 -- component. Diagnose arrays with incomplete components now.
1975 -- If the prefix is an access to array, this does not freeze
1976 -- the designated type.
1978 if Nkind (P) /= N_Explicit_Dereference then
1979 Check_Fully_Declared (Component_Type (P_Type), P);
1980 end if;
1982 D := Number_Dimensions (P_Type);
1984 else
1985 if Is_Private_Type (P_Type) then
1986 Error_Attr_P ("prefix for % attribute may not be private type");
1988 elsif Is_Access_Type (P_Type)
1989 and then Is_Array_Type (Designated_Type (P_Type))
1990 and then Is_Entity_Name (P)
1991 and then Is_Type (Entity (P))
1992 then
1993 Error_Attr_P ("prefix of % attribute cannot be access type");
1995 elsif Attr_Id = Attribute_First
1996 or else
1997 Attr_Id = Attribute_Last
1998 then
1999 Error_Attr ("invalid prefix for % attribute", P);
2001 else
2002 Error_Attr_P ("prefix for % attribute must be array");
2003 end if;
2004 end if;
2006 if Present (E1) then
2007 Resolve (E1, Any_Integer);
2008 Set_Etype (E1, Standard_Integer);
2010 if not Is_OK_Static_Expression (E1)
2011 or else Raises_Constraint_Error (E1)
2012 then
2013 Flag_Non_Static_Expr
2014 ("expression for dimension must be static!", E1);
2015 Error_Attr;
2016 end if;
2018 declare
2019 Value : constant Uint := Expr_Value (E1);
2020 begin
2022 if Value > D or else Value < 1 then
2023 Error_Attr ("invalid dimension number for array type", E1);
2024 end if;
2026 -- Replace the static value to simplify the tree for gigi
2027 Fold_Uint (E1, Value, True);
2028 end;
2030 end if;
2032 if (Style_Check and Style_Check_Array_Attribute_Index)
2033 and then Comes_From_Source (N)
2034 then
2035 Style.Check_Array_Attribute_Index (N, E1, D);
2036 end if;
2037 end Check_Array_Type;
2039 -------------------------
2040 -- Check_Asm_Attribute --
2041 -------------------------
2043 procedure Check_Asm_Attribute is
2044 begin
2045 Check_Type;
2046 Check_E2;
2048 -- Check first argument is static string expression
2050 Analyze_And_Resolve (E1, Standard_String);
2052 if Etype (E1) = Any_Type then
2053 return;
2055 elsif not Is_OK_Static_Expression (E1) then
2056 Flag_Non_Static_Expr
2057 ("constraint argument must be static string expression!", E1);
2058 Error_Attr;
2059 end if;
2061 -- Check second argument is right type
2063 Analyze_And_Resolve (E2, Entity (P));
2065 -- Note: that is all we need to do, we don't need to check
2066 -- that it appears in a correct context. The Ada type system
2067 -- will do that for us.
2069 end Check_Asm_Attribute;
2071 ---------------------
2072 -- Check_Component --
2073 ---------------------
2075 procedure Check_Component is
2076 begin
2077 Check_E0;
2079 if Nkind (P) /= N_Selected_Component
2080 or else
2081 (Ekind (Entity (Selector_Name (P))) /= E_Component
2082 and then
2083 Ekind (Entity (Selector_Name (P))) /= E_Discriminant)
2084 then
2085 Error_Attr_P ("prefix for % attribute must be selected component");
2086 end if;
2087 end Check_Component;
2089 ------------------------------------
2090 -- Check_Decimal_Fixed_Point_Type --
2091 ------------------------------------
2093 procedure Check_Decimal_Fixed_Point_Type is
2094 begin
2095 Check_Type;
2097 if not Is_Decimal_Fixed_Point_Type (P_Type) then
2098 Error_Attr_P ("prefix of % attribute must be decimal type");
2099 end if;
2100 end Check_Decimal_Fixed_Point_Type;
2102 -----------------------
2103 -- Check_Dereference --
2104 -----------------------
2106 procedure Check_Dereference is
2107 begin
2109 -- Case of a subtype mark
2111 if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
2112 return;
2113 end if;
2115 -- Case of an expression
2117 Resolve (P_Old);
2119 if Is_Access_Type (P_Type) then
2121 -- If there is an implicit dereference, then we must freeze the
2122 -- designated type of the access type, since the type of the
2123 -- referenced array is this type (see AI95-00106).
2125 -- As done elsewhere, freezing must not happen when preanalyzing
2126 -- a pre- or postcondition or a default value for an object or for
2127 -- a formal parameter.
2129 if not In_Spec_Expression then
2130 Freeze_Before (N, Designated_Type (P_Type));
2131 end if;
2133 Rewrite (P_Old,
2134 Make_Explicit_Dereference (Sloc (P_Old),
2135 Prefix => Relocate_Node (P_Old)));
2137 Analyze_And_Resolve (P_Old);
2138 P_Type := Etype (P_Old);
2140 if P_Type = Any_Type then
2141 raise Bad_Attribute;
2142 end if;
2144 P_Base_Type := Base_Type (P_Type);
2145 end if;
2146 end Check_Dereference;
2148 -------------------------
2149 -- Check_Discrete_Type --
2150 -------------------------
2152 procedure Check_Discrete_Type is
2153 begin
2154 Check_Type;
2156 if not Is_Discrete_Type (P_Type) then
2157 Error_Attr_P ("prefix of % attribute must be discrete type");
2158 end if;
2159 end Check_Discrete_Type;
2161 --------------
2162 -- Check_E0 --
2163 --------------
2165 procedure Check_E0 is
2166 begin
2167 if Present (E1) then
2168 Unexpected_Argument (E1);
2169 end if;
2170 end Check_E0;
2172 --------------
2173 -- Check_E1 --
2174 --------------
2176 procedure Check_E1 is
2177 begin
2178 Check_Either_E0_Or_E1;
2180 if No (E1) then
2182 -- Special-case attributes that are functions and that appear as
2183 -- the prefix of another attribute. Error is posted on parent.
2185 if Nkind (Parent (N)) = N_Attribute_Reference
2186 and then Attribute_Name (Parent (N)) in Name_Address
2187 | Name_Code_Address
2188 | Name_Access
2189 then
2190 Error_Msg_Name_1 := Attribute_Name (Parent (N));
2191 Error_Msg_N ("illegal prefix for % attribute", Parent (N));
2192 Set_Etype (Parent (N), Any_Type);
2193 Set_Entity (Parent (N), Any_Type);
2194 raise Bad_Attribute;
2196 else
2197 Error_Attr ("missing argument for % attribute", N);
2198 end if;
2199 end if;
2200 end Check_E1;
2202 --------------
2203 -- Check_E2 --
2204 --------------
2206 procedure Check_E2 is
2207 begin
2208 if No (E1) then
2209 Error_Attr ("missing arguments for % attribute (2 required)", N);
2210 elsif No (E2) then
2211 Error_Attr ("missing argument for % attribute (2 required)", N);
2212 end if;
2213 end Check_E2;
2215 ---------------------------
2216 -- Check_Either_E0_Or_E1 --
2217 ---------------------------
2219 procedure Check_Either_E0_Or_E1 is
2220 begin
2221 if Present (E2) then
2222 Unexpected_Argument (E2);
2223 end if;
2224 end Check_Either_E0_Or_E1;
2226 ----------------------
2227 -- Check_Enum_Image --
2228 ----------------------
2230 procedure Check_Enum_Image (Check_Enumeration_Maps : Boolean := False) is
2231 Lit : Entity_Id;
2233 begin
2234 -- Ensure that Check_Enumeration_Maps parameter is set precisely for
2235 -- attributes whose implementation requires enumeration maps.
2237 pragma Assert
2238 (Check_Enumeration_Maps = (Attr_Id in Attribute_Image
2239 | Attribute_Img
2240 | Attribute_Valid_Value
2241 | Attribute_Value
2242 | Attribute_Wide_Image
2243 | Attribute_Wide_Value
2244 | Attribute_Wide_Wide_Image
2245 | Attribute_Wide_Wide_Value));
2247 -- When an enumeration type appears in an attribute reference, all
2248 -- literals of the type are marked as referenced. This must only be
2249 -- done if the attribute reference appears in the current source.
2250 -- Otherwise the information on references may differ between a
2251 -- normal compilation and one that performs inlining.
2253 if Is_Enumeration_Type (P_Base_Type)
2254 and then In_Extended_Main_Code_Unit (N)
2255 then
2256 if Check_Enumeration_Maps then
2257 Check_Restriction (No_Enumeration_Maps, N);
2258 end if;
2260 Lit := First_Literal (P_Base_Type);
2261 while Present (Lit) loop
2262 Set_Referenced (Lit);
2263 Next_Literal (Lit);
2264 end loop;
2265 end if;
2266 end Check_Enum_Image;
2268 ----------------------------
2269 -- Check_First_Last_Valid --
2270 ----------------------------
2272 procedure Check_First_Last_Valid is
2273 begin
2274 Check_Discrete_Type;
2276 -- Freeze the subtype now, so that the following test for predicates
2277 -- works (we set the predicates stuff up at freeze time)
2279 Insert_Actions (N, Freeze_Entity (P_Type, P));
2281 -- Now test for dynamic predicate
2283 if Has_Predicates (P_Type)
2284 and then not (Has_Static_Predicate (P_Type))
2285 then
2286 Error_Attr_P
2287 ("prefix of % attribute may not have dynamic predicate");
2288 end if;
2290 -- Check non-static subtype
2292 if not Is_OK_Static_Subtype (P_Type) then
2293 Error_Attr_P ("prefix of % attribute must be a static subtype");
2294 end if;
2296 -- Test case for no values
2298 if Expr_Value (Type_Low_Bound (P_Type)) >
2299 Expr_Value (Type_High_Bound (P_Type))
2300 or else (Has_Predicates (P_Type)
2301 and then
2302 Is_Empty_List (Static_Discrete_Predicate (P_Type)))
2303 then
2304 Error_Attr_P
2305 ("prefix of % attribute must be subtype with at least one "
2306 & "value");
2307 end if;
2308 end Check_First_Last_Valid;
2310 ----------------------------
2311 -- Check_Fixed_Point_Type --
2312 ----------------------------
2314 procedure Check_Fixed_Point_Type is
2315 begin
2316 Check_Type;
2318 if not Is_Fixed_Point_Type (P_Type) then
2319 Error_Attr_P ("prefix of % attribute must be fixed point type");
2320 end if;
2321 end Check_Fixed_Point_Type;
2323 ------------------------------
2324 -- Check_Fixed_Point_Type_0 --
2325 ------------------------------
2327 procedure Check_Fixed_Point_Type_0 is
2328 begin
2329 Check_Fixed_Point_Type;
2330 Check_E0;
2331 end Check_Fixed_Point_Type_0;
2333 -------------------------------
2334 -- Check_Floating_Point_Type --
2335 -------------------------------
2337 procedure Check_Floating_Point_Type is
2338 begin
2339 Check_Type;
2341 if not Is_Floating_Point_Type (P_Type) then
2342 Error_Attr_P ("prefix of % attribute must be float type");
2343 end if;
2344 end Check_Floating_Point_Type;
2346 ---------------------------------
2347 -- Check_Floating_Point_Type_0 --
2348 ---------------------------------
2350 procedure Check_Floating_Point_Type_0 is
2351 begin
2352 Check_Floating_Point_Type;
2353 Check_E0;
2354 end Check_Floating_Point_Type_0;
2356 ---------------------------------
2357 -- Check_Floating_Point_Type_1 --
2358 ---------------------------------
2360 procedure Check_Floating_Point_Type_1 is
2361 begin
2362 Check_Floating_Point_Type;
2363 Check_E1;
2364 end Check_Floating_Point_Type_1;
2366 ---------------------------------
2367 -- Check_Floating_Point_Type_2 --
2368 ---------------------------------
2370 procedure Check_Floating_Point_Type_2 is
2371 begin
2372 Check_Floating_Point_Type;
2373 Check_E2;
2374 end Check_Floating_Point_Type_2;
2376 ------------------------
2377 -- Check_Integer_Type --
2378 ------------------------
2380 procedure Check_Integer_Type is
2381 begin
2382 Check_Type;
2384 if not Is_Integer_Type (P_Type) then
2385 Error_Attr_P ("prefix of % attribute must be integer type");
2386 end if;
2387 end Check_Integer_Type;
2389 --------------------------------
2390 -- Check_Modular_Integer_Type --
2391 --------------------------------
2393 procedure Check_Modular_Integer_Type is
2394 begin
2395 Check_Type;
2397 if not Is_Modular_Integer_Type (P_Type) then
2398 Error_Attr_P
2399 ("prefix of % attribute must be modular integer type");
2400 end if;
2401 end Check_Modular_Integer_Type;
2403 ------------------------
2404 -- Check_Not_CPP_Type --
2405 ------------------------
2407 procedure Check_Not_CPP_Type is
2408 begin
2409 if Is_Tagged_Type (Etype (P))
2410 and then Convention (Etype (P)) = Convention_CPP
2411 and then Is_CPP_Class (Root_Type (Etype (P)))
2412 then
2413 Error_Attr_P
2414 ("invalid use of % attribute with 'C'P'P tagged type");
2415 end if;
2416 end Check_Not_CPP_Type;
2418 -------------------------------
2419 -- Check_Not_Incomplete_Type --
2420 -------------------------------
2422 procedure Check_Not_Incomplete_Type is
2423 E : Entity_Id;
2424 Typ : Entity_Id;
2426 begin
2427 -- Ada 2005 (AI-50217, AI-326): If the prefix is an explicit
2428 -- dereference we have to check wrong uses of incomplete types
2429 -- (other wrong uses are checked at their freezing point).
2431 -- In Ada 2012, incomplete types can appear in subprogram
2432 -- profiles, but formals with incomplete types cannot be the
2433 -- prefix of attributes.
2435 -- Example 1: Limited-with
2437 -- limited with Pkg;
2438 -- package P is
2439 -- type Acc is access Pkg.T;
2440 -- X : Acc;
2441 -- S : Integer := X.all'Size; -- ERROR
2442 -- end P;
2444 -- Example 2: Tagged incomplete
2446 -- type T is tagged;
2447 -- type Acc is access all T;
2448 -- X : Acc;
2449 -- S : constant Integer := X.all'Size; -- ERROR
2450 -- procedure Q (Obj : Integer := X.all'Alignment); -- ERROR
2452 if Ada_Version >= Ada_2005
2453 and then Nkind (P) = N_Explicit_Dereference
2454 then
2455 E := P;
2456 while Nkind (E) = N_Explicit_Dereference loop
2457 E := Prefix (E);
2458 end loop;
2460 Typ := Etype (E);
2462 if From_Limited_With (Typ) then
2463 Error_Attr_P
2464 ("prefix of % attribute cannot be an incomplete type");
2466 -- If the prefix is an access type check the designated type
2468 elsif Is_Access_Type (Typ)
2469 and then Nkind (P) = N_Explicit_Dereference
2470 then
2471 Typ := Directly_Designated_Type (Typ);
2472 end if;
2474 if Is_Class_Wide_Type (Typ) then
2475 Typ := Root_Type (Typ);
2476 end if;
2478 -- A legal use of a shadow entity occurs only when the unit where
2479 -- the non-limited view resides is imported via a regular with
2480 -- clause in the current body. Such references to shadow entities
2481 -- may occur in subprogram formals.
2483 if Is_Incomplete_Type (Typ)
2484 and then From_Limited_With (Typ)
2485 and then Present (Non_Limited_View (Typ))
2486 and then Is_Legal_Shadow_Entity_In_Body (Typ)
2487 then
2488 Typ := Non_Limited_View (Typ);
2489 end if;
2491 -- If still incomplete, it can be a local incomplete type, or a
2492 -- limited view whose scope is also a limited view.
2494 if Ekind (Typ) = E_Incomplete_Type then
2495 if not From_Limited_With (Typ)
2496 and then No (Full_View (Typ))
2497 then
2498 Error_Attr_P
2499 ("prefix of % attribute cannot be an incomplete type");
2501 -- The limited view may be available indirectly through
2502 -- an intermediate unit. If the non-limited view is available
2503 -- the attribute reference is legal.
2505 elsif From_Limited_With (Typ)
2506 and then
2507 (No (Non_Limited_View (Typ))
2508 or else Is_Incomplete_Type (Non_Limited_View (Typ)))
2509 then
2510 Error_Attr_P
2511 ("prefix of % attribute cannot be an incomplete type");
2512 end if;
2513 end if;
2515 -- Ada 2012 : formals in bodies may be incomplete, but no attribute
2516 -- legally applies.
2518 elsif Is_Entity_Name (P)
2519 and then Is_Formal (Entity (P))
2520 and then Is_Incomplete_Type (Etype (Etype (P)))
2521 then
2522 Error_Attr_P
2523 ("prefix of % attribute cannot be an incomplete type");
2524 end if;
2526 if not Is_Entity_Name (P)
2527 or else not Is_Type (Entity (P))
2528 or else In_Spec_Expression
2529 then
2530 return;
2531 elsif not Is_Current_Instance (P) then
2532 Check_Fully_Declared (P_Type, P);
2533 end if;
2534 end Check_Not_Incomplete_Type;
2536 ----------------------------
2537 -- Check_Object_Reference --
2538 ----------------------------
2540 procedure Check_Object_Reference (P : Node_Id) is
2541 Rtyp : Entity_Id;
2543 begin
2544 -- If we need an object, and we have a prefix that is the name of a
2545 -- function entity, convert it into a function call.
2547 if Is_Entity_Name (P)
2548 and then Ekind (Entity (P)) = E_Function
2549 then
2550 Rtyp := Etype (Entity (P));
2552 Rewrite (P,
2553 Make_Function_Call (Sloc (P),
2554 Name => Relocate_Node (P)));
2556 Analyze_And_Resolve (P, Rtyp);
2558 -- Otherwise we must have an object reference
2560 elsif not Is_Object_Reference (P) then
2561 Error_Attr_P ("prefix of % attribute must be object");
2562 end if;
2563 end Check_Object_Reference;
2565 ----------------------------
2566 -- Check_PolyORB_Attribute --
2567 ----------------------------
2569 procedure Check_PolyORB_Attribute is
2570 begin
2571 Validate_Non_Static_Attribute_Function_Call;
2573 Check_Type;
2574 Check_Not_CPP_Type;
2576 if Get_PCS_Name /= Name_PolyORB_DSA then
2577 Error_Attr
2578 ("attribute% requires the 'Poly'O'R'B 'P'C'S", N);
2579 end if;
2580 end Check_PolyORB_Attribute;
2582 ------------------------
2583 -- Check_Program_Unit --
2584 ------------------------
2586 procedure Check_Program_Unit is
2587 begin
2588 if Is_Entity_Name (P) then
2589 declare
2590 E : constant Entity_Id := Entity (P);
2591 begin
2592 if Ekind (E) in E_Protected_Type
2593 | E_Task_Type
2594 | Entry_Kind
2595 | Generic_Unit_Kind
2596 | Subprogram_Kind
2597 | E_Package
2598 or else Is_Single_Concurrent_Object (E)
2599 then
2600 return;
2601 end if;
2602 end;
2603 end if;
2605 Error_Attr_P ("prefix of % attribute must be program unit");
2606 end Check_Program_Unit;
2608 ---------------------
2609 -- Check_Real_Type --
2610 ---------------------
2612 procedure Check_Real_Type is
2613 begin
2614 Check_Type;
2616 if not Is_Real_Type (P_Type) then
2617 Error_Attr_P ("prefix of % attribute must be real type");
2618 end if;
2619 end Check_Real_Type;
2621 ----------------------------
2622 -- Check_Enumeration_Type --
2623 ----------------------------
2625 procedure Check_Enumeration_Type is
2626 begin
2627 Check_Type;
2629 if not Is_Enumeration_Type (P_Type) then
2630 Error_Attr_P ("prefix of % attribute must be enumeration type");
2631 end if;
2632 end Check_Enumeration_Type;
2634 -----------------------
2635 -- Check_Scalar_Type --
2636 -----------------------
2638 procedure Check_Scalar_Type is
2639 begin
2640 Check_Type;
2642 if not Is_Scalar_Type (P_Type) then
2643 Error_Attr_P ("prefix of % attribute must be scalar type");
2644 end if;
2645 end Check_Scalar_Type;
2647 ---------------------------
2648 -- Check_Standard_Prefix --
2649 ---------------------------
2651 procedure Check_Standard_Prefix is
2652 begin
2653 Check_E0;
2655 if Nkind (P) /= N_Identifier or else Chars (P) /= Name_Standard then
2656 Error_Attr ("only allowed prefix for % attribute is Standard", P);
2657 end if;
2658 end Check_Standard_Prefix;
2660 -------------------------------
2661 -- Check_Put_Image_Attribute --
2662 -------------------------------
2664 procedure Check_Put_Image_Attribute is
2665 begin
2666 -- Put_Image is a procedure, and can only appear at the position of a
2667 -- procedure call. If it's a list member and it's parent is a
2668 -- procedure call or aggregate, then this is appearing as an actual
2669 -- parameter or component association, which is wrong.
2671 if Is_List_Member (N)
2672 and then Nkind (Parent (N)) not in
2673 N_Procedure_Call_Statement | N_Aggregate
2674 then
2675 null;
2676 else
2677 Error_Attr
2678 ("invalid context for attribute%, which is a procedure", N);
2679 end if;
2681 Check_Type;
2682 Analyze_And_Resolve (E1);
2684 -- Check that the first argument is
2685 -- Ada.Strings.Text_Buffers.Root_Buffer_Type'Class.
2687 -- Note: the double call to Root_Type here is needed because the
2688 -- root type of a class-wide type is the corresponding type (e.g.
2689 -- X for X'Class, and we really want to go to the root.)
2691 if not Is_RTE (Root_Type (Root_Type (Etype (E1))),
2692 RE_Root_Buffer_Type)
2693 then
2694 Error_Attr
2695 ("expected Ada.Strings.Text_Buffers.Root_Buffer_Type''Class",
2696 E1);
2697 end if;
2699 -- Check that the second argument is of the right type
2701 Analyze (E2);
2702 Resolve (E2, P_Type);
2703 end Check_Put_Image_Attribute;
2705 ----------------------------
2706 -- Check_Stream_Attribute --
2707 ----------------------------
2709 procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is
2710 Etyp : Entity_Id;
2711 Btyp : Entity_Id;
2713 In_Shared_Var_Procs : Boolean;
2714 -- True when compiling System.Shared_Storage.Shared_Var_Procs body.
2715 -- For this runtime package (always compiled in GNAT mode), we allow
2716 -- stream attributes references for limited types for the case where
2717 -- shared passive objects are implemented using stream attributes,
2718 -- which is the default in GNAT's persistent storage implementation.
2720 begin
2721 Validate_Non_Static_Attribute_Function_Call;
2723 -- With the exception of 'Input, Stream attributes are procedures,
2724 -- and can only appear at the position of procedure calls. We check
2725 -- for this here, before they are rewritten, to give a more precise
2726 -- diagnostic.
2728 if Nam = TSS_Stream_Input then
2729 null;
2731 elsif Is_List_Member (N)
2732 and then Nkind (Parent (N)) not in
2733 N_Procedure_Call_Statement | N_Aggregate
2734 then
2735 null;
2737 else
2738 Error_Attr
2739 ("invalid context for attribute%, which is a procedure", N);
2740 end if;
2742 Check_Type;
2743 Btyp := Implementation_Base_Type (P_Type);
2745 -- Stream attributes not allowed on limited types unless the
2746 -- attribute reference was generated by the expander (in which
2747 -- case the underlying type will be used, as described in Sinfo),
2748 -- or the attribute was specified explicitly for the type itself
2749 -- or one of its ancestors (taking visibility rules into account if
2750 -- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp
2751 -- (with no visibility restriction).
2753 declare
2754 Gen_Body : constant Node_Id := Enclosing_Generic_Body (N);
2755 begin
2756 if Present (Gen_Body) then
2757 In_Shared_Var_Procs :=
2758 Is_RTE (Corresponding_Spec (Gen_Body), RE_Shared_Var_Procs);
2759 else
2760 In_Shared_Var_Procs := False;
2761 end if;
2762 end;
2764 if (Comes_From_Source (N)
2765 and then not (In_Shared_Var_Procs or In_Instance))
2766 and then not Stream_Attribute_Available (P_Type, Nam)
2767 and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert)
2768 then
2769 Error_Msg_Name_1 := Aname;
2771 if Is_Limited_Type (P_Type) then
2772 Error_Msg_NE
2773 ("limited type& has no% attribute", P, P_Type);
2774 Explain_Limited_Type (P_Type, P);
2775 else
2776 Error_Msg_NE
2777 ("attribute% for type& is not available", P, P_Type);
2778 end if;
2779 end if;
2781 -- Check for no stream operations allowed from No_Tagged_Streams
2783 if Is_Tagged_Type (P_Type)
2784 and then Present (No_Tagged_Streams_Pragma (P_Type))
2785 then
2786 Error_Msg_Sloc := Sloc (No_Tagged_Streams_Pragma (P_Type));
2787 Error_Msg_NE
2788 ("no stream operations for & (No_Tagged_Streams #)", N, P_Type);
2789 return;
2790 end if;
2792 -- Check restriction violations
2794 -- First check the No_Streams restriction, which prohibits the use
2795 -- of explicit stream attributes in the source program. We do not
2796 -- prevent the occurrence of stream attributes in generated code,
2797 -- for instance those generated implicitly for dispatching purposes.
2799 if Comes_From_Source (N) then
2800 Check_Restriction (No_Streams, P);
2801 end if;
2803 -- AI05-0057: if restriction No_Default_Stream_Attributes is active,
2804 -- it is illegal to use a predefined elementary type stream attribute
2805 -- either by itself, or more importantly as part of the attribute
2806 -- subprogram for a composite type. However, if the broader
2807 -- restriction No_Streams is active, stream operations are not
2808 -- generated, and there is no error.
2810 if Restriction_Active (No_Default_Stream_Attributes)
2811 and then not Restriction_Active (No_Streams)
2812 then
2813 declare
2814 T : Entity_Id;
2816 begin
2817 if Nam = TSS_Stream_Input
2818 or else
2819 Nam = TSS_Stream_Read
2820 then
2821 T :=
2822 Type_Without_Stream_Operation (P_Type, TSS_Stream_Read);
2823 else
2824 T :=
2825 Type_Without_Stream_Operation (P_Type, TSS_Stream_Write);
2826 end if;
2828 if Present (T) then
2829 Check_Restriction (No_Default_Stream_Attributes, N);
2831 Error_Msg_NE
2832 ("missing user-defined Stream Read or Write for type&",
2833 N, T);
2834 if not Is_Elementary_Type (P_Type) then
2835 Error_Msg_NE
2836 ("\which is a component of type&", N, P_Type);
2837 end if;
2838 end if;
2839 end;
2840 end if;
2842 -- Check special case of Exception_Id and Exception_Occurrence which
2843 -- are not allowed for restriction No_Exception_Registration.
2845 if Restriction_Check_Required (No_Exception_Registration)
2846 and then (Is_RTE (P_Type, RE_Exception_Id)
2847 or else
2848 Is_RTE (P_Type, RE_Exception_Occurrence))
2849 then
2850 Check_Restriction (No_Exception_Registration, P);
2851 end if;
2853 -- If the No_Tagged_Type_Registration restriction is active, then
2854 -- class-wide streaming attributes are not allowed.
2856 if Restriction_Check_Required (No_Tagged_Type_Registration)
2857 and then Is_Class_Wide_Type (P_Type)
2858 then
2859 Check_Restriction (No_Tagged_Type_Registration, P);
2860 end if;
2862 -- Here we must check that the first argument is an access type
2863 -- that is compatible with Ada.Streams.Root_Stream_Type'Class.
2865 Analyze_And_Resolve (E1);
2866 Etyp := Etype (E1);
2868 -- Note: the double call to Root_Type here is needed because the
2869 -- root type of a class-wide type is the corresponding type (e.g.
2870 -- X for X'Class, and we really want to go to the root.)
2872 if not Is_Access_Type (Etyp)
2873 or else not Is_RTE (Root_Type (Root_Type (Designated_Type (Etyp))),
2874 RE_Root_Stream_Type)
2875 then
2876 Error_Attr
2877 ("expected access to Ada.Streams.Root_Stream_Type''Class", E1);
2878 end if;
2880 -- Check that the second argument is of the right type if there is
2881 -- one (the Input attribute has only one argument so this is skipped)
2883 if Present (E2) then
2884 Analyze (E2);
2886 if Nam = TSS_Stream_Read
2887 and then not Is_OK_Variable_For_Out_Formal (E2)
2888 then
2889 Error_Attr
2890 ("second argument of % attribute must be a variable", E2);
2891 end if;
2893 Resolve (E2, P_Type);
2894 end if;
2896 Check_Not_CPP_Type;
2897 end Check_Stream_Attribute;
2899 -------------------------
2900 -- Check_System_Prefix --
2901 -------------------------
2903 procedure Check_System_Prefix is
2904 begin
2905 if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then
2906 Error_Attr ("only allowed prefix for % attribute is System", P);
2907 end if;
2908 end Check_System_Prefix;
2910 -----------------------
2911 -- Check_Task_Prefix --
2912 -----------------------
2914 procedure Check_Task_Prefix is
2915 begin
2916 -- Ada 2005 (AI-345): Attribute 'Terminated can be applied to
2917 -- task interface class-wide types.
2919 if Is_Task_Type (Etype (P))
2920 or else (Is_Access_Type (Etype (P))
2921 and then Is_Task_Type (Designated_Type (Etype (P))))
2922 or else (Ada_Version >= Ada_2005
2923 and then Ekind (Etype (P)) = E_Class_Wide_Type
2924 and then Is_Interface (Etype (P))
2925 and then Is_Task_Interface (Etype (P)))
2926 then
2927 Resolve (P);
2929 else
2930 if Ada_Version >= Ada_2005 then
2931 Error_Attr_P
2932 ("prefix of % attribute must be a task or a task " &
2933 "interface class-wide object");
2935 else
2936 Error_Attr_P ("prefix of % attribute must be a task");
2937 end if;
2938 end if;
2939 end Check_Task_Prefix;
2941 ----------------
2942 -- Check_Type --
2943 ----------------
2945 -- The possibilities are an entity name denoting a type, or an
2946 -- attribute reference that denotes a type (Base or Class). If
2947 -- the type is incomplete, replace it with its full view.
2949 procedure Check_Type is
2950 begin
2951 if not Is_Entity_Name (P)
2952 or else not Is_Type (Entity (P))
2953 then
2954 Error_Attr_P ("prefix of % attribute must be a type");
2956 elsif Is_Protected_Self_Reference (P) then
2957 Error_Attr_P
2958 ("prefix of % attribute denotes current instance "
2959 & "(RM 9.4(21/2))");
2961 elsif Ekind (Entity (P)) = E_Incomplete_Type
2962 and then Present (Full_View (Entity (P)))
2963 then
2964 P_Type := Full_View (Entity (P));
2965 Set_Entity (P, P_Type);
2966 end if;
2967 end Check_Type;
2969 ---------------------
2970 -- Check_Unit_Name --
2971 ---------------------
2973 procedure Check_Unit_Name (Nod : Node_Id) is
2974 begin
2975 if Nkind (Nod) = N_Identifier then
2976 return;
2978 elsif Nkind (Nod) in N_Selected_Component | N_Expanded_Name then
2979 Check_Unit_Name (Prefix (Nod));
2981 if Nkind (Selector_Name (Nod)) = N_Identifier then
2982 return;
2983 end if;
2984 end if;
2986 Error_Attr ("argument for % attribute must be unit name", P);
2987 end Check_Unit_Name;
2989 ----------------
2990 -- Error_Attr --
2991 ----------------
2993 procedure Error_Attr is
2994 begin
2995 Set_Etype (N, Any_Type);
2996 Set_Entity (N, Any_Type);
2997 raise Bad_Attribute;
2998 end Error_Attr;
3000 procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
3001 begin
3002 Error_Msg_Name_1 := Aname;
3003 Error_Msg_N (Msg, Error_Node);
3004 Error_Attr;
3005 end Error_Attr;
3007 ------------------
3008 -- Error_Attr_P --
3009 ------------------
3011 procedure Error_Attr_P (Msg : String; Msg_Cont : String := "") is
3012 begin
3013 Error_Msg_Name_1 := Aname;
3014 Error_Msg_F (Msg, P);
3015 if Msg_Cont /= "" then
3016 Error_Msg_F (Msg_Cont, P);
3017 end if;
3018 Error_Attr;
3019 end Error_Attr_P;
3021 ----------------------------
3022 -- Legal_Formal_Attribute --
3023 ----------------------------
3025 procedure Legal_Formal_Attribute is
3026 begin
3027 Check_E0;
3029 if not Is_Entity_Name (P)
3030 or else not Is_Type (Entity (P))
3031 then
3032 Error_Attr_P ("prefix of % attribute must be generic type");
3034 elsif Is_Generic_Actual_Type (Entity (P))
3035 or else In_Instance
3036 or else In_Inlined_Body
3037 then
3038 null;
3040 elsif Is_Generic_Type (Entity (P)) then
3041 if Is_Definite_Subtype (Entity (P)) then
3042 Error_Attr_P
3043 ("prefix of % attribute must be indefinite generic type");
3044 end if;
3046 else
3047 Error_Attr_P
3048 ("prefix of % attribute must be indefinite generic type");
3049 end if;
3051 Set_Etype (N, Standard_Boolean);
3052 end Legal_Formal_Attribute;
3054 ---------------------------------------------------------------
3055 -- Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements --
3056 ---------------------------------------------------------------
3058 procedure Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements is
3059 begin
3060 Check_E0;
3061 Check_Type;
3062 Check_Not_Incomplete_Type;
3063 Set_Etype (N, Universal_Integer);
3064 end Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements;
3066 -------------
3067 -- Min_Max --
3068 -------------
3070 procedure Min_Max is
3071 begin
3072 -- Attribute can appear as function name in a reduction.
3073 -- Semantic checks are performed later.
3075 if Nkind (Parent (N)) = N_Attribute_Reference
3076 and then Attribute_Name (Parent (N)) = Name_Reduce
3077 then
3078 Set_Etype (N, P_Base_Type);
3079 return;
3080 end if;
3082 Check_E2;
3083 Check_Scalar_Type;
3084 Resolve (E1, P_Base_Type);
3085 Resolve (E2, P_Base_Type);
3086 Set_Etype (N, P_Base_Type);
3088 -- Check for comparison on unordered enumeration type
3090 if Bad_Unordered_Enumeration_Reference (N, P_Base_Type) then
3091 Error_Msg_Sloc := Sloc (P_Base_Type);
3092 Error_Msg_NE
3093 ("comparison on unordered enumeration type& declared#?.u?",
3094 N, P_Base_Type);
3095 end if;
3096 end Min_Max;
3098 ------------------------
3099 -- Standard_Attribute --
3100 ------------------------
3102 procedure Standard_Attribute (Val : Int) is
3103 begin
3104 Check_Standard_Prefix;
3105 Rewrite (N, Make_Integer_Literal (Loc, Val));
3106 Analyze (N);
3107 Set_Is_Static_Expression (N, True);
3108 end Standard_Attribute;
3110 --------------------
3111 -- Uneval_Old_Msg --
3112 --------------------
3114 procedure Uneval_Old_Msg is
3115 Uneval_Old_Setting : Character;
3116 Prag : Node_Id;
3118 begin
3119 -- If from aspect, then Uneval_Old_Setting comes from flags in the
3120 -- N_Aspect_Specification node that corresponds to the attribute.
3122 -- First find the pragma in which we appear (note that at this stage,
3123 -- even if we appeared originally within an aspect specification, we
3124 -- are now within the corresponding pragma).
3126 Prag := N;
3127 loop
3128 Prag := Parent (Prag);
3129 exit when No (Prag) or else Nkind (Prag) = N_Pragma;
3130 end loop;
3132 if Present (Prag) then
3133 if Uneval_Old_Accept (Prag) then
3134 Uneval_Old_Setting := 'A';
3135 elsif Uneval_Old_Warn (Prag) then
3136 Uneval_Old_Setting := 'W';
3137 else
3138 Uneval_Old_Setting := 'E';
3139 end if;
3141 -- If we did not find the pragma, that's odd, just use the setting
3142 -- from Opt.Uneval_Old. Perhaps this is due to a previous error?
3144 else
3145 Uneval_Old_Setting := Opt.Uneval_Old;
3146 end if;
3148 -- Processing depends on the setting of Uneval_Old
3150 case Uneval_Old_Setting is
3151 when 'E' =>
3152 -- ??? In the case where Ada_Version is < Ada_2022 and
3153 -- an illegal 'Old prefix would be legal in Ada_2022,
3154 -- we'd like to call Error_Msg_Ada_2022_Feature.
3155 -- Identifying that case involves some work.
3157 Error_Attr_P
3158 ("prefix of attribute % that is potentially "
3159 & "unevaluated must statically name an entity"
3161 -- further text needed for accuracy if Ada_2022
3162 & (if Ada_Version >= Ada_2022
3163 and then Attr_Id = Attribute_Old
3164 then " or be eligible for conditional evaluation"
3165 & " (RM 6.1.1 (27))"
3166 else ""),
3167 Msg_Cont =>
3168 "\using pragma Unevaluated_Use_Of_Old (Allow) will make "
3169 & "this legal");
3171 when 'W' =>
3172 Error_Msg_Name_1 := Aname;
3173 Error_Msg_F
3174 ("??prefix of attribute % appears in potentially "
3175 & "unevaluated context, exception may be raised", P);
3177 when 'A' =>
3178 null;
3180 when others =>
3181 raise Program_Error;
3182 end case;
3183 end Uneval_Old_Msg;
3185 -------------------------
3186 -- Unexpected Argument --
3187 -------------------------
3189 procedure Unexpected_Argument (En : Node_Id) is
3190 begin
3191 Error_Attr ("unexpected argument for % attribute", En);
3192 end Unexpected_Argument;
3194 -------------------------------------------------
3195 -- Validate_Non_Static_Attribute_Function_Call --
3196 -------------------------------------------------
3198 -- This function should be moved to Sem_Dist ???
3200 procedure Validate_Non_Static_Attribute_Function_Call is
3201 begin
3202 if In_Preelaborated_Unit
3203 and then not In_Subprogram_Or_Concurrent_Unit
3204 then
3205 Flag_Non_Static_Expr
3206 ("non-static function call in preelaborated unit!", N);
3207 end if;
3208 end Validate_Non_Static_Attribute_Function_Call;
3210 -- Start of processing for Analyze_Attribute
3212 begin
3213 -- Immediate return if unrecognized attribute (already diagnosed by
3214 -- parser, so there is nothing more that we need to do).
3216 if not Is_Attribute_Name (Aname) then
3217 raise Bad_Attribute;
3218 end if;
3220 Check_Restriction_No_Use_Of_Attribute (N);
3222 -- Deal with Ada 83 issues
3224 if Comes_From_Source (N) then
3225 if not Attribute_83 (Attr_Id) then
3226 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3227 Error_Msg_Name_1 := Aname;
3228 Error_Msg_N ("(Ada 83) attribute% is not standard??", N);
3229 end if;
3231 if Attribute_Impl_Def (Attr_Id) then
3232 Check_Restriction (No_Implementation_Attributes, N);
3233 end if;
3234 end if;
3235 end if;
3237 -- Deal with Ada 2005 attributes that are implementation attributes
3238 -- because they appear in a version of Ada before Ada 2005, ditto for
3239 -- Ada 2012 and Ada 2022 attributes appearing in an earlier version.
3241 if (Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005)
3242 or else
3243 (Attribute_12 (Attr_Id) and then Ada_Version < Ada_2012)
3244 or else
3245 (Attribute_22 (Attr_Id) and then Ada_Version < Ada_2022)
3246 then
3247 Check_Restriction (No_Implementation_Attributes, N);
3248 end if;
3250 -- Remote access to subprogram type access attribute reference needs
3251 -- unanalyzed copy for tree transformation. The analyzed copy is used
3252 -- for its semantic information (whether prefix is a remote subprogram
3253 -- name), the unanalyzed copy is used to construct new subtree rooted
3254 -- with N_Aggregate which represents a fat pointer aggregate.
3256 if Aname = Name_Access then
3257 Discard_Node (Copy_Separate_Tree (N));
3258 end if;
3260 -- Analyze prefix and exit if error in analysis. If the prefix is an
3261 -- incomplete type, use full view if available. Note that there are
3262 -- some attributes for which we do not analyze the prefix, since the
3263 -- prefix is not a normal name, or else needs special handling.
3265 if Aname /= Name_Elab_Body and then
3266 Aname /= Name_Elab_Spec and then
3267 Aname /= Name_Elab_Subp_Body and then
3268 Aname /= Name_Enabled and then
3269 Aname /= Name_Old
3270 then
3271 Analyze (P);
3272 P_Type := Etype (P);
3274 if Is_Entity_Name (P)
3275 and then Present (Entity (P))
3276 and then Is_Type (Entity (P))
3277 then
3278 if Ekind (Entity (P)) = E_Incomplete_Type then
3279 P_Type := Get_Full_View (P_Type);
3280 Set_Entity (P, P_Type);
3281 Set_Etype (P, P_Type);
3283 elsif Entity (P) = Current_Scope
3284 and then Is_Record_Type (Entity (P))
3285 then
3286 -- Use of current instance within the type. Verify that if the
3287 -- attribute appears within a constraint, it yields an access
3288 -- type, other uses are illegal.
3290 declare
3291 Par : Node_Id;
3293 begin
3294 Par := Parent (N);
3295 while Present (Par)
3296 and then Nkind (Parent (Par)) /= N_Component_Definition
3297 loop
3298 Par := Parent (Par);
3299 end loop;
3301 if Present (Par)
3302 and then Nkind (Par) = N_Subtype_Indication
3303 then
3304 if Attr_Id /= Attribute_Access
3305 and then Attr_Id /= Attribute_Unchecked_Access
3306 and then Attr_Id /= Attribute_Unrestricted_Access
3307 then
3308 Error_Msg_N
3309 ("in a constraint the current instance can only "
3310 & "be used with an access attribute", N);
3311 end if;
3312 end if;
3313 end;
3314 end if;
3315 end if;
3317 if P_Type = Any_Type then
3318 raise Bad_Attribute;
3319 end if;
3321 P_Base_Type := Base_Type (P_Type);
3322 end if;
3324 -- Analyze expressions that may be present, exiting if an error occurs
3326 if No (Exprs) then
3327 E1 := Empty;
3328 E2 := Empty;
3330 else
3331 E1 := First (Exprs);
3333 -- Skip analysis for case of Restriction_Set, we do not expect
3334 -- the argument to be analyzed in this case.
3336 if Aname /= Name_Restriction_Set then
3337 Analyze (E1);
3339 -- Check for missing/bad expression (result of previous error)
3341 if No (E1)
3342 or else (Etype (E1) = Any_Type and then Full_Analysis)
3343 then
3344 Check_Error_Detected;
3345 raise Bad_Attribute;
3346 end if;
3347 end if;
3349 E2 := Next (E1);
3351 if Present (E2) then
3352 Analyze (E2);
3354 if Etype (E2) = Any_Type then
3355 raise Bad_Attribute;
3356 end if;
3358 if Present (Next (E2)) then
3359 Unexpected_Argument (Next (E2));
3360 end if;
3361 end if;
3362 end if;
3364 -- Cases where prefix must be resolvable by itself
3366 if Is_Overloaded (P)
3367 and then Aname /= Name_Access
3368 and then Aname /= Name_Address
3369 and then Aname /= Name_Code_Address
3370 and then Aname /= Name_Result
3371 and then Aname /= Name_Unchecked_Access
3372 then
3373 -- The prefix must be resolvable by itself, without reference to the
3374 -- attribute. One case that requires special handling is a prefix
3375 -- that is a function name, where one interpretation may be a
3376 -- parameterless call. Entry attributes are handled specially below.
3378 if Is_Entity_Name (P)
3379 and then Aname not in Name_Count | Name_Caller
3380 then
3381 Check_Parameterless_Call (P);
3382 end if;
3384 if Is_Overloaded (P) then
3386 -- Ada 2005 (AI-345): Since protected and task types have
3387 -- primitive entry wrappers, the attributes Count, and Caller
3388 -- require a context check
3390 if Aname in Name_Count | Name_Caller then
3391 declare
3392 Count : Natural := 0;
3393 I : Interp_Index;
3394 It : Interp;
3396 begin
3397 Get_First_Interp (P, I, It);
3398 while Present (It.Nam) loop
3399 if Comes_From_Source (It.Nam) then
3400 Count := Count + 1;
3401 else
3402 Remove_Interp (I);
3403 end if;
3405 Get_Next_Interp (I, It);
3406 end loop;
3408 if Count > 1 then
3409 Error_Attr ("ambiguous prefix for % attribute", P);
3410 else
3411 Set_Is_Overloaded (P, False);
3412 end if;
3413 end;
3415 else
3416 Error_Attr ("ambiguous prefix for % attribute", P);
3417 end if;
3418 end if;
3419 end if;
3421 -- If the prefix was rewritten as a raise node, then rewrite N as a
3422 -- raise node, to avoid creating inconsistent trees. We still need to
3423 -- perform legality checks on the original tree.
3425 if Nkind (P) in N_Raise_xxx_Error then
3426 Rewrite (N, Relocate_Node (P));
3427 P := Original_Node (P_Old);
3428 end if;
3430 -- Remaining processing depends on attribute
3432 case Attr_Id is
3434 -- Attributes related to Ada 2012 iterators. Attribute specifications
3435 -- exist for these, but they cannot be queried.
3437 when Attribute_Constant_Indexing
3438 | Attribute_Default_Iterator
3439 | Attribute_Implicit_Dereference
3440 | Attribute_Iterator_Element
3441 | Attribute_Iterable
3442 | Attribute_Variable_Indexing
3444 Error_Msg_N ("illegal attribute", N);
3446 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
3447 -- were already rejected by the parser. Thus they shouldn't appear here.
3449 when Internal_Attribute_Id =>
3450 raise Program_Error;
3452 ------------------
3453 -- Abort_Signal --
3454 ------------------
3456 when Attribute_Abort_Signal =>
3457 Check_Standard_Prefix;
3458 Rewrite (N, New_Occurrence_Of (Stand.Abort_Signal, Loc));
3459 Analyze (N);
3461 ------------
3462 -- Access --
3463 ------------
3465 when Attribute_Access =>
3466 Analyze_Access_Attribute;
3467 Check_Not_Incomplete_Type;
3469 -------------
3470 -- Address --
3471 -------------
3473 when Attribute_Address =>
3474 Check_E0;
3475 Address_Checks;
3476 Check_Not_Incomplete_Type;
3478 -- If the prefix is a dereference of a value whose associated access
3479 -- type has been specified with aspect Designated_Storage_Model, then
3480 -- use the associated Storage_Model_Type's address type as the type
3481 -- of the attribute. Otherwise we use System.Address as usual. This
3482 -- isn't normally legit for a predefined attribute, but this is for
3483 -- our own extension to addressing and currently requires extensions
3484 -- to be enabled (such as with -gnatX0).
3486 declare
3487 Prefix_Obj : constant Node_Id := Get_Referenced_Object (P);
3488 Addr_Type : Entity_Id := RTE (RE_Address);
3489 begin
3490 if Nkind (Prefix_Obj) = N_Explicit_Dereference then
3491 declare
3492 P_Type : constant Entity_Id := Etype (Prefix (Prefix_Obj));
3494 use Storage_Model_Support;
3495 begin
3496 if Has_Designated_Storage_Model_Aspect (P_Type) then
3497 Addr_Type := Storage_Model_Address_Type
3498 (Storage_Model_Object (P_Type));
3499 end if;
3500 end;
3501 end if;
3503 Set_Etype (N, Addr_Type);
3504 end;
3506 ------------------
3507 -- Address_Size --
3508 ------------------
3510 when Attribute_Address_Size =>
3511 Standard_Attribute (System_Address_Size);
3513 --------------
3514 -- Adjacent --
3515 --------------
3517 when Attribute_Adjacent
3518 | Attribute_Copy_Sign
3519 | Attribute_Remainder
3521 Check_Floating_Point_Type_2;
3522 Set_Etype (N, P_Base_Type);
3523 Resolve (E1, P_Base_Type);
3524 Resolve (E2, P_Base_Type);
3526 ---------
3527 -- Aft --
3528 ---------
3530 when Attribute_Aft =>
3531 Check_Fixed_Point_Type_0;
3532 Set_Etype (N, Universal_Integer);
3534 ---------------
3535 -- Alignment --
3536 ---------------
3538 when Attribute_Alignment =>
3540 -- Don't we need more checking here, cf Size ???
3542 Check_E0;
3543 Check_Not_Incomplete_Type;
3544 Check_Not_CPP_Type;
3545 Set_Etype (N, Universal_Integer);
3547 ---------------
3548 -- Asm_Input --
3549 ---------------
3551 when Attribute_Asm_Input =>
3552 Check_Asm_Attribute;
3554 -- The back end may need to take the address of E2
3556 if Is_Entity_Name (E2) then
3557 Set_Address_Taken (Entity (E2));
3558 end if;
3560 Set_Etype (N, RTE (RE_Asm_Input_Operand));
3562 ----------------
3563 -- Asm_Output --
3564 ----------------
3566 when Attribute_Asm_Output =>
3567 Check_Asm_Attribute;
3569 if Etype (E2) = Any_Type then
3570 return;
3572 elsif Aname = Name_Asm_Output then
3573 if not Is_Variable (E2) then
3574 Error_Attr
3575 ("second argument for Asm_Output is not variable", E2);
3576 end if;
3577 end if;
3579 Note_Possible_Modification (E2, Sure => True);
3581 -- The back end may need to take the address of E2
3583 if Is_Entity_Name (E2) then
3584 Set_Address_Taken (Entity (E2));
3585 end if;
3587 Set_Etype (N, RTE (RE_Asm_Output_Operand));
3589 -----------------------------
3590 -- Atomic_Always_Lock_Free --
3591 -----------------------------
3593 when Attribute_Atomic_Always_Lock_Free =>
3594 Check_E0;
3595 Check_Type;
3596 Set_Etype (N, Standard_Boolean);
3598 ----------
3599 -- Base --
3600 ----------
3602 -- Note: when the base attribute appears in the context of a subtype
3603 -- mark, the analysis is done by Sem_Ch8.Find_Type, rather than by
3604 -- the following circuit.
3606 when Attribute_Base => Base : declare
3607 Typ : Entity_Id;
3609 begin
3610 Check_E0;
3611 Find_Type (P);
3612 Typ := Entity (P);
3614 if Ada_Version >= Ada_95
3615 and then not Is_Scalar_Type (Typ)
3616 and then not Is_Generic_Type (Typ)
3617 then
3618 Error_Attr_P ("prefix of Base attribute must be scalar type");
3620 elsif Sloc (Typ) = Standard_Location
3621 and then Base_Type (Typ) = Typ
3622 and then Warn_On_Redundant_Constructs
3623 then
3624 Error_Msg_NE -- CODEFIX
3625 ("?r?redundant attribute, & is its own base type", N, Typ);
3626 end if;
3628 Set_Etype (N, Base_Type (Entity (P)));
3629 Set_Entity (N, Base_Type (Entity (P)));
3630 Rewrite (N, New_Occurrence_Of (Entity (N), Loc));
3631 Analyze (N);
3632 end Base;
3634 ---------
3635 -- Bit --
3636 ---------
3638 when Attribute_Bit =>
3639 Check_E0;
3641 if not Is_Object_Reference (P) then
3642 Error_Attr_P ("prefix of % attribute must be object");
3644 -- What about the access object cases ???
3646 else
3647 null;
3648 end if;
3650 Set_Etype (N, Universal_Integer);
3652 ---------------
3653 -- Bit_Order --
3654 ---------------
3656 when Attribute_Bit_Order =>
3657 Check_E0;
3658 Check_Type;
3660 if not Is_Record_Type (P_Type) then
3661 Error_Attr_P ("prefix of % attribute must be record type");
3662 end if;
3664 if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then
3665 Rewrite (N,
3666 New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
3667 else
3668 Rewrite (N,
3669 New_Occurrence_Of (RTE (RE_Low_Order_First), Loc));
3670 end if;
3672 Resolve (N);
3674 -- Reset incorrect indication of staticness
3676 Set_Is_Static_Expression (N, False);
3678 ------------------
3679 -- Bit_Position --
3680 ------------------
3682 -- Note: in generated code, we can have a Bit_Position attribute
3683 -- applied to a (naked) record component (i.e. the prefix is an
3684 -- identifier that references an E_Component or E_Discriminant
3685 -- entity directly, and this is interpreted as expected by Gigi.
3686 -- The following code will not tolerate such usage, but when the
3687 -- expander creates this special case, it marks it as analyzed
3688 -- immediately and sets an appropriate type.
3690 when Attribute_Bit_Position =>
3691 if Comes_From_Source (N) then
3692 Check_Component;
3693 end if;
3695 Set_Etype (N, Universal_Integer);
3697 ------------------
3698 -- Body_Version --
3699 ------------------
3701 when Attribute_Body_Version =>
3702 Check_E0;
3703 Check_Program_Unit;
3704 Set_Etype (N, RTE (RE_Version_String));
3706 --------------
3707 -- Callable --
3708 --------------
3710 when Attribute_Callable
3711 | Attribute_Terminated
3713 Check_E0;
3714 Set_Etype (N, Standard_Boolean);
3715 Check_Task_Prefix;
3717 ------------
3718 -- Caller --
3719 ------------
3721 when Attribute_Caller => Caller : declare
3722 Ent : Entity_Id;
3723 S : Entity_Id;
3725 begin
3726 Check_E0;
3728 if Nkind (P) in N_Identifier | N_Expanded_Name then
3729 Ent := Entity (P);
3731 if not Is_Entry (Ent) then
3732 Error_Attr ("invalid entry name", N);
3733 end if;
3735 else
3736 Error_Attr ("invalid entry name", N);
3737 end if;
3739 for J in reverse 0 .. Scope_Stack.Last loop
3740 S := Scope_Stack.Table (J).Entity;
3742 if S = Scope (Ent) then
3743 Error_Attr ("Caller must appear in matching accept or body", N);
3744 elsif S = Ent then
3745 exit;
3746 end if;
3747 end loop;
3749 Set_Etype (N, RTE (RO_AT_Task_Id));
3750 end Caller;
3752 -------------
3753 -- Ceiling --
3754 -------------
3756 when Attribute_Ceiling
3757 | Attribute_Floor
3758 | Attribute_Fraction
3759 | Attribute_Machine
3760 | Attribute_Machine_Rounding
3761 | Attribute_Model
3762 | Attribute_Rounding
3763 | Attribute_Truncation
3764 | Attribute_Unbiased_Rounding
3766 Check_Floating_Point_Type_1;
3767 Set_Etype (N, P_Base_Type);
3768 Resolve (E1, P_Base_Type);
3770 -----------
3771 -- Class --
3772 -----------
3774 when Attribute_Class =>
3775 Check_Restriction (No_Dispatch, N);
3776 Check_E0;
3777 Find_Type (N);
3779 -- Applying Class to untagged incomplete type is obsolescent in Ada
3780 -- 2005. Note that we can't test Is_Tagged_Type here on P_Type, since
3781 -- this flag gets set by Find_Type in this situation.
3783 if Restriction_Check_Required (No_Obsolescent_Features)
3784 and then Ada_Version >= Ada_2005
3785 and then Ekind (P_Type) = E_Incomplete_Type
3786 then
3787 declare
3788 DN : constant Node_Id := Declaration_Node (P_Type);
3789 begin
3790 if Nkind (DN) = N_Incomplete_Type_Declaration
3791 and then not Tagged_Present (DN)
3792 then
3793 Check_Restriction (No_Obsolescent_Features, P);
3794 end if;
3795 end;
3796 end if;
3798 ------------------
3799 -- Code_Address --
3800 ------------------
3802 when Attribute_Code_Address =>
3803 Check_E0;
3805 if Nkind (P) = N_Attribute_Reference
3806 and then Attribute_Name (P) in Name_Elab_Body | Name_Elab_Spec
3807 then
3808 null;
3810 elsif not Is_Entity_Name (P)
3811 or else (Ekind (Entity (P)) /= E_Function
3812 and then
3813 Ekind (Entity (P)) /= E_Procedure)
3814 then
3815 Error_Attr ("invalid prefix for % attribute", P);
3817 -- Issue an error if the prefix denotes an eliminated subprogram
3819 else
3820 Set_Address_Taken (Entity (P));
3821 Check_For_Eliminated_Subprogram (P, Entity (P));
3822 end if;
3824 Set_Etype (N, RTE (RE_Address));
3826 ----------------------
3827 -- Compiler_Version --
3828 ----------------------
3830 when Attribute_Compiler_Version =>
3831 Check_E0;
3832 Check_Standard_Prefix;
3833 Rewrite (N, Make_String_Literal (Loc, "GNAT " & Gnat_Version_String));
3834 Analyze_And_Resolve (N, Standard_String);
3835 Set_Is_Static_Expression (N, True);
3837 --------------------
3838 -- Component_Size --
3839 --------------------
3841 when Attribute_Component_Size =>
3842 Check_E0;
3843 Set_Etype (N, Universal_Integer);
3845 -- Note: unlike other array attributes, unconstrained arrays are OK
3847 if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then
3848 null;
3849 else
3850 Check_Array_Type;
3851 end if;
3853 -------------
3854 -- Compose --
3855 -------------
3857 when Attribute_Compose
3858 | Attribute_Leading_Part
3859 | Attribute_Scaling
3861 Check_Floating_Point_Type_2;
3862 Set_Etype (N, P_Base_Type);
3863 Resolve (E1, P_Base_Type);
3864 Resolve (E2, Any_Integer);
3866 -----------------
3867 -- Constrained --
3868 -----------------
3870 when Attribute_Constrained =>
3871 Check_E0;
3872 Set_Etype (N, Standard_Boolean);
3874 -- Case from RM J.4(2) of constrained applied to private type
3876 if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
3877 Check_Restriction (No_Obsolescent_Features, P);
3879 if Warn_On_Obsolescent_Feature then
3880 Error_Msg_N
3881 ("constrained for private type is an obsolescent feature "
3882 & "(RM J.4)?j?", N);
3883 end if;
3885 -- If we are within an instance, the attribute must be legal
3886 -- because it was valid in the generic unit. Ditto if this is
3887 -- an inlining of a function declared in an instance.
3889 if In_Instance or else In_Inlined_Body then
3890 return;
3892 -- For sure OK if we have a real private type itself, but must
3893 -- be completed, cannot apply Constrained to incomplete type.
3895 elsif Is_Private_Type (Entity (P)) then
3897 -- Note: this is one of the Annex J features that does not
3898 -- generate a warning from -gnatwj, since in fact it seems
3899 -- very useful, and is used in the GNAT runtime.
3901 Check_Not_Incomplete_Type;
3902 return;
3903 end if;
3905 -- Normal (non-obsolescent case) of application to object or value of
3906 -- a discriminated type.
3908 else
3909 -- AI12-0068: In a type or subtype aspect, a prefix denoting the
3910 -- current instance of the (sub)type is defined to be a value,
3911 -- not an object, so the Constrained attribute is always True
3912 -- (see RM 8.6(18/5) and RM 3.7.2(3/5)). We issue a warning about
3913 -- this unintuitive result, to help avoid confusion.
3915 if Is_Current_Instance_Reference_In_Type_Aspect (P) then
3916 Error_Msg_Name_1 := Aname;
3917 Error_Msg_N
3918 ("current instance attribute % in subtype aspect always " &
3919 "true??", N);
3921 else
3922 Check_Object_Reference (P);
3923 end if;
3925 -- If N does not come from source, then we allow the
3926 -- the attribute prefix to be of a private type whose
3927 -- full type has discriminants. This occurs in cases
3928 -- involving expanded calls to stream attributes.
3930 if not Comes_From_Source (N) then
3931 P_Type := Underlying_Type (P_Type);
3932 end if;
3934 -- Must have discriminants or be an access type designating a type
3935 -- with discriminants. If it is a class-wide type it has unknown
3936 -- discriminants.
3938 if Has_Discriminants (P_Type)
3939 or else Has_Unknown_Discriminants (P_Type)
3940 or else
3941 (Is_Access_Type (P_Type)
3942 and then Has_Discriminants (Designated_Type (P_Type)))
3943 then
3944 return;
3946 -- The rule given in 3.7.2 is part of static semantics, but the
3947 -- intent is clearly that it be treated as a legality rule, and
3948 -- rechecked in the visible part of an instance. Nevertheless
3949 -- the intent also seems to be it should legally apply to the
3950 -- actual of a formal with unknown discriminants, regardless of
3951 -- whether the actual has discriminants, in which case the value
3952 -- of the attribute is determined using the J.4 rules. This choice
3953 -- seems the most useful, and is compatible with existing tests.
3955 elsif In_Instance then
3956 return;
3958 -- Also allow an object of a generic type if extensions allowed
3959 -- and allow this for any type at all.
3961 elsif (Is_Generic_Type (P_Type)
3962 or else Is_Generic_Actual_Type (P_Type))
3963 and then All_Extensions_Allowed
3964 then
3965 return;
3966 end if;
3967 end if;
3969 -- Fall through if bad prefix
3971 Error_Attr_P
3972 ("prefix of % attribute must be object of discriminated type");
3974 ---------------
3975 -- Copy_Sign --
3976 ---------------
3978 -- Shares processing with Adjacent attribute
3980 -----------
3981 -- Count --
3982 -----------
3984 when Attribute_Count => Count : declare
3985 Ent : Entity_Id;
3986 S : Entity_Id;
3987 Tsk : Entity_Id;
3989 begin
3990 Check_E0;
3992 if Nkind (P) in N_Identifier | N_Expanded_Name then
3993 Ent := Entity (P);
3995 if Ekind (Ent) /= E_Entry then
3996 Error_Attr ("invalid entry name", N);
3997 end if;
3999 elsif Nkind (P) = N_Indexed_Component then
4000 if not Is_Entity_Name (Prefix (P))
4001 or else No (Entity (Prefix (P)))
4002 or else Ekind (Entity (Prefix (P))) /= E_Entry_Family
4003 then
4004 if Nkind (Prefix (P)) = N_Selected_Component
4005 and then Present (Entity (Selector_Name (Prefix (P))))
4006 and then Ekind (Entity (Selector_Name (Prefix (P)))) =
4007 E_Entry_Family
4008 then
4009 Error_Attr
4010 ("attribute % must apply to entry of current task", P);
4012 else
4013 Error_Attr ("invalid entry family name", P);
4014 end if;
4016 else
4017 Ent := Entity (Prefix (P));
4018 end if;
4020 elsif Nkind (P) = N_Selected_Component
4021 and then Present (Entity (Selector_Name (P)))
4022 and then Ekind (Entity (Selector_Name (P))) = E_Entry
4023 then
4024 Error_Attr
4025 ("attribute % must apply to entry of current task", P);
4027 else
4028 Error_Attr ("invalid entry name", N);
4029 end if;
4031 for J in reverse 0 .. Scope_Stack.Last loop
4032 S := Scope_Stack.Table (J).Entity;
4034 if S = Scope (Ent) then
4035 if Nkind (P) = N_Expanded_Name then
4036 Tsk := Entity (Prefix (P));
4038 -- The prefix denotes either the task type, or else a
4039 -- single task whose task type is being analyzed.
4041 if (Is_Type (Tsk) and then Tsk = S)
4042 or else (not Is_Type (Tsk)
4043 and then Etype (Tsk) = S
4044 and then not (Comes_From_Source (S)))
4045 then
4046 null;
4047 else
4048 Error_Attr
4049 ("attribute % must apply to entry of current task", N);
4050 end if;
4051 end if;
4053 exit;
4055 elsif Ekind (Scope (Ent)) in Task_Kind
4056 and then Ekind (S) not in E_Block
4057 | E_Entry
4058 | E_Entry_Family
4059 | E_Loop
4060 then
4061 Error_Attr ("attribute % cannot appear in inner unit", N);
4063 elsif Ekind (Scope (Ent)) = E_Protected_Type
4064 and then not Has_Completion (Scope (Ent))
4065 then
4066 Error_Attr ("attribute % can only be used inside body", N);
4067 end if;
4068 end loop;
4070 if Is_Overloaded (P) then
4071 declare
4072 Index : Interp_Index;
4073 It : Interp;
4075 begin
4076 Get_First_Interp (P, Index, It);
4077 while Present (It.Nam) loop
4078 if It.Nam = Ent then
4079 null;
4081 -- Ada 2005 (AI-345): Do not consider primitive entry
4082 -- wrappers generated for task or protected types.
4084 elsif Ada_Version >= Ada_2005
4085 and then not Comes_From_Source (It.Nam)
4086 then
4087 null;
4089 else
4090 Error_Attr ("ambiguous entry name", N);
4091 end if;
4093 Get_Next_Interp (Index, It);
4094 end loop;
4095 end;
4096 end if;
4098 Set_Etype (N, Universal_Integer);
4099 end Count;
4101 -----------------------
4102 -- Default_Bit_Order --
4103 -----------------------
4105 when Attribute_Default_Bit_Order => Default_Bit_Order : declare
4106 Target_Default_Bit_Order : System.Bit_Order;
4108 begin
4109 Check_Standard_Prefix;
4111 if Bytes_Big_Endian then
4112 Target_Default_Bit_Order := System.High_Order_First;
4113 else
4114 Target_Default_Bit_Order := System.Low_Order_First;
4115 end if;
4117 Rewrite (N,
4118 Make_Integer_Literal (Loc,
4119 UI_From_Int (System.Bit_Order'Pos (Target_Default_Bit_Order))));
4121 Set_Etype (N, Universal_Integer);
4122 Set_Is_Static_Expression (N);
4123 end Default_Bit_Order;
4125 ----------------------------------
4126 -- Default_Scalar_Storage_Order --
4127 ----------------------------------
4129 when Attribute_Default_Scalar_Storage_Order => Default_SSO : declare
4130 RE_Default_SSO : RE_Id;
4132 begin
4133 Check_Standard_Prefix;
4135 case Opt.Default_SSO is
4136 when ' ' =>
4137 if Bytes_Big_Endian then
4138 RE_Default_SSO := RE_High_Order_First;
4139 else
4140 RE_Default_SSO := RE_Low_Order_First;
4141 end if;
4143 when 'H' =>
4144 RE_Default_SSO := RE_High_Order_First;
4146 when 'L' =>
4147 RE_Default_SSO := RE_Low_Order_First;
4149 when others =>
4150 raise Program_Error;
4151 end case;
4153 Rewrite (N, New_Occurrence_Of (RTE (RE_Default_SSO), Loc));
4154 end Default_SSO;
4156 --------------
4157 -- Definite --
4158 --------------
4160 when Attribute_Definite =>
4161 Legal_Formal_Attribute;
4163 -----------
4164 -- Delta --
4165 -----------
4167 when Attribute_Delta =>
4168 Check_Fixed_Point_Type_0;
4169 Set_Etype (N, Universal_Real);
4171 ------------
4172 -- Denorm --
4173 ------------
4175 when Attribute_Denorm
4176 | Attribute_Signed_Zeros
4178 Check_Floating_Point_Type_0;
4179 Set_Etype (N, Standard_Boolean);
4181 -----------
4182 -- Deref --
4183 -----------
4185 when Attribute_Deref =>
4186 Check_Type;
4187 Check_E1;
4188 Resolve (E1, RTE (RE_Address));
4189 Set_Etype (N, P_Type);
4191 ---------------------
4192 -- Descriptor_Size --
4193 ---------------------
4195 when Attribute_Descriptor_Size =>
4196 Check_E0;
4198 if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then
4199 Error_Attr_P ("prefix of attribute % must denote a type");
4200 end if;
4202 Set_Etype (N, Universal_Integer);
4204 ------------
4205 -- Digits --
4206 ------------
4208 when Attribute_Digits =>
4209 Check_E0;
4210 Check_Type;
4212 if not Is_Floating_Point_Type (P_Type)
4213 and then not Is_Decimal_Fixed_Point_Type (P_Type)
4214 then
4215 Error_Attr_P
4216 ("prefix of % attribute must be float or decimal type");
4217 end if;
4219 Set_Etype (N, Universal_Integer);
4221 ---------------
4222 -- Elab_Body --
4223 ---------------
4225 -- Also handles processing for Elab_Spec and Elab_Subp_Body
4227 when Attribute_Elab_Body
4228 | Attribute_Elab_Spec
4229 | Attribute_Elab_Subp_Body
4231 Check_E0;
4232 Check_Unit_Name (P);
4233 Set_Etype (N, Standard_Void_Type);
4235 -- We have to manually call the expander in this case to get
4236 -- the necessary expansion (normally attributes that return
4237 -- entities are not expanded).
4239 Expand (N);
4241 ---------------
4242 -- Elab_Spec --
4243 ---------------
4245 -- Shares processing with Elab_Body attribute
4247 ----------------
4248 -- Elaborated --
4249 ----------------
4251 when Attribute_Elaborated =>
4252 Check_E0;
4253 Check_Unit_Name (P);
4254 Set_Etype (N, Standard_Boolean);
4256 ----------
4257 -- Emax --
4258 ----------
4260 when Attribute_Emax
4261 | Attribute_Machine_Emax
4262 | Attribute_Machine_Emin
4263 | Attribute_Machine_Mantissa
4264 | Attribute_Model_Emin
4265 | Attribute_Model_Mantissa
4266 | Attribute_Safe_Emax
4268 Check_Floating_Point_Type_0;
4269 Set_Etype (N, Universal_Integer);
4271 -------------
4272 -- Enabled --
4273 -------------
4275 when Attribute_Enabled =>
4276 Check_Either_E0_Or_E1;
4278 if Present (E1) then
4279 if not Is_Entity_Name (E1) or else No (Entity (E1)) then
4280 Error_Msg_N ("entity name expected for Enabled attribute", E1);
4281 E1 := Empty;
4282 end if;
4283 end if;
4285 if Nkind (P) /= N_Identifier then
4286 Error_Msg_N ("identifier expected (check name)", P);
4287 elsif Get_Check_Id (Chars (P)) = No_Check_Id then
4288 Error_Msg_N ("& is not a recognized check name", P);
4289 end if;
4291 Set_Etype (N, Standard_Boolean);
4293 --------------
4294 -- Enum_Rep --
4295 --------------
4297 when Attribute_Enum_Rep =>
4299 -- T'Enum_Rep (X) case
4301 if Present (E1) then
4302 Check_E1;
4303 Check_Discrete_Type;
4304 Resolve (E1, P_Base_Type);
4306 -- X'Enum_Rep case. X must be an object or enumeration literal
4307 -- (including an attribute reference), and it must be of a
4308 -- discrete type.
4310 elsif not
4311 ((Is_Object_Reference (P)
4312 or else
4313 (Is_Entity_Name (P)
4314 and then Ekind (Entity (P)) = E_Enumeration_Literal)
4315 or else Nkind (P) = N_Attribute_Reference)
4316 and then Is_Discrete_Type (Etype (P)))
4317 then
4318 Error_Attr_P ("prefix of % attribute must be discrete object");
4319 end if;
4321 Set_Etype (N, Universal_Integer);
4323 --------------
4324 -- Enum_Val --
4325 --------------
4327 when Attribute_Enum_Val =>
4328 Check_E1;
4329 Check_Type;
4331 if not Is_Enumeration_Type (P_Type) then
4332 Error_Attr_P ("prefix of % attribute must be enumeration type");
4333 end if;
4335 -- If the enumeration type has a standard representation, the effect
4336 -- is the same as 'Val, so rewrite the attribute as a 'Val.
4338 if not Has_Non_Standard_Rep (P_Base_Type) then
4339 Rewrite (N,
4340 Make_Attribute_Reference (Loc,
4341 Prefix => Relocate_Node (Prefix (N)),
4342 Attribute_Name => Name_Val,
4343 Expressions => New_List (Relocate_Node (E1))));
4344 Analyze_And_Resolve (N, P_Base_Type);
4346 -- Non-standard representation case (enumeration with holes)
4348 else
4349 Check_Enum_Image;
4350 Resolve (E1, Any_Integer);
4351 Set_Etype (N, P_Base_Type);
4352 end if;
4354 -------------
4355 -- Epsilon --
4356 -------------
4358 when Attribute_Epsilon
4359 | Attribute_Model_Epsilon
4360 | Attribute_Model_Small
4361 | Attribute_Safe_First
4362 | Attribute_Safe_Last
4364 Check_Floating_Point_Type_0;
4365 Set_Etype (N, Universal_Real);
4367 --------------
4368 -- Exponent --
4369 --------------
4371 when Attribute_Exponent =>
4372 Check_Floating_Point_Type_1;
4373 Set_Etype (N, Universal_Integer);
4374 Resolve (E1, P_Base_Type);
4376 ------------------
4377 -- External_Tag --
4378 ------------------
4380 when Attribute_External_Tag =>
4381 Check_E0;
4382 Check_Type;
4384 Set_Etype (N, Standard_String);
4386 if not Is_Tagged_Type (P_Type) then
4387 Error_Attr_P ("prefix of % attribute must be tagged");
4388 end if;
4390 ---------------
4391 -- Fast_Math --
4392 ---------------
4394 when Attribute_Fast_Math =>
4395 Check_Standard_Prefix;
4396 Rewrite (N, New_Occurrence_Of (Boolean_Literals (Fast_Math), Loc));
4398 -----------------------
4399 -- Finalization_Size --
4400 -----------------------
4402 when Attribute_Finalization_Size =>
4403 Check_E0;
4405 -- The prefix denotes an object
4407 if Is_Object_Reference (P) then
4408 Check_Object_Reference (P);
4410 -- The prefix denotes a type
4412 elsif Is_Entity_Name (P) and then Is_Type (Entity (P)) then
4413 Check_Type;
4414 Check_Not_Incomplete_Type;
4416 -- Attribute 'Finalization_Size is not defined for class-wide
4417 -- types because it is not possible to know statically whether
4418 -- a definite type will have controlled components or not.
4420 if Is_Class_Wide_Type (Etype (P)) then
4421 Error_Attr_P
4422 ("prefix of % attribute cannot denote a class-wide type");
4423 end if;
4425 -- The prefix denotes an illegal construct
4427 else
4428 Error_Attr_P
4429 ("prefix of % attribute must be a definite type or an object");
4430 end if;
4432 Set_Etype (N, Universal_Integer);
4434 -----------
4435 -- First --
4436 -----------
4438 when Attribute_First
4439 | Attribute_Last
4441 Check_Array_Or_Scalar_Type;
4442 Bad_Attribute_For_Predicate;
4444 ---------------
4445 -- First_Bit --
4446 ---------------
4448 when Attribute_First_Bit
4449 | Attribute_Last_Bit
4450 | Attribute_Position
4452 Check_Component;
4453 Set_Etype (N, Universal_Integer);
4455 -----------------
4456 -- First_Valid --
4457 -----------------
4459 when Attribute_First_Valid
4460 | Attribute_Last_Valid
4462 Check_First_Last_Valid;
4463 Set_Etype (N, P_Type);
4465 -----------------
4466 -- Fixed_Value --
4467 -----------------
4469 when Attribute_Fixed_Value =>
4470 Check_Fixed_Point_Type;
4471 Check_E1;
4472 Resolve (E1, Any_Integer);
4473 Set_Etype (N, P_Base_Type);
4475 -----------
4476 -- Floor --
4477 -----------
4479 -- Shares processing with Ceiling attribute
4481 ----------
4482 -- Fore --
4483 ----------
4485 when Attribute_Fore =>
4486 Check_Fixed_Point_Type_0;
4487 Set_Etype (N, Universal_Integer);
4489 --------------
4490 -- Fraction --
4491 --------------
4493 -- Shares processing with Ceiling attribute
4495 --------------
4496 -- From_Any --
4497 --------------
4499 when Attribute_From_Any =>
4500 Check_E1;
4501 Check_PolyORB_Attribute;
4502 Set_Etype (N, P_Base_Type);
4504 -----------------------
4505 -- Has_Access_Values --
4506 -----------------------
4508 when Attribute_Has_Access_Values
4509 | Attribute_Has_Tagged_Values
4511 Check_Type;
4512 Check_E0;
4513 Set_Etype (N, Standard_Boolean);
4515 ----------------------
4516 -- Has_Same_Storage --
4517 ----------------------
4519 when Attribute_Has_Same_Storage
4520 | Attribute_Overlaps_Storage
4522 Check_E1;
4524 -- The arguments must be objects of any type
4526 Analyze_And_Resolve (P);
4527 Analyze_And_Resolve (E1);
4528 Check_Object_Reference (P);
4529 Check_Object_Reference (E1);
4530 Set_Etype (N, Standard_Boolean);
4532 -----------
4533 -- Index --
4534 -----------
4536 when Attribute_Index => Index : declare
4537 Ent : Entity_Id;
4538 Legal : Boolean;
4539 Spec_Id : Entity_Id;
4541 begin
4542 Check_E0;
4543 Analyze_Index_Attribute (Legal, Spec_Id);
4545 if not Legal or else No (Spec_Id) then
4546 Error_Attr ("attribute % must apply to entry family", P);
4547 end if;
4549 -- Legality checks
4551 if Nkind (P) in N_Identifier | N_Expanded_Name then
4552 Ent := Entity (P);
4554 if Ekind (Ent) /= E_Entry_Family then
4555 Error_Attr
4556 ("attribute % must apply to entry family", P);
4558 -- Analysis of pre/postconditions of an entry [family] occurs when
4559 -- the conditions are relocated to the contract wrapper procedure
4560 -- (see subprogram Build_Contract_Wrapper).
4562 elsif Contract_Wrapper (Ent) /= Spec_Id then
4563 Error_Attr
4564 ("attribute % must apply to current entry family", P);
4565 end if;
4567 elsif Nkind (P) in N_Indexed_Component
4568 | N_Selected_Component
4569 then
4570 Error_Attr
4571 ("attribute % must apply to current entry family", P);
4573 else
4574 Error_Attr ("invalid entry family name", N);
4575 end if;
4577 Set_Etype (N, Entry_Index_Type (Ent));
4578 end Index;
4580 -----------------------
4581 -- Has_Tagged_Values --
4582 -----------------------
4584 -- Shares processing with Has_Access_Values attribute
4586 -----------------------
4587 -- Has_Discriminants --
4588 -----------------------
4590 when Attribute_Has_Discriminants =>
4591 Legal_Formal_Attribute;
4593 --------------
4594 -- Identity --
4595 --------------
4597 when Attribute_Identity =>
4598 Check_E0;
4600 if Etype (P) = Standard_Exception_Type then
4601 Set_Etype (N, RTE (RE_Exception_Id));
4603 -- Ada 2005 (AI-345): Attribute 'Identity may be applied to task
4604 -- interface class-wide types.
4606 elsif Is_Task_Type (Etype (P))
4607 or else (Is_Access_Type (Etype (P))
4608 and then Is_Task_Type (Designated_Type (Etype (P))))
4609 or else (Ada_Version >= Ada_2005
4610 and then Ekind (Etype (P)) = E_Class_Wide_Type
4611 and then Is_Interface (Etype (P))
4612 and then Is_Task_Interface (Etype (P)))
4613 then
4614 Resolve (P);
4615 Set_Etype (N, RTE (RO_AT_Task_Id));
4617 else
4618 if Ada_Version >= Ada_2005 then
4619 Error_Attr_P
4620 ("prefix of % attribute must be an exception, a task or a "
4621 & "task interface class-wide object");
4622 else
4623 Error_Attr_P
4624 ("prefix of % attribute must be a task or an exception");
4625 end if;
4626 end if;
4628 -----------
4629 -- Image --
4630 -----------
4632 when Attribute_Image =>
4633 if Is_Real_Type (P_Type) then
4634 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
4635 Error_Msg_Name_1 := Aname;
4636 Error_Msg_N
4637 ("(Ada 83) % attribute not allowed for real types", N);
4638 end if;
4639 end if;
4641 Analyze_Image_Attribute (Standard_String);
4643 ---------
4644 -- Img --
4645 ---------
4647 when Attribute_Img =>
4648 Analyze_Image_Attribute (Standard_String);
4650 -----------------
4651 -- Initialized --
4652 -----------------
4654 when Attribute_Initialized =>
4655 Check_E0;
4657 if Comes_From_Source (N) then
4659 -- This attribute can be prefixed with references to objects or
4660 -- values (such as a current instance value given within a type
4661 -- or subtype aspect).
4663 if not Is_Object_Reference (P)
4664 and then not Is_Current_Instance_Reference_In_Type_Aspect (P)
4665 then
4666 Error_Attr_P ("prefix of % attribute must be object");
4668 -- Just like attribute 'Valid_Scalars this attribute is illegal
4669 -- on unchecked union types.
4671 elsif Has_Unchecked_Union (Validated_View (P_Type)) then
4672 Error_Attr_P
4673 ("attribute % not allowed for Unchecked_Union type");
4674 end if;
4675 end if;
4677 Set_Etype (N, Standard_Boolean);
4679 -----------
4680 -- Input --
4681 -----------
4683 when Attribute_Input =>
4684 Check_E1;
4685 Check_Stream_Attribute (TSS_Stream_Input);
4686 Set_Etype (N, P_Base_Type);
4688 -------------------
4689 -- Integer_Value --
4690 -------------------
4692 when Attribute_Integer_Value =>
4693 Check_E1;
4694 Check_Integer_Type;
4695 Resolve (E1, Any_Fixed);
4697 -- Signal an error if argument type is not a specific fixed-point
4698 -- subtype. An error has been signalled already if the argument
4699 -- was not of a fixed-point type.
4701 if Etype (E1) = Any_Fixed and then not Error_Posted (E1) then
4702 Error_Attr ("argument of % must be of a fixed-point type", E1);
4703 end if;
4705 Set_Etype (N, P_Base_Type);
4707 -------------------
4708 -- Invalid_Value --
4709 -------------------
4711 when Attribute_Invalid_Value =>
4712 Check_E0;
4713 Check_Scalar_Type;
4714 Set_Etype (N, P_Base_Type);
4715 Invalid_Value_Used := True;
4717 -----------
4718 -- Large --
4719 -----------
4721 when Attribute_Large
4722 | Attribute_Small
4723 | Attribute_Safe_Large
4724 | Attribute_Safe_Small
4726 Check_E0;
4727 Check_Real_Type;
4728 Set_Etype (N, Universal_Real);
4730 ----------
4731 -- Last --
4732 ----------
4734 -- Shares processing with First attribute
4736 --------------
4737 -- Last_Bit --
4738 --------------
4740 -- Shares processing with First_Bit attribute
4742 ----------------
4743 -- Last_Valid --
4744 ----------------
4746 -- Shares processing with First_Valid attribute
4748 ------------------
4749 -- Leading_Part --
4750 ------------------
4752 -- Shares processing with Compose attribute
4754 ------------
4755 -- Length --
4756 ------------
4758 when Attribute_Length =>
4759 Check_Array_Type;
4760 Set_Etype (N, Universal_Integer);
4762 -------------------
4763 -- Library_Level --
4764 -------------------
4766 when Attribute_Library_Level =>
4767 Check_E0;
4769 if not Is_Entity_Name (P) then
4770 Error_Attr_P ("prefix of % attribute must be an entity name");
4771 end if;
4773 if not Inside_A_Generic then
4774 Set_Boolean_Result (N,
4775 Is_Library_Level_Entity (Entity (P)));
4776 end if;
4778 Set_Etype (N, Standard_Boolean);
4780 ----------------
4781 -- Loop_Entry --
4782 ----------------
4784 when Attribute_Loop_Entry => Loop_Entry : declare
4785 procedure Check_References_In_Prefix (Loop_Id : Entity_Id);
4786 -- Inspect the prefix for any uses of entities declared within the
4787 -- related loop. Loop_Id denotes the loop identifier.
4789 --------------------------------
4790 -- Check_References_In_Prefix --
4791 --------------------------------
4793 procedure Check_References_In_Prefix (Loop_Id : Entity_Id) is
4794 Loop_Decl : constant Node_Id := Label_Construct (Parent (Loop_Id));
4796 function Check_Reference (Nod : Node_Id) return Traverse_Result;
4797 -- Detect attribute 'Loop_Entry in prefix P and determine whether
4798 -- a reference mentions an entity declared within the related
4799 -- loop.
4801 function Declared_Within (Nod : Node_Id) return Boolean;
4802 -- Determine whether Nod appears in the subtree of Loop_Decl but
4803 -- not within the subtree of the prefix P itself.
4805 ---------------------
4806 -- Check_Reference --
4807 ---------------------
4809 function Check_Reference (Nod : Node_Id) return Traverse_Result is
4810 Orig_Nod : constant Node_Id := Original_Node (Nod);
4811 -- Check presence of Loop_Entry in the prefix P by looking at
4812 -- the original node for Nod, as it will have been rewritten
4813 -- into its own prefix if the assertion is ignored (see code
4814 -- below).
4816 begin
4817 if Is_Attribute_Loop_Entry (Orig_Nod) then
4818 Error_Msg_Name_1 := Name_Loop_Entry;
4819 Error_Msg_Name_2 := Name_Loop_Entry;
4820 Error_Msg_N
4821 ("attribute % cannot appear in the prefix of attribute %",
4822 Nod);
4823 return Abandon;
4825 elsif Nkind (Nod) = N_Identifier
4826 and then Present (Entity (Nod))
4827 and then Declared_Within (Declaration_Node (Entity (Nod)))
4828 then
4829 Error_Attr
4830 ("prefix of attribute % cannot reference local entities",
4831 Nod);
4832 else
4833 return OK;
4834 end if;
4835 end Check_Reference;
4837 procedure Check_References is new Traverse_Proc (Check_Reference);
4839 ---------------------
4840 -- Declared_Within --
4841 ---------------------
4843 function Declared_Within (Nod : Node_Id) return Boolean is
4844 Stmt : Node_Id;
4846 begin
4847 Stmt := Nod;
4848 while Present (Stmt) loop
4849 if Stmt = Loop_Decl then
4850 return True;
4852 elsif Stmt = P then
4853 return False;
4855 -- Prevent the search from going too far
4857 elsif Is_Body_Or_Package_Declaration (Stmt) then
4858 exit;
4859 end if;
4861 Stmt := Parent (Stmt);
4862 end loop;
4864 return False;
4865 end Declared_Within;
4867 -- Start of processing for Check_Prefix_For_Local_References
4869 begin
4870 Check_References (P);
4871 end Check_References_In_Prefix;
4873 -- Local variables
4875 Context : constant Node_Id := Parent (N);
4876 Attr : Node_Id;
4877 Encl_Loop : Node_Id := Empty;
4878 Encl_Prag : Node_Id := Empty;
4879 Loop_Id : Entity_Id := Empty;
4880 Scop : Entity_Id;
4881 Stmt : Node_Id;
4883 -- Start of processing for Loop_Entry
4885 begin
4886 Attr := N;
4888 -- Set the type of the attribute now to ensure the successful
4889 -- continuation of analysis even if the attribute is misplaced.
4891 Set_Etype (Attr, P_Type);
4893 -- Attribute 'Loop_Entry may appear in several flavors:
4895 -- * Prefix'Loop_Entry - in this form, the attribute applies to the
4896 -- nearest enclosing loop.
4898 -- * Prefix'Loop_Entry (Expr) - depending on what Expr denotes, the
4899 -- attribute may be related to a loop denoted by label Expr or
4900 -- the prefix may denote an array object and Expr may act as an
4901 -- indexed component.
4903 -- * Prefix'Loop_Entry (Expr1, ..., ExprN) - the attribute applies
4904 -- to the nearest enclosing loop, all expressions are part of
4905 -- an indexed component.
4907 -- * Prefix'Loop_Entry (Expr) (...) (...) - depending on what Expr
4908 -- denotes, the attribute may be related to a loop denoted by
4909 -- label Expr or the prefix may denote a multidimensional array
4910 -- array object and Expr along with the rest of the expressions
4911 -- may act as indexed components.
4913 -- Regardless of variations, the attribute reference does not have an
4914 -- expression list. Instead, all available expressions are stored as
4915 -- indexed components.
4917 -- When the attribute is part of an indexed component, find the first
4918 -- expression as it will determine the semantics of 'Loop_Entry.
4920 -- If the attribute is itself an index in an indexed component, i.e.
4921 -- a member of a list, the context itself is not relevant (the code
4922 -- below would lead to an infinite loop) and the attribute applies
4923 -- to the enclosing loop.
4925 if Nkind (Context) = N_Indexed_Component
4926 and then not Is_List_Member (N)
4927 then
4928 E1 := First (Expressions (Context));
4929 E2 := Next (E1);
4931 -- The attribute reference appears in the following form:
4933 -- Prefix'Loop_Entry (Exp1, Expr2, ..., ExprN) [(...)]
4935 -- In this case, the loop name is omitted and no rewriting is
4936 -- required.
4938 if Present (E2) then
4939 null;
4941 -- The form of the attribute is:
4943 -- Prefix'Loop_Entry (Expr) [(...)]
4945 -- If Expr denotes a loop entry, the whole attribute and indexed
4946 -- component will have to be rewritten to reflect this relation.
4948 else
4949 pragma Assert (Present (E1));
4951 -- Do not expand the expression as it may have side effects.
4952 -- Simply preanalyze to determine whether it is a loop name or
4953 -- something else.
4955 Preanalyze_And_Resolve (E1);
4957 if Is_Entity_Name (E1)
4958 and then Present (Entity (E1))
4959 and then Ekind (Entity (E1)) = E_Loop
4960 then
4961 Loop_Id := Entity (E1);
4963 -- Transform the attribute and enclosing indexed component
4965 Set_Expressions (N, Expressions (Context));
4966 Rewrite (Context, N);
4967 Set_Etype (Context, P_Type);
4969 Attr := Context;
4970 end if;
4971 end if;
4972 end if;
4974 -- The prefix must denote an object
4976 if not Is_Object_Reference (P) then
4977 Error_Attr_P ("prefix of attribute % must denote an object");
4978 end if;
4980 -- The prefix cannot be of a limited type because the expansion of
4981 -- Loop_Entry must create a constant initialized by the evaluated
4982 -- prefix.
4984 if Is_Inherently_Limited_Type (Etype (P)) then
4985 Error_Attr_P ("prefix of attribute % cannot be limited");
4986 end if;
4988 -- Climb the parent chain to verify the location of the attribute and
4989 -- find the enclosing loop.
4991 Stmt := Attr;
4992 while Present (Stmt) loop
4994 -- Locate the corresponding enclosing pragma. Note that in the
4995 -- case of Assert[And_Cut] and Assume, we have already checked
4996 -- that the pragma appears in an appropriate loop location.
4998 if Nkind (Original_Node (Stmt)) = N_Pragma
4999 and then
5000 Pragma_Name_Unmapped (Original_Node (Stmt))
5001 in Name_Loop_Invariant
5002 | Name_Loop_Variant
5003 | Name_Assert
5004 | Name_Assert_And_Cut
5005 | Name_Assume
5006 then
5007 Encl_Prag := Original_Node (Stmt);
5009 -- Locate the enclosing loop (if any). Note that Ada 2012 array
5010 -- iteration may be expanded into several nested loops, we are
5011 -- interested in the outermost one which has the loop identifier,
5012 -- and comes from source.
5014 elsif Nkind (Stmt) = N_Loop_Statement
5015 and then Present (Identifier (Stmt))
5016 and then Comes_From_Source (Original_Node (Stmt))
5017 and then Nkind (Original_Node (Stmt)) = N_Loop_Statement
5018 then
5019 Encl_Loop := Stmt;
5021 -- The original attribute reference may lack a loop name. Use
5022 -- the name of the enclosing loop because it is the related
5023 -- loop.
5025 if No (Loop_Id) then
5026 Loop_Id := Entity (Identifier (Encl_Loop));
5027 end if;
5029 exit;
5031 -- Prevent the search from going too far
5033 elsif Is_Body_Or_Package_Declaration (Stmt) then
5034 exit;
5035 end if;
5037 Stmt := Parent (Stmt);
5038 end loop;
5040 -- Loop_Entry must appear within a Loop_Assertion pragma (Assert,
5041 -- Assert_And_Cut, Assume count as loop assertion pragmas for this
5042 -- purpose if they appear in an appropriate location in a loop,
5043 -- which was already checked by the top level pragma circuit).
5045 -- Loop_Entry also denotes a value and as such can appear within an
5046 -- expression that is an argument for another loop aspect. In that
5047 -- case it will have been expanded into the corresponding assignment.
5049 if Expander_Active
5050 and then Nkind (Parent (N)) = N_Assignment_Statement
5051 and then not Comes_From_Source (Parent (N))
5052 then
5053 null;
5055 elsif No (Encl_Prag) then
5056 Error_Attr ("attribute% must appear within appropriate pragma", N);
5057 end if;
5059 -- A Loop_Entry that applies to a given loop statement must not
5060 -- appear within a body of accept statement, if this construct is
5061 -- itself enclosed by the given loop statement.
5063 for Index in reverse 0 .. Scope_Stack.Last loop
5064 Scop := Scope_Stack.Table (Index).Entity;
5066 if Ekind (Scop) = E_Loop and then Scop = Loop_Id then
5067 exit;
5068 elsif Ekind (Scop) in E_Block | E_Loop | E_Return_Statement then
5069 null;
5070 else
5071 Error_Attr
5072 ("attribute % cannot appear in body or accept statement", N);
5073 end if;
5074 end loop;
5076 -- The prefix cannot mention entities declared within the related
5077 -- loop because they will not be visible once the prefix is moved
5078 -- outside the loop.
5080 Check_References_In_Prefix (Loop_Id);
5082 -- The prefix must statically name an object if the pragma does not
5083 -- apply to the innermost enclosing loop statement, or if it appears
5084 -- within a potentially unevaluated expression.
5086 if Is_Entity_Name (P)
5087 or else Nkind (Parent (P)) = N_Object_Renaming_Declaration
5088 or else Statically_Names_Object (P)
5089 then
5090 null;
5092 elsif Present (Encl_Loop)
5093 and then Entity (Identifier (Encl_Loop)) /= Loop_Id
5094 then
5095 Error_Attr_P
5096 ("prefix of attribute % that applies to outer loop must denote "
5097 & "an entity");
5099 elsif Is_Potentially_Unevaluated (P) then
5100 Uneval_Old_Msg;
5101 end if;
5103 -- Replace the Loop_Entry attribute reference by its prefix if the
5104 -- related pragma is ignored. This transformation is OK with respect
5105 -- to typing because Loop_Entry's type is that of its prefix. This
5106 -- early transformation also avoids the generation of a useless loop
5107 -- entry constant.
5109 if Present (Encl_Prag) and then Is_Ignored (Encl_Prag) then
5110 Rewrite (N, Relocate_Node (P));
5111 Preanalyze_And_Resolve (N);
5113 else
5114 Preanalyze_And_Resolve (P);
5115 end if;
5116 end Loop_Entry;
5118 -------------
5119 -- Machine --
5120 -------------
5122 -- Shares processing with Ceiling attribute
5124 ------------------
5125 -- Machine_Emax --
5126 ------------------
5128 -- Shares processing with Emax attribute
5130 ------------------
5131 -- Machine_Emin --
5132 ------------------
5134 -- Shares processing with Emax attribute
5136 ----------------------
5137 -- Machine_Mantissa --
5138 ----------------------
5140 -- Shares processing with Emax attribute
5142 -----------------------
5143 -- Machine_Overflows --
5144 -----------------------
5146 when Attribute_Machine_Overflows
5147 | Attribute_Machine_Rounds
5149 Check_Real_Type;
5150 Check_E0;
5151 Set_Etype (N, Standard_Boolean);
5153 -------------------
5154 -- Machine_Radix --
5155 -------------------
5157 when Attribute_Machine_Radix
5158 | Attribute_Mantissa
5160 Check_Real_Type;
5161 Check_E0;
5162 Set_Etype (N, Universal_Integer);
5164 ----------------------
5165 -- Machine_Rounding --
5166 ----------------------
5168 -- Shares processing with Ceiling attribute
5170 --------------------
5171 -- Machine_Rounds --
5172 --------------------
5174 -- Shares processing with Machine_Overflows attribute
5176 ------------------
5177 -- Machine_Size --
5178 ------------------
5180 when Attribute_Machine_Size
5181 | Attribute_Object_Size
5182 | Attribute_Value_Size
5184 Check_E0;
5185 Check_Type;
5186 Check_Not_Incomplete_Type;
5187 Set_Etype (N, Universal_Integer);
5189 --------------
5190 -- Mantissa --
5191 --------------
5193 -- Shares processing with Machine_Radix attribute
5195 ---------
5196 -- Max --
5197 ---------
5199 when Attribute_Max =>
5200 Min_Max;
5202 ----------------------------------
5203 -- Max_Alignment_For_Allocation --
5204 ----------------------------------
5206 when Attribute_Max_Size_In_Storage_Elements =>
5207 Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements;
5209 ----------------------
5210 -- Max_Integer_Size --
5211 ----------------------
5213 when Attribute_Max_Integer_Size =>
5214 Standard_Attribute (System_Max_Integer_Size);
5216 ----------------------------------
5217 -- Max_Size_In_Storage_Elements --
5218 ----------------------------------
5220 when Attribute_Max_Alignment_For_Allocation =>
5221 Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements;
5223 -----------------------
5224 -- Maximum_Alignment --
5225 -----------------------
5227 when Attribute_Maximum_Alignment =>
5228 Standard_Attribute (Ttypes.Maximum_Alignment);
5230 --------------------
5231 -- Mechanism_Code --
5232 --------------------
5234 when Attribute_Mechanism_Code =>
5235 if not Is_Entity_Name (P)
5236 or else not Is_Subprogram (Entity (P))
5237 then
5238 Error_Attr_P ("prefix of % attribute must be subprogram");
5239 end if;
5241 Check_Either_E0_Or_E1;
5243 if Present (E1) then
5244 Resolve (E1, Any_Integer);
5245 Set_Etype (E1, Standard_Integer);
5247 if not Is_OK_Static_Expression (E1) then
5248 Flag_Non_Static_Expr
5249 ("expression for parameter number must be static!", E1);
5250 Error_Attr;
5252 elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
5253 or else Intval (E1) < 0
5254 then
5255 Error_Attr ("invalid parameter number for % attribute", E1);
5256 end if;
5257 end if;
5259 Set_Etype (N, Universal_Integer);
5261 ---------
5262 -- Min --
5263 ---------
5265 when Attribute_Min =>
5266 Min_Max;
5268 ---------
5269 -- Mod --
5270 ---------
5272 when Attribute_Mod =>
5274 -- Note: this attribute is only allowed in Ada 2005 mode, but
5275 -- we do not need to test that here, since Mod is only recognized
5276 -- as an attribute name in Ada 2005 mode during the parse.
5278 Check_E1;
5279 Check_Modular_Integer_Type;
5280 Resolve (E1, Any_Integer);
5281 Set_Etype (N, P_Base_Type);
5283 -----------
5284 -- Model --
5285 -----------
5287 -- Shares processing with Ceiling attribute
5289 ----------------
5290 -- Model_Emin --
5291 ----------------
5293 -- Shares processing with Emax attribute
5295 -------------------
5296 -- Model_Epsilon --
5297 -------------------
5299 -- Shares processing with Epsilon attribute
5301 --------------------
5302 -- Model_Mantissa --
5303 --------------------
5305 -- Shares processing with Emax attribute
5307 -----------------
5308 -- Model_Small --
5309 -----------------
5311 -- Shares processing with Epsilon attribute
5313 -------------
5314 -- Modulus --
5315 -------------
5317 when Attribute_Modulus =>
5318 Check_E0;
5319 Check_Modular_Integer_Type;
5320 Set_Etype (N, Universal_Integer);
5322 --------------------
5323 -- Null_Parameter --
5324 --------------------
5326 when Attribute_Null_Parameter => Null_Parameter : declare
5327 Parnt : constant Node_Id := Parent (N);
5328 GParnt : constant Node_Id := Parent (Parnt);
5330 procedure Bad_Null_Parameter (Msg : String);
5331 -- Used if bad Null parameter attribute node is found. Issues
5332 -- given error message, and also sets the type to Any_Type to
5333 -- avoid blowups later on from dealing with a junk node.
5335 procedure Must_Be_Imported (Proc_Ent : Entity_Id);
5336 -- Called to check that Proc_Ent is imported subprogram
5338 ------------------------
5339 -- Bad_Null_Parameter --
5340 ------------------------
5342 procedure Bad_Null_Parameter (Msg : String) is
5343 begin
5344 Error_Msg_N (Msg, N);
5345 Set_Etype (N, Any_Type);
5346 end Bad_Null_Parameter;
5348 ----------------------
5349 -- Must_Be_Imported --
5350 ----------------------
5352 procedure Must_Be_Imported (Proc_Ent : Entity_Id) is
5353 Pent : constant Entity_Id := Ultimate_Alias (Proc_Ent);
5355 begin
5356 -- Ignore check if procedure not frozen yet (we will get
5357 -- another chance when the default parameter is reanalyzed)
5359 if not Is_Frozen (Pent) then
5360 return;
5362 elsif not Is_Imported (Pent) then
5363 Bad_Null_Parameter
5364 ("Null_Parameter can only be used with imported subprogram");
5366 else
5367 return;
5368 end if;
5369 end Must_Be_Imported;
5371 -- Start of processing for Null_Parameter
5373 begin
5374 Check_Type;
5375 Check_E0;
5376 Set_Etype (N, P_Type);
5378 -- Case of attribute used as default expression
5380 if Nkind (Parnt) = N_Parameter_Specification then
5381 Must_Be_Imported (Defining_Entity (GParnt));
5383 -- Case of attribute used as actual for subprogram (positional)
5385 elsif Nkind (Parnt) in N_Subprogram_Call
5386 and then Is_Entity_Name (Name (Parnt))
5387 then
5388 Must_Be_Imported (Entity (Name (Parnt)));
5390 -- Case of attribute used as actual for subprogram (named)
5392 elsif Nkind (Parnt) = N_Parameter_Association
5393 and then Nkind (GParnt) in N_Subprogram_Call
5394 and then Is_Entity_Name (Name (GParnt))
5395 then
5396 Must_Be_Imported (Entity (Name (GParnt)));
5398 -- Not an allowed case
5400 else
5401 Bad_Null_Parameter
5402 ("Null_Parameter must be actual or default parameter");
5403 end if;
5404 end Null_Parameter;
5406 -----------------
5407 -- Object_Size --
5408 -----------------
5410 -- Shares processing with Machine_Size attribute
5412 ---------
5413 -- Old --
5414 ---------
5416 when Attribute_Old => Old : declare
5417 procedure Check_References_In_Prefix (Subp_Id : Entity_Id);
5418 -- Inspect the contents of the prefix and detect illegal uses of a
5419 -- nested 'Old, attribute 'Result or a use of an entity declared in
5420 -- the related postcondition expression. Subp_Id is the subprogram to
5421 -- which the related postcondition applies.
5423 --------------------------------
5424 -- Check_References_In_Prefix --
5425 --------------------------------
5427 procedure Check_References_In_Prefix (Subp_Id : Entity_Id) is
5428 function Check_Reference (Nod : Node_Id) return Traverse_Result;
5429 -- Detect attribute 'Old, attribute 'Result of a use of an entity
5430 -- and perform the appropriate semantic check.
5432 ---------------------
5433 -- Check_Reference --
5434 ---------------------
5436 function Check_Reference (Nod : Node_Id) return Traverse_Result is
5437 begin
5438 -- Attributes 'Old and 'Result cannot appear in the prefix of
5439 -- another attribute 'Old.
5441 if Nkind (Nod) = N_Attribute_Reference
5442 and then Attribute_Name (Nod) in Name_Old | Name_Result
5443 then
5444 Error_Msg_Name_1 := Attribute_Name (Nod);
5445 Error_Msg_Name_2 := Name_Old;
5446 Error_Msg_N
5447 ("attribute % cannot appear in the prefix of attribute %",
5448 Nod);
5449 return Abandon;
5451 -- Entities mentioned within the prefix of attribute 'Old must
5452 -- be global to the related postcondition. If this is not the
5453 -- case, then the scope of the local entity is nested within
5454 -- that of the subprogram. Moreover, we need to know whether
5455 -- Entity (Nod) occurs in the tree rooted at the prefix to
5456 -- ensure the entity is not declared within then prefix itself.
5458 elsif Is_Entity_Name (Nod)
5459 and then Present (Entity (Nod))
5460 and then Scope_Within (Scope (Entity (Nod)), Subp_Id)
5461 and then not In_Subtree (Entity (Nod), P)
5462 then
5463 Error_Attr
5464 ("prefix of attribute % cannot reference local entities",
5465 Nod);
5467 -- Otherwise keep inspecting the prefix
5469 else
5470 return OK;
5471 end if;
5472 end Check_Reference;
5474 procedure Check_References is new Traverse_Proc (Check_Reference);
5476 -- Start of processing for Check_References_In_Prefix
5478 begin
5479 Check_References (P);
5480 end Check_References_In_Prefix;
5482 -- Local variables
5484 Legal : Boolean;
5485 Pref_Id : Entity_Id;
5486 Pref_Typ : Entity_Id;
5487 Spec_Id : Entity_Id;
5489 -- Start of processing for Old
5491 begin
5492 -- The attribute reference is a primary. If any expressions follow,
5493 -- then the attribute reference is an indexable object. Transform the
5494 -- attribute into an indexed component and analyze it.
5496 if Present (E1) then
5497 Rewrite (N,
5498 Make_Indexed_Component (Loc,
5499 Prefix =>
5500 Make_Attribute_Reference (Loc,
5501 Prefix => Relocate_Node (P),
5502 Attribute_Name => Name_Old),
5503 Expressions => Expressions (N)));
5504 Analyze (N);
5505 return;
5506 end if;
5508 Analyze_Attribute_Old_Result (Legal, Spec_Id);
5510 -- The aspect or pragma where attribute 'Old resides should be
5511 -- associated with a subprogram declaration or a body. If this is not
5512 -- the case, then the aspect or pragma is illegal. Return as analysis
5513 -- cannot be carried out.
5515 -- The exception to this rule is when generating C since in this case
5516 -- postconditions are inlined.
5518 if No (Spec_Id)
5519 and then Modify_Tree_For_C
5520 and then In_Inlined_Body
5521 then
5522 Spec_Id := Entity (P);
5524 elsif not Legal then
5525 return;
5526 end if;
5528 -- The prefix must be preanalyzed as the full analysis will take
5529 -- place during expansion.
5531 Preanalyze_And_Resolve (P);
5533 -- Ensure that the prefix does not contain attributes 'Old or 'Result
5535 Check_References_In_Prefix (Spec_Id);
5537 -- Set the type of the attribute now to prevent cascaded errors
5539 Pref_Typ := Etype (P);
5540 Set_Etype (N, Pref_Typ);
5542 -- Legality checks
5544 if Is_Limited_Type (Pref_Typ) then
5545 Error_Attr ("attribute % cannot apply to limited objects", P);
5546 end if;
5548 -- The prefix is a simple name
5550 if Is_Entity_Name (P) and then Present (Entity (P)) then
5551 Pref_Id := Entity (P);
5553 -- Emit a warning when the prefix is a constant. Note that the use
5554 -- of Error_Attr would reset the type of N to Any_Type even though
5555 -- this is a warning. Use Error_Msg_XXX instead.
5557 if Is_Constant_Object (Pref_Id) then
5558 Error_Msg_Name_1 := Name_Old;
5559 Error_Msg_N
5560 ("??attribute % applied to constant has no effect", P);
5561 end if;
5563 -- Otherwise the prefix is not a simple name
5565 else
5566 -- Ensure that the prefix of attribute 'Old is an entity when it
5567 -- is potentially unevaluated (6.1.1 (27/3)). This rule is
5568 -- relaxed in Ada 2022 - this relaxation is reflected in the
5569 -- call (below) to Eligible_For_Conditional_Evaluation.
5571 if Is_Potentially_Unevaluated (N)
5572 and then not Statically_Names_Object (P)
5573 and then not
5574 Old_Attr_Util.Conditional_Evaluation
5575 .Eligible_For_Conditional_Evaluation (N)
5576 then
5577 Uneval_Old_Msg;
5579 -- Detect a possible infinite recursion when the prefix denotes
5580 -- the related function.
5582 -- function Func (...) return ...
5583 -- with Post => Func'Old ...;
5585 -- The function may be specified in qualified form X.Y where X is
5586 -- a protected object and Y is a protected function. In that case
5587 -- ensure that the qualified form has an entity.
5589 elsif Nkind (P) = N_Function_Call
5590 and then Nkind (Name (P)) in N_Has_Entity
5591 then
5592 Pref_Id := Entity (Name (P));
5594 if Ekind (Spec_Id) in E_Function | E_Generic_Function
5595 and then Pref_Id = Spec_Id
5596 then
5597 Error_Msg_Warn := SPARK_Mode /= On;
5598 Error_Msg_N ("!possible infinite recursion<<", P);
5599 Error_Msg_N ("\!??Storage_Error ]<<", P);
5600 end if;
5601 end if;
5603 -- The prefix of attribute 'Old may refer to a component of a
5604 -- formal parameter. In this case its expansion may generate
5605 -- actual subtypes that are referenced in an inner context and
5606 -- that must be elaborated within the subprogram itself. If the
5607 -- prefix includes a function call, it may involve finalization
5608 -- actions that should be inserted when the attribute has been
5609 -- rewritten as a declaration. Create a declaration for the prefix
5610 -- and insert it at the start of the enclosing subprogram. This is
5611 -- an expansion activity that has to be performed now to prevent
5612 -- out-of-order issues.
5614 -- This expansion is both harmful and not needed in SPARK mode,
5615 -- since the formal verification back end relies on the types of
5616 -- nodes (hence is not robust w.r.t. a change to base type here),
5617 -- and does not suffer from the out-of-order issue described
5618 -- above. Thus, this expansion is skipped in SPARK mode.
5620 -- The expansion is not relevant for discrete types, which will
5621 -- not generate extra declarations, and where use of the base type
5622 -- may lead to spurious errors if context is a case.
5624 if not GNATprove_Mode then
5625 if not Is_Discrete_Type (Pref_Typ) then
5626 Pref_Typ := Base_Type (Pref_Typ);
5627 end if;
5629 Set_Etype (N, Pref_Typ);
5630 Set_Etype (P, Pref_Typ);
5632 Analyze_Dimension (N);
5633 Expand (N);
5634 end if;
5635 end if;
5636 end Old;
5638 ------------
5639 -- Output --
5640 ------------
5642 when Attribute_Output =>
5643 Check_E2;
5644 Check_Stream_Attribute (TSS_Stream_Output);
5645 Set_Etype (N, Standard_Void_Type);
5646 Resolve (N, Standard_Void_Type);
5648 ------------------
5649 -- Partition_ID --
5650 ------------------
5652 when Attribute_Partition_ID =>
5653 Check_E0;
5655 if P_Type /= Any_Type then
5656 if not Is_Library_Level_Entity (Entity (P)) then
5657 Error_Attr_P
5658 ("prefix of % attribute must be library-level entity");
5660 -- The defining entity of prefix should not be declared inside a
5661 -- Pure unit. RM E.1(8). Is_Pure was set during declaration.
5663 elsif Is_Entity_Name (P)
5664 and then Is_Pure (Entity (P))
5665 then
5666 Error_Attr_P ("prefix of% attribute must not be declared pure");
5667 end if;
5668 end if;
5670 Set_Etype (N, Universal_Integer);
5672 -------------------------
5673 -- Passed_By_Reference --
5674 -------------------------
5676 when Attribute_Passed_By_Reference =>
5677 Check_E0;
5678 Check_Type;
5679 Check_Not_Incomplete_Type;
5680 Set_Etype (N, Standard_Boolean);
5682 ------------------
5683 -- Pool_Address --
5684 ------------------
5686 when Attribute_Pool_Address =>
5687 Check_E0;
5688 Set_Etype (N, RTE (RE_Address));
5690 ---------
5691 -- Pos --
5692 ---------
5694 when Attribute_Pos =>
5695 Check_Discrete_Type;
5696 Check_E1;
5697 Resolve (E1, P_Base_Type);
5698 Set_Etype (N, Universal_Integer);
5700 --------------
5701 -- Position --
5702 --------------
5704 -- Shares processing with First_Bit attribute
5706 ----------
5707 -- Pred --
5708 ----------
5710 when Attribute_Pred
5711 | Attribute_Succ
5713 Check_Scalar_Type;
5714 Check_E1;
5715 Resolve (E1, P_Base_Type);
5716 Set_Etype (N, P_Base_Type);
5718 -- Since Pred/Succ work on the base type, we normally do no check for
5719 -- the floating-point case, since the base type is unconstrained. But
5720 -- we make an exception in Check_Float_Overflow mode.
5722 if Is_Floating_Point_Type (P_Type) then
5723 if not Range_Checks_Suppressed (P_Base_Type) then
5724 Set_Do_Range_Check (E1);
5725 end if;
5727 -- If not modular type, test for overflow check required
5729 else
5730 if not Is_Modular_Integer_Type (P_Type)
5731 and then not Range_Checks_Suppressed (P_Base_Type)
5732 then
5733 Enable_Range_Check (E1);
5734 end if;
5735 end if;
5737 ----------------------------------
5738 -- Preelaborable_Initialization --
5739 ----------------------------------
5741 when Attribute_Preelaborable_Initialization =>
5742 Check_E0;
5743 Check_Type;
5745 -- If we're in an instance, we know that the legality of the
5746 -- attribute prefix type was already checked in the generic.
5748 if not In_Instance then
5750 -- If the prefix type is a generic formal type, then it must be
5751 -- either a formal private type or a formal derived type.
5753 if Is_Generic_Type (P_Type) then
5754 if not Is_Private_Type (P_Type)
5755 and then not Is_Derived_Type (P_Type)
5756 then
5757 Error_Attr_P ("formal type prefix of % attribute must be "
5758 & "formal private or formal derived type");
5759 end if;
5761 -- Otherwise, the prefix type must be a nonformal composite
5762 -- type declared within the visible part of a package or
5763 -- generic package.
5765 elsif not Is_Composite_Type (P_Type)
5766 or else not Original_View_In_Visible_Part (P_Type)
5767 then
5768 Error_Attr_P
5769 ("prefix of % attribute must be composite type declared "
5770 & "in visible part of a package or generic package");
5771 end if;
5772 end if;
5774 Set_Etype (N, Standard_Boolean);
5776 --------------
5777 -- Priority --
5778 --------------
5780 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5782 when Attribute_Priority =>
5783 if Ada_Version < Ada_2005 then
5784 Error_Attr ("% attribute is allowed only in Ada 2005 mode", P);
5785 end if;
5787 Check_E0;
5789 Check_Restriction (No_Dynamic_Priorities, N);
5791 -- The prefix must be a protected object (AARM D.5.2 (2/2))
5793 if Is_Protected_Type (Etype (P))
5794 or else (Is_Access_Type (Etype (P))
5795 and then Is_Protected_Type (Designated_Type (Etype (P))))
5796 then
5797 Resolve (P);
5798 else
5799 Error_Attr_P ("prefix of % attribute must be a protected object");
5800 end if;
5802 Set_Etype (N, Standard_Integer);
5804 -- Must be called from within a protected procedure or entry of the
5805 -- protected object.
5807 declare
5808 S : Entity_Id;
5810 begin
5811 S := Current_Scope;
5812 while S /= Etype (P)
5813 and then S /= Standard_Standard
5814 loop
5815 S := Scope (S);
5816 end loop;
5818 if S = Standard_Standard then
5819 Error_Attr ("the attribute % is only allowed inside protected "
5820 & "operations", P);
5821 end if;
5822 end;
5824 Validate_Non_Static_Attribute_Function_Call;
5826 ---------------
5827 -- Put_Image --
5828 ---------------
5830 when Attribute_Put_Image =>
5831 Check_E2;
5832 Check_Put_Image_Attribute;
5833 Set_Etype (N, Standard_Void_Type);
5834 Resolve (N, Standard_Void_Type);
5836 -----------
5837 -- Range --
5838 -----------
5840 when Attribute_Range =>
5841 Check_Array_Or_Scalar_Type;
5842 Bad_Attribute_For_Predicate;
5844 if Ada_Version = Ada_83
5845 and then Is_Scalar_Type (P_Type)
5846 and then Comes_From_Source (N)
5847 then
5848 Error_Attr
5849 ("(Ada 83) % attribute not allowed for scalar type", P);
5850 end if;
5852 ------------
5853 -- Result --
5854 ------------
5856 when Attribute_Result => Result : declare
5857 function Denote_Same_Function
5858 (Pref_Id : Entity_Id;
5859 Spec_Id : Entity_Id) return Boolean;
5860 -- Determine whether the entity of the prefix Pref_Id denotes the
5861 -- same entity as that of the related subprogram Spec_Id.
5863 --------------------------
5864 -- Denote_Same_Function --
5865 --------------------------
5867 function Denote_Same_Function
5868 (Pref_Id : Entity_Id;
5869 Spec_Id : Entity_Id) return Boolean
5871 Over_Id : constant Entity_Id := Overridden_Operation (Spec_Id);
5872 Subp_Spec : constant Node_Id := Parent (Spec_Id);
5874 begin
5875 -- The prefix denotes the related subprogram
5877 if Pref_Id = Spec_Id then
5878 return True;
5880 -- Account for a special case when attribute 'Result appears in
5881 -- the postcondition of a generic function.
5883 -- generic
5884 -- function Gen_Func return ...
5885 -- with Post => Gen_Func'Result ...;
5887 -- When the generic function is instantiated, the Chars field of
5888 -- the instantiated prefix still denotes the name of the generic
5889 -- function. Note that any preemptive transformation is impossible
5890 -- without a proper analysis. The structure of the wrapper package
5891 -- is as follows:
5893 -- package Anon_Gen_Pack is
5894 -- <subtypes and renamings>
5895 -- function Subp_Decl return ...; -- (!)
5896 -- pragma Postcondition (Gen_Func'Result ...); -- (!)
5897 -- function Gen_Func ... renames Subp_Decl;
5898 -- end Anon_Gen_Pack;
5900 elsif Nkind (Subp_Spec) = N_Function_Specification
5901 and then Present (Generic_Parent (Subp_Spec))
5902 and then Ekind (Pref_Id) in E_Generic_Function | E_Function
5903 then
5904 if Generic_Parent (Subp_Spec) = Pref_Id then
5905 return True;
5907 elsif Present (Alias (Pref_Id))
5908 and then Alias (Pref_Id) = Spec_Id
5909 then
5910 return True;
5911 end if;
5913 -- Account for a special case where a primitive of a tagged type
5914 -- inherits a class-wide postcondition from a parent type. In this
5915 -- case the prefix of attribute 'Result denotes the overriding
5916 -- primitive.
5918 elsif Present (Over_Id) and then Pref_Id = Over_Id then
5919 return True;
5921 -- When a qualified name is used for the prefix, homonyms may come
5922 -- before the current function in the homonym chain.
5924 elsif Has_Homonym (Pref_Id)
5925 and then Present (Homonym (Pref_Id))
5926 then
5927 return Denote_Same_Function (Homonym (Pref_Id), Spec_Id);
5928 end if;
5930 -- Otherwise the prefix does not denote the related subprogram
5932 return False;
5933 end Denote_Same_Function;
5935 -- Local variables
5937 In_Inlined_C_Postcondition : constant Boolean :=
5938 Modify_Tree_For_C
5939 and then In_Inlined_Body;
5941 Legal : Boolean;
5942 Pref_Id : Entity_Id;
5943 Spec_Id : Entity_Id;
5945 -- Start of processing for Result
5947 begin
5948 -- The attribute reference is a primary. If any expressions follow,
5949 -- then the attribute reference is an indexable object. Transform the
5950 -- attribute into an indexed component and analyze it.
5952 if Present (E1) then
5953 Rewrite (N,
5954 Make_Indexed_Component (Loc,
5955 Prefix =>
5956 Make_Attribute_Reference (Loc,
5957 Prefix => Relocate_Node (P),
5958 Attribute_Name => Name_Result),
5959 Expressions => Expressions (N)));
5960 Analyze (N);
5961 return;
5962 end if;
5964 Analyze_Attribute_Old_Result (Legal, Spec_Id);
5966 -- The aspect or pragma where attribute 'Result resides should be
5967 -- associated with a subprogram declaration or a body. If this is not
5968 -- the case, then the aspect or pragma is illegal. Return as analysis
5969 -- cannot be carried out.
5971 -- The exception to this rule is when generating C since in this case
5972 -- postconditions are inlined.
5974 if No (Spec_Id) and then In_Inlined_C_Postcondition then
5975 Spec_Id := Entity (P);
5977 elsif not Legal then
5978 Error_Attr ("prefix of % attribute must be a function", P);
5979 end if;
5981 -- Attribute 'Result is part of postconditions expansion. There is
5982 -- no need to perform the semantic checks below as they were already
5983 -- verified when the attribute was analyzed in its original context.
5984 -- Instead, rewrite the attribute as a reference to formal parameter
5985 -- _Result of the _Wrapped_Statements procedure.
5987 if Chars (Spec_Id) = Name_uWrapped_Statements
5988 or else
5989 (In_Inlined_C_Postcondition
5990 and then Nkind (Parent (Spec_Id)) = N_Block_Statement)
5991 then
5992 Rewrite (N, Make_Identifier (Loc, Name_uResult));
5994 -- The type of formal parameter _Result is that of the function
5995 -- encapsulating the _Postconditions procedure. Resolution must
5996 -- be carried out against the function return type.
5998 Analyze_And_Resolve (N, Etype (Scope (Spec_Id)));
6000 -- Otherwise attribute 'Result appears in its original context and
6001 -- all semantic checks should be carried out.
6003 else
6004 -- Verify the legality of the prefix. It must denotes the entity
6005 -- of the related [generic] function.
6007 if Is_Entity_Name (P) then
6008 Pref_Id := Entity (P);
6010 -- Either both the prefix and the annotated spec must be
6011 -- generic functions, or they both must be nongeneric
6012 -- functions, or the prefix must be generic and the spec
6013 -- must be nongeneric (i.e. it must denote an instance).
6015 if (Ekind (Pref_Id) in E_Function | E_Generic_Function
6016 and then Ekind (Pref_Id) = Ekind (Spec_Id))
6017 or else
6018 (Ekind (Pref_Id) = E_Generic_Function
6019 and then Ekind (Spec_Id) = E_Function)
6020 then
6021 if Denote_Same_Function (Pref_Id, Spec_Id) then
6023 -- Correct the prefix of the attribute when the context
6024 -- is a generic function.
6026 if Pref_Id /= Spec_Id then
6027 Rewrite (P, New_Occurrence_Of (Spec_Id, Loc));
6028 Analyze (P);
6029 end if;
6031 Set_Etype (N, Etype (Spec_Id));
6033 -- Otherwise the prefix denotes some unrelated function
6035 else
6036 Error_Msg_Name_2 := Chars (Spec_Id);
6037 Error_Attr
6038 ("incorrect prefix for attribute %, expected %", P);
6039 end if;
6041 -- If the prefix is an access-to-subprogram type, then it must
6042 -- be the same as the annotated type.
6044 elsif Is_Access_Subprogram_Type (Pref_Id) then
6045 if Pref_Id = Spec_Id then
6046 Set_Etype (N, Etype (Designated_Type (Spec_Id)));
6047 else
6048 Error_Msg_Name_2 := Chars (Spec_Id);
6049 Error_Attr
6050 ("incorrect prefix for attribute %, expected %", P);
6051 end if;
6053 -- Otherwise the prefix denotes some other form of subprogram
6054 -- entity.
6056 else
6057 Error_Attr
6058 ("attribute % can only appear in postcondition of "
6059 & "function", P);
6060 end if;
6062 -- Otherwise the prefix is illegal
6064 else
6065 Error_Msg_Name_2 := Chars (Spec_Id);
6066 Error_Attr ("incorrect prefix for attribute %, expected %", P);
6067 end if;
6068 end if;
6069 end Result;
6071 ------------------
6072 -- Range_Length --
6073 ------------------
6075 when Attribute_Range_Length =>
6076 Check_E0;
6077 Check_Discrete_Type;
6078 Set_Etype (N, Universal_Integer);
6080 ------------
6081 -- Reduce --
6082 ------------
6084 when Attribute_Reduce =>
6085 Check_E2;
6086 Error_Msg_Ada_2022_Feature ("Reduce attribute", Sloc (N));
6088 declare
6089 Stream : constant Node_Id := Prefix (N);
6090 Typ : Entity_Id;
6091 begin
6092 if Nkind (Stream) /= N_Aggregate then
6093 -- Prefix is a name, as for other attributes.
6095 -- If the object is a function we asume that it is not
6096 -- overloaded. AI12-242 does not suggest a name resolution
6097 -- rule for that case, but we can suppose that the expected
6098 -- type of the reduction is the expected type of the component
6099 -- of the prefix.
6101 Analyze_And_Resolve (Stream);
6102 Typ := Etype (Stream);
6104 -- Verify that prefix can be iterated upon.
6106 if Is_Array_Type (Typ)
6107 or else Has_Aspect (Typ, Aspect_Default_Iterator)
6108 or else Has_Aspect (Typ, Aspect_Iterable)
6109 then
6110 null;
6111 else
6112 Error_Msg_NE
6113 ("cannot apply Reduce to object of type&", N, Typ);
6114 end if;
6116 elsif Present (Expressions (Stream))
6117 or else No (Component_Associations (Stream))
6118 or else Nkind (First (Component_Associations (Stream))) /=
6119 N_Iterated_Component_Association
6120 then
6121 Error_Msg_N
6122 ("prefix of Reduce must be an iterated component", N);
6123 end if;
6125 Analyze (E1);
6126 Analyze (E2);
6127 Set_Etype (N, Etype (E2));
6128 end;
6130 ----------
6131 -- Read --
6132 ----------
6134 when Attribute_Read =>
6135 Check_E2;
6136 Check_Stream_Attribute (TSS_Stream_Read);
6137 Set_Etype (N, Standard_Void_Type);
6138 Resolve (N, Standard_Void_Type);
6139 Note_Possible_Modification (E2, Sure => True);
6141 ---------
6142 -- Ref --
6143 ---------
6145 when Attribute_Ref =>
6146 Check_E1;
6148 if Nkind (P) /= N_Expanded_Name
6149 or else not Is_RTE (P_Type, RE_Address)
6150 then
6151 Error_Attr_P ("prefix of % attribute must be System.Address");
6152 end if;
6154 Analyze_And_Resolve (E1, Any_Integer);
6155 Set_Etype (N, RTE (RE_Address));
6157 ---------------
6158 -- Remainder --
6159 ---------------
6161 -- Shares processing with Adjacent attribute
6163 ---------------------
6164 -- Restriction_Set --
6165 ---------------------
6167 when Attribute_Restriction_Set => Restriction_Set : declare
6168 R : Restriction_Id;
6169 U : Node_Id;
6170 Unam : Unit_Name_Type;
6172 begin
6173 Check_E1;
6174 Check_System_Prefix;
6176 -- No_Dependence case
6178 if Nkind (E1) = N_Parameter_Association then
6179 pragma Assert (Chars (Selector_Name (E1)) = Name_No_Dependence);
6180 U := Explicit_Actual_Parameter (E1);
6182 if not OK_No_Dependence_Unit_Name (U) then
6183 Set_Boolean_Result (N, False);
6184 Error_Attr;
6185 end if;
6187 -- See if there is an entry already in the table. That's the
6188 -- case in which we can return True.
6190 for J in No_Dependences.First .. No_Dependences.Last loop
6191 if Designate_Same_Unit (U, No_Dependences.Table (J).Unit)
6192 and then No_Dependences.Table (J).Warn = False
6193 then
6194 Set_Boolean_Result (N, True);
6195 return;
6196 end if;
6197 end loop;
6199 -- If not in the No_Dependence table, result is False
6201 Set_Boolean_Result (N, False);
6203 -- In this case, we must ensure that the binder will reject any
6204 -- other unit in the partition that sets No_Dependence for this
6205 -- unit. We do that by making an entry in the special table kept
6206 -- for this purpose (if the entry is not there already).
6208 Unam := Get_Spec_Name (Get_Unit_Name (U));
6210 for J in Restriction_Set_Dependences.First ..
6211 Restriction_Set_Dependences.Last
6212 loop
6213 if Restriction_Set_Dependences.Table (J) = Unam then
6214 return;
6215 end if;
6216 end loop;
6218 Restriction_Set_Dependences.Append (Unam);
6220 -- Normal restriction case
6222 else
6223 if Nkind (E1) /= N_Identifier then
6224 Set_Boolean_Result (N, False);
6225 Error_Attr ("attribute % requires restriction identifier", E1);
6227 else
6228 R := Get_Restriction_Id (Process_Restriction_Synonyms (E1));
6230 if R = Not_A_Restriction_Id then
6231 Set_Boolean_Result (N, False);
6232 Error_Msg_Node_1 := E1;
6233 Error_Attr ("invalid restriction identifier &", E1);
6235 elsif R not in Partition_Boolean_Restrictions then
6236 Set_Boolean_Result (N, False);
6237 Error_Msg_Node_1 := E1;
6238 Error_Attr
6239 ("& is not a boolean partition-wide restriction", E1);
6240 end if;
6242 if Restriction_Active (R) then
6243 Set_Boolean_Result (N, True);
6244 else
6245 Check_Restriction (R, N);
6246 Set_Boolean_Result (N, False);
6247 end if;
6248 end if;
6249 end if;
6250 end Restriction_Set;
6252 -----------
6253 -- Round --
6254 -----------
6256 when Attribute_Round =>
6257 Check_E1;
6258 Check_Decimal_Fixed_Point_Type;
6259 Set_Etype (N, P_Base_Type);
6261 -- Because the context is universal_real (3.5.10(12)) it is a
6262 -- legal context for a universal fixed expression. This is the
6263 -- only attribute whose functional description involves U_R.
6265 if Etype (E1) = Universal_Fixed then
6266 declare
6267 Conv : constant Node_Id := Make_Type_Conversion (Loc,
6268 Subtype_Mark => New_Occurrence_Of (Universal_Real, Loc),
6269 Expression => Relocate_Node (E1));
6271 begin
6272 Rewrite (E1, Conv);
6273 Analyze (E1);
6274 end;
6275 end if;
6277 Resolve (E1, Any_Real);
6279 --------------
6280 -- Rounding --
6281 --------------
6283 -- Shares processing with Ceiling attribute
6285 ---------------
6286 -- Safe_Emax --
6287 ---------------
6289 -- Shares processing with Emax attribute
6291 ----------------
6292 -- Safe_First --
6293 ----------------
6295 -- Shares processing with Epsilon attribute
6297 ----------------
6298 -- Safe_Large --
6299 ----------------
6301 -- Shares processing with Large attribute
6303 ---------------
6304 -- Safe_Last --
6305 ---------------
6307 -- Shares processing with Epsilon attribute
6309 ----------------
6310 -- Safe_Small --
6311 ----------------
6313 -- Shares processing with Large attribute
6315 --------------------------
6316 -- Scalar_Storage_Order --
6317 --------------------------
6319 when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : declare
6320 Ent : Entity_Id := Empty;
6322 begin
6323 Check_E0;
6324 Check_Type;
6326 if not (Is_Record_Type (P_Type) or else Is_Array_Type (P_Type)) then
6328 -- The attribute applies to generic private types (in which case
6329 -- the legality rule is applied in the instance) as well as to
6330 -- composite types. For noncomposite types it always returns the
6331 -- default bit order for the target.
6332 -- Allowing formal private types was originally introduced in
6333 -- GNAT_Mode only, to compile instances of Sequential_IO, but
6334 -- users find it more generally useful in generic units.
6336 if not (Is_Generic_Type (P_Type) and then Is_Private_Type (P_Type))
6337 and then not In_Instance
6338 then
6339 Error_Attr_P
6340 ("prefix of % attribute must be record or array type");
6342 elsif not Is_Generic_Type (P_Type) then
6343 if Bytes_Big_Endian then
6344 Ent := RTE (RE_High_Order_First);
6345 else
6346 Ent := RTE (RE_Low_Order_First);
6347 end if;
6348 end if;
6350 elsif Bytes_Big_Endian xor Reverse_Storage_Order (P_Type) then
6351 Ent := RTE (RE_High_Order_First);
6353 else
6354 Ent := RTE (RE_Low_Order_First);
6355 end if;
6357 if Present (Ent) then
6358 Rewrite (N, New_Occurrence_Of (Ent, Loc));
6359 end if;
6361 Set_Etype (N, RTE (RE_Bit_Order));
6362 Resolve (N);
6364 -- Reset incorrect indication of staticness
6366 Set_Is_Static_Expression (N, False);
6367 end Scalar_Storage_Order;
6369 -----------
6370 -- Scale --
6371 -----------
6373 when Attribute_Scale =>
6374 Check_E0;
6375 Check_Decimal_Fixed_Point_Type;
6376 Set_Etype (N, Universal_Integer);
6378 -------------
6379 -- Scaling --
6380 -------------
6382 -- Shares processing with Compose attribute
6384 ------------------
6385 -- Signed_Zeros --
6386 ------------------
6388 -- Shares processing with Denorm attribute
6390 ----------
6391 -- Size --
6392 ----------
6394 when Attribute_Size
6395 | Attribute_VADS_Size
6397 Check_E0;
6399 -- If prefix is parameterless function call, rewrite and resolve
6400 -- as such.
6402 if Is_Entity_Name (P)
6403 and then Ekind (Entity (P)) = E_Function
6404 then
6405 Resolve (P);
6407 -- Similar processing for a protected function call
6409 elsif Nkind (P) = N_Selected_Component
6410 and then Ekind (Entity (Selector_Name (P))) = E_Function
6411 then
6412 Resolve (P);
6413 end if;
6415 if Is_Object_Reference (P) then
6416 Check_Object_Reference (P);
6418 elsif Is_Entity_Name (P)
6419 and then (Is_Type (Entity (P))
6420 or else Ekind (Entity (P)) = E_Enumeration_Literal)
6421 then
6422 null;
6424 elsif Nkind (P) = N_Type_Conversion
6425 and then not Comes_From_Source (P)
6426 then
6427 null;
6429 -- Some other compilers allow dubious use of X'???'Size
6431 elsif Relaxed_RM_Semantics
6432 and then Nkind (P) = N_Attribute_Reference
6433 then
6434 null;
6436 else
6437 Error_Attr_P ("invalid prefix for % attribute");
6438 end if;
6440 Check_Not_Incomplete_Type;
6441 Check_Not_CPP_Type;
6442 Set_Etype (N, Universal_Integer);
6444 -- If we are processing pragmas Compile_Time_Warning and Compile_
6445 -- Time_Errors after the back end has been called and this occurrence
6446 -- of 'Size is known at compile time then it is safe to perform this
6447 -- evaluation. Needed to perform the static evaluation of the full
6448 -- boolean expression of these pragmas. Note that Known_RM_Size is
6449 -- sometimes True when Size_Known_At_Compile_Time is False, when the
6450 -- back end has computed it.
6452 if In_Compile_Time_Warning_Or_Error
6453 and then Is_Entity_Name (P)
6454 and then (Is_Type (Entity (P))
6455 or else Ekind (Entity (P)) = E_Enumeration_Literal)
6456 and then (Known_RM_Size (Entity (P))
6457 or else Size_Known_At_Compile_Time (Entity (P)))
6458 then
6459 declare
6460 Prefix_E : Entity_Id := Entity (P);
6461 Siz : Uint;
6463 begin
6464 -- Handle private and incomplete types
6466 if Present (Underlying_Type (Prefix_E)) then
6467 Prefix_E := Underlying_Type (Prefix_E);
6468 end if;
6470 if Known_Static_RM_Size (Prefix_E) then
6471 Siz := RM_Size (Prefix_E);
6472 else
6473 Siz := Esize (Prefix_E);
6474 end if;
6476 -- Protect the frontend against cases where the attribute
6477 -- Size_Known_At_Compile_Time is set, but the Esize value
6478 -- is not available (see Einfo.ads).
6480 if Present (Siz) then
6481 Rewrite (N, Make_Integer_Literal (Sloc (N), Siz));
6482 Analyze (N);
6483 end if;
6484 end;
6485 end if;
6487 -----------
6488 -- Small --
6489 -----------
6491 -- Shares processing with Large attribute
6493 ---------------------------------------
6494 -- Small_Denominator/Small_Numerator --
6495 ---------------------------------------
6497 when Attribute_Small_Denominator
6498 | Attribute_Small_Numerator
6500 Check_Fixed_Point_Type_0;
6501 Set_Etype (N, Universal_Integer);
6503 ------------------
6504 -- Storage_Pool --
6505 ------------------
6507 when Attribute_Storage_Pool
6508 | Attribute_Simple_Storage_Pool
6510 Check_E0;
6512 if Is_Access_Type (P_Type) then
6513 if Ekind (P_Type) = E_Access_Subprogram_Type then
6514 Error_Attr_P
6515 ("cannot use % attribute for access-to-subprogram type");
6516 end if;
6518 -- Set appropriate entity
6520 if Present (Associated_Storage_Pool (Root_Type (P_Type))) then
6521 Set_Entity (N, Associated_Storage_Pool (Root_Type (P_Type)));
6522 else
6523 Set_Entity (N, RTE (RE_Global_Pool_Object));
6524 end if;
6526 if Attr_Id = Attribute_Storage_Pool then
6527 if Present (Get_Rep_Pragma (Etype (Entity (N)),
6528 Name_Simple_Storage_Pool_Type))
6529 then
6530 Error_Msg_Name_1 := Aname;
6531 Error_Msg_Warn := SPARK_Mode /= On;
6532 Error_Msg_N
6533 ("cannot use % attribute for type with simple storage "
6534 & "pool<<", N);
6535 Error_Msg_N ("\Program_Error [<<", N);
6537 Rewrite
6538 (N, Make_Raise_Program_Error
6539 (Sloc (N), Reason => PE_Explicit_Raise));
6540 end if;
6542 Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
6544 -- In the Simple_Storage_Pool case, verify that the pool entity is
6545 -- actually of a simple storage pool type, and set the attribute's
6546 -- type to the pool object's type.
6548 else
6549 if No (Get_Rep_Pragma (Etype (Entity (N)),
6550 Name_Simple_Storage_Pool_Type))
6551 then
6552 Error_Attr_P
6553 ("cannot use % attribute for type without simple " &
6554 "storage pool");
6555 end if;
6557 Set_Etype (N, Etype (Entity (N)));
6558 end if;
6560 -- Validate_Remote_Access_To_Class_Wide_Type for attribute
6561 -- Storage_Pool since this attribute is not defined for such
6562 -- types (RM E.2.2(17)).
6564 Validate_Remote_Access_To_Class_Wide_Type (N);
6566 else
6567 Error_Attr_P ("prefix of % attribute must be access type");
6568 end if;
6570 ------------------
6571 -- Storage_Size --
6572 ------------------
6574 when Attribute_Storage_Size =>
6575 Check_E0;
6577 if Is_Task_Type (P_Type) then
6578 Set_Etype (N, Universal_Integer);
6580 -- Use with tasks is an obsolescent feature
6582 Check_Restriction (No_Obsolescent_Features, P);
6584 elsif Is_Access_Type (P_Type) then
6585 Set_Etype (N, Universal_Integer);
6587 if Ekind (P_Type) = E_Access_Subprogram_Type then
6588 Error_Attr_P
6589 ("cannot use % attribute for access-to-subprogram type");
6590 end if;
6592 if Is_Entity_Name (P)
6593 and then Is_Type (Entity (P))
6594 then
6595 Check_Type;
6597 -- Validate_Remote_Access_To_Class_Wide_Type for attribute
6598 -- Storage_Size since this attribute is not defined for
6599 -- such types (RM E.2.2(17)).
6601 Validate_Remote_Access_To_Class_Wide_Type (N);
6603 -- The prefix is allowed to be an implicit dereference of an
6604 -- access value designating a task.
6606 else
6607 Check_Task_Prefix;
6608 end if;
6610 else
6611 Error_Attr_P ("prefix of % attribute must be access or task type");
6612 end if;
6614 ------------------
6615 -- Storage_Unit --
6616 ------------------
6618 when Attribute_Storage_Unit =>
6619 Standard_Attribute (Ttypes.System_Storage_Unit);
6621 -----------------
6622 -- Stream_Size --
6623 -----------------
6625 when Attribute_Stream_Size =>
6626 Check_E0;
6627 Check_Type;
6629 if Is_Entity_Name (P)
6630 and then Is_Elementary_Type (Entity (P))
6631 then
6632 Set_Etype (N, Universal_Integer);
6633 else
6634 Error_Attr_P ("invalid prefix for % attribute");
6635 end if;
6637 ---------------
6638 -- Stub_Type --
6639 ---------------
6641 when Attribute_Stub_Type =>
6642 Check_Type;
6643 Check_E0;
6645 if Is_Remote_Access_To_Class_Wide_Type (Base_Type (P_Type)) then
6647 -- For a real RACW [sub]type, use corresponding stub type
6649 if not Is_Generic_Type (P_Type) then
6650 Rewrite (N,
6651 New_Occurrence_Of
6652 (Corresponding_Stub_Type (Base_Type (P_Type)), Loc));
6654 -- For a generic type (that has been marked as an RACW using the
6655 -- Remote_Access_Type aspect or pragma), use a generic RACW stub
6656 -- type. Note that if the actual is not a remote access type, the
6657 -- instantiation will fail.
6659 else
6660 -- Note: we go to the underlying type here because the view
6661 -- returned by RTE (RE_RACW_Stub_Type) might be incomplete.
6663 Rewrite (N,
6664 New_Occurrence_Of
6665 (Underlying_Type (RTE (RE_RACW_Stub_Type)), Loc));
6666 end if;
6668 else
6669 Error_Attr_P
6670 ("prefix of% attribute must be remote access-to-class-wide");
6671 end if;
6673 ----------
6674 -- Succ --
6675 ----------
6677 -- Shares processing with Pred attribute
6679 --------------------------------
6680 -- System_Allocator_Alignment --
6681 --------------------------------
6683 when Attribute_System_Allocator_Alignment =>
6684 Standard_Attribute (Ttypes.System_Allocator_Alignment);
6686 ---------
6687 -- Tag --
6688 ---------
6690 when Attribute_Tag =>
6691 Check_E0;
6692 Check_Dereference;
6694 if not Is_Tagged_Type (P_Type) then
6695 Error_Attr_P ("prefix of % attribute must be tagged");
6697 -- Next test does not apply to generated code why not, and what does
6698 -- the illegal reference mean???
6700 elsif Is_Object_Reference (P)
6701 and then not Is_Class_Wide_Type (P_Type)
6702 and then Comes_From_Source (N)
6703 then
6704 Error_Attr_P
6705 ("% attribute can only be applied to objects " &
6706 "of class-wide type");
6707 end if;
6709 -- The prefix cannot be an incomplete type. However, references to
6710 -- 'Tag can be generated when expanding interface conversions, and
6711 -- this is legal.
6713 if Comes_From_Source (N) then
6714 Check_Not_Incomplete_Type;
6716 -- 'Tag requires visibility on the corresponding package holding
6717 -- the tag, so record a reference here, to avoid spurious unused
6718 -- with_clause reported when compiling the main unit.
6720 if In_Extended_Main_Source_Unit (Current_Scope) then
6721 Set_Referenced (P_Type, True);
6722 Set_Referenced (Scope (P_Type), True);
6723 end if;
6724 end if;
6726 -- Set appropriate type
6728 Set_Etype (N, RTE (RE_Tag));
6730 -----------------
6731 -- Target_Name --
6732 -----------------
6734 when Attribute_Target_Name => Target_Name : declare
6735 TN : constant String := Sdefault.Target_Name.all;
6736 TL : Natural;
6738 begin
6739 Check_Standard_Prefix;
6741 TL := TN'Last;
6743 if TN (TL) = '/' or else TN (TL) = '\' then
6744 TL := TL - 1;
6745 end if;
6747 Rewrite (N,
6748 Make_String_Literal (Loc,
6749 Strval => TN (TN'First .. TL)));
6750 Analyze_And_Resolve (N, Standard_String);
6751 Set_Is_Static_Expression (N, True);
6752 end Target_Name;
6754 ----------------
6755 -- Terminated --
6756 ----------------
6758 -- Shares processing with Callable attribute
6760 ----------------
6761 -- To_Address --
6762 ----------------
6764 when Attribute_To_Address => To_Address : declare
6765 Val : Uint;
6766 begin
6767 Check_E1;
6768 Check_System_Prefix;
6770 Generate_Reference (RTE (RE_Address), P);
6771 Analyze_And_Resolve (E1, Any_Integer);
6772 Set_Etype (N, RTE (RE_Address));
6773 Set_Is_Static_Expression (N, Is_Static_Expression (E1));
6775 -- OK static expression case, check range and set appropriate type
6777 if Is_OK_Static_Expression (E1) then
6778 Val := Expr_Value (E1);
6780 if Val < -(Uint_2 ** (System_Address_Size - 1))
6781 or else
6782 Val > Uint_2 ** System_Address_Size - 1
6783 then
6784 Error_Attr ("address value out of range for % attribute", E1);
6785 end if;
6787 -- In most cases the expression is a numeric literal or some other
6788 -- address expression, but if it is a declared constant it may be
6789 -- of a compatible type that must be left on the node.
6791 if Is_Entity_Name (E1) then
6792 null;
6794 -- Set type to universal integer if negative
6796 elsif Val < 0 then
6797 Set_Etype (E1, Universal_Integer);
6799 -- Otherwise set type to Unsigned_64 to accommodate large values
6801 else
6802 Set_Etype (E1, Standard_Unsigned_64);
6803 end if;
6804 end if;
6805 end To_Address;
6807 ------------
6808 -- To_Any --
6809 ------------
6811 when Attribute_To_Any =>
6812 Check_E1;
6813 Check_PolyORB_Attribute;
6814 Set_Etype (N, RTE (RE_Any));
6816 ----------------
6817 -- Truncation --
6818 ----------------
6820 -- Shares processing with Ceiling attribute
6822 ----------------
6823 -- Type_Class --
6824 ----------------
6826 when Attribute_Type_Class =>
6827 Check_E0;
6828 Check_Type;
6829 Check_Not_Incomplete_Type;
6830 Set_Etype (N, RTE (RE_Type_Class));
6832 --------------
6833 -- TypeCode --
6834 --------------
6836 when Attribute_TypeCode =>
6837 Check_E0;
6838 Check_PolyORB_Attribute;
6839 Set_Etype (N, RTE (RE_TypeCode));
6841 --------------
6842 -- Type_Key --
6843 --------------
6845 when Attribute_Type_Key => Type_Key : declare
6846 Full_Name : constant String_Id :=
6847 Fully_Qualified_Name_String (Entity (P));
6849 CRC : CRC32;
6850 -- The computed signature for the type
6852 Deref : Boolean;
6853 -- To simplify the handling of mutually recursive types, follow a
6854 -- single dereference link in a composite type.
6856 procedure Compute_Type_Key (T : Entity_Id);
6857 -- Create a CRC integer from the declaration of the type. For a
6858 -- composite type, fold in the representation of its components in
6859 -- recursive fashion. We use directly the source representation of
6860 -- the types involved.
6862 ----------------------
6863 -- Compute_Type_Key --
6864 ----------------------
6866 procedure Compute_Type_Key (T : Entity_Id) is
6867 Buffer : Source_Buffer_Ptr;
6868 P_Max : Source_Ptr;
6869 P_Min : Source_Ptr;
6870 Rep : Node_Id;
6871 SFI : Source_File_Index;
6873 procedure Process_One_Declaration;
6874 -- Update CRC with the characters of one type declaration, or a
6875 -- representation pragma that applies to the type.
6877 -----------------------------
6878 -- Process_One_Declaration --
6879 -----------------------------
6881 procedure Process_One_Declaration is
6882 begin
6883 -- Scan type declaration, skipping blanks
6885 for Ptr in P_Min .. P_Max loop
6886 if Buffer (Ptr) /= ' ' then
6887 System.CRC32.Update (CRC, Buffer (Ptr));
6888 end if;
6889 end loop;
6890 end Process_One_Declaration;
6892 -- Start of processing for Compute_Type_Key
6894 begin
6895 if Is_Itype (T) then
6896 return;
6897 end if;
6899 -- If the type is declared in Standard, there is no source, so
6900 -- just use its name.
6902 if Scope (T) = Standard_Standard then
6903 declare
6904 Name : constant String := Get_Name_String (Chars (T));
6905 begin
6906 for J in Name'Range loop
6907 System.CRC32.Update (CRC, Name (J));
6908 end loop;
6909 end;
6911 return;
6912 end if;
6914 Sloc_Range (Enclosing_Declaration (T), P_Min, P_Max);
6915 SFI := Get_Source_File_Index (P_Min);
6916 pragma Assert (SFI = Get_Source_File_Index (P_Max));
6917 Buffer := Source_Text (SFI);
6919 Process_One_Declaration;
6921 -- Recurse on relevant component types
6923 if Is_Array_Type (T) then
6924 Compute_Type_Key (Component_Type (T));
6926 elsif Is_Access_Type (T) then
6927 if not Deref then
6928 Deref := True;
6929 Compute_Type_Key (Designated_Type (T));
6930 end if;
6932 elsif Is_Derived_Type (T) then
6933 Compute_Type_Key (Etype (T));
6935 elsif Is_Record_Type (T) then
6936 declare
6937 Comp : Entity_Id;
6938 begin
6939 Comp := First_Component (T);
6940 while Present (Comp) loop
6941 Compute_Type_Key (Etype (Comp));
6942 Next_Component (Comp);
6943 end loop;
6944 end;
6945 end if;
6947 if Is_First_Subtype (T) then
6949 -- Fold in representation aspects for the type, which appear in
6950 -- the same source buffer. If the representation aspects are in
6951 -- a different source file, then skip them; they apply to some
6952 -- other type, perhaps one we're derived from.
6954 Rep := First_Rep_Item (T);
6956 while Present (Rep) loop
6957 if Comes_From_Source (Rep) then
6958 Sloc_Range (Rep, P_Min, P_Max);
6960 if SFI = Get_Source_File_Index (P_Min) then
6961 pragma Assert (SFI = Get_Source_File_Index (P_Max));
6962 Process_One_Declaration;
6963 end if;
6964 end if;
6966 Next_Rep_Item (Rep);
6967 end loop;
6968 end if;
6969 end Compute_Type_Key;
6971 -- Start of processing for Type_Key
6973 begin
6974 Check_E0;
6975 Check_Type;
6977 Start_String;
6978 Deref := False;
6980 -- Copy all characters in Full_Name but the trailing NUL
6982 for J in 1 .. String_Length (Full_Name) - 1 loop
6983 Store_String_Char (Get_String_Char (Full_Name, Pos (J)));
6984 end loop;
6986 -- Compute CRC and convert it to string one character at a time, so
6987 -- as not to use Image within the compiler.
6989 Initialize (CRC);
6990 Compute_Type_Key (Entity (P));
6992 if not Is_Frozen (Entity (P))
6993 and then not Is_Generic_Type (Entity (P))
6994 and then not Is_Generic_Actual_Type (Entity (P))
6995 then
6996 Error_Msg_N ("premature usage of Type_Key?", N);
6997 end if;
6999 while CRC > 0 loop
7000 Store_String_Char (Character'Val (48 + (CRC rem 10)));
7001 CRC := CRC / 10;
7002 end loop;
7004 Rewrite (N, Make_String_Literal (Loc, End_String));
7005 Analyze_And_Resolve (N, Standard_String);
7006 end Type_Key;
7008 -----------------------
7009 -- Unbiased_Rounding --
7010 -----------------------
7012 -- Shares processing with Ceiling attribute
7014 ----------------------
7015 -- Unchecked_Access --
7016 ----------------------
7018 when Attribute_Unchecked_Access =>
7019 if Comes_From_Source (N) then
7020 Check_Restriction (No_Unchecked_Access, N);
7021 end if;
7023 Analyze_Access_Attribute;
7024 Check_Not_Incomplete_Type;
7026 -------------------------
7027 -- Unconstrained_Array --
7028 -------------------------
7030 when Attribute_Unconstrained_Array =>
7031 Check_E0;
7032 Check_Type;
7033 Check_Not_Incomplete_Type;
7034 Set_Etype (N, Standard_Boolean);
7035 Set_Is_Static_Expression (N, True);
7037 ------------------------------
7038 -- Universal_Literal_String --
7039 ------------------------------
7041 -- This is a GNAT specific attribute whose prefix must be a named
7042 -- number where the expression is either a single numeric literal,
7043 -- or a numeric literal immediately preceded by a minus sign. The
7044 -- result is equivalent to a string literal containing the text of
7045 -- the literal as it appeared in the source program with a possible
7046 -- leading minus sign.
7048 when Attribute_Universal_Literal_String =>
7049 Check_E0;
7051 if not Is_Entity_Name (P)
7052 or else not Is_Named_Number (Entity (P))
7053 then
7054 Error_Attr_P ("prefix for % attribute must be named number");
7056 else
7057 declare
7058 Expr : Node_Id;
7059 Negative : Boolean;
7060 S : Source_Ptr;
7061 Src : Source_Buffer_Ptr;
7063 begin
7064 Expr := Original_Node (Expression (Parent (Entity (P))));
7066 if Nkind (Expr) = N_Op_Minus then
7067 Negative := True;
7068 Expr := Original_Node (Right_Opnd (Expr));
7069 else
7070 Negative := False;
7071 end if;
7073 if Nkind (Expr) not in N_Integer_Literal | N_Real_Literal then
7074 Error_Attr
7075 ("named number for % attribute must be simple literal", N);
7076 end if;
7078 -- Build string literal corresponding to source literal text
7080 Start_String;
7082 if Negative then
7083 Store_String_Char (Get_Char_Code ('-'));
7084 end if;
7086 S := Sloc (Expr);
7087 Src := Source_Text (Get_Source_File_Index (S));
7089 while Src (S) /= ';' and then Src (S) /= ' ' loop
7090 Store_String_Char (Get_Char_Code (Src (S)));
7091 S := S + 1;
7092 end loop;
7094 -- Now we rewrite the attribute with the string literal
7096 Rewrite (N,
7097 Make_String_Literal (Loc, End_String));
7098 Analyze (N);
7099 Set_Is_Static_Expression (N, True);
7100 end;
7101 end if;
7103 -------------------------
7104 -- Unrestricted_Access --
7105 -------------------------
7107 -- This is a GNAT specific attribute which is like Access except that
7108 -- all scope checks and checks for aliased views are omitted. It is
7109 -- documented as being equivalent to the use of the Address attribute
7110 -- followed by an unchecked conversion to the target access type.
7112 when Attribute_Unrestricted_Access =>
7114 -- If from source, deal with relevant restrictions
7116 if Comes_From_Source (N) then
7117 Check_Restriction (No_Unchecked_Access, N);
7119 if Nkind (P) in N_Has_Entity
7120 and then Present (Entity (P))
7121 and then Is_Object (Entity (P))
7122 then
7123 Check_Restriction (No_Implicit_Aliasing, N);
7124 end if;
7125 end if;
7127 if Is_Entity_Name (P) then
7128 Set_Address_Taken (Entity (P));
7129 end if;
7131 -- It might seem reasonable to call Address_Checks here to apply the
7132 -- same set of semantic checks that we enforce for 'Address (after
7133 -- all we document Unrestricted_Access as being equivalent to the
7134 -- use of Address followed by an Unchecked_Conversion). However, if
7135 -- we do enable these checks, we get multiple failures in both the
7136 -- compiler run-time and in our regression test suite, so we leave
7137 -- out these checks for now. To be investigated further some time???
7139 -- Address_Checks;
7141 -- Now complete analysis using common access processing
7143 Analyze_Access_Attribute;
7145 ------------
7146 -- Update --
7147 ------------
7149 when Attribute_Update => Update : declare
7150 Common_Typ : Entity_Id;
7151 -- The common type of a multiple component update for a record
7153 Comps : Elist_Id := No_Elist;
7154 -- A list used in the resolution of a record update. It contains the
7155 -- entities of all record components processed so far.
7157 procedure Analyze_Array_Component_Update (Assoc : Node_Id);
7158 -- Analyze and resolve array_component_association Assoc against the
7159 -- index of array type P_Type.
7161 procedure Analyze_Record_Component_Update (Comp : Node_Id);
7162 -- Analyze and resolve record_component_association Comp against
7163 -- record type P_Type.
7165 ------------------------------------
7166 -- Analyze_Array_Component_Update --
7167 ------------------------------------
7169 procedure Analyze_Array_Component_Update (Assoc : Node_Id) is
7170 Expr : Node_Id;
7171 High : Node_Id;
7172 Index : Node_Id;
7173 Index_Typ : Entity_Id;
7174 Low : Node_Id;
7176 begin
7177 -- The current association contains a sequence of indexes denoting
7178 -- an element of a multidimensional array:
7180 -- (Index_1, ..., Index_N)
7182 -- Examine each individual index and resolve it against the proper
7183 -- index type of the array.
7185 if Nkind (First (Choices (Assoc))) = N_Aggregate then
7186 Expr := First (Choices (Assoc));
7187 while Present (Expr) loop
7189 -- The use of others is illegal (SPARK RM 4.4.1(12))
7191 if Nkind (Expr) = N_Others_Choice then
7192 Error_Attr
7193 ("OTHERS choice not allowed in attribute %", Expr);
7195 -- Otherwise analyze and resolve all indexes
7197 else
7198 Index := First (Expressions (Expr));
7199 Index_Typ := First_Index (P_Type);
7200 while Present (Index) and then Present (Index_Typ) loop
7201 Analyze_And_Resolve (Index, Etype (Index_Typ));
7202 Next (Index);
7203 Next_Index (Index_Typ);
7204 end loop;
7206 -- Detect a case where the association either lacks an
7207 -- index or contains an extra index.
7209 if Present (Index) or else Present (Index_Typ) then
7210 Error_Msg_N
7211 ("dimension mismatch in index list", Assoc);
7212 end if;
7213 end if;
7215 Next (Expr);
7216 end loop;
7218 -- The current association denotes either a single component or a
7219 -- range of components of a one dimensional array:
7221 -- 1, 2 .. 5
7223 -- Resolve the index or its high and low bounds (if range) against
7224 -- the proper index type of the array.
7226 else
7227 Index := First (Choices (Assoc));
7228 Index_Typ := First_Index (P_Type);
7230 if Present (Next_Index (Index_Typ)) then
7231 Error_Msg_N ("too few subscripts in array reference", Assoc);
7232 end if;
7234 while Present (Index) loop
7236 -- The use of others is illegal (SPARK RM 4.4.1(12))
7238 if Nkind (Index) = N_Others_Choice then
7239 Error_Attr
7240 ("OTHERS choice not allowed in attribute %", Index);
7242 -- The index denotes a range of elements
7244 elsif Nkind (Index) = N_Range then
7245 Low := Low_Bound (Index);
7246 High := High_Bound (Index);
7248 Analyze_And_Resolve (Low, Etype (Index_Typ));
7249 Analyze_And_Resolve (High, Etype (Index_Typ));
7251 -- Otherwise the index denotes a single element
7253 else
7254 Analyze_And_Resolve (Index, Etype (Index_Typ));
7255 end if;
7257 Next (Index);
7258 end loop;
7259 end if;
7260 end Analyze_Array_Component_Update;
7262 -------------------------------------
7263 -- Analyze_Record_Component_Update --
7264 -------------------------------------
7266 procedure Analyze_Record_Component_Update (Comp : Node_Id) is
7267 Comp_Name : constant Name_Id := Chars (Comp);
7268 Base_Typ : Entity_Id;
7269 Comp_Or_Discr : Entity_Id;
7271 begin
7272 -- Find the discriminant or component whose name corresponds to
7273 -- Comp. A simple character comparison is sufficient because all
7274 -- visible names within a record type are unique.
7276 Comp_Or_Discr := First_Entity (P_Type);
7277 while Present (Comp_Or_Discr) loop
7278 if Chars (Comp_Or_Discr) = Comp_Name then
7280 -- Decorate the component reference by setting its entity
7281 -- and type for resolution purposes.
7283 Set_Entity (Comp, Comp_Or_Discr);
7284 Set_Etype (Comp, Etype (Comp_Or_Discr));
7285 exit;
7286 end if;
7288 Next_Entity (Comp_Or_Discr);
7289 end loop;
7291 -- Diagnose an illegal reference
7293 if Present (Comp_Or_Discr) then
7294 if Ekind (Comp_Or_Discr) = E_Discriminant then
7295 Error_Attr
7296 ("attribute % may not modify record discriminants", Comp);
7298 else pragma Assert (Ekind (Comp_Or_Discr) = E_Component);
7299 if Contains (Comps, Comp_Or_Discr) then
7300 Error_Msg_N ("component & already updated", Comp);
7302 -- Mark this component as processed
7304 else
7305 Append_New_Elmt (Comp_Or_Discr, Comps);
7306 end if;
7307 end if;
7309 -- The update aggregate mentions an entity that does not belong to
7310 -- the record type.
7312 else
7313 Error_Msg_N ("& is not a component of aggregate subtype", Comp);
7314 end if;
7316 -- Verify the consistency of types when the current component is
7317 -- part of a multiple component update.
7319 -- Comp_1 | ... | Comp_N => <value>
7321 if Present (Etype (Comp)) then
7322 Base_Typ := Base_Type (Etype (Comp));
7324 -- Save the type of the first component reference as the
7325 -- remaning references (if any) must resolve to this type.
7327 if No (Common_Typ) then
7328 Common_Typ := Base_Typ;
7330 elsif Base_Typ /= Common_Typ then
7331 Error_Msg_N
7332 ("components in choice list must have same type", Comp);
7333 end if;
7334 end if;
7335 end Analyze_Record_Component_Update;
7337 -- Local variables
7339 Assoc : Node_Id;
7340 Comp : Node_Id;
7342 -- Start of processing for Update
7344 begin
7345 if Warn_On_Obsolescent_Feature then
7346 Error_Msg_N ("?j?attribute Update is an obsolescent feature", N);
7347 Error_Msg_N ("\?j?use a delta aggregate instead", N);
7348 end if;
7350 Check_E1;
7352 if not Is_Object_Reference (P) then
7353 Error_Attr_P ("prefix of attribute % must denote an object");
7355 elsif not Is_Array_Type (P_Type)
7356 and then not Is_Record_Type (P_Type)
7357 then
7358 Error_Attr_P ("prefix of attribute % must be a record or array");
7360 elsif Is_Inherently_Limited_Type (P_Type) then
7361 Error_Attr ("prefix of attribute % cannot be limited", N);
7363 elsif Nkind (E1) /= N_Aggregate then
7364 Error_Attr ("attribute % requires component association list", N);
7366 elsif Present (Expressions (E1)) then
7367 Error_Attr ("attribute % requires named component associations",
7368 First (Expressions (E1)));
7370 end if;
7372 -- Inspect the update aggregate, looking at all the associations and
7373 -- choices. Perform the following checks:
7375 -- 1) Legality of "others" in all cases
7376 -- 2) Legality of <>
7377 -- 3) Component legality for arrays
7378 -- 4) Component legality for records
7380 -- The remaining checks are performed on the expanded attribute
7382 Assoc := First (Component_Associations (E1));
7383 while Present (Assoc) loop
7385 -- The use of <> is illegal (SPARK RM 4.4.1(1))
7387 if Box_Present (Assoc) then
7388 Error_Attr
7389 ("default initialization not allowed in attribute %", Assoc);
7391 -- Otherwise process the association
7393 else
7394 Analyze (Expression (Assoc));
7396 if Is_Array_Type (P_Type) then
7397 Analyze_Array_Component_Update (Assoc);
7399 elsif Is_Record_Type (P_Type) then
7401 -- Reset the common type used in a multiple component update
7402 -- as we are processing the contents of a new association.
7404 Common_Typ := Empty;
7406 Comp := First (Choices (Assoc));
7407 while Present (Comp) loop
7408 if Nkind (Comp) = N_Identifier then
7409 Analyze_Record_Component_Update (Comp);
7411 -- The use of others is illegal (SPARK RM 4.4.1(5))
7413 elsif Nkind (Comp) = N_Others_Choice then
7414 Error_Attr
7415 ("OTHERS choice not allowed in attribute %", Comp);
7417 -- The name of a record component cannot appear in any
7418 -- other form.
7420 else
7421 Error_Msg_N
7422 ("name should be identifier or OTHERS", Comp);
7423 end if;
7425 Next (Comp);
7426 end loop;
7427 end if;
7428 end if;
7430 Next (Assoc);
7431 end loop;
7433 -- The type of attribute 'Update is that of the prefix
7435 Set_Etype (N, P_Type);
7437 Sem_Warn.Warn_On_Suspicious_Update (N);
7438 end Update;
7440 ---------
7441 -- Val --
7442 ---------
7444 when Attribute_Val =>
7445 Check_E1;
7446 Check_Discrete_Type;
7448 -- Note, we need a range check in general, but we wait for the
7449 -- Resolve call to do this, since we want to let Eval_Attribute
7450 -- have a chance to find an static illegality first.
7452 Resolve (E1, Any_Integer);
7453 Set_Etype (N, P_Base_Type);
7455 -----------
7456 -- Valid --
7457 -----------
7459 when Attribute_Valid => Valid : declare
7460 Pred_Func : constant Entity_Id := Predicate_Function (P_Type);
7462 begin
7463 Check_E0;
7465 -- Ignore check for object if we have a 'Valid reference generated
7466 -- by the expanded code, since in some cases valid checks can occur
7467 -- on items that are names, but are not objects (e.g. attributes).
7469 if Comes_From_Source (N) then
7470 Check_Object_Reference (P);
7472 if not Is_Scalar_Type (P_Type) then
7473 Error_Attr_P ("object for % attribute must be of scalar type");
7474 end if;
7476 -- If the attribute appears within the subtype's own predicate
7477 -- function, then issue a warning that this will cause infinite
7478 -- recursion.
7480 if Present (Pred_Func) and then Current_Scope = Pred_Func then
7481 Error_Msg_N ("attribute Valid requires a predicate check??", N);
7482 Error_Msg_N ("\and will result in infinite recursion??", N);
7483 end if;
7484 end if;
7486 Set_Etype (N, Standard_Boolean);
7487 end Valid;
7489 -----------------
7490 -- Valid_Value --
7491 -----------------
7493 when Attribute_Valid_Value =>
7494 Check_E1;
7495 Check_Enumeration_Type;
7496 Check_Enum_Image (Check_Enumeration_Maps => True);
7497 Set_Etype (N, Standard_Boolean);
7498 Validate_Non_Static_Attribute_Function_Call;
7500 if P_Type in Standard_Boolean
7501 | Standard_Character
7502 | Standard_Wide_Character
7503 | Standard_Wide_Wide_Character
7504 then
7505 Error_Attr_P
7506 ("prefix of % attribute must not be a type in Standard");
7507 end if;
7509 if Discard_Names (First_Subtype (P_Type)) then
7510 Error_Attr_P
7511 ("prefix of % attribute must not have Discard_Names");
7512 end if;
7514 -------------------
7515 -- Valid_Scalars --
7516 -------------------
7518 when Attribute_Valid_Scalars => Valid_Scalars : declare
7519 begin
7520 Check_E0;
7522 if Comes_From_Source (N) then
7523 Check_Object_Reference (P);
7525 -- Attribute 'Valid_Scalars is illegal on unchecked union types
7526 -- regardles of the privacy, because it is not always guaranteed
7527 -- that the components are retrievable based on whether the
7528 -- discriminants are inferable.
7530 if Has_Unchecked_Union (Validated_View (P_Type)) then
7531 Error_Attr_P
7532 ("attribute % not allowed for Unchecked_Union type");
7534 -- Do not emit any diagnostics related to private types to avoid
7535 -- disclosing the structure of the type.
7537 elsif Is_Private_Type (P_Type) then
7539 -- Attribute 'Valid_Scalars is not supported on private tagged
7540 -- types due to a code generation issue. Is_Visible_Component
7541 -- does not allow for a component of a private tagged type to
7542 -- be successfully retrieved.
7543 -- ??? This attribute should simply ignore type privacy
7544 -- (see Validated_View). It should examine components of the
7545 -- tagged type extensions (if any) and recursively examine
7546 -- 'Valid_Scalars of the parent's type (if any).
7548 -- Do not use Error_Attr_P because this bypasses any subsequent
7549 -- processing and leaves the attribute with type Any_Type. This
7550 -- in turn prevents the proper expansion of the attribute into
7551 -- True.
7553 if Is_Tagged_Type (P_Type) then
7554 Error_Msg_Name_1 := Aname;
7555 Error_Msg_N ("??effects of attribute % are ignored", N);
7556 end if;
7558 -- Otherwise the type is not private
7560 else
7561 if not Scalar_Part_Present (P_Type) then
7562 Error_Msg_Name_1 := Aname;
7563 Error_Msg_F
7564 ("??attribute % always True, no scalars to check", P);
7565 Set_Boolean_Result (N, True);
7566 end if;
7567 end if;
7568 end if;
7570 Set_Etype (N, Standard_Boolean);
7571 end Valid_Scalars;
7573 -----------
7574 -- Value --
7575 -----------
7577 when Attribute_Value
7578 | Attribute_Wide_Value
7579 | Attribute_Wide_Wide_Value
7581 Check_E1;
7582 Check_Scalar_Type;
7583 Check_Enum_Image (Check_Enumeration_Maps => True);
7585 -- Set Etype before resolving expression because expansion of
7586 -- expression may require enclosing type. Note that the type
7587 -- returned by 'Value is the base type of the prefix type.
7589 Set_Etype (N, P_Base_Type);
7590 Validate_Non_Static_Attribute_Function_Call;
7592 -- Check restriction No_Fixed_IO
7594 if Restriction_Check_Required (No_Fixed_IO)
7595 and then Is_Fixed_Point_Type (P_Type)
7596 then
7597 Check_Restriction (No_Fixed_IO, P);
7598 end if;
7600 ----------------
7601 -- Value_Size --
7602 ----------------
7604 -- Shares processing with Machine_Size attribute
7606 -------------
7607 -- Version --
7608 -------------
7610 when Attribute_Version =>
7611 Check_E0;
7612 Check_Program_Unit;
7613 Set_Etype (N, RTE (RE_Version_String));
7615 ------------------
7616 -- Wchar_T_Size --
7617 ------------------
7619 when Attribute_Wchar_T_Size =>
7620 Standard_Attribute (Interfaces_Wchar_T_Size);
7622 ----------------
7623 -- Wide_Image --
7624 ----------------
7626 when Attribute_Wide_Image =>
7627 Analyze_Image_Attribute (Standard_Wide_String);
7629 ---------------------
7630 -- Wide_Wide_Image --
7631 ---------------------
7633 when Attribute_Wide_Wide_Image =>
7634 Analyze_Image_Attribute (Standard_Wide_Wide_String);
7636 ----------------
7637 -- Wide_Value --
7638 ----------------
7640 -- Shares processing with Value attribute
7642 ---------------------
7643 -- Wide_Wide_Value --
7644 ---------------------
7646 -- Shares processing with Value attribute
7648 ---------------------
7649 -- Wide_Wide_Width --
7650 ---------------------
7652 when Attribute_Wide_Wide_Width
7653 | Attribute_Wide_Width
7654 | Attribute_Width
7656 Check_E0;
7657 Check_Scalar_Type;
7658 Set_Etype (N, Universal_Integer);
7660 ----------------
7661 -- Wide_Width --
7662 ----------------
7664 -- Shares processing with Wide_Wide_Width attribute
7666 -----------
7667 -- Width --
7668 -----------
7670 -- Shares processing with Wide_Wide_Width attribute
7672 ---------------
7673 -- Word_Size --
7674 ---------------
7676 when Attribute_Word_Size =>
7677 Standard_Attribute (System_Word_Size);
7679 -----------
7680 -- Write --
7681 -----------
7683 when Attribute_Write =>
7684 Check_E2;
7685 Check_Stream_Attribute (TSS_Stream_Write);
7686 Set_Etype (N, Standard_Void_Type);
7687 Resolve (N, Standard_Void_Type);
7689 end case;
7691 -- In SPARK certain attributes (see below) depend on Tasking_State.
7692 -- Ensure that the entity is available for gnat2why by loading it.
7693 -- See SPARK RM 9(19) for the relevant rule.
7695 if GNATprove_Mode then
7696 case Attr_Id is
7697 when Attribute_Callable
7698 | Attribute_Caller
7699 | Attribute_Count
7700 | Attribute_Terminated
7702 SPARK_Implicit_Load (RE_Tasking_State);
7704 when others =>
7705 null;
7706 end case;
7707 end if;
7709 -- All errors raise Bad_Attribute, so that we get out before any further
7710 -- damage occurs when an error is detected (for example, if we check for
7711 -- one attribute expression, and the check succeeds, we want to be able
7712 -- to proceed securely assuming that an expression is in fact present.
7714 -- Note: we set the attribute analyzed in this case to prevent any
7715 -- attempt at reanalysis which could generate spurious error msgs.
7717 exception
7718 when Bad_Attribute =>
7719 Set_Analyzed (N);
7720 Set_Etype (N, Any_Type);
7721 return;
7722 end Analyze_Attribute;
7724 --------------------
7725 -- Eval_Attribute --
7726 --------------------
7728 procedure Eval_Attribute (N : Node_Id) is
7729 Loc : constant Source_Ptr := Sloc (N);
7731 C_Type : constant Entity_Id := Etype (N);
7732 -- The type imposed by the context
7734 Aname : Name_Id;
7735 -- Attribute_Name (N) after verification of validity of N
7737 Id : Attribute_Id;
7738 -- Get_Attribute_Id (Aname) after Aname is set
7740 P : Node_Id;
7741 -- Prefix (N) after verification of validity of N
7743 E1 : Node_Id;
7744 -- First expression, or Empty if none
7746 E2 : Node_Id;
7747 -- Second expression, or Empty if none
7749 P_Entity : Entity_Id;
7750 -- Entity denoted by prefix
7752 P_Type : Entity_Id;
7753 -- The type of the prefix
7755 P_Base_Type : Entity_Id;
7756 -- The base type of the prefix type
7758 P_Root_Type : Entity_Id;
7759 -- The root type of the prefix type
7761 Static : Boolean := False;
7762 -- True if the result is Static. This is set by the general processing
7763 -- to true if the prefix is static, and all expressions are static. It
7764 -- can be reset as processing continues for particular attributes. This
7765 -- flag can still be True if the reference raises a constraint error.
7766 -- Is_Static_Expression (N) is set to follow this value as it is set
7767 -- and we could always reference this, but it is convenient to have a
7768 -- simple short name to use, since it is frequently referenced.
7770 Lo_Bound, Hi_Bound : Node_Id;
7771 -- Expressions for low and high bounds of type or array index referenced
7772 -- by First, Last, or Length attribute for array, set by Set_Bounds.
7774 CE_Node : Node_Id;
7775 -- Constraint error node used if we have an attribute reference has
7776 -- an argument that raises a constraint error. In this case we replace
7777 -- the attribute with a raise constraint_error node. This is important
7778 -- processing, since otherwise gigi might see an attribute which it is
7779 -- unprepared to deal with.
7781 procedure Check_Concurrent_Discriminant (Bound : Node_Id);
7782 -- If Bound is a reference to a discriminant of a task or protected type
7783 -- occurring within the object's body, rewrite attribute reference into
7784 -- a reference to the corresponding discriminal. Use for the expansion
7785 -- of checks against bounds of entry family index subtypes.
7787 procedure Check_Expressions;
7788 -- In case where the attribute is not foldable, the expressions, if
7789 -- any, of the attribute, are in a non-static context. This procedure
7790 -- performs the required additional checks.
7792 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean;
7793 -- Determines if the given type has compile time known bounds. Note
7794 -- that we enter the case statement even in cases where the prefix
7795 -- type does NOT have known bounds, so it is important to guard any
7796 -- attempt to evaluate both bounds with a call to this function.
7798 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint);
7799 -- This procedure is called when the attribute N has a non-static
7800 -- but compile time known value given by Val. It includes the
7801 -- necessary checks for out of range values.
7803 function Fore_Value return Nat;
7804 -- Computes the Fore value for the current attribute prefix, which is
7805 -- known to be a static fixed-point type. Used by Fore and Width.
7807 function Mantissa return Uint;
7808 -- Returns the Mantissa value for the prefix type
7810 procedure Set_Bounds;
7811 -- Used for First, Last and Length attributes applied to an array or
7812 -- array subtype. Sets the variables Lo_Bound and Hi_Bound to the low
7813 -- and high bound expressions for the index referenced by the attribute
7814 -- designator (i.e. the first index if no expression is present, and the
7815 -- N'th index if the value N is present as an expression). Also used for
7816 -- First and Last of scalar types and for First_Valid and Last_Valid.
7817 -- Static is reset to False if the type or index type is not statically
7818 -- constrained.
7820 -----------------------------------
7821 -- Check_Concurrent_Discriminant --
7822 -----------------------------------
7824 procedure Check_Concurrent_Discriminant (Bound : Node_Id) is
7825 Tsk : Entity_Id;
7826 -- The concurrent (task or protected) type
7828 begin
7829 if Nkind (Bound) = N_Identifier
7830 and then Ekind (Entity (Bound)) = E_Discriminant
7831 and then Is_Concurrent_Record_Type (Scope (Entity (Bound)))
7832 then
7833 Tsk := Corresponding_Concurrent_Type (Scope (Entity (Bound)));
7835 if In_Open_Scopes (Tsk) and then Has_Completion (Tsk) then
7837 -- Find discriminant of original concurrent type, and use
7838 -- its current discriminal, which is the renaming within
7839 -- the task/protected body.
7841 Rewrite (N,
7842 New_Occurrence_Of
7843 (Find_Body_Discriminal (Entity (Bound)), Loc));
7844 end if;
7845 end if;
7846 end Check_Concurrent_Discriminant;
7848 -----------------------
7849 -- Check_Expressions --
7850 -----------------------
7852 procedure Check_Expressions is
7853 E : Node_Id;
7854 begin
7855 E := E1;
7856 while Present (E) loop
7857 Check_Non_Static_Context (E);
7858 Next (E);
7859 end loop;
7860 end Check_Expressions;
7862 ----------------------------------
7863 -- Compile_Time_Known_Attribute --
7864 ----------------------------------
7866 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint) is
7867 T : constant Entity_Id := Etype (N);
7869 begin
7870 Fold_Uint (N, Val, False);
7872 -- Check that result is in bounds of the type if it is static
7874 if Is_In_Range (N, T, Assume_Valid => False) then
7875 null;
7877 elsif Is_Out_Of_Range (N, T) then
7878 Apply_Compile_Time_Constraint_Error
7879 (N, "value not in range of}??", CE_Range_Check_Failed);
7881 elsif not Range_Checks_Suppressed (T) then
7882 Enable_Range_Check (N);
7884 else
7885 Set_Do_Range_Check (N, False);
7886 end if;
7887 end Compile_Time_Known_Attribute;
7889 -------------------------------
7890 -- Compile_Time_Known_Bounds --
7891 -------------------------------
7893 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean is
7894 begin
7895 return
7896 Compile_Time_Known_Value (Type_Low_Bound (Typ))
7897 and then
7898 Compile_Time_Known_Value (Type_High_Bound (Typ));
7899 end Compile_Time_Known_Bounds;
7901 ----------------
7902 -- Fore_Value --
7903 ----------------
7905 -- Note that the Fore calculation is based on the actual values
7906 -- of the bounds, and does not take into account possible rounding.
7908 function Fore_Value return Nat is
7909 Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type));
7910 Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type));
7911 Small : constant Ureal := Small_Value (P_Type);
7912 Lo_Real : constant Ureal := Lo * Small;
7913 Hi_Real : constant Ureal := Hi * Small;
7914 T : Ureal;
7915 R : Nat;
7917 begin
7918 -- Bounds are given in terms of small units, so first compute
7919 -- proper values as reals.
7921 T := UR_Max (abs Lo_Real, abs Hi_Real);
7922 R := 2;
7924 -- Loop to compute proper value if more than one digit required
7926 while T >= Ureal_10 loop
7927 R := R + 1;
7928 T := T / Ureal_10;
7929 end loop;
7931 return R;
7932 end Fore_Value;
7934 --------------
7935 -- Mantissa --
7936 --------------
7938 -- Table of mantissa values accessed by function Computed using
7939 -- the relation:
7941 -- T'Mantissa = integer next above (D * log(10)/log(2)) + 1)
7943 -- where D is T'Digits (RM83 3.5.7)
7945 Mantissa_Value : constant array (Nat range 1 .. 40) of Nat := (
7946 1 => 5,
7947 2 => 8,
7948 3 => 11,
7949 4 => 15,
7950 5 => 18,
7951 6 => 21,
7952 7 => 25,
7953 8 => 28,
7954 9 => 31,
7955 10 => 35,
7956 11 => 38,
7957 12 => 41,
7958 13 => 45,
7959 14 => 48,
7960 15 => 51,
7961 16 => 55,
7962 17 => 58,
7963 18 => 61,
7964 19 => 65,
7965 20 => 68,
7966 21 => 71,
7967 22 => 75,
7968 23 => 78,
7969 24 => 81,
7970 25 => 85,
7971 26 => 88,
7972 27 => 91,
7973 28 => 95,
7974 29 => 98,
7975 30 => 101,
7976 31 => 104,
7977 32 => 108,
7978 33 => 111,
7979 34 => 114,
7980 35 => 118,
7981 36 => 121,
7982 37 => 124,
7983 38 => 128,
7984 39 => 131,
7985 40 => 134);
7987 function Mantissa return Uint is
7988 begin
7989 return
7990 UI_From_Int (Mantissa_Value (UI_To_Int (Digits_Value (P_Type))));
7991 end Mantissa;
7993 ----------------
7994 -- Set_Bounds --
7995 ----------------
7997 procedure Set_Bounds is
7998 Ndim : Nat;
7999 Indx : Node_Id;
8000 Ityp : Entity_Id;
8002 begin
8003 -- For a string literal subtype, we have to construct the bounds.
8004 -- Valid Ada code never applies attributes to string literals, but
8005 -- it is convenient to allow the expander to generate attribute
8006 -- references of this type (e.g. First and Last applied to a string
8007 -- literal).
8009 -- Note that the whole point of the E_String_Literal_Subtype is to
8010 -- avoid this construction of bounds, but the cases in which we
8011 -- have to materialize them are rare enough that we don't worry.
8013 -- The low bound is simply the low bound of the base type. The
8014 -- high bound is computed from the length of the string and this
8015 -- low bound.
8017 if Ekind (P_Type) = E_String_Literal_Subtype then
8018 Ityp := Etype (First_Index (Base_Type (P_Type)));
8019 Lo_Bound := Type_Low_Bound (Ityp);
8021 Hi_Bound :=
8022 Make_Integer_Literal (Sloc (P),
8023 Intval =>
8024 Expr_Value (Lo_Bound) + String_Literal_Length (P_Type) - 1);
8026 Set_Parent (Hi_Bound, P);
8027 Analyze_And_Resolve (Hi_Bound, Etype (Lo_Bound));
8028 return;
8030 -- For non-array case, just get bounds of scalar type
8032 elsif Is_Scalar_Type (P_Type) then
8033 Ityp := P_Type;
8035 -- For a fixed-point type, we must freeze to get the attributes
8036 -- of the fixed-point type set now so we can reference them.
8038 if Is_Fixed_Point_Type (P_Type)
8039 and then not Is_Frozen (Base_Type (P_Type))
8040 and then Compile_Time_Known_Value (Type_Low_Bound (P_Type))
8041 and then Compile_Time_Known_Value (Type_High_Bound (P_Type))
8042 then
8043 Freeze_Fixed_Point_Type (Base_Type (P_Type));
8044 end if;
8046 -- For array case, get type of proper index
8048 else
8049 if No (E1) then
8050 Ndim := 1;
8051 else
8052 Ndim := UI_To_Int (Expr_Value (E1));
8053 end if;
8055 Indx := First_Index (P_Type);
8056 for J in 1 .. Ndim - 1 loop
8057 Next_Index (Indx);
8058 end loop;
8060 -- If no index type, get out (some other error occurred, and
8061 -- we don't have enough information to complete the job).
8063 if No (Indx) then
8064 Lo_Bound := Error;
8065 Hi_Bound := Error;
8066 return;
8067 end if;
8069 Ityp := Etype (Indx);
8070 end if;
8072 -- A discrete range in an index constraint is allowed to be a
8073 -- subtype indication. This is syntactically a pain, but should
8074 -- not propagate to the entity for the corresponding index subtype.
8075 -- After checking that the subtype indication is legal, the range
8076 -- of the subtype indication should be transfered to the entity.
8077 -- The attributes for the bounds should remain the simple retrievals
8078 -- that they are now.
8080 Lo_Bound := Type_Low_Bound (Ityp);
8081 Hi_Bound := Type_High_Bound (Ityp);
8083 -- If subtype is non-static, result is definitely non-static
8085 if not Is_Static_Subtype (Ityp) then
8086 Static := False;
8087 Set_Is_Static_Expression (N, False);
8089 -- Subtype is static, does it raise CE?
8091 elsif not Is_OK_Static_Subtype (Ityp) then
8092 Set_Raises_Constraint_Error (N);
8093 end if;
8094 end Set_Bounds;
8096 -- Start of processing for Eval_Attribute
8098 begin
8099 -- Return immediately if e.g. N has been rewritten or is malformed due
8100 -- to previous errors.
8102 if Nkind (N) /= N_Attribute_Reference then
8103 return;
8104 end if;
8106 Aname := Attribute_Name (N);
8107 Id := Get_Attribute_Id (Aname);
8108 P := Prefix (N);
8110 -- The To_Address attribute can be static, but it cannot be evaluated at
8111 -- compile time, so just return.
8113 if Id = Attribute_To_Address then
8114 return;
8115 end if;
8117 -- Initialize result as non-static, will be reset if appropriate
8119 Set_Is_Static_Expression (N, False);
8121 -- Acquire first two expressions (at the moment, no attributes take more
8122 -- than two expressions in any case).
8124 if Present (Expressions (N)) then
8125 E1 := First (Expressions (N));
8126 E2 := Next (E1);
8127 else
8128 E1 := Empty;
8129 E2 := Empty;
8130 end if;
8132 -- Special processing for Enabled attribute. This attribute has a very
8133 -- special prefix, and the easiest way to avoid lots of special checks
8134 -- to protect this special prefix from causing trouble is to deal with
8135 -- this attribute immediately and be done with it.
8137 if Id = Attribute_Enabled then
8139 -- We skip evaluation if the expander is not active. This is not just
8140 -- an optimization. It is of key importance that we not rewrite the
8141 -- attribute in a generic template, since we want to pick up the
8142 -- setting of the check in the instance.
8144 if not Inside_A_Generic then
8145 declare
8146 C : constant Check_Id := Get_Check_Id (Chars (P));
8147 R : Boolean;
8149 begin
8150 if No (E1) then
8151 if C in Predefined_Check_Id then
8152 R := Scope_Suppress.Suppress (C);
8153 else
8154 R := Is_Check_Suppressed (Empty, C);
8155 end if;
8157 else
8158 R := Is_Check_Suppressed (Entity (E1), C);
8159 end if;
8161 Rewrite (N, New_Occurrence_Of (Boolean_Literals (not R), Loc));
8162 end;
8163 end if;
8165 return;
8166 end if;
8168 -- Attribute 'Img applied to a static enumeration value is static, and
8169 -- we will do the folding right here (things get confused if we let this
8170 -- case go through the normal circuitry).
8172 if Id = Attribute_Img
8173 and then Is_Entity_Name (P)
8174 and then Is_Enumeration_Type (Etype (Entity (P)))
8175 and then Is_OK_Static_Expression (P)
8176 then
8177 declare
8178 Lit : constant Entity_Id := Expr_Value_E (P);
8179 Str : String_Id;
8181 begin
8182 Start_String;
8183 Get_Unqualified_Decoded_Name_String (Chars (Lit));
8184 Set_Casing (All_Upper_Case);
8185 Store_String_Chars (Name_Buffer (1 .. Name_Len));
8186 Str := End_String;
8188 Rewrite (N, Make_String_Literal (Loc, Strval => Str));
8189 Analyze_And_Resolve (N, Standard_String);
8190 Set_Is_Static_Expression (N, True);
8191 end;
8193 return;
8194 end if;
8196 -- Special processing for cases where the prefix is an object or value,
8197 -- including string literals (attributes of string literals can only
8198 -- appear in generated code) and current instance prefixes in type or
8199 -- subtype aspects.
8201 if Is_Object_Reference (P)
8202 or else Is_Current_Instance_Reference_In_Type_Aspect (P)
8203 or else Nkind (P) = N_String_Literal
8204 or else (Is_Entity_Name (P)
8205 and then Ekind (Entity (P)) = E_Enumeration_Literal)
8206 then
8207 -- For Alignment, give alignment of object if available, otherwise we
8208 -- cannot fold Alignment.
8210 if Id = Attribute_Alignment then
8211 if Is_Entity_Name (P) and then Known_Alignment (Entity (P)) then
8212 Compile_Time_Known_Attribute (N, Alignment (Entity (P)));
8213 else
8214 Check_Expressions;
8215 end if;
8217 return;
8219 -- For Component_Size, the prefix is an array object, and we apply
8220 -- the attribute to the type of the object. This is allowed for both
8221 -- unconstrained and constrained arrays, since the bounds have no
8222 -- influence on the value of this attribute.
8224 elsif Id = Attribute_Component_Size then
8225 P_Entity := Etype (P);
8227 -- For Enum_Rep, evaluation depends on the nature of the prefix and
8228 -- the optional argument.
8230 elsif Id = Attribute_Enum_Rep then
8231 if Is_Entity_Name (P) then
8233 declare
8234 Enum_Expr : Node_Id;
8235 -- The enumeration-type expression of interest
8237 begin
8238 -- P'Enum_Rep case
8240 if Ekind (Entity (P)) in E_Constant | E_Enumeration_Literal
8241 then
8242 Enum_Expr := P;
8244 -- Enum_Type'Enum_Rep (E1) case
8246 elsif Is_Enumeration_Type (Entity (P)) then
8247 Enum_Expr := E1;
8249 -- Otherwise the attribute must be expanded into a
8250 -- conversion and evaluated at run time.
8252 else
8253 Check_Expressions;
8254 return;
8255 end if;
8257 -- We can fold if the expression is an enumeration
8258 -- literal, or if it denotes a constant whose value
8259 -- is known at compile time.
8261 if Nkind (Enum_Expr) in N_Has_Entity
8262 and then (Ekind (Entity (Enum_Expr)) =
8263 E_Enumeration_Literal
8264 or else
8265 (Ekind (Entity (Enum_Expr)) = E_Constant
8266 and then Nkind (Parent (Entity (Enum_Expr))) =
8267 N_Object_Declaration
8268 and then Present
8269 (Expression (Parent (Entity (P))))
8270 and then Compile_Time_Known_Value
8271 (Expression (Parent (Entity (P))))))
8272 then
8273 P_Entity := Etype (P);
8274 else
8275 Check_Expressions;
8276 return;
8277 end if;
8278 end;
8280 -- Otherwise the attribute is illegal, do not attempt to perform
8281 -- any kind of folding.
8283 else
8284 return;
8285 end if;
8287 -- For Bit_Position, give Component_Bit_Offset of object if available
8288 -- otherwise we cannot fold Bit_Position. Note that the attribute can
8289 -- be applied to a naked record component in generated code, in which
8290 -- case the prefix is an identifier that references the component or
8291 -- discriminant entity.
8293 elsif Id = Attribute_Bit_Position then
8294 declare
8295 CE : Entity_Id;
8297 begin
8298 if Is_Entity_Name (P) then
8299 CE := Entity (P);
8300 else
8301 CE := Entity (Selector_Name (P));
8302 end if;
8304 if Known_Static_Component_Bit_Offset (CE) then
8305 Compile_Time_Known_Attribute
8306 (N, Component_Bit_Offset (CE));
8307 else
8308 Check_Expressions;
8309 end if;
8311 return;
8312 end;
8314 -- For Position, in Ada 2005 (or later) if we have the non-default
8315 -- bit order, we return the original value as given in the component
8316 -- clause (RM 2005 13.5.2(3/2)). Otherwise (Ada 83/95, or later with
8317 -- default bit order) return the value if it is known statically.
8319 elsif Id = Attribute_Position then
8320 declare
8321 CE : constant Entity_Id := Entity (Selector_Name (P));
8323 begin
8324 if Present (Component_Clause (CE))
8325 and then Ada_Version >= Ada_2005
8326 and then Reverse_Bit_Order (Scope (CE))
8327 then
8328 Compile_Time_Known_Attribute
8329 (N, Expr_Value (Position (Component_Clause (CE))));
8331 elsif Known_Static_Component_Bit_Offset (CE) then
8332 Compile_Time_Known_Attribute
8333 (N, Component_Bit_Offset (CE) / System_Storage_Unit);
8335 else
8336 Check_Expressions;
8337 end if;
8339 return;
8340 end;
8342 -- For First_Bit, in Ada 2005 (or later) if we have the non-default
8343 -- bit order, we return the original value as given in the component
8344 -- clause (RM 2005 13.5.2(3/2)). Otherwise (Ada 83/95, or later with
8345 -- default bit order) return the value if it is known statically.
8347 elsif Id = Attribute_First_Bit then
8348 declare
8349 CE : constant Entity_Id := Entity (Selector_Name (P));
8351 begin
8352 if Present (Component_Clause (CE))
8353 and then Ada_Version >= Ada_2005
8354 and then Reverse_Bit_Order (Scope (CE))
8355 then
8356 Compile_Time_Known_Attribute
8357 (N, Expr_Value (First_Bit (Component_Clause (CE))));
8359 elsif Known_Static_Component_Bit_Offset (CE) then
8360 Compile_Time_Known_Attribute
8361 (N, Component_Bit_Offset (CE) mod System_Storage_Unit);
8363 else
8364 Check_Expressions;
8365 end if;
8367 return;
8368 end;
8370 -- For Last_Bit, in Ada 2005 (or later) if we have the non-default
8371 -- bit order, we return the original value as given in the component
8372 -- clause (RM 2005 13.5.2(3/2)). Otherwise (Ada 83/95, or later with
8373 -- default bit order) return the value if it is known statically.
8375 elsif Id = Attribute_Last_Bit then
8376 declare
8377 CE : constant Entity_Id := Entity (Selector_Name (P));
8379 begin
8380 if Present (Component_Clause (CE))
8381 and then Ada_Version >= Ada_2005
8382 and then Reverse_Bit_Order (Scope (CE))
8383 then
8384 Compile_Time_Known_Attribute
8385 (N, Expr_Value (Last_Bit (Component_Clause (CE))));
8387 elsif Known_Static_Component_Bit_Offset (CE)
8388 and then Known_Static_Esize (CE)
8389 then
8390 Compile_Time_Known_Attribute
8391 (N, (Component_Bit_Offset (CE) mod System_Storage_Unit)
8392 + Esize (CE) - 1);
8393 else
8394 Check_Expressions;
8395 end if;
8397 return;
8398 end;
8400 -- For First, Last and Length, the prefix is an array object, and we
8401 -- apply the attribute to its type, but we need a constrained type
8402 -- for this, so we use the actual subtype if available.
8404 elsif Id = Attribute_First
8405 or else Id = Attribute_Last
8406 or else Id = Attribute_Length
8407 then
8408 declare
8409 AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P);
8411 begin
8412 if Present (AS) and then Is_Constrained (AS) then
8413 P_Entity := AS;
8415 -- If we have an unconstrained type we cannot fold
8417 else
8418 Check_Expressions;
8419 return;
8420 end if;
8421 end;
8423 elsif Id = Attribute_Size then
8424 -- For Enum_Lit'Size, use Enum_Type'Object_Size. Taking the 'Size
8425 -- of a literal is kind of a strange thing to do, so we don't want
8426 -- to pass this oddity on to the back end. Note that Etype of an
8427 -- enumeration literal is always a (base) type, never a
8428 -- constrained subtype, so the Esize is always known.
8430 if Is_Entity_Name (P)
8431 and then Ekind (Entity (P)) = E_Enumeration_Literal
8432 then
8433 pragma Assert (Known_Static_Esize (Etype (P)));
8434 Compile_Time_Known_Attribute (N, Esize (Etype (P)));
8436 -- Otherwise, if Size is available, use that
8438 elsif Is_Entity_Name (P) and then Known_Static_Esize (Entity (P))
8439 then
8440 Compile_Time_Known_Attribute (N, Esize (Entity (P)));
8442 -- Otherwise, we cannot fold
8444 else
8445 Check_Expressions;
8446 end if;
8448 return;
8450 else
8451 Check_Expressions;
8452 return;
8453 end if;
8455 -- Cases where P is not an object. Cannot do anything if P is not the
8456 -- name of an entity.
8458 elsif not Is_Entity_Name (P) then
8459 Check_Expressions;
8460 return;
8462 -- Otherwise get prefix entity
8464 else
8465 P_Entity := Entity (P);
8466 end if;
8468 -- If we are asked to evaluate an attribute where the prefix is a
8469 -- non-frozen generic actual type whose RM_Size has not been set,
8470 -- then abandon the effort.
8472 if Is_Type (P_Entity)
8473 and then (not Is_Frozen (P_Entity)
8474 and then Is_Generic_Actual_Type (P_Entity)
8475 and then not Known_RM_Size (P_Entity))
8477 -- However, the attribute Unconstrained_Array must be evaluated,
8478 -- since it is documented to be a static attribute (and can for
8479 -- example appear in a Compile_Time_Warning pragma). The frozen
8480 -- status of the type does not affect its evaluation. Likewise
8481 -- for attributes intended to be used with generic definitions.
8483 and then Id not in Attribute_Unconstrained_Array
8484 | Attribute_Has_Access_Values
8485 | Attribute_Has_Discriminants
8486 | Attribute_Has_Tagged_Values
8487 then
8488 return;
8489 end if;
8491 -- At this stage P_Entity is the entity to which the attribute
8492 -- is to be applied. This is usually simply the entity of the
8493 -- prefix, except in some cases of attributes for objects, where
8494 -- as described above, we apply the attribute to the object type.
8496 -- Here is where we make sure that static attributes are properly
8497 -- marked as such. These are attributes whose prefix is a static
8498 -- scalar subtype, whose result is scalar, and whose arguments, if
8499 -- present, are static scalar expressions. Note that such references
8500 -- are static expressions even if they raise Constraint_Error.
8502 -- For example, Boolean'Pos (1/0 = 0) is a static expression, even
8503 -- though evaluating it raises constraint error. This means that a
8504 -- declaration like:
8506 -- X : constant := (if True then 1 else Boolean'Pos (1/0 = 0));
8508 -- is legal, since here this expression appears in a statically
8509 -- unevaluated position, so it does not actually raise an exception.
8511 -- T'Descriptor_Size is never static, even if T is static.
8513 if Is_Scalar_Type (P_Entity)
8514 and then not Is_Generic_Type (P_Entity)
8515 and then Is_Static_Subtype (P_Entity)
8516 and then Is_Scalar_Type (Etype (N))
8517 and then
8518 (No (E1)
8519 or else (Is_Static_Expression (E1)
8520 and then Is_Scalar_Type (Etype (E1))))
8521 and then
8522 (No (E2)
8523 or else (Is_Static_Expression (E2)
8524 and then Is_Scalar_Type (Etype (E1))))
8525 and then Id /= Attribute_Descriptor_Size
8527 -- If the front-end conjures up Integer'Pred (Integer'First)
8528 -- as the high bound of a null array aggregate, then we don't
8529 -- want to reject that as an illegal static expression.
8531 and then not Is_Null_Array_Aggregate_High_Bound (N)
8532 then
8533 Static := True;
8534 Set_Is_Static_Expression (N, True);
8535 end if;
8537 -- First foldable possibility is a scalar or array type (RM 4.9(7))
8538 -- that is not generic (generic types are eliminated by RM 4.9(25)).
8539 -- Note we allow nonstatic nongeneric types at this stage as further
8540 -- described below.
8542 if Is_Type (P_Entity)
8543 and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity))
8544 and then not Is_Generic_Type (P_Entity)
8545 then
8546 P_Type := P_Entity;
8548 -- Second foldable possibility is an array object (RM 4.9(8))
8550 elsif Ekind (P_Entity) in E_Variable | E_Constant
8551 and then Is_Array_Type (Etype (P_Entity))
8552 and then not Is_Generic_Type (Etype (P_Entity))
8553 then
8554 P_Type := Etype (P_Entity);
8556 -- If the entity is an array constant with an unconstrained nominal
8557 -- subtype then get the type from the initial value. If the value has
8558 -- been expanded into assignments, there is no expression and the
8559 -- attribute reference remains dynamic.
8561 -- We could do better here and retrieve the type ???
8563 if Ekind (P_Entity) = E_Constant
8564 and then not Is_Constrained (P_Type)
8565 then
8566 if No (Constant_Value (P_Entity)) then
8567 return;
8568 else
8569 P_Type := Etype (Constant_Value (P_Entity));
8570 end if;
8571 end if;
8573 -- Definite must be folded if the prefix is not a generic type, that
8574 -- is to say if we are within an instantiation. Same processing applies
8575 -- to selected GNAT attributes.
8577 elsif (Id = Attribute_Atomic_Always_Lock_Free or else
8578 Id = Attribute_Definite or else
8579 Id = Attribute_Descriptor_Size or else
8580 Id = Attribute_Has_Access_Values or else
8581 Id = Attribute_Has_Discriminants or else
8582 Id = Attribute_Has_Tagged_Values or else
8583 Id = Attribute_Preelaborable_Initialization or else
8584 Id = Attribute_Type_Class or else
8585 Id = Attribute_Unconstrained_Array or else
8586 Id = Attribute_Max_Alignment_For_Allocation)
8587 and then not Is_Generic_Type (P_Entity)
8588 then
8589 P_Type := P_Entity;
8591 -- We can fold 'Size applied to a type if the size is known (as happens
8592 -- for a size from an attribute definition clause). At this stage, this
8593 -- can happen only for types (e.g. record types) for which the size is
8594 -- always non-static. We exclude generic types from consideration (since
8595 -- they have bogus sizes set within templates). We can also fold
8596 -- Max_Size_In_Storage_Elements in the same cases.
8598 elsif (Id = Attribute_Size or
8599 Id = Attribute_Max_Size_In_Storage_Elements)
8600 and then Is_Type (P_Entity)
8601 and then not Is_Generic_Type (P_Entity)
8602 and then Known_Static_RM_Size (P_Entity)
8603 then
8604 declare
8605 Attr_Value : Uint := RM_Size (P_Entity);
8606 begin
8607 if Id = Attribute_Max_Size_In_Storage_Elements then
8608 Attr_Value := (Attr_Value + System_Storage_Unit - 1)
8609 / System_Storage_Unit;
8610 end if;
8611 Compile_Time_Known_Attribute (N, Attr_Value);
8612 end;
8613 return;
8615 -- We can fold 'Alignment applied to a type if the alignment is known
8616 -- (as happens for an alignment from an attribute definition clause).
8617 -- At this stage, this can happen only for types (e.g. record types) for
8618 -- which the size is always non-static. We exclude generic types from
8619 -- consideration (since they have bogus sizes set within templates).
8621 elsif Id = Attribute_Alignment
8622 and then Is_Type (P_Entity)
8623 and then not Is_Generic_Type (P_Entity)
8624 and then Known_Alignment (P_Entity)
8625 then
8626 Compile_Time_Known_Attribute (N, Alignment (P_Entity));
8627 return;
8629 -- If this is an access attribute that is known to fail accessibility
8630 -- check, rewrite accordingly.
8632 elsif Id = Attribute_Address
8633 and then Raises_Constraint_Error (N)
8634 then
8635 Rewrite (N,
8636 Make_Raise_Program_Error (Loc,
8637 Reason => PE_Accessibility_Check_Failed));
8638 Set_Etype (N, C_Type);
8639 return;
8641 -- No other cases are foldable (they certainly aren't static, and at
8642 -- the moment we don't try to fold any cases other than the ones above).
8644 else
8645 Check_Expressions;
8646 return;
8647 end if;
8649 -- If either attribute or the prefix is Any_Type, then propagate
8650 -- Any_Type to the result and don't do anything else at all.
8652 if P_Type = Any_Type
8653 or else (Present (E1) and then Etype (E1) = Any_Type)
8654 or else (Present (E2) and then Etype (E2) = Any_Type)
8655 then
8656 Set_Etype (N, Any_Type);
8657 return;
8658 end if;
8660 -- Scalar subtype case. We have not yet enforced the static requirement
8661 -- of (RM 4.9(7)) and we don't intend to just yet, since there are cases
8662 -- of non-static attribute references (e.g. S'Digits for a non-static
8663 -- floating-point type, which we can compute at compile time).
8665 -- Note: this folding of non-static attributes is not simply a case of
8666 -- optimization. For many of the attributes affected, Gigi cannot handle
8667 -- the attribute and depends on the front end having folded them away.
8669 -- Note: although we don't require staticness at this stage, we do set
8670 -- the Static variable to record the staticness, for easy reference by
8671 -- those attributes where it matters (e.g. Succ and Pred), and also to
8672 -- be used to ensure that non-static folded things are not marked as
8673 -- being static (a check that is done right at the end).
8675 P_Root_Type := Root_Type (P_Type);
8676 P_Base_Type := Base_Type (P_Type);
8678 -- If the root type or base type is generic, then we cannot fold. This
8679 -- test is needed because subtypes of generic types are not always
8680 -- marked as being generic themselves (which seems odd???)
8682 if Is_Generic_Type (P_Root_Type)
8683 or else Is_Generic_Type (P_Base_Type)
8684 then
8685 return;
8686 end if;
8688 if Is_Scalar_Type (P_Type) then
8689 if not Is_Static_Subtype (P_Type) then
8690 Static := False;
8691 Set_Is_Static_Expression (N, False);
8692 elsif not Is_OK_Static_Subtype (P_Type) then
8693 Set_Raises_Constraint_Error (N);
8694 end if;
8696 -- RM 13.14(8/4): a nonstatic expression in a spec expression does
8697 -- not cause freezing, so the representation attributes cannot be
8698 -- evaluated at this point if the type is not already frozen.
8700 if not Static
8701 and then In_Spec_Expression
8702 and then Id in Attribute_Alignment
8703 | Attribute_Component_Size
8704 | Attribute_Max_Alignment_For_Allocation
8705 | Attribute_Max_Size_In_Storage_Elements
8706 | Attribute_Object_Size
8707 | Attribute_Size
8708 | Attribute_Small
8709 | Attribute_VADS_Size
8710 | Attribute_Value_Size
8711 and then not Is_Frozen (P_Type)
8712 then
8713 return;
8714 end if;
8716 -- Array case. We enforce the constrained requirement of (RM 4.9(7-8))
8717 -- since we can't do anything with unconstrained arrays. In addition,
8718 -- only the First, Last and Length attributes are possibly static.
8720 -- Atomic_Always_Lock_Free, Definite, Descriptor_Size, Has_Access_Values
8721 -- Has_Discriminants, Has_Tagged_Values, Type_Class, and
8722 -- Unconstrained_Array are again exceptions, because they apply as well
8723 -- to unconstrained types.
8725 -- In addition Component_Size is an exception since it is possibly
8726 -- foldable, even though it is never static, and it does apply to
8727 -- unconstrained arrays. Furthermore, it is essential to fold this
8728 -- in the packed case, since otherwise the value will be incorrect.
8730 -- Folding can also be done for Preelaborable_Initialization based on
8731 -- whether the prefix type has preelaborable initialization, even though
8732 -- the attribute is nonstatic.
8734 elsif Id = Attribute_Atomic_Always_Lock_Free or else
8735 Id = Attribute_Definite or else
8736 Id = Attribute_Descriptor_Size or else
8737 Id = Attribute_Has_Access_Values or else
8738 Id = Attribute_Has_Discriminants or else
8739 Id = Attribute_Has_Tagged_Values or else
8740 Id = Attribute_Preelaborable_Initialization or else
8741 Id = Attribute_Type_Class or else
8742 Id = Attribute_Unconstrained_Array or else
8743 Id = Attribute_Component_Size
8744 then
8745 Static := False;
8746 Set_Is_Static_Expression (N, False);
8748 elsif Id /= Attribute_Max_Alignment_For_Allocation then
8749 if not Is_Constrained (P_Type)
8750 or else (Id /= Attribute_First and then
8751 Id /= Attribute_Last and then
8752 Id /= Attribute_Length)
8753 then
8754 Check_Expressions;
8755 return;
8756 end if;
8758 -- The rules in (RM 4.9(7,8)) require a static array, but as in the
8759 -- scalar case, we hold off on enforcing staticness, since there are
8760 -- cases which we can fold at compile time even though they are not
8761 -- static (e.g. 'Length applied to a static index, even though other
8762 -- non-static indexes make the array type non-static). This is only
8763 -- an optimization, but it falls out essentially free, so why not.
8764 -- Again we compute the variable Static for easy reference later
8765 -- (note that no array attributes are static in Ada 83).
8767 -- We also need to set Static properly for subsequent legality checks
8768 -- which might otherwise accept non-static constants in contexts
8769 -- where they are not legal.
8771 Static :=
8772 Ada_Version >= Ada_95 and then Statically_Denotes_Entity (P);
8773 Set_Is_Static_Expression (N, Static);
8775 declare
8776 Nod : Node_Id;
8778 begin
8779 Nod := First_Index (P_Type);
8781 -- The expression is static if the array type is constrained
8782 -- by given bounds, and not by an initial expression. Constant
8783 -- strings are static in any case.
8785 if Root_Type (P_Type) /= Standard_String then
8786 Static :=
8787 Static and then not Is_Constr_Subt_For_U_Nominal (P_Type);
8788 Set_Is_Static_Expression (N, Static);
8789 end if;
8791 while Present (Nod) loop
8792 if not Is_Static_Subtype (Etype (Nod)) then
8793 Static := False;
8794 Set_Is_Static_Expression (N, False);
8796 elsif not Is_OK_Static_Subtype (Etype (Nod)) then
8797 Set_Raises_Constraint_Error (N);
8798 Static := False;
8799 Set_Is_Static_Expression (N, False);
8800 end if;
8802 -- If however the index type is generic, or derived from
8803 -- one, attributes cannot be folded.
8805 if Is_Generic_Type (Root_Type (Etype (Nod)))
8806 and then Id /= Attribute_Component_Size
8807 then
8808 return;
8809 end if;
8811 Next_Index (Nod);
8812 end loop;
8813 end;
8814 end if;
8816 -- Check any expressions that are present. Note that these expressions,
8817 -- depending on the particular attribute type, are either part of the
8818 -- attribute designator, or they are arguments in a case where the
8819 -- attribute reference returns a function. In the latter case, the
8820 -- rule in (RM 4.9(22)) applies and in particular requires the type
8821 -- of the expressions to be scalar in order for the attribute to be
8822 -- considered to be static.
8824 declare
8825 E : Node_Id;
8827 begin
8828 E := E1;
8830 while Present (E) loop
8832 -- If expression is not static, then the attribute reference
8833 -- result certainly cannot be static.
8835 if not Is_Static_Expression (E) then
8836 Static := False;
8837 Set_Is_Static_Expression (N, False);
8838 end if;
8840 if Raises_Constraint_Error (E) then
8841 Set_Raises_Constraint_Error (N);
8842 end if;
8844 -- If the result is not known at compile time, or is not of
8845 -- a scalar type, then the result is definitely not static,
8846 -- so we can quit now.
8848 if not Compile_Time_Known_Value (E)
8849 or else not Is_Scalar_Type (Etype (E))
8850 then
8851 Check_Expressions;
8852 return;
8854 -- If the expression raises a constraint error, then so does
8855 -- the attribute reference. We keep going in this case because
8856 -- we are still interested in whether the attribute reference
8857 -- is static even if it is not static.
8859 elsif Raises_Constraint_Error (E) then
8860 Set_Raises_Constraint_Error (N);
8861 end if;
8863 Next (E);
8864 end loop;
8866 if Raises_Constraint_Error (Prefix (N)) then
8867 Set_Is_Static_Expression (N, False);
8868 return;
8869 end if;
8870 end;
8872 -- Deal with the case of a static attribute reference that raises
8873 -- constraint error. The Raises_Constraint_Error flag will already
8874 -- have been set, and the Static flag shows whether the attribute
8875 -- reference is static. In any case we certainly can't fold such an
8876 -- attribute reference.
8878 -- Note that the rewriting of the attribute node with the constraint
8879 -- error node is essential in this case, because otherwise Gigi might
8880 -- blow up on one of the attributes it never expects to see.
8882 -- The constraint_error node must have the type imposed by the context,
8883 -- to avoid spurious errors in the enclosing expression.
8885 if Raises_Constraint_Error (N) then
8886 CE_Node :=
8887 Make_Raise_Constraint_Error (Sloc (N),
8888 Reason => CE_Range_Check_Failed);
8889 Set_Etype (CE_Node, Etype (N));
8890 Set_Raises_Constraint_Error (CE_Node);
8891 Check_Expressions;
8892 Rewrite (N, Relocate_Node (CE_Node));
8893 Set_Raises_Constraint_Error (N, True);
8894 return;
8895 end if;
8897 -- At this point we have a potentially foldable attribute reference.
8898 -- If Static is set, then the attribute reference definitely obeys
8899 -- the requirements in (RM 4.9(7,8,22)), and it definitely can be
8900 -- folded. If Static is not set, then the attribute may or may not
8901 -- be foldable, and the individual attribute processing routines
8902 -- test Static as required in cases where it makes a difference.
8904 -- In the case where Static is not set, we do know that all the
8905 -- expressions present are at least known at compile time (we assumed
8906 -- above that if this was not the case, then there was no hope of static
8907 -- evaluation). However, we did not require that the bounds of the
8908 -- prefix type be compile time known, let alone static). That's because
8909 -- there are many attributes that can be computed at compile time on
8910 -- non-static subtypes, even though such references are not static
8911 -- expressions.
8913 -- For VAX float, the root type is an IEEE type. So make sure to use the
8914 -- base type instead of the root-type for floating point attributes.
8916 case Id is
8918 -- Attributes related to Ada 2012 iterators; nothing to evaluate for
8919 -- these.
8921 when Attribute_Constant_Indexing
8922 | Attribute_Default_Iterator
8923 | Attribute_Implicit_Dereference
8924 | Attribute_Iterator_Element
8925 | Attribute_Iterable
8926 | Attribute_Reduce
8927 | Attribute_Variable_Indexing
8929 null;
8931 -- Internal attributes used to deal with Ada 2012 delayed aspects.
8932 -- These were already rejected by the parser. Thus they shouldn't
8933 -- appear here.
8935 when Internal_Attribute_Id =>
8936 raise Program_Error;
8938 --------------
8939 -- Adjacent --
8940 --------------
8942 when Attribute_Adjacent =>
8943 Fold_Ureal
8945 Eval_Fat.Adjacent
8946 (P_Base_Type, Expr_Value_R (E1), Expr_Value_R (E2)),
8947 Static);
8949 ---------
8950 -- Aft --
8951 ---------
8953 when Attribute_Aft =>
8954 Fold_Uint (N, Aft_Value (P_Type), Static);
8956 ---------------
8957 -- Alignment --
8958 ---------------
8960 when Attribute_Alignment => Alignment_Block : declare
8961 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
8963 begin
8964 -- Fold if alignment is set and not otherwise
8966 if Known_Alignment (P_TypeA) then
8967 Fold_Uint (N, Alignment (P_TypeA), Static);
8968 end if;
8969 end Alignment_Block;
8971 -----------------------------
8972 -- Atomic_Always_Lock_Free --
8973 -----------------------------
8975 -- Atomic_Always_Lock_Free attribute is a Boolean, thus no need to fold
8976 -- here.
8978 when Attribute_Atomic_Always_Lock_Free => Atomic_Always_Lock_Free :
8979 declare
8980 V : constant Entity_Id :=
8981 Boolean_Literals
8982 (Support_Atomic_Primitives_On_Target
8983 and then Support_Atomic_Primitives (P_Type));
8985 begin
8986 Rewrite (N, New_Occurrence_Of (V, Loc));
8988 -- Analyze and resolve as boolean. Note that this attribute is a
8989 -- static attribute in GNAT.
8991 Analyze_And_Resolve (N, Standard_Boolean);
8992 Static := True;
8993 Set_Is_Static_Expression (N);
8994 end Atomic_Always_Lock_Free;
8996 ---------
8997 -- Bit --
8998 ---------
9000 -- Bit can never be folded
9002 when Attribute_Bit =>
9003 null;
9005 ------------------
9006 -- Body_Version --
9007 ------------------
9009 -- Body_version can never be static
9011 when Attribute_Body_Version =>
9012 null;
9014 -------------
9015 -- Ceiling --
9016 -------------
9018 when Attribute_Ceiling =>
9019 Fold_Ureal
9020 (N, Eval_Fat.Ceiling (P_Base_Type, Expr_Value_R (E1)), Static);
9022 --------------------
9023 -- Component_Size --
9024 --------------------
9026 -- Fold Component_Size if it is known at compile time, which is always
9027 -- true in the packed array case. It is important that the packed array
9028 -- case is handled here since the back end would otherwise get confused
9029 -- by the equivalent packed array type.
9031 when Attribute_Component_Size =>
9032 if Known_Static_Component_Size (P_Type) then
9033 Fold_Uint (N, Component_Size (P_Type), Static);
9034 end if;
9036 -------------
9037 -- Compose --
9038 -------------
9040 when Attribute_Compose =>
9041 Fold_Ureal
9043 Eval_Fat.Compose (P_Base_Type, Expr_Value_R (E1), Expr_Value (E2)),
9044 Static);
9046 -----------------
9047 -- Constrained --
9048 -----------------
9050 -- Constrained is never folded for now, there may be cases that
9051 -- could be handled at compile time. To be looked at later.
9053 when Attribute_Constrained =>
9055 -- The expander might fold it and set the static flag accordingly,
9056 -- but with expansion disabled, it remains as an attribute reference,
9057 -- and this reference is not static.
9059 Set_Is_Static_Expression (N, False);
9061 ---------------
9062 -- Copy_Sign --
9063 ---------------
9065 when Attribute_Copy_Sign =>
9066 Fold_Ureal
9068 Eval_Fat.Copy_Sign
9069 (P_Base_Type, Expr_Value_R (E1), Expr_Value_R (E2)),
9070 Static);
9072 --------------
9073 -- Definite --
9074 --------------
9076 when Attribute_Definite =>
9077 Rewrite (N, New_Occurrence_Of (
9078 Boolean_Literals (Is_Definite_Subtype (P_Entity)), Loc));
9079 Analyze_And_Resolve (N, Standard_Boolean);
9081 -----------
9082 -- Delta --
9083 -----------
9085 when Attribute_Delta =>
9086 Fold_Ureal (N, Delta_Value (P_Type), True);
9088 ------------
9089 -- Denorm --
9090 ------------
9092 when Attribute_Denorm =>
9093 Fold_Uint
9094 (N, UI_From_Int (Boolean'Pos (Has_Denormals (P_Type))), Static);
9096 ---------------------
9097 -- Descriptor_Size --
9098 ---------------------
9100 -- Descriptor_Size is nonnull only for unconstrained array types
9102 when Attribute_Descriptor_Size =>
9103 if not Is_Array_Type (P_Type) or else Is_Constrained (P_Type) then
9104 Fold_Uint (N, Uint_0, Static);
9105 end if;
9107 ------------
9108 -- Digits --
9109 ------------
9111 when Attribute_Digits =>
9112 Fold_Uint (N, Digits_Value (P_Type), Static);
9114 ----------
9115 -- Emax --
9116 ----------
9118 when Attribute_Emax =>
9120 -- Ada 83 attribute is defined as (RM83 3.5.8)
9122 -- T'Emax = 4 * T'Mantissa
9124 Fold_Uint (N, 4 * Mantissa, Static);
9126 --------------
9127 -- Enum_Rep --
9128 --------------
9130 when Attribute_Enum_Rep => Enum_Rep : declare
9131 Val : Node_Id;
9133 begin
9134 -- The attribute appears in the form:
9136 -- Enum_Typ'Enum_Rep (Const)
9137 -- Enum_Typ'Enum_Rep (Enum_Lit)
9139 if Present (E1) then
9140 Val := E1;
9142 -- Otherwise the prefix denotes a constant or enumeration literal:
9144 -- Const'Enum_Rep
9145 -- Enum_Lit'Enum_Rep
9147 else
9148 Val := P;
9149 end if;
9151 -- For an enumeration type with a non-standard representation use
9152 -- the Enumeration_Rep field of the proper constant. Note that this
9153 -- will not work for types Character/Wide_[Wide-]Character, since no
9154 -- real entities are created for the enumeration literals, but that
9155 -- does not matter since these two types do not have non-standard
9156 -- representations anyway.
9158 if Is_Enumeration_Type (P_Type)
9159 and then Has_Non_Standard_Rep (P_Type)
9160 then
9161 Fold_Uint (N, Enumeration_Rep (Expr_Value_E (Val)), Static);
9163 -- For enumeration types with standard representations and all other
9164 -- cases (i.e. all integer and modular types), Enum_Rep is equivalent
9165 -- to Pos.
9167 else
9168 Fold_Uint (N, Expr_Value (Val), Static);
9169 end if;
9170 end Enum_Rep;
9172 --------------
9173 -- Enum_Val --
9174 --------------
9176 when Attribute_Enum_Val => Enum_Val : declare
9177 Lit : Entity_Id;
9179 begin
9180 -- We have something like Enum_Type'Enum_Val (23), so search for a
9181 -- corresponding value in the list of Enum_Rep values for the type.
9183 Lit := First_Literal (P_Base_Type);
9184 loop
9185 if Enumeration_Rep (Lit) = Expr_Value (E1) then
9186 Fold_Uint (N, Enumeration_Pos (Lit), Static);
9187 exit;
9188 end if;
9190 Next_Literal (Lit);
9192 if No (Lit) then
9193 Apply_Compile_Time_Constraint_Error
9194 (N, "no representation value matches",
9195 CE_Range_Check_Failed,
9196 Warn => not Static);
9197 exit;
9198 end if;
9199 end loop;
9200 end Enum_Val;
9202 -------------
9203 -- Epsilon --
9204 -------------
9206 when Attribute_Epsilon =>
9208 -- Ada 83 attribute is defined as (RM83 3.5.8)
9210 -- T'Epsilon = 2.0**(1 - T'Mantissa)
9212 Fold_Ureal (N, Ureal_2 ** (1 - Mantissa), True);
9214 --------------
9215 -- Exponent --
9216 --------------
9218 when Attribute_Exponent =>
9219 Fold_Uint (N,
9220 Eval_Fat.Exponent (P_Base_Type, Expr_Value_R (E1)), Static);
9222 -----------------------
9223 -- Finalization_Size --
9224 -----------------------
9226 when Attribute_Finalization_Size =>
9227 null;
9229 -----------
9230 -- First --
9231 -----------
9233 when Attribute_First =>
9234 Set_Bounds;
9236 if Compile_Time_Known_Value (Lo_Bound) then
9237 if Is_Real_Type (P_Type) then
9238 Fold_Ureal (N, Expr_Value_R (Lo_Bound), Static);
9239 else
9240 Fold_Uint (N, Expr_Value (Lo_Bound), Static);
9241 end if;
9243 else
9244 Check_Concurrent_Discriminant (Lo_Bound);
9245 end if;
9247 -----------------
9248 -- First_Valid --
9249 -----------------
9251 when Attribute_First_Valid =>
9252 if Has_Predicates (P_Type)
9253 and then Has_Static_Predicate (P_Type)
9254 then
9255 declare
9256 FirstN : constant Node_Id :=
9257 First (Static_Discrete_Predicate (P_Type));
9258 begin
9259 if Nkind (FirstN) = N_Range then
9260 Fold_Uint (N, Expr_Value (Low_Bound (FirstN)), Static);
9261 else
9262 Fold_Uint (N, Expr_Value (FirstN), Static);
9263 end if;
9264 end;
9266 else
9267 Set_Bounds;
9268 Fold_Uint (N, Expr_Value (Lo_Bound), Static);
9269 end if;
9271 -----------------
9272 -- Fixed_Value --
9273 -----------------
9275 when Attribute_Fixed_Value =>
9276 null;
9278 -----------
9279 -- Floor --
9280 -----------
9282 when Attribute_Floor =>
9283 Fold_Ureal
9284 (N, Eval_Fat.Floor (P_Base_Type, Expr_Value_R (E1)), Static);
9286 ----------
9287 -- Fore --
9288 ----------
9290 when Attribute_Fore =>
9291 if Compile_Time_Known_Bounds (P_Type) then
9292 Fold_Uint (N, UI_From_Int (Fore_Value), Static);
9293 end if;
9295 --------------
9296 -- Fraction --
9297 --------------
9299 when Attribute_Fraction =>
9300 Fold_Ureal
9301 (N, Eval_Fat.Fraction (P_Base_Type, Expr_Value_R (E1)), Static);
9303 -----------------------
9304 -- Has_Access_Values --
9305 -----------------------
9307 when Attribute_Has_Access_Values =>
9308 Rewrite (N, New_Occurrence_Of
9309 (Boolean_Literals (Has_Access_Values (P_Root_Type)), Loc));
9310 Analyze_And_Resolve (N, Standard_Boolean);
9312 -----------------------
9313 -- Has_Discriminants --
9314 -----------------------
9316 when Attribute_Has_Discriminants =>
9317 Rewrite (N, New_Occurrence_Of (
9318 Boolean_Literals (Has_Discriminants (P_Entity)), Loc));
9319 Analyze_And_Resolve (N, Standard_Boolean);
9321 ----------------------
9322 -- Has_Same_Storage --
9323 ----------------------
9325 when Attribute_Has_Same_Storage =>
9326 null;
9328 -----------------------
9329 -- Has_Tagged_Values --
9330 -----------------------
9332 when Attribute_Has_Tagged_Values =>
9333 Rewrite (N, New_Occurrence_Of
9334 (Boolean_Literals (Has_Tagged_Component (P_Root_Type)), Loc));
9335 Analyze_And_Resolve (N, Standard_Boolean);
9337 --------------
9338 -- Identity --
9339 --------------
9341 when Attribute_Identity =>
9342 null;
9344 -----------
9345 -- Image --
9346 -----------
9348 -- Image is a scalar attribute, but is never static, because it is
9349 -- not a static function (having a non-scalar argument (RM 4.9(22))
9350 -- However, we can constant-fold the image of an enumeration literal
9351 -- if names are available and default Image implementation has not
9352 -- been overridden.
9354 when Attribute_Image =>
9355 if Is_Entity_Name (E1)
9356 and then Ekind (Entity (E1)) = E_Enumeration_Literal
9357 and then not Discard_Names (First_Subtype (Etype (E1)))
9358 and then not Global_Discard_Names
9359 and then not Has_Aspect (Etype (E1), Aspect_Put_Image)
9360 then
9361 declare
9362 Lit : constant Entity_Id := Entity (E1);
9363 Str : String_Id;
9364 begin
9365 Start_String;
9366 Get_Unqualified_Decoded_Name_String (Chars (Lit));
9367 Set_Casing (All_Upper_Case);
9368 Store_String_Chars (Name_Buffer (1 .. Name_Len));
9369 Str := End_String;
9370 Rewrite (N, Make_String_Literal (Loc, Strval => Str));
9371 Analyze_And_Resolve (N, Standard_String);
9372 Set_Is_Static_Expression (N, False);
9373 end;
9374 end if;
9376 -------------------
9377 -- Integer_Value --
9378 -------------------
9380 -- We never try to fold Integer_Value (though perhaps we could???)
9382 when Attribute_Integer_Value =>
9383 null;
9385 -------------------
9386 -- Invalid_Value --
9387 -------------------
9389 -- Invalid_Value is a scalar attribute that is never static, because
9390 -- the value is by design out of range.
9392 when Attribute_Invalid_Value =>
9393 null;
9395 -----------
9396 -- Large --
9397 -----------
9399 when Attribute_Large =>
9401 -- For fixed-point, we use the identity:
9403 -- T'Large = (2.0**T'Mantissa - 1.0) * T'Small
9405 if Is_Fixed_Point_Type (P_Type) then
9406 Rewrite (N,
9407 Make_Op_Multiply (Loc,
9408 Left_Opnd =>
9409 Make_Op_Subtract (Loc,
9410 Left_Opnd =>
9411 Make_Op_Expon (Loc,
9412 Left_Opnd =>
9413 Make_Real_Literal (Loc, Ureal_2),
9414 Right_Opnd =>
9415 Make_Attribute_Reference (Loc,
9416 Prefix => P,
9417 Attribute_Name => Name_Mantissa)),
9418 Right_Opnd => Make_Real_Literal (Loc, Ureal_1)),
9420 Right_Opnd =>
9421 Make_Real_Literal (Loc, Small_Value (Entity (P)))));
9423 Analyze_And_Resolve (N, C_Type);
9425 -- Floating-point (Ada 83 compatibility)
9427 else
9428 -- Ada 83 attribute is defined as (RM83 3.5.8)
9430 -- T'Large = 2.0**T'Emax * (1.0 - 2.0**(-T'Mantissa))
9432 -- where
9434 -- T'Emax = 4 * T'Mantissa
9436 Fold_Ureal
9438 Ureal_2 ** (4 * Mantissa) * (Ureal_1 - Ureal_2 ** (-Mantissa)),
9439 True);
9440 end if;
9442 ----------
9443 -- Last --
9444 ----------
9446 when Attribute_Last =>
9447 Set_Bounds;
9449 if Compile_Time_Known_Value (Hi_Bound) then
9450 if Is_Real_Type (P_Type) then
9451 Fold_Ureal (N, Expr_Value_R (Hi_Bound), Static);
9452 else
9453 Fold_Uint (N, Expr_Value (Hi_Bound), Static);
9454 end if;
9456 else
9457 Check_Concurrent_Discriminant (Hi_Bound);
9458 end if;
9460 ----------------
9461 -- Last_Valid --
9462 ----------------
9464 when Attribute_Last_Valid =>
9465 if Has_Predicates (P_Type)
9466 and then Has_Static_Predicate (P_Type)
9467 then
9468 declare
9469 LastN : constant Node_Id :=
9470 Last (Static_Discrete_Predicate (P_Type));
9471 begin
9472 if Nkind (LastN) = N_Range then
9473 Fold_Uint (N, Expr_Value (High_Bound (LastN)), Static);
9474 else
9475 Fold_Uint (N, Expr_Value (LastN), Static);
9476 end if;
9477 end;
9479 else
9480 Set_Bounds;
9481 Fold_Uint (N, Expr_Value (Hi_Bound), Static);
9482 end if;
9484 ------------------
9485 -- Leading_Part --
9486 ------------------
9488 when Attribute_Leading_Part => Leading_Part : declare
9489 Radix_Digits : constant Uint := Expr_Value (E2);
9491 begin
9492 if UI_Le (Radix_Digits, Uint_0) then
9493 Apply_Compile_Time_Constraint_Error
9494 (N, "Radix_Digits in Leading_Part is zero or negative",
9495 CE_Explicit_Raise,
9496 Warn => not Static);
9498 Check_Expressions;
9499 return;
9500 end if;
9502 Fold_Ureal
9504 Eval_Fat.Leading_Part
9505 (P_Base_Type, Expr_Value_R (E1), Radix_Digits),
9506 Static);
9507 end Leading_Part;
9509 ------------
9510 -- Length --
9511 ------------
9513 when Attribute_Length => Length : declare
9514 Ind : Node_Id;
9516 begin
9517 -- If any index type is a formal type, or derived from one, the
9518 -- bounds are not static. Treating them as static can produce
9519 -- spurious warnings or improper constant folding.
9521 Ind := First_Index (P_Type);
9522 while Present (Ind) loop
9523 if Is_Generic_Type (Root_Type (Etype (Ind))) then
9524 return;
9525 end if;
9527 Next_Index (Ind);
9528 end loop;
9530 Set_Bounds;
9532 -- For two compile time values, we can compute length
9534 if Compile_Time_Known_Value (Lo_Bound)
9535 and then Compile_Time_Known_Value (Hi_Bound)
9536 then
9537 Fold_Uint (N,
9538 UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))),
9539 Static);
9540 end if;
9542 -- One more case is where Hi_Bound and Lo_Bound are compile-time
9543 -- comparable, and we can figure out the difference between them.
9545 declare
9546 Diff : aliased Uint;
9548 begin
9549 case
9550 Compile_Time_Compare
9551 (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
9553 when EQ =>
9554 Fold_Uint (N, Uint_1, Static);
9556 when GT =>
9557 Fold_Uint (N, Uint_0, Static);
9559 when LT =>
9560 if Present (Diff) then
9561 Fold_Uint (N, Diff + 1, Static);
9562 end if;
9564 when others =>
9565 null;
9566 end case;
9567 end;
9568 end Length;
9570 ----------------
9571 -- Loop_Entry --
9572 ----------------
9574 -- Loop_Entry acts as an alias of a constant initialized to the prefix
9575 -- of the said attribute at the point of entry into the related loop. As
9576 -- such, the attribute reference does not need to be evaluated because
9577 -- the prefix is the one that is evaluted.
9579 when Attribute_Loop_Entry =>
9580 null;
9582 -------------
9583 -- Machine --
9584 -------------
9586 -- We use the same rounding as the one used for RM 4.9(38/2)
9588 when Attribute_Machine =>
9589 Fold_Ureal
9590 (N, Machine_Number (P_Base_Type, Expr_Value_R (E1), N), Static);
9591 Set_Is_Machine_Number (N);
9593 ------------------
9594 -- Machine_Emax --
9595 ------------------
9597 when Attribute_Machine_Emax =>
9598 Fold_Uint (N, Machine_Emax_Value (P_Type), Static);
9600 ------------------
9601 -- Machine_Emin --
9602 ------------------
9604 when Attribute_Machine_Emin =>
9605 Fold_Uint (N, Machine_Emin_Value (P_Type), Static);
9607 ----------------------
9608 -- Machine_Mantissa --
9609 ----------------------
9611 when Attribute_Machine_Mantissa =>
9612 Fold_Uint (N, Machine_Mantissa_Value (P_Type), Static);
9614 -----------------------
9615 -- Machine_Overflows --
9616 -----------------------
9618 when Attribute_Machine_Overflows =>
9620 -- Always true for fixed-point
9622 if Is_Fixed_Point_Type (P_Type) then
9623 Fold_Uint (N, True_Value, Static);
9625 -- Floating point case
9627 else
9628 Fold_Uint (N,
9629 UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)),
9630 Static);
9631 end if;
9633 -------------------
9634 -- Machine_Radix --
9635 -------------------
9637 when Attribute_Machine_Radix =>
9638 if Is_Fixed_Point_Type (P_Type) then
9639 if Is_Decimal_Fixed_Point_Type (P_Type)
9640 and then Machine_Radix_10 (P_Type)
9641 then
9642 Fold_Uint (N, Uint_10, Static);
9643 else
9644 Fold_Uint (N, Uint_2, Static);
9645 end if;
9647 -- All floating-point type always have radix 2
9649 else
9650 Fold_Uint (N, Uint_2, Static);
9651 end if;
9653 ----------------------
9654 -- Machine_Rounding --
9655 ----------------------
9657 -- Note: for the folding case, it is fine to treat Machine_Rounding
9658 -- exactly the same way as Rounding, since this is one of the allowed
9659 -- behaviors, and performance is not an issue here. It might be a bit
9660 -- better to give the same result as it would give at run time, even
9661 -- though the non-determinism is certainly permitted.
9663 when Attribute_Machine_Rounding =>
9664 Fold_Ureal
9665 (N, Eval_Fat.Rounding (P_Base_Type, Expr_Value_R (E1)), Static);
9667 --------------------
9668 -- Machine_Rounds --
9669 --------------------
9671 when Attribute_Machine_Rounds =>
9673 -- Always False for fixed-point
9675 if Is_Fixed_Point_Type (P_Type) then
9676 Fold_Uint (N, False_Value, Static);
9678 -- Else yield proper floating-point result
9680 else
9681 Fold_Uint
9682 (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)),
9683 Static);
9684 end if;
9686 ------------------
9687 -- Machine_Size --
9688 ------------------
9690 -- Note: Machine_Size is identical to Object_Size
9692 when Attribute_Machine_Size => Machine_Size : declare
9693 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
9695 begin
9696 if Known_Esize (P_TypeA) then
9697 Fold_Uint (N, Esize (P_TypeA), Static);
9698 end if;
9699 end Machine_Size;
9701 --------------
9702 -- Mantissa --
9703 --------------
9705 when Attribute_Mantissa =>
9707 -- Fixed-point mantissa
9709 if Is_Fixed_Point_Type (P_Type) then
9711 -- Compile time foldable case
9713 if Compile_Time_Known_Value (Type_Low_Bound (P_Type))
9714 and then
9715 Compile_Time_Known_Value (Type_High_Bound (P_Type))
9716 then
9717 -- The calculation of the obsolete Ada 83 attribute Mantissa
9718 -- is annoying, because of AI00143, quoted here:
9720 -- !question 84-01-10
9722 -- Consider the model numbers for F:
9724 -- type F is delta 1.0 range -7.0 .. 8.0;
9726 -- The wording requires that F'MANTISSA be the SMALLEST
9727 -- integer number for which each bound of the specified
9728 -- range is either a model number or lies at most small
9729 -- distant from a model number. This means F'MANTISSA
9730 -- is required to be 3 since the range -7.0 .. 7.0 fits
9731 -- in 3 signed bits, and 8 is "at most" 1.0 from a model
9732 -- number, namely, 7. Is this analysis correct? Note that
9733 -- this implies the upper bound of the range is not
9734 -- represented as a model number.
9736 -- !response 84-03-17
9738 -- The analysis is correct. The upper and lower bounds for
9739 -- a fixed point type can lie outside the range of model
9740 -- numbers.
9742 declare
9743 Siz : Uint;
9744 LBound : Ureal;
9745 UBound : Ureal;
9746 Bound : Ureal;
9747 Max_Man : Uint;
9749 begin
9750 LBound := Expr_Value_R (Type_Low_Bound (P_Type));
9751 UBound := Expr_Value_R (Type_High_Bound (P_Type));
9752 Bound := UR_Max (UR_Abs (LBound), UR_Abs (UBound));
9753 Max_Man := UR_Trunc (Bound / Small_Value (P_Type));
9755 -- If the Bound is exactly a model number, i.e. a multiple
9756 -- of Small, then we back it off by one to get the integer
9757 -- value that must be representable.
9759 if Small_Value (P_Type) * Max_Man = Bound then
9760 Max_Man := Max_Man - 1;
9761 end if;
9763 -- Now find corresponding size = Mantissa value
9765 Siz := Uint_0;
9766 while 2 ** Siz < Max_Man loop
9767 Siz := Siz + 1;
9768 end loop;
9770 Fold_Uint (N, Siz, Static);
9771 end;
9773 else
9774 -- The case of dynamic bounds cannot be evaluated at compile
9775 -- time. Instead we use a runtime routine (see Exp_Attr).
9777 null;
9778 end if;
9780 -- Floating-point Mantissa
9782 else
9783 Fold_Uint (N, Mantissa, Static);
9784 end if;
9786 ---------
9787 -- Max --
9788 ---------
9790 when Attribute_Max =>
9791 if Is_Real_Type (P_Type) then
9792 Fold_Ureal
9793 (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
9794 else
9795 Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static);
9796 end if;
9798 ----------------------------------
9799 -- Max_Alignment_For_Allocation --
9800 ----------------------------------
9802 -- Max_Alignment_For_Allocation is usually the Alignment. However,
9803 -- arrays are allocated with dope, so we need to take into account both
9804 -- the alignment of the array, which comes from the component alignment,
9805 -- and the alignment of the dope. Also, if the alignment is unknown, we
9806 -- use the max (it's OK to be pessimistic).
9808 when Attribute_Max_Alignment_For_Allocation => Max_Align : declare
9809 A : Uint := UI_From_Int (Ttypes.Maximum_Alignment);
9810 begin
9811 if Known_Alignment (P_Type)
9812 and then (not Is_Array_Type (P_Type) or else Alignment (P_Type) > A)
9813 then
9814 A := Alignment (P_Type);
9815 end if;
9817 Fold_Uint (N, A, Static);
9818 end Max_Align;
9820 ----------------------------------
9821 -- Max_Size_In_Storage_Elements --
9822 ----------------------------------
9824 -- Max_Size_In_Storage_Elements is simply the Size rounded up to a
9825 -- Storage_Unit boundary. We can fold any cases for which the size
9826 -- is known by the front end.
9828 when Attribute_Max_Size_In_Storage_Elements =>
9829 if Known_Esize (P_Type) then
9830 Fold_Uint (N,
9831 (Esize (P_Type) + System_Storage_Unit - 1) /
9832 System_Storage_Unit,
9833 Static);
9834 end if;
9836 --------------------
9837 -- Mechanism_Code --
9838 --------------------
9840 when Attribute_Mechanism_Code => Mechanism_Code : declare
9841 Formal : Entity_Id;
9842 Mech : Mechanism_Type;
9843 Val : Int;
9845 begin
9846 if No (E1) then
9847 Mech := Mechanism (P_Entity);
9849 else
9850 Val := UI_To_Int (Expr_Value (E1));
9852 Formal := First_Formal (P_Entity);
9853 for J in 1 .. Val - 1 loop
9854 Next_Formal (Formal);
9855 end loop;
9857 Mech := Mechanism (Formal);
9858 end if;
9860 if Mech < 0 then
9861 Fold_Uint (N, UI_From_Int (Int (-Mech)), Static);
9862 end if;
9863 end Mechanism_Code;
9865 ---------
9866 -- Min --
9867 ---------
9869 when Attribute_Min =>
9870 if Is_Real_Type (P_Type) then
9871 Fold_Ureal
9872 (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
9873 else
9874 Fold_Uint
9875 (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static);
9876 end if;
9878 ---------
9879 -- Mod --
9880 ---------
9882 when Attribute_Mod =>
9883 Fold_Uint
9884 (N, UI_Mod (Expr_Value (E1), Modulus (P_Base_Type)), Static);
9886 -----------
9887 -- Model --
9888 -----------
9890 when Attribute_Model =>
9891 Fold_Ureal
9892 (N, Eval_Fat.Model (P_Base_Type, Expr_Value_R (E1)), Static);
9894 ----------------
9895 -- Model_Emin --
9896 ----------------
9898 when Attribute_Model_Emin =>
9899 Fold_Uint (N, Model_Emin_Value (P_Base_Type), Static);
9901 -------------------
9902 -- Model_Epsilon --
9903 -------------------
9905 when Attribute_Model_Epsilon =>
9906 Fold_Ureal (N, Model_Epsilon_Value (P_Base_Type), Static);
9908 --------------------
9909 -- Model_Mantissa --
9910 --------------------
9912 when Attribute_Model_Mantissa =>
9913 Fold_Uint (N, Model_Mantissa_Value (P_Base_Type), Static);
9915 -----------------
9916 -- Model_Small --
9917 -----------------
9919 when Attribute_Model_Small =>
9920 Fold_Ureal (N, Model_Small_Value (P_Base_Type), Static);
9922 -------------
9923 -- Modulus --
9924 -------------
9926 when Attribute_Modulus =>
9927 Fold_Uint (N, Modulus (P_Type), Static);
9929 --------------------
9930 -- Null_Parameter --
9931 --------------------
9933 -- Cannot fold, we know the value sort of, but the whole point is
9934 -- that there is no way to talk about this imaginary value except
9935 -- by using the attribute, so we leave it the way it is.
9937 when Attribute_Null_Parameter =>
9938 null;
9940 -----------------
9941 -- Object_Size --
9942 -----------------
9944 -- The Object_Size attribute for a type returns the Esize of the
9945 -- type and can be folded if this value is known.
9947 when Attribute_Object_Size => Object_Size : declare
9948 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
9950 begin
9951 if Known_Esize (P_TypeA) then
9952 Fold_Uint (N, Esize (P_TypeA), Static);
9953 end if;
9954 end Object_Size;
9956 ----------------------
9957 -- Overlaps_Storage --
9958 ----------------------
9960 when Attribute_Overlaps_Storage =>
9961 null;
9963 -------------------------
9964 -- Passed_By_Reference --
9965 -------------------------
9967 -- Scalar types are never passed by reference
9969 when Attribute_Passed_By_Reference =>
9970 Fold_Uint (N, False_Value, Static);
9972 ---------
9973 -- Pos --
9974 ---------
9976 when Attribute_Pos =>
9977 Fold_Uint (N, Expr_Value (E1), Static);
9979 ----------
9980 -- Pred --
9981 ----------
9983 when Attribute_Pred =>
9985 -- Floating-point case
9987 if Is_Floating_Point_Type (P_Type) then
9988 Fold_Ureal
9989 (N, Eval_Fat.Pred (P_Base_Type, Expr_Value_R (E1)), Static);
9991 -- Fixed-point case
9993 elsif Is_Fixed_Point_Type (P_Type) then
9994 Fold_Ureal
9995 (N, Expr_Value_R (E1) - Small_Value (P_Type), True);
9997 -- Modular integer case (wraps)
9999 elsif Is_Modular_Integer_Type (P_Type) then
10000 Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type), Static);
10002 -- Other scalar cases
10004 else
10005 pragma Assert (Is_Scalar_Type (P_Type));
10007 if Is_Enumeration_Type (P_Type)
10008 and then Expr_Value (E1) =
10009 Expr_Value (Type_Low_Bound (P_Base_Type))
10010 then
10011 Apply_Compile_Time_Constraint_Error
10012 (N, "Pred of `&''First`",
10013 CE_Overflow_Check_Failed,
10014 Ent => P_Base_Type,
10015 Warn => not Static);
10017 Check_Expressions;
10018 return;
10020 -- Rewrite the FE-constructed high bound of a null array
10021 -- aggregate to raise CE.
10023 elsif Is_Signed_Integer_Type (P_Type)
10024 and then Expr_Value (E1) =
10025 Expr_Value (Type_Low_Bound (P_Base_Type))
10026 and then Is_Null_Array_Aggregate_High_Bound (N)
10027 then
10028 Apply_Compile_Time_Constraint_Error
10029 (N, "Pred of `&''First`",
10030 CE_Overflow_Check_Failed,
10031 Ent => P_Base_Type,
10032 Warn => True);
10034 Rewrite (N, Make_Raise_Constraint_Error (Sloc (N),
10035 Reason => CE_Overflow_Check_Failed));
10036 Set_Etype (N, P_Base_Type);
10037 return;
10038 end if;
10040 Fold_Uint (N, Expr_Value (E1) - 1, Static);
10041 end if;
10043 ----------------------------------
10044 -- Preelaborable_Initialization --
10045 ----------------------------------
10047 when Attribute_Preelaborable_Initialization =>
10048 Fold_Uint
10050 UI_From_Int
10051 (Boolean'Pos (Has_Preelaborable_Initialization (P_Type))),
10052 Static);
10054 -----------
10055 -- Range --
10056 -----------
10058 -- No processing required, because by this stage, Range has been
10059 -- replaced by First .. Last, so this branch can never be taken.
10061 when Attribute_Range =>
10062 raise Program_Error;
10064 ------------------
10065 -- Range_Length --
10066 ------------------
10068 when Attribute_Range_Length => Range_Length : declare
10069 Diff : aliased Uint;
10071 begin
10072 Set_Bounds;
10074 -- Can fold if both bounds are compile time known
10076 if Compile_Time_Known_Value (Hi_Bound)
10077 and then Compile_Time_Known_Value (Lo_Bound)
10078 then
10079 Fold_Uint (N,
10080 UI_Max
10081 (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1),
10082 Static);
10083 end if;
10085 -- One more case is where Hi_Bound and Lo_Bound are compile-time
10086 -- comparable, and we can figure out the difference between them.
10088 case Compile_Time_Compare
10089 (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
10091 when EQ =>
10092 Fold_Uint (N, Uint_1, Static);
10094 when GT =>
10095 Fold_Uint (N, Uint_0, Static);
10097 when LT =>
10098 if Present (Diff) then
10099 Fold_Uint (N, Diff + 1, Static);
10100 end if;
10102 when others =>
10103 null;
10104 end case;
10105 end Range_Length;
10107 ---------
10108 -- Ref --
10109 ---------
10111 when Attribute_Ref =>
10112 Fold_Uint (N, Expr_Value (E1), Static);
10114 ---------------
10115 -- Remainder --
10116 ---------------
10118 when Attribute_Remainder => Remainder : declare
10119 X : constant Ureal := Expr_Value_R (E1);
10120 Y : constant Ureal := Expr_Value_R (E2);
10122 begin
10123 if UR_Is_Zero (Y) then
10124 Apply_Compile_Time_Constraint_Error
10125 (N, "division by zero in Remainder",
10126 CE_Overflow_Check_Failed,
10127 Warn => not Static);
10129 Check_Expressions;
10130 return;
10131 end if;
10133 Fold_Ureal (N, Eval_Fat.Remainder (P_Base_Type, X, Y), Static);
10134 end Remainder;
10136 -----------------
10137 -- Restriction --
10138 -----------------
10140 when Attribute_Restriction_Set =>
10141 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
10142 Set_Is_Static_Expression (N);
10144 -----------
10145 -- Round --
10146 -----------
10148 when Attribute_Round => Round : declare
10149 Sr : Ureal;
10150 Si : Uint;
10152 begin
10153 -- First we get the (exact result) in units of small
10155 Sr := Expr_Value_R (E1) / Small_Value (C_Type);
10157 -- Now round that exactly to an integer
10159 Si := UR_To_Uint (Sr);
10161 -- Finally the result is obtained by converting back to real
10163 Fold_Ureal (N, Si * Small_Value (C_Type), Static);
10164 end Round;
10166 --------------
10167 -- Rounding --
10168 --------------
10170 when Attribute_Rounding =>
10171 Fold_Ureal
10172 (N, Eval_Fat.Rounding (P_Base_Type, Expr_Value_R (E1)), Static);
10174 ---------------
10175 -- Safe_Emax --
10176 ---------------
10178 when Attribute_Safe_Emax =>
10179 Fold_Uint (N, Safe_Emax_Value (P_Type), Static);
10181 ----------------
10182 -- Safe_First --
10183 ----------------
10185 when Attribute_Safe_First =>
10186 Fold_Ureal (N, Safe_First_Value (P_Type), Static);
10188 ----------------
10189 -- Safe_Large --
10190 ----------------
10192 when Attribute_Safe_Large =>
10193 if Is_Fixed_Point_Type (P_Type) then
10194 Fold_Ureal
10195 (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static);
10196 else
10197 Fold_Ureal (N, Safe_Last_Value (P_Type), Static);
10198 end if;
10200 ---------------
10201 -- Safe_Last --
10202 ---------------
10204 when Attribute_Safe_Last =>
10205 Fold_Ureal (N, Safe_Last_Value (P_Type), Static);
10207 ----------------
10208 -- Safe_Small --
10209 ----------------
10211 when Attribute_Safe_Small =>
10213 -- In Ada 95, the old Ada 83 attribute Safe_Small is redundant
10214 -- for fixed-point, since is the same as Small, but we implement
10215 -- it for backwards compatibility.
10217 if Is_Fixed_Point_Type (P_Type) then
10218 Fold_Ureal (N, Small_Value (P_Type), Static);
10220 -- Ada 83 Safe_Small for floating-point cases
10222 else
10223 Fold_Ureal (N, Model_Small_Value (P_Type), Static);
10224 end if;
10226 -----------
10227 -- Scale --
10228 -----------
10230 when Attribute_Scale =>
10231 Fold_Uint (N, Scale_Value (P_Type), Static);
10233 -------------
10234 -- Scaling --
10235 -------------
10237 when Attribute_Scaling =>
10238 Fold_Ureal
10240 Eval_Fat.Scaling
10241 (P_Base_Type, Expr_Value_R (E1), Expr_Value (E2)),
10242 Static);
10244 ------------------
10245 -- Signed_Zeros --
10246 ------------------
10248 when Attribute_Signed_Zeros =>
10249 Fold_Uint
10250 (N, UI_From_Int (Boolean'Pos (Has_Signed_Zeros (P_Type))), Static);
10252 ----------
10253 -- Size --
10254 ----------
10256 -- Size attribute returns the RM size. All scalar types can be folded,
10257 -- as well as any types for which the size is known by the front end,
10258 -- including any type for which a size attribute is specified. This is
10259 -- one of the places where it is annoying that a size of zero means two
10260 -- things (zero size for scalars, unspecified size for non-scalars).
10262 when Attribute_Size
10263 | Attribute_VADS_Size
10265 Size : declare
10266 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
10268 begin
10269 pragma Assert
10270 (if Is_Scalar_Type (P_TypeA) then Known_RM_Size (P_TypeA));
10271 if Known_RM_Size (P_TypeA) then
10272 -- VADS_Size case
10274 if Id = Attribute_VADS_Size or else Use_VADS_Size then
10275 declare
10276 S : constant Node_Id := Size_Clause (P_TypeA);
10278 begin
10279 -- If a size clause applies, then use the size from it.
10280 -- This is one of the rare cases where we can use the
10281 -- Size_Clause field for a subtype when Has_Size_Clause
10282 -- is False. Consider:
10284 -- type x is range 1 .. 64;
10285 -- for x'size use 12;
10286 -- subtype y is x range 0 .. 3;
10288 -- Here y has a size clause inherited from x, but
10289 -- normally it does not apply, and y'size is 2. However,
10290 -- y'VADS_Size is indeed 12 and not 2.
10292 if Present (S)
10293 and then Is_OK_Static_Expression (Expression (S))
10294 then
10295 Fold_Uint (N, Expr_Value (Expression (S)), Static);
10297 -- If no size is specified, then we simply use the object
10298 -- size in the VADS_Size case (e.g. Natural'Size is equal
10299 -- to Integer'Size, not one less).
10301 else
10302 Fold_Uint (N, Esize (P_TypeA), Static);
10303 end if;
10304 end;
10306 -- Normal case (Size) in which case we want the RM_Size
10308 else
10309 Fold_Uint (N, RM_Size (P_TypeA), Static);
10310 end if;
10311 end if;
10312 end Size;
10314 -----------
10315 -- Small --
10316 -----------
10318 when Attribute_Small =>
10320 -- The floating-point case is present only for Ada 83 compatibility.
10321 -- Note that strictly this is an illegal addition, since we are
10322 -- extending an Ada 95 defined attribute, but we anticipate an
10323 -- ARG ruling that will permit this.
10325 if Is_Floating_Point_Type (P_Type) then
10327 -- Ada 83 attribute is defined as (RM83 3.5.8)
10329 -- T'Small = 2.0**(-T'Emax - 1)
10331 -- where
10333 -- T'Emax = 4 * T'Mantissa
10335 Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1), Static);
10337 -- Normal Ada 95 fixed-point case
10339 else
10340 Fold_Ureal (N, Small_Value (P_Type), True);
10341 end if;
10343 -----------------------
10344 -- Small_Denominator --
10345 -----------------------
10347 when Attribute_Small_Denominator =>
10348 Fold_Uint (N, Norm_Den (Small_Value (P_Type)), True);
10350 ---------------------
10351 -- Small_Numerator --
10352 ---------------------
10354 when Attribute_Small_Numerator =>
10355 Fold_Uint (N, Norm_Num (Small_Value (P_Type)), True);
10357 -----------------
10358 -- Stream_Size --
10359 -----------------
10361 when Attribute_Stream_Size =>
10362 null;
10364 ----------
10365 -- Succ --
10366 ----------
10368 when Attribute_Succ =>
10369 -- Floating-point case
10371 if Is_Floating_Point_Type (P_Type) then
10372 Fold_Ureal
10373 (N, Eval_Fat.Succ (P_Base_Type, Expr_Value_R (E1)), Static);
10375 -- Fixed-point case
10377 elsif Is_Fixed_Point_Type (P_Type) then
10378 Fold_Ureal (N, Expr_Value_R (E1) + Small_Value (P_Type), Static);
10380 -- Modular integer case (wraps)
10382 elsif Is_Modular_Integer_Type (P_Type) then
10383 Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type), Static);
10385 -- Other scalar cases
10387 else
10388 pragma Assert (Is_Scalar_Type (P_Type));
10390 if Is_Enumeration_Type (P_Type)
10391 and then Expr_Value (E1) =
10392 Expr_Value (Type_High_Bound (P_Base_Type))
10393 then
10394 Apply_Compile_Time_Constraint_Error
10395 (N, "Succ of `&''Last`",
10396 CE_Overflow_Check_Failed,
10397 Ent => P_Base_Type,
10398 Warn => not Static);
10400 Check_Expressions;
10401 return;
10402 else
10403 Fold_Uint (N, Expr_Value (E1) + 1, Static);
10404 end if;
10405 end if;
10407 ----------------
10408 -- Truncation --
10409 ----------------
10411 when Attribute_Truncation =>
10412 Fold_Ureal
10414 Eval_Fat.Truncation (P_Base_Type, Expr_Value_R (E1)),
10415 Static);
10417 ----------------
10418 -- Type_Class --
10419 ----------------
10421 when Attribute_Type_Class => Type_Class : declare
10422 Typ : constant Entity_Id := Underlying_Type (P_Base_Type);
10423 Id : RE_Id;
10425 begin
10426 if Is_Descendant_Of_Address (Typ) then
10427 Id := RE_Type_Class_Address;
10429 elsif Is_Enumeration_Type (Typ) then
10430 Id := RE_Type_Class_Enumeration;
10432 elsif Is_Integer_Type (Typ) then
10433 Id := RE_Type_Class_Integer;
10435 elsif Is_Fixed_Point_Type (Typ) then
10436 Id := RE_Type_Class_Fixed_Point;
10438 elsif Is_Floating_Point_Type (Typ) then
10439 Id := RE_Type_Class_Floating_Point;
10441 elsif Is_Array_Type (Typ) then
10442 Id := RE_Type_Class_Array;
10444 elsif Is_Record_Type (Typ) then
10445 Id := RE_Type_Class_Record;
10447 elsif Is_Access_Type (Typ) then
10448 Id := RE_Type_Class_Access;
10450 elsif Is_Task_Type (Typ) then
10451 Id := RE_Type_Class_Task;
10453 -- We treat protected types like task types. It would make more
10454 -- sense to have another enumeration value, but after all the
10455 -- whole point of this feature is to be exactly DEC compatible,
10456 -- and changing the type Type_Class would not meet this requirement.
10458 elsif Is_Protected_Type (Typ) then
10459 Id := RE_Type_Class_Task;
10461 -- Not clear if there are any other possibilities, but if there
10462 -- are, then we will treat them as the address case.
10464 else
10465 Id := RE_Type_Class_Address;
10466 end if;
10468 Rewrite (N, New_Occurrence_Of (RTE (Id), Loc));
10469 end Type_Class;
10471 -----------------------
10472 -- Unbiased_Rounding --
10473 -----------------------
10475 when Attribute_Unbiased_Rounding =>
10476 Fold_Ureal
10478 Eval_Fat.Unbiased_Rounding (P_Base_Type, Expr_Value_R (E1)),
10479 Static);
10481 -------------------------
10482 -- Unconstrained_Array --
10483 -------------------------
10485 when Attribute_Unconstrained_Array => Unconstrained_Array : declare
10486 Typ : constant Entity_Id := Underlying_Type (P_Type);
10488 begin
10489 Rewrite (N, New_Occurrence_Of (
10490 Boolean_Literals (
10491 Is_Array_Type (P_Type)
10492 and then not Is_Constrained (Typ)), Loc));
10494 -- Analyze and resolve as boolean, note that this attribute is
10495 -- a static attribute in GNAT.
10497 Analyze_And_Resolve (N, Standard_Boolean);
10498 Static := True;
10499 Set_Is_Static_Expression (N, True);
10500 end Unconstrained_Array;
10502 -- Attribute Update is never static
10504 when Attribute_Update =>
10505 return;
10507 ---------------
10508 -- VADS_Size --
10509 ---------------
10511 -- Processing is shared with Size
10513 ---------
10514 -- Val --
10515 ---------
10517 when Attribute_Val =>
10518 if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type))
10519 or else
10520 Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type))
10521 then
10522 Apply_Compile_Time_Constraint_Error
10523 (N, "Val expression out of range",
10524 CE_Range_Check_Failed,
10525 Warn => not Static);
10527 Check_Expressions;
10528 return;
10530 else
10531 Fold_Uint (N, Expr_Value (E1), Static);
10532 end if;
10534 ----------------
10535 -- Value_Size --
10536 ----------------
10538 -- The Value_Size attribute for a type returns the RM size of the type.
10539 -- This an always be folded for scalar types, and can also be folded for
10540 -- non-scalar types if the size is set. This is one of the places where
10541 -- it is annoying that a size of zero means two things!
10543 when Attribute_Value_Size => Value_Size : declare
10544 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
10546 begin
10547 pragma Assert
10548 (if Is_Scalar_Type (P_TypeA) then Known_RM_Size (P_TypeA));
10549 if Known_RM_Size (P_TypeA) then
10550 Fold_Uint (N, RM_Size (P_TypeA), Static);
10551 end if;
10552 end Value_Size;
10554 -------------
10555 -- Version --
10556 -------------
10558 -- Version can never be static
10560 when Attribute_Version =>
10561 null;
10563 ----------------
10564 -- Wide_Image --
10565 ----------------
10567 -- Wide_Image is a scalar attribute, but is never static, because it
10568 -- is not a static function (having a non-scalar argument (RM 4.9(22))
10570 when Attribute_Wide_Image =>
10571 null;
10573 ---------------------
10574 -- Wide_Wide_Image --
10575 ---------------------
10577 -- Wide_Wide_Image is a scalar attribute but is never static, because it
10578 -- is not a static function (having a non-scalar argument (RM 4.9(22)).
10580 when Attribute_Wide_Wide_Image =>
10581 null;
10583 ---------------------
10584 -- Wide_Wide_Width --
10585 ---------------------
10587 -- Processing for Wide_Wide_Width is combined with Width
10589 ----------------
10590 -- Wide_Width --
10591 ----------------
10593 -- Processing for Wide_Width is combined with Width
10595 -----------
10596 -- Width --
10597 -----------
10599 -- This processing also handles the case of Wide_[Wide_]Width
10601 when Attribute_Width
10602 | Attribute_Wide_Width
10603 | Attribute_Wide_Wide_Width
10605 if Compile_Time_Known_Bounds (P_Type) then
10607 -- Floating-point types
10609 if Is_Floating_Point_Type (P_Type) then
10611 -- Width is zero for a null range (RM 3.5 (38))
10613 if Expr_Value_R (Type_High_Bound (P_Type)) <
10614 Expr_Value_R (Type_Low_Bound (P_Type))
10615 then
10616 Fold_Uint (N, Uint_0, Static);
10618 else
10619 -- For floating-point, we have +N.dddE+nnn where length
10620 -- of ddd is determined by type'Digits - 1, but is one
10621 -- if Digits is one (RM 3.5 (33)).
10623 -- nnn is set to 2 for Short_Float and Float (32 bit
10624 -- floats), and 3 for Long_Float and Long_Long_Float.
10625 -- For machines where Long_Long_Float is the IEEE
10626 -- extended precision type, the exponent takes 4 digits.
10628 declare
10629 Len : Int :=
10630 Int'Max (2, UI_To_Int (Digits_Value (P_Type)));
10632 begin
10633 if Esize (P_Type) <= 32 then
10634 Len := Len + 6;
10635 elsif Esize (P_Type) = 64 then
10636 Len := Len + 7;
10637 else
10638 Len := Len + 8;
10639 end if;
10641 Fold_Uint (N, UI_From_Int (Len), Static);
10642 end;
10643 end if;
10645 -- Fixed-point types
10647 elsif Is_Fixed_Point_Type (P_Type) then
10649 -- Width is zero for a null range (RM 3.5 (38))
10651 if Expr_Value (Type_High_Bound (P_Type)) <
10652 Expr_Value (Type_Low_Bound (P_Type))
10653 then
10654 Fold_Uint (N, Uint_0, Static);
10656 -- The non-null case depends on the specific real type
10658 else
10659 -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34))
10661 Fold_Uint
10662 (N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type),
10663 Static);
10664 end if;
10666 -- Discrete types
10668 else
10669 declare
10670 R : constant Entity_Id := Root_Type (P_Type);
10671 Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type));
10672 Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type));
10673 W : Nat;
10674 Wt : Nat;
10675 T : Uint;
10676 L : Node_Id;
10677 C : Character;
10679 begin
10680 -- Empty ranges
10682 if Lo > Hi then
10683 W := 0;
10685 -- Width for types derived from Standard.Character
10686 -- and Standard.Wide_[Wide_]Character.
10688 elsif Is_Standard_Character_Type (P_Type) then
10689 W := 0;
10691 -- Set W larger if needed
10693 for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop
10695 -- All wide characters look like Hex_hhhhhhhh
10697 if J > 255 then
10699 -- No need to compute this more than once
10701 exit;
10703 else
10704 C := Character'Val (J);
10706 -- Test for all cases where Character'Image
10707 -- yields an image that is longer than three
10708 -- characters. First the cases of Reserved_xxx
10709 -- names (length = 12).
10711 case C is
10712 when Reserved_128
10713 | Reserved_129
10714 | Reserved_132
10715 | Reserved_153
10717 Wt := 12;
10719 when BS
10720 | CR
10721 | EM
10722 | FF
10723 | FS
10724 | GS
10725 | HT
10726 | LF
10727 | MW
10728 | PM
10729 | RI
10730 | RS
10731 | SI
10732 | SO
10733 | ST
10734 | US
10735 | VT
10737 Wt := 2;
10739 when ACK
10740 | APC
10741 | BEL
10742 | BPH
10743 | CAN
10744 | CCH
10745 | CSI
10746 | DC1
10747 | DC2
10748 | DC3
10749 | DC4
10750 | DCS
10751 | DEL
10752 | DLE
10753 | ENQ
10754 | EOT
10755 | EPA
10756 | ESA
10757 | ESC
10758 | ETB
10759 | ETX
10760 | HTJ
10761 | HTS
10762 | NAK
10763 | NBH
10764 | NEL
10765 | NUL
10766 | OSC
10767 | PLD
10768 | PLU
10769 | PU1
10770 | PU2
10771 | SCI
10772 | SOH
10773 | SOS
10774 | SPA
10775 | SS2
10776 | SS3
10777 | SSA
10778 | STS
10779 | STX
10780 | SUB
10781 | SYN
10782 | VTS
10784 Wt := 3;
10786 when Space .. Tilde
10787 | No_Break_Space .. LC_Y_Diaeresis
10789 -- Special case of soft hyphen in Ada 2005
10791 if C = Character'Val (16#AD#)
10792 and then Ada_Version >= Ada_2005
10793 then
10794 Wt := 11;
10795 else
10796 Wt := 3;
10797 end if;
10798 end case;
10800 W := Int'Max (W, Wt);
10801 end if;
10802 end loop;
10804 -- Width for types derived from Standard.Boolean
10806 elsif R = Standard_Boolean then
10807 if Lo = 0 then
10808 W := 5; -- FALSE
10809 else
10810 W := 4; -- TRUE
10811 end if;
10813 -- Width for integer types
10815 elsif Is_Integer_Type (P_Type) then
10816 T := UI_Max (abs Lo, abs Hi);
10818 W := 2;
10819 while T >= 10 loop
10820 W := W + 1;
10821 T := T / 10;
10822 end loop;
10824 -- User declared enum type with discard names
10826 elsif Discard_Names (R) then
10828 -- If range is null, result is zero, that has already
10829 -- been dealt with, so what we need is the power of ten
10830 -- that accommodates the Pos of the largest value, which
10831 -- is the high bound of the range + one for the space.
10833 W := 1;
10834 T := Hi;
10835 while T /= 0 loop
10836 T := T / 10;
10837 W := W + 1;
10838 end loop;
10840 -- Only remaining possibility is user declared enum type
10841 -- with normal case of Discard_Names not active.
10843 else
10844 pragma Assert (Is_Enumeration_Type (P_Type));
10846 W := 0;
10847 L := First_Literal (P_Type);
10848 while Present (L) loop
10850 -- Only pay attention to in range characters
10852 if Lo <= Enumeration_Pos (L)
10853 and then Enumeration_Pos (L) <= Hi
10854 then
10855 -- For Width case, use decoded name
10857 if Id = Attribute_Width then
10858 Get_Decoded_Name_String (Chars (L));
10859 Wt := Nat (Name_Len);
10861 -- For Wide_[Wide_]Width, use encoded name, and
10862 -- then adjust for the encoding.
10864 else
10865 Get_Name_String (Chars (L));
10867 -- Character literals are always of length 3
10869 if Name_Buffer (1) = 'Q' then
10870 Wt := 3;
10872 -- Otherwise loop to adjust for upper/wide chars
10874 else
10875 Wt := Nat (Name_Len);
10877 for J in 1 .. Name_Len loop
10878 if Name_Buffer (J) = 'U' then
10879 Wt := Wt - 2;
10880 elsif Name_Buffer (J) = 'W' then
10881 Wt := Wt - 4;
10882 end if;
10883 end loop;
10884 end if;
10885 end if;
10887 W := Int'Max (W, Wt);
10888 end if;
10890 Next_Literal (L);
10891 end loop;
10892 end if;
10894 Fold_Uint (N, UI_From_Int (W), Static);
10895 end;
10896 end if;
10897 end if;
10899 -- The following attributes denote functions that cannot be folded
10901 when Attribute_From_Any
10902 | Attribute_To_Any
10903 | Attribute_TypeCode
10905 null;
10907 -- The following attributes can never be folded, and furthermore we
10908 -- should not even have entered the case statement for any of these.
10909 -- Note that in some cases, the values have already been folded as
10910 -- a result of the processing in Analyze_Attribute or earlier in
10911 -- this procedure.
10913 when Attribute_Abort_Signal
10914 | Attribute_Access
10915 | Attribute_Address
10916 | Attribute_Address_Size
10917 | Attribute_Asm_Input
10918 | Attribute_Asm_Output
10919 | Attribute_Base
10920 | Attribute_Bit_Order
10921 | Attribute_Bit_Position
10922 | Attribute_Callable
10923 | Attribute_Caller
10924 | Attribute_Class
10925 | Attribute_Code_Address
10926 | Attribute_Compiler_Version
10927 | Attribute_Count
10928 | Attribute_Default_Bit_Order
10929 | Attribute_Default_Scalar_Storage_Order
10930 | Attribute_Deref
10931 | Attribute_Elaborated
10932 | Attribute_Elab_Body
10933 | Attribute_Elab_Spec
10934 | Attribute_Elab_Subp_Body
10935 | Attribute_Enabled
10936 | Attribute_External_Tag
10937 | Attribute_Fast_Math
10938 | Attribute_First_Bit
10939 | Attribute_Img
10940 | Attribute_Input
10941 | Attribute_Index
10942 | Attribute_Initialized
10943 | Attribute_Last_Bit
10944 | Attribute_Library_Level
10945 | Attribute_Max_Integer_Size
10946 | Attribute_Maximum_Alignment
10947 | Attribute_Old
10948 | Attribute_Output
10949 | Attribute_Partition_ID
10950 | Attribute_Pool_Address
10951 | Attribute_Position
10952 | Attribute_Priority
10953 | Attribute_Put_Image
10954 | Attribute_Read
10955 | Attribute_Result
10956 | Attribute_Scalar_Storage_Order
10957 | Attribute_Simple_Storage_Pool
10958 | Attribute_Storage_Pool
10959 | Attribute_Storage_Size
10960 | Attribute_Storage_Unit
10961 | Attribute_Stub_Type
10962 | Attribute_System_Allocator_Alignment
10963 | Attribute_Tag
10964 | Attribute_Target_Name
10965 | Attribute_Terminated
10966 | Attribute_To_Address
10967 | Attribute_Type_Key
10968 | Attribute_Unchecked_Access
10969 | Attribute_Universal_Literal_String
10970 | Attribute_Unrestricted_Access
10971 | Attribute_Valid
10972 | Attribute_Valid_Scalars
10973 | Attribute_Valid_Value
10974 | Attribute_Value
10975 | Attribute_Wchar_T_Size
10976 | Attribute_Wide_Value
10977 | Attribute_Wide_Wide_Value
10978 | Attribute_Word_Size
10979 | Attribute_Write
10981 raise Program_Error;
10982 end case;
10984 -- At the end of the case, one more check. If we did a static evaluation
10985 -- so that the result is now a literal, then set Is_Static_Expression
10986 -- in the constant only if the prefix type is a static subtype. For
10987 -- non-static subtypes, the folding is still OK, but not static.
10989 -- An exception is the GNAT attribute Constrained_Array which is
10990 -- defined to be a static attribute in all cases.
10992 if Nkind (N) in N_Integer_Literal
10993 | N_Real_Literal
10994 | N_Character_Literal
10995 | N_String_Literal
10996 or else (Is_Entity_Name (N)
10997 and then Ekind (Entity (N)) = E_Enumeration_Literal)
10998 then
10999 Set_Is_Static_Expression (N, Static);
11001 -- If this is still an attribute reference, then it has not been folded
11002 -- and that means that its expressions are in a non-static context.
11004 elsif Nkind (N) = N_Attribute_Reference then
11005 Check_Expressions;
11007 -- Note: the else case not covered here are odd cases where the
11008 -- processing has transformed the attribute into something other
11009 -- than a constant. Nothing more to do in such cases.
11011 else
11012 null;
11013 end if;
11014 end Eval_Attribute;
11016 ------------------------------
11017 -- Is_Anonymous_Tagged_Base --
11018 ------------------------------
11020 function Is_Anonymous_Tagged_Base
11021 (Anon : Entity_Id;
11022 Typ : Entity_Id) return Boolean
11024 begin
11025 return
11026 Anon = Current_Scope
11027 and then Is_Itype (Anon)
11028 and then Associated_Node_For_Itype (Anon) = Parent (Typ);
11029 end Is_Anonymous_Tagged_Base;
11031 --------------------------------
11032 -- Name_Implies_Lvalue_Prefix --
11033 --------------------------------
11035 function Name_Implies_Lvalue_Prefix (Nam : Name_Id) return Boolean is
11036 pragma Assert (Is_Attribute_Name (Nam));
11037 begin
11038 return Attribute_Name_Implies_Lvalue_Prefix (Get_Attribute_Id (Nam));
11039 end Name_Implies_Lvalue_Prefix;
11041 -----------------------
11042 -- Resolve_Attribute --
11043 -----------------------
11045 procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is
11046 Loc : constant Source_Ptr := Sloc (N);
11047 P : constant Node_Id := Prefix (N);
11048 Aname : constant Name_Id := Attribute_Name (N);
11049 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
11050 Btyp : constant Entity_Id := Base_Type (Typ);
11051 Des_Btyp : Entity_Id;
11052 Index : Interp_Index;
11053 It : Interp;
11054 Nom_Subt : Entity_Id;
11056 function Declared_Within_Generic_Unit
11057 (Entity : Entity_Id;
11058 Generic_Unit : Node_Id) return Boolean;
11059 -- Returns True if Declared_Entity is declared within the declarative
11060 -- region of Generic_Unit; otherwise returns False.
11062 function Is_Thin_Pointer_To_Unc_Array (T : Entity_Id) return Boolean;
11063 -- Return True if T is a thin pointer to an unconstrained array type
11065 ----------------------------------
11066 -- Declared_Within_Generic_Unit --
11067 ----------------------------------
11069 function Declared_Within_Generic_Unit
11070 (Entity : Entity_Id;
11071 Generic_Unit : Node_Id) return Boolean
11073 Generic_Encloser : Node_Id := Enclosing_Generic_Unit (Entity);
11075 begin
11076 while Present (Generic_Encloser) loop
11077 if Generic_Encloser = Generic_Unit then
11078 return True;
11079 end if;
11081 -- We have to step to the scope of the generic's entity, because
11082 -- otherwise we'll just get back the same generic.
11084 Generic_Encloser :=
11085 Enclosing_Generic_Unit
11086 (Scope (Defining_Entity (Generic_Encloser)));
11087 end loop;
11089 return False;
11090 end Declared_Within_Generic_Unit;
11092 ----------------------------------
11093 -- Is_Thin_Pointer_To_Unc_Array --
11094 ----------------------------------
11096 function Is_Thin_Pointer_To_Unc_Array (T : Entity_Id) return Boolean is
11097 begin
11098 if Is_Access_Type (T)
11099 and then Has_Size_Clause (T)
11100 and then RM_Size (T) = System_Address_Size
11101 then
11102 declare
11103 DT : constant Entity_Id := Designated_Type (T);
11105 begin
11106 return Is_Array_Type (DT) and then not Is_Constrained (DT);
11107 end;
11109 else
11110 return False;
11111 end if;
11112 end Is_Thin_Pointer_To_Unc_Array;
11114 -- Start of processing for Resolve_Attribute
11116 begin
11117 -- If error during analysis, no point in continuing, except for array
11118 -- types, where we get better recovery by using unconstrained indexes
11119 -- than nothing at all (see Check_Array_Type).
11121 if Error_Posted (N)
11122 and then Attr_Id /= Attribute_First
11123 and then Attr_Id /= Attribute_Last
11124 and then Attr_Id /= Attribute_Length
11125 and then Attr_Id /= Attribute_Range
11126 then
11127 return;
11128 end if;
11130 -- If attribute was universal type, reset to actual type
11132 if Is_Universal_Numeric_Type (Etype (N)) then
11133 Set_Etype (N, Typ);
11134 end if;
11136 -- A Ghost attribute must appear in a specific context
11138 if Is_Ghost_Attribute_Reference (N) then
11139 Check_Ghost_Context (Empty, N);
11140 end if;
11142 -- Remaining processing depends on attribute
11144 case Attr_Id is
11146 ------------
11147 -- Access --
11148 ------------
11150 -- For access attributes, if the prefix denotes an entity, it is
11151 -- interpreted as a name, never as a call. It may be overloaded,
11152 -- in which case resolution uses the profile of the context type.
11153 -- Otherwise prefix must be resolved.
11155 when Attribute_Access
11156 | Attribute_Unchecked_Access
11157 | Attribute_Unrestricted_Access
11159 -- Note possible modification if we have a variable
11161 if Is_Variable (P)
11162 and then not Is_Access_Constant (Typ)
11163 then
11164 Note_Possible_Modification (P, Sure => False);
11165 end if;
11167 -- Case where prefix is an entity name
11169 if Is_Entity_Name (P) then
11171 -- Deal with case where prefix itself is overloaded
11173 if Is_Overloaded (P) then
11174 Get_First_Interp (P, Index, It);
11175 while Present (It.Nam) loop
11176 if Type_Conformant (Designated_Type (Typ), It.Nam) then
11177 Set_Entity (P, It.Nam);
11179 -- The prefix is definitely NOT overloaded anymore at
11180 -- this point, so we reset the Is_Overloaded flag to
11181 -- avoid any confusion when reanalyzing the node.
11183 Set_Is_Overloaded (P, False);
11184 Set_Is_Overloaded (N, False);
11185 Generate_Reference (Entity (P), P);
11186 exit;
11187 end if;
11189 Get_Next_Interp (Index, It);
11190 end loop;
11192 -- If Prefix is a subprogram name, this reference freezes,
11193 -- but not if within spec expression mode. The profile of
11194 -- the subprogram is not frozen at this point.
11196 if not In_Spec_Expression then
11197 Freeze_Before (N, Entity (P), Do_Freeze_Profile => False);
11198 end if;
11200 -- If it is a type, there is nothing to resolve.
11201 -- If it is a subprogram, do not freeze its profile.
11202 -- If it is an object, complete its resolution.
11204 elsif Is_Overloadable (Entity (P)) then
11205 if not In_Spec_Expression then
11206 Freeze_Before (N, Entity (P), Do_Freeze_Profile => False);
11207 end if;
11209 -- Nothing to do if prefix is a type name
11211 elsif Is_Type (Entity (P)) then
11212 null;
11214 -- Otherwise non-overloaded other case, resolve the prefix
11216 else
11217 Resolve (P);
11218 end if;
11220 -- Some further error checks
11222 Error_Msg_Name_1 := Aname;
11224 if not Is_Entity_Name (P) then
11225 null;
11227 elsif Is_Overloadable (Entity (P))
11228 and then Is_Abstract_Subprogram (Entity (P))
11229 then
11230 Error_Msg_F ("prefix of % attribute cannot be abstract", P);
11231 Set_Etype (N, Any_Type);
11233 elsif Ekind (Entity (P)) = E_Enumeration_Literal then
11234 Error_Msg_F
11235 ("prefix of % attribute cannot be enumeration literal", P);
11236 Set_Etype (N, Any_Type);
11238 -- An attempt to take 'Access of a function that renames an
11239 -- enumeration literal. Issue a specialized error message.
11241 elsif Ekind (Entity (P)) = E_Function
11242 and then Present (Alias (Entity (P)))
11243 and then Ekind (Alias (Entity (P))) = E_Enumeration_Literal
11244 then
11245 Error_Msg_F
11246 ("prefix of % attribute cannot be function renaming "
11247 & "an enumeration literal", P);
11248 Set_Etype (N, Any_Type);
11250 elsif Convention (Entity (P)) = Convention_Intrinsic then
11251 Error_Msg_F ("prefix of % attribute cannot be intrinsic", P);
11252 Set_Etype (N, Any_Type);
11253 end if;
11255 -- Assignments, return statements, components of aggregates,
11256 -- generic instantiations will require convention checks if
11257 -- the type is an access to subprogram. Given that there will
11258 -- also be accessibility checks on those, this is where the
11259 -- checks can eventually be centralized ???
11261 if Ekind (Btyp) in E_Access_Protected_Subprogram_Type
11262 | E_Access_Subprogram_Type
11263 | E_Anonymous_Access_Protected_Subprogram_Type
11264 | E_Anonymous_Access_Subprogram_Type
11265 then
11266 -- Deal with convention mismatch
11268 if Convention (Designated_Type (Btyp)) /=
11269 Convention (Entity (P))
11270 then
11271 Error_Msg_FE
11272 ("subprogram & has wrong convention", P, Entity (P));
11273 Error_Msg_Sloc := Sloc (Btyp);
11274 Error_Msg_FE ("\does not match & declared#", P, Btyp);
11276 if not Is_Itype (Btyp)
11277 and then not Has_Convention_Pragma (Btyp)
11278 and then Convention (Entity (P)) /= Convention_Intrinsic
11279 then
11280 Error_Msg_FE
11281 ("\probable missing pragma Convention for &",
11282 P, Btyp);
11283 end if;
11285 else
11286 Check_Subtype_Conformant
11287 (New_Id => Entity (P),
11288 Old_Id => Designated_Type (Btyp),
11289 Err_Loc => P);
11290 end if;
11292 if Attr_Id = Attribute_Unchecked_Access then
11293 Error_Msg_Name_1 := Aname;
11294 Error_Msg_F
11295 ("attribute% cannot be applied to a subprogram", P);
11297 elsif Aname = Name_Unrestricted_Access then
11298 null; -- Nothing to check
11300 -- Check the static accessibility rule of 3.10.2(32).
11301 -- This rule also applies within the private part of an
11302 -- instantiation. This rule does not apply to anonymous
11303 -- access-to-subprogram types in access parameters.
11305 elsif Attr_Id = Attribute_Access
11306 and then not In_Instance_Body
11307 and then
11308 (Ekind (Btyp) = E_Access_Subprogram_Type
11309 or else Is_Local_Anonymous_Access (Btyp))
11310 and then Subprogram_Access_Level (Entity (P)) >
11311 Type_Access_Level (Btyp)
11312 then
11313 Error_Msg_F
11314 ("subprogram must not be deeper than access type", P);
11316 -- Check the restriction of 3.10.2(32) that disallows the
11317 -- access attribute within a generic body when the ultimate
11318 -- ancestor of the type of the attribute is declared outside
11319 -- of the generic unit and the subprogram is declared within
11320 -- that generic unit. This includes any such attribute that
11321 -- occurs within the body of a generic unit that is a child
11322 -- of the generic unit where the subprogram is declared.
11324 -- The rule also prohibits applying the attribute when the
11325 -- access type is a generic formal access type (since the
11326 -- level of the actual type is not known). This restriction
11327 -- does not apply when the attribute type is an anonymous
11328 -- access-to-subprogram type. Note that this check was
11329 -- revised by AI-229, because the original Ada 95 rule
11330 -- was too lax. The original rule only applied when the
11331 -- subprogram was declared within the body of the generic,
11332 -- which allowed the possibility of dangling references).
11333 -- The rule was also too strict in some cases, in that it
11334 -- didn't permit the access to be declared in the generic
11335 -- spec, whereas the revised rule does (as long as it's not
11336 -- a formal type).
11338 -- There are a couple of subtleties of the test for applying
11339 -- the check that are worth noting. First, we only apply it
11340 -- when the levels of the subprogram and access type are the
11341 -- same (the case where the subprogram is statically deeper
11342 -- was applied above, and the case where the type is deeper
11343 -- is always safe). Second, we want the check to apply
11344 -- within nested generic bodies and generic child unit
11345 -- bodies, but not to apply to an attribute that appears in
11346 -- the generic unit's specification. This is done by testing
11347 -- that the attribute's innermost enclosing generic body is
11348 -- not the same as the innermost generic body enclosing the
11349 -- generic unit where the subprogram is declared (we don't
11350 -- want the check to apply when the access attribute is in
11351 -- the spec and there's some other generic body enclosing
11352 -- generic). Finally, there's no point applying the check
11353 -- when within an instance, because any violations will have
11354 -- been caught by the compilation of the generic unit.
11356 -- We relax this check in Relaxed_RM_Semantics mode for
11357 -- compatibility with legacy code for use by Ada source
11358 -- code analyzers (e.g. CodePeer).
11360 elsif Attr_Id = Attribute_Access
11361 and then not Relaxed_RM_Semantics
11362 and then not In_Instance
11363 and then Present (Enclosing_Generic_Unit (Entity (P)))
11364 and then Present (Enclosing_Generic_Body (N))
11365 and then Enclosing_Generic_Body (N) /=
11366 Enclosing_Generic_Body
11367 (Enclosing_Generic_Unit (Entity (P)))
11368 and then Subprogram_Access_Level (Entity (P)) =
11369 Type_Access_Level (Btyp)
11370 and then Ekind (Btyp) /=
11371 E_Anonymous_Access_Subprogram_Type
11372 and then Ekind (Btyp) /=
11373 E_Anonymous_Access_Protected_Subprogram_Type
11374 then
11375 -- The attribute type's ultimate ancestor must be
11376 -- declared within the same generic unit as the
11377 -- subprogram is declared (including within another
11378 -- nested generic unit). The error message is
11379 -- specialized to say "ancestor" for the case where the
11380 -- access type is not its own ancestor, since saying
11381 -- simply "access type" would be very confusing.
11383 if not Declared_Within_Generic_Unit
11384 (Root_Type (Btyp),
11385 Enclosing_Generic_Unit (Entity (P)))
11386 then
11387 Error_Msg_N
11388 ("''Access attribute not allowed in generic body",
11391 if Root_Type (Btyp) = Btyp then
11392 Error_Msg_NE
11393 ("\because " &
11394 "access type & is declared outside " &
11395 "generic unit (RM 3.10.2(32))", N, Btyp);
11396 else
11397 Error_Msg_NE
11398 ("\because ancestor of " &
11399 "access type & is declared outside " &
11400 "generic unit (RM 3.10.2(32))", N, Btyp);
11401 end if;
11403 Error_Msg_NE
11404 ("\move ''Access to private part, or " &
11405 "(Ada 2005) use anonymous access type instead of &",
11406 N, Btyp);
11408 -- If the ultimate ancestor of the attribute's type is
11409 -- a formal type, then the attribute is illegal because
11410 -- the actual type might be declared at a higher level.
11411 -- The error message is specialized to say "ancestor"
11412 -- for the case where the access type is not its own
11413 -- ancestor, since saying simply "access type" would be
11414 -- very confusing.
11416 elsif Is_Generic_Type (Root_Type (Btyp)) then
11417 if Root_Type (Btyp) = Btyp then
11418 Error_Msg_N
11419 ("access type must not be a generic formal type",
11421 else
11422 Error_Msg_N
11423 ("ancestor access type must not be a generic " &
11424 "formal type", N);
11425 end if;
11426 end if;
11427 end if;
11428 end if;
11430 -- If this is a renaming, an inherited operation, or a
11431 -- subprogram instance, use the original entity. This may make
11432 -- the node type-inconsistent, so this transformation can only
11433 -- be done if the node will not be reanalyzed. In particular,
11434 -- if it is within a default expression, the transformation
11435 -- must be delayed until the default subprogram is created for
11436 -- it, when the enclosing subprogram is frozen.
11438 if Is_Entity_Name (P)
11439 and then Is_Overloadable (Entity (P))
11440 and then Present (Alias (Entity (P)))
11441 and then Expander_Active
11442 then
11443 Rewrite (P,
11444 New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
11445 end if;
11447 elsif Nkind (P) = N_Selected_Component
11448 and then Is_Overloadable (Entity (Selector_Name (P)))
11449 then
11450 -- Protected operation. If operation is overloaded, must
11451 -- disambiguate. Prefix that denotes protected object itself
11452 -- is resolved with its own type.
11454 if Attr_Id = Attribute_Unchecked_Access then
11455 Error_Msg_Name_1 := Aname;
11456 Error_Msg_F
11457 ("attribute% cannot be applied to protected operation", P);
11458 end if;
11460 Resolve (Prefix (P));
11462 if not Is_Overloaded (P) then
11463 Generate_Reference (Entity (Selector_Name (P)), P);
11465 else
11466 Get_First_Interp (P, Index, It);
11467 while Present (It.Nam) loop
11468 if Type_Conformant (Designated_Type (Typ), It.Nam) then
11469 Set_Entity (Selector_Name (P), It.Nam);
11471 -- The prefix is definitely NOT overloaded anymore at
11472 -- this point, so we reset the Is_Overloaded flag to
11473 -- avoid any confusion when reanalyzing the node.
11475 Set_Is_Overloaded (P, False);
11476 Set_Is_Overloaded (N, False);
11477 Generate_Reference (Entity (Selector_Name (P)), P);
11478 exit;
11479 end if;
11481 Get_Next_Interp (Index, It);
11482 end loop;
11483 end if;
11485 -- Implement check implied by 3.10.2 (18.1/2) : F.all'access is
11486 -- statically illegal if F is an anonymous access to subprogram.
11488 elsif Nkind (P) = N_Explicit_Dereference
11489 and then Is_Entity_Name (Prefix (P))
11490 and then Ekind (Etype (Entity (Prefix (P)))) =
11491 E_Anonymous_Access_Subprogram_Type
11492 then
11493 Error_Msg_N ("anonymous access to subprogram "
11494 & "has deeper accessibility than any master", P);
11496 elsif Is_Overloaded (P) then
11498 -- Use the designated type of the context to disambiguate
11499 -- Note that this was not strictly conformant to Ada 95,
11500 -- but was the implementation adopted by most Ada 95 compilers.
11501 -- The use of the context type to resolve an Access attribute
11502 -- reference is now mandated in AI-235 for Ada 2005.
11504 declare
11505 Index : Interp_Index;
11506 It : Interp;
11508 begin
11509 Get_First_Interp (P, Index, It);
11510 while Present (It.Typ) loop
11511 if Covers (Designated_Type (Typ), It.Typ) then
11512 Resolve (P, It.Typ);
11513 exit;
11514 end if;
11516 Get_Next_Interp (Index, It);
11517 end loop;
11518 end;
11519 else
11520 Resolve (P);
11521 end if;
11523 -- Refuse to compute access to variables and constants when that
11524 -- would drop the strub mode associated with them, unless they're
11525 -- unchecked conversions. We don't have to do this when the types
11526 -- of the data objects are annotated: then the access type
11527 -- designates the annotated type, and there's no loss. Only when
11528 -- the variable is annotated directly that the pragma gets
11529 -- attached to the variable, rather than to its type, and then,
11530 -- expressing an access-to-annotated-type type to hold the 'Access
11531 -- result is not possible without resorting to that very annotated
11532 -- type.
11534 if Attr_Id /= Attribute_Unchecked_Access
11535 and then Comes_From_Source (N)
11536 and then Is_Entity_Name (P)
11537 and then Explicit_Strub_Mode (Entity (P)) = Enabled
11538 and then
11539 Explicit_Strub_Mode (Designated_Type (Btyp)) = Unspecified
11540 then
11541 Error_Msg_F ("target access type drops `strub` mode from &", P);
11542 end if;
11544 -- X'Access is illegal if X denotes a constant and the access type
11545 -- is access-to-variable. Same for 'Unchecked_Access. The rule
11546 -- does not apply to 'Unrestricted_Access. If the reference is a
11547 -- default-initialized aggregate component for a self-referential
11548 -- type the reference is legal.
11550 if not (Ekind (Btyp) = E_Access_Subprogram_Type
11551 or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
11552 or else (Is_Record_Type (Btyp)
11553 and then
11554 Present (Corresponding_Remote_Type (Btyp)))
11555 or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type
11556 or else Ekind (Btyp)
11557 = E_Anonymous_Access_Protected_Subprogram_Type
11558 or else Is_Access_Constant (Btyp)
11559 or else Is_Variable (P)
11560 or else Attr_Id = Attribute_Unrestricted_Access)
11561 then
11562 if Is_Entity_Name (P)
11563 and then Is_Type (Entity (P))
11564 then
11565 -- Legality of a self-reference through an access
11566 -- attribute has been verified in Analyze_Access_Attribute.
11568 null;
11570 elsif Comes_From_Source (N) then
11571 Error_Msg_F ("access-to-variable designates constant", P);
11572 end if;
11573 end if;
11575 Des_Btyp := Designated_Type (Btyp);
11577 if Ada_Version >= Ada_2005
11578 and then Is_Incomplete_Type (Des_Btyp)
11579 then
11580 -- Ada 2005 (AI-412): If the (sub)type is a limited view of an
11581 -- imported entity, and the non-limited view is visible, make
11582 -- use of it. If it is an incomplete subtype, use the base type
11583 -- in any case.
11585 if From_Limited_With (Des_Btyp)
11586 and then Present (Non_Limited_View (Des_Btyp))
11587 then
11588 Des_Btyp := Non_Limited_View (Des_Btyp);
11590 elsif Ekind (Des_Btyp) = E_Incomplete_Subtype then
11591 Des_Btyp := Etype (Des_Btyp);
11592 end if;
11593 end if;
11595 if Ekind (Btyp) in E_General_Access_Type | E_Anonymous_Access_Type
11596 then
11597 -- Ada 2005 (AI-230): Check the accessibility of anonymous
11598 -- access types for stand-alone objects, record and array
11599 -- components, and return objects. For a component definition
11600 -- the level is the same of the enclosing composite type.
11602 if Ada_Version >= Ada_2005
11603 and then Attr_Id = Attribute_Access
11604 and then (Is_Local_Anonymous_Access (Btyp)
11606 -- Handle cases where Btyp is the anonymous access
11607 -- type of an Ada 2012 stand-alone object.
11609 or else Nkind (Associated_Node_For_Itype (Btyp)) =
11610 N_Object_Declaration)
11612 -- Verify that static checking is OK (namely that we aren't
11613 -- in a specific context requiring dynamic checks on
11614 -- expicitly aliased parameters), and then check the level.
11616 -- Otherwise a check will be generated later when the return
11617 -- statement gets expanded.
11619 and then not Is_Special_Aliased_Formal_Access (N)
11620 and then
11621 Static_Accessibility_Level (N, Zero_On_Dynamic_Level) >
11622 Deepest_Type_Access_Level (Btyp)
11623 then
11624 -- In an instance, this is a runtime check, but one we know
11625 -- will fail, so generate an appropriate warning. As usual,
11626 -- this kind of warning is an error in SPARK mode.
11628 if In_Instance_Body then
11629 Error_Msg_Warn :=
11630 SPARK_Mode /= On
11631 and then
11632 not No_Dynamic_Accessibility_Checks_Enabled (P);
11634 Error_Msg_F
11635 ("non-local pointer cannot point to local object<<", P);
11636 Error_Msg_F ("\Program_Error [<<", P);
11638 Rewrite (N,
11639 Make_Raise_Program_Error (Loc,
11640 Reason => PE_Accessibility_Check_Failed));
11641 Set_Etype (N, Typ);
11643 else
11644 Error_Msg_F
11645 ("non-local pointer cannot point to local object", P);
11646 end if;
11647 end if;
11649 if Attr_Id /= Attribute_Unrestricted_Access
11650 and then Is_Dependent_Component_Of_Mutable_Object (P)
11651 then
11652 Error_Msg_F
11653 ("illegal attribute for discriminant-dependent component",
11655 end if;
11657 -- Check static matching rule of 3.10.2(27). Nominal subtype
11658 -- of the prefix must statically match the designated type.
11660 Nom_Subt := Etype (P);
11662 if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then
11663 Nom_Subt := Base_Type (Nom_Subt);
11664 end if;
11666 -- We do not enforce static matching for Unrestricted_Access
11667 -- except for a thin pointer to an unconstrained array type,
11668 -- because, in this case, the designated object must contain
11669 -- its bounds, which means that it must have an unconstrained
11670 -- nominal subtype (and be aliased, as will be checked below).
11672 if Attr_Id = Attribute_Unrestricted_Access
11673 and then not (Is_Thin_Pointer_To_Unc_Array (Typ)
11674 and then Is_Aliased_View (Original_Node (P)))
11675 then
11676 null;
11678 elsif Is_Tagged_Type (Designated_Type (Typ)) then
11680 -- If the attribute is in the context of an access
11681 -- parameter, then the prefix is allowed to be of
11682 -- the class-wide type (by AI-127).
11684 if Ekind (Typ) = E_Anonymous_Access_Type then
11685 if not Covers (Designated_Type (Typ), Nom_Subt)
11686 and then not Covers (Nom_Subt, Designated_Type (Typ))
11687 then
11688 declare
11689 Desig : Entity_Id;
11691 begin
11692 Desig := Designated_Type (Typ);
11694 if Is_Class_Wide_Type (Desig) then
11695 Desig := Etype (Desig);
11696 end if;
11698 if Is_Anonymous_Tagged_Base (Nom_Subt, Desig) then
11699 null;
11701 else
11702 Error_Msg_FE
11703 ("type of prefix: & not compatible",
11704 P, Nom_Subt);
11705 Error_Msg_FE
11706 ("\with &, the expected designated type",
11707 P, Designated_Type (Typ));
11708 end if;
11709 end;
11710 end if;
11712 elsif not Covers (Designated_Type (Typ), Nom_Subt)
11713 or else
11714 (not Is_Class_Wide_Type (Designated_Type (Typ))
11715 and then Is_Class_Wide_Type (Nom_Subt))
11716 then
11717 Error_Msg_FE
11718 ("type of prefix: & is not covered", P, Nom_Subt);
11719 Error_Msg_FE
11720 ("\by &, the expected designated type" &
11721 " (RM 3.10.2 (27))", P, Designated_Type (Typ));
11722 end if;
11724 if Is_Class_Wide_Type (Designated_Type (Typ))
11725 and then Has_Discriminants (Etype (Designated_Type (Typ)))
11726 and then Is_Constrained (Etype (Designated_Type (Typ)))
11727 and then Designated_Type (Typ) /= Nom_Subt
11728 then
11729 Apply_Discriminant_Check
11730 (N, Etype (Designated_Type (Typ)));
11731 end if;
11733 -- Ada 2005 (AI-363): Require static matching when designated
11734 -- type has discriminants and a constrained partial view, since
11735 -- in general objects of such types are mutable, so we can't
11736 -- allow the access value to designate a constrained object
11737 -- (because access values must be assumed to designate mutable
11738 -- objects when designated type does not impose a constraint).
11740 elsif Subtypes_Statically_Match (Des_Btyp, Nom_Subt) then
11741 null;
11743 elsif Has_Discriminants (Designated_Type (Typ))
11744 and then not Is_Constrained (Des_Btyp)
11745 and then
11746 (Ada_Version < Ada_2005
11747 or else
11748 not Object_Type_Has_Constrained_Partial_View
11749 (Typ => Designated_Type (Base_Type (Typ)),
11750 Scop => Current_Scope))
11751 then
11752 null;
11754 else
11755 Error_Msg_F
11756 ("object subtype must statically match "
11757 & "designated subtype", P);
11759 if Is_Entity_Name (P)
11760 and then Is_Array_Type (Designated_Type (Typ))
11761 then
11762 declare
11763 D : constant Node_Id := Declaration_Node (Entity (P));
11764 begin
11765 Error_Msg_N
11766 ("aliased object has explicit bounds??", D);
11767 Error_Msg_N
11768 ("\declare without bounds (and with explicit "
11769 & "initialization)??", D);
11770 Error_Msg_N
11771 ("\for use with unconstrained access??", D);
11772 end;
11773 end if;
11774 end if;
11776 -- Check the static accessibility rule of 3.10.2(28). Note that
11777 -- this check is not performed for the case of an anonymous
11778 -- access type, since the access attribute is always legal
11779 -- in such a context - unless the restriction
11780 -- No_Dynamic_Accessibility_Checks is active.
11782 declare
11783 No_Dynamic_Acc_Checks : constant Boolean :=
11784 No_Dynamic_Accessibility_Checks_Enabled (Btyp);
11786 Compatible_Alt_Checks : constant Boolean :=
11787 No_Dynamic_Acc_Checks and then not Debug_Flag_Underscore_B;
11789 begin
11790 if Attr_Id = Attribute_Access
11791 and then (Ekind (Btyp) = E_General_Access_Type
11792 or else No_Dynamic_Acc_Checks)
11794 -- In the case of the alternate "compatibility"
11795 -- accessibility model we do not perform a static
11796 -- accessibility check on actuals for anonymous access
11797 -- types - so exclude them here.
11799 and then not (Compatible_Alt_Checks
11800 and then Is_Actual_Parameter (N)
11801 and then Ekind (Btyp)
11802 = E_Anonymous_Access_Type)
11804 -- Call Accessibility_Level directly to avoid returning
11805 -- zero on cases where the prefix is an explicitly aliased
11806 -- parameter in a return statement, instead of using the
11807 -- normal Static_Accessibility_Level function.
11809 -- Shouldn't this be handled somehow in
11810 -- Static_Accessibility_Level ???
11812 and then Nkind (Accessibility_Level (P, Dynamic_Level))
11813 = N_Integer_Literal
11814 and then
11815 Intval (Accessibility_Level (P, Dynamic_Level))
11816 > Deepest_Type_Access_Level (Btyp)
11817 then
11818 Accessibility_Message (N, Typ);
11819 return;
11820 end if;
11821 end;
11822 end if;
11824 if Ekind (Btyp) in E_Access_Protected_Subprogram_Type
11825 | E_Anonymous_Access_Protected_Subprogram_Type
11826 then
11827 if Is_Entity_Name (P)
11828 and then not Is_Protected_Type (Scope (Entity (P)))
11829 then
11830 Error_Msg_F ("context requires a protected subprogram", P);
11832 -- Check accessibility of protected object against that of the
11833 -- access type, but only on user code, because the expander
11834 -- creates access references for handlers. If the context is an
11835 -- anonymous_access_to_protected, there are no accessibility
11836 -- checks either. Omit check entirely for Unrestricted_Access.
11838 elsif Static_Accessibility_Level (P, Zero_On_Dynamic_Level)
11839 > Deepest_Type_Access_Level (Btyp)
11840 and then Comes_From_Source (N)
11841 and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type
11842 and then Attr_Id /= Attribute_Unrestricted_Access
11843 then
11844 Accessibility_Message (N, Typ);
11845 return;
11847 -- AI05-0225: If the context is not an access to protected
11848 -- function, the prefix must be a variable, given that it may
11849 -- be used subsequently in a protected call.
11851 elsif Nkind (P) = N_Selected_Component
11852 and then not Is_Variable (Prefix (P))
11853 and then Ekind (Entity (Selector_Name (P))) /= E_Function
11854 then
11855 Error_Msg_N
11856 ("target object of access to protected procedure "
11857 & "must be variable", N);
11859 elsif Is_Entity_Name (P) then
11860 Check_Internal_Protected_Use (N, Entity (P));
11861 end if;
11863 elsif Ekind (Btyp) in E_Access_Subprogram_Type
11864 | E_Anonymous_Access_Subprogram_Type
11865 and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type
11866 then
11867 Error_Msg_F ("context requires a non-protected subprogram", P);
11868 end if;
11870 -- AI12-0412: The rule in RM 6.1.1(18.2/5) disallows applying
11871 -- attribute Access to a primitive of an abstract type when the
11872 -- primitive has any Pre'Class or Post'Class aspects specified
11873 -- with nonstatic expressions.
11875 if Attr_Id = Attribute_Access
11876 and then Ekind (Btyp) in E_Access_Subprogram_Type
11877 | E_Anonymous_Access_Subprogram_Type
11878 and then Is_Entity_Name (P)
11879 and then Is_Dispatching_Operation (Entity (P))
11880 and then
11881 Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post (Entity (P))
11882 then
11883 Error_Msg_N
11884 ("attribute not allowed for primitive of abstract type with "
11885 & "nonstatic class-wide pre/postconditions",
11887 end if;
11889 -- The context cannot be a pool-specific type, but this is a
11890 -- legality rule, not a resolution rule, so it must be checked
11891 -- separately, after possibly disambiguation (see AI-245).
11893 if Ekind (Btyp) = E_Access_Type
11894 and then Attr_Id /= Attribute_Unrestricted_Access
11895 then
11896 Wrong_Type (N, Typ);
11897 end if;
11899 -- The context may be a constrained access type (however ill-
11900 -- advised such subtypes might be) so in order to generate a
11901 -- constraint check we need to set the type of the attribute
11902 -- reference to the base type of the context.
11904 Set_Etype (N, Btyp);
11906 -- Check for incorrect atomic/volatile/VFA reference (RM C.6(12))
11908 if Attr_Id /= Attribute_Unrestricted_Access then
11909 if Is_Atomic_Object (P)
11910 and then not Is_Atomic (Designated_Type (Typ))
11911 then
11912 Error_Msg_F
11913 ("access to atomic object cannot yield access-to-" &
11914 "non-atomic type", P);
11916 elsif Is_Volatile_Object_Ref (P)
11917 and then not Is_Volatile (Designated_Type (Typ))
11918 then
11919 Error_Msg_F
11920 ("access to volatile object cannot yield access-to-" &
11921 "non-volatile type", P);
11923 elsif Is_Volatile_Full_Access_Object_Ref (P)
11924 and then not Is_Volatile_Full_Access (Designated_Type (Typ))
11925 then
11926 Error_Msg_F
11927 ("access to full access object cannot yield access-to-" &
11928 "non-full-access type", P);
11929 end if;
11931 -- Check for nonatomic subcomponent of a full access object
11932 -- in Ada 2022 (RM C.6 (12)).
11934 if Ada_Version >= Ada_2022
11935 and then Is_Subcomponent_Of_Full_Access_Object (P)
11936 and then not Is_Atomic_Object (P)
11937 then
11938 Error_Msg_NE
11939 ("cannot have access attribute with prefix &", N, P);
11940 Error_Msg_N
11941 ("\nonatomic subcomponent of full access object "
11942 & "(RM C.6(12))", N);
11943 end if;
11944 end if;
11946 -- Check for aliased view. We allow a nonaliased prefix when in
11947 -- an instance because the prefix may have been a tagged formal
11948 -- object, which is defined to be aliased even when the actual
11949 -- might not be (other instance cases will have been caught in
11950 -- the generic). Similarly, within an inlined body we know that
11951 -- the attribute is legal in the original subprogram, therefore
11952 -- legal in the expansion.
11954 if not (Is_Entity_Name (P)
11955 and then Is_Overloadable (Entity (P)))
11956 and then not (Nkind (P) = N_Selected_Component
11957 and then
11958 Is_Overloadable (Entity (Selector_Name (P))))
11959 and then not Is_Aliased_View (Original_Node (P))
11960 and then not In_Instance
11961 and then not In_Inlined_Body
11962 and then Comes_From_Source (N)
11963 then
11964 -- Here we have a non-aliased view. This is illegal unless we
11965 -- have the case of Unrestricted_Access, where for now we allow
11966 -- this (we will reject later if expected type is access to an
11967 -- unconstrained array with a thin pointer).
11969 -- No need for an error message on a generated access reference
11970 -- for the controlling argument in a dispatching call: error
11971 -- will be reported when resolving the call.
11973 if Attr_Id /= Attribute_Unrestricted_Access then
11974 Error_Msg_Name_1 := Aname;
11975 Error_Msg_N ("prefix of % attribute must be aliased", P);
11977 -- Check for unrestricted access where expected type is a thin
11978 -- pointer to an unconstrained array.
11980 elsif Is_Thin_Pointer_To_Unc_Array (Typ) then
11981 Error_Msg_N
11982 ("illegal use of Unrestricted_Access attribute", P);
11983 Error_Msg_N
11984 ("\attempt to generate thin pointer to unaliased "
11985 & "object", P);
11986 end if;
11987 end if;
11989 -- Check that the prefix does not have a value conversion of an
11990 -- array type since a value conversion is like an aggregate with
11991 -- respect to determining accessibility level (RM 3.10.2).
11993 if not Prefix_With_Safe_Accessibility_Level (N, Typ) then
11994 Accessibility_Message (N, Typ);
11995 return;
11996 end if;
11998 -- Mark that address of entity is taken in case of
11999 -- 'Unrestricted_Access or in case of a subprogram.
12001 if Is_Entity_Name (P)
12002 and then (Attr_Id = Attribute_Unrestricted_Access
12003 or else Is_Subprogram (Entity (P)))
12004 then
12005 Set_Address_Taken (Entity (P));
12006 end if;
12008 -- Deal with possible elaboration check
12010 if Is_Entity_Name (P) and then Is_Subprogram (Entity (P)) then
12011 declare
12012 Subp_Id : constant Entity_Id := Entity (P);
12013 Scop : constant Entity_Id := Scope (Subp_Id);
12014 Subp_Decl : constant Node_Id :=
12015 Unit_Declaration_Node (Subp_Id);
12016 Flag_Id : Entity_Id;
12017 Subp_Body : Node_Id;
12019 -- If the access has been taken and the body of the subprogram
12020 -- has not been see yet, indirect calls must be protected with
12021 -- elaboration checks. We have the proper elaboration machinery
12022 -- for subprograms declared in packages, but within a block or
12023 -- a subprogram the body will appear in the same declarative
12024 -- part, and we must insert a check in the eventual body itself
12025 -- using the elaboration flag that we generate now. The check
12026 -- is then inserted when the body is expanded. This processing
12027 -- is not needed for a stand alone expression function because
12028 -- the internally generated spec and body are always inserted
12029 -- as a pair in the same declarative list.
12031 begin
12032 if Expander_Active
12033 and then Comes_From_Source (Subp_Id)
12034 and then Comes_From_Source (N)
12035 and then In_Open_Scopes (Scop)
12036 and then Ekind (Scop) in E_Block | E_Procedure | E_Function
12037 and then not Has_Completion (Subp_Id)
12038 and then No (Elaboration_Entity (Subp_Id))
12039 and then Nkind (Subp_Decl) = N_Subprogram_Declaration
12040 and then Nkind (Original_Node (Subp_Decl)) /=
12041 N_Expression_Function
12042 then
12043 -- Create elaboration variable for it
12045 Flag_Id := Make_Temporary (Loc, 'E');
12046 Set_Elaboration_Entity (Subp_Id, Flag_Id);
12047 Set_Is_Frozen (Flag_Id);
12049 -- Insert declaration for flag after subprogram
12050 -- declaration. Note that attribute reference may
12051 -- appear within a nested scope.
12053 Insert_After_And_Analyze (Subp_Decl,
12054 Make_Object_Declaration (Loc,
12055 Defining_Identifier => Flag_Id,
12056 Object_Definition =>
12057 New_Occurrence_Of (Standard_Short_Integer, Loc),
12058 Expression =>
12059 Make_Integer_Literal (Loc, Uint_0)));
12061 -- The above sets the Scope of the flag entity to the
12062 -- current scope, in which the attribute appears, but
12063 -- the flag declaration has been inserted after that
12064 -- of Subp_Id, so the scope of the flag is the same as
12065 -- that of Subp_Id. This is relevant when unnesting,
12066 -- where processing depends on correct scope setting.
12068 Set_Scope (Flag_Id, Scop);
12069 end if;
12071 -- Taking the 'Access of an expression function freezes its
12072 -- expression (RM 13.14 10.3/3). This does not apply to an
12073 -- expression function that acts as a completion because the
12074 -- generated body is immediately analyzed and the expression
12075 -- is automatically frozen.
12077 if Is_Expression_Function (Subp_Id)
12078 and then Present (Corresponding_Body (Subp_Decl))
12079 then
12080 Subp_Body :=
12081 Unit_Declaration_Node (Corresponding_Body (Subp_Decl));
12083 -- The body has already been analyzed when the expression
12084 -- function acts as a completion.
12086 if Analyzed (Subp_Body) then
12087 null;
12089 -- Attribute 'Access may appear within the generated body
12090 -- of the expression function subject to the attribute:
12092 -- function F is (... F'Access ...);
12094 -- If the expression function is on the scope stack, then
12095 -- the body is currently being analyzed. Do not reanalyze
12096 -- it because this will lead to infinite recursion.
12098 elsif In_Open_Scopes (Subp_Id) then
12099 null;
12101 -- If reference to the expression function appears in an
12102 -- inner scope, for example as an actual in an instance,
12103 -- this is not a freeze point either.
12105 elsif Scope (Subp_Id) /= Current_Scope then
12106 null;
12108 -- Dispatch tables are not a freeze point either
12110 elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
12111 and then Is_Dispatch_Table_Entity (Etype (Parent (N)))
12112 then
12113 null;
12115 -- Analyze the body of the expression function to freeze
12116 -- the expression.
12118 else
12119 Analyze (Subp_Body);
12120 end if;
12121 end if;
12122 end;
12123 end if;
12125 -------------
12126 -- Address --
12127 -------------
12129 -- Deal with resolving the type for Address attribute, overloading
12130 -- is not permitted here, since there is no context to resolve it.
12132 when Attribute_Address
12133 | Attribute_Code_Address
12135 -- To be safe, assume that if the address of a variable is taken,
12136 -- it may be modified via this address, so note modification,
12137 -- unless the address is compared directly, which should not be
12138 -- considered a modification.
12140 if Is_Variable (P)
12141 and then Nkind (Parent (N)) not in N_Op_Compare
12142 then
12143 Note_Possible_Modification (P, Sure => False);
12144 end if;
12146 if Nkind (P) in N_Subexpr and then Is_Overloaded (P) then
12147 Get_First_Interp (P, Index, It);
12148 Get_Next_Interp (Index, It);
12150 if Present (It.Nam) then
12151 Error_Msg_Name_1 := Aname;
12152 Error_Msg_F
12153 ("prefix of % attribute cannot be overloaded", P);
12154 end if;
12155 end if;
12157 if not Is_Entity_Name (P)
12158 or else not Is_Overloadable (Entity (P))
12159 then
12160 Resolve (P);
12161 end if;
12163 -- If this is the name of a derived subprogram, or that of a
12164 -- generic actual, the address is that of the original entity.
12166 if Is_Entity_Name (P)
12167 and then Is_Overloadable (Entity (P))
12168 and then Present (Alias (Entity (P)))
12169 then
12170 Rewrite (P,
12171 New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
12172 end if;
12174 if Is_Entity_Name (P) then
12175 Set_Address_Taken (Entity (P));
12176 end if;
12178 if Nkind (P) = N_Slice then
12180 -- Arr (X .. Y)'address is identical to Arr (X)'address,
12181 -- even if the array is packed and the slice itself is not
12182 -- addressable. Transform the prefix into an indexed component.
12184 -- Note that the transformation is safe only if we know that
12185 -- the slice is non-null. That is because a null slice can have
12186 -- an out of bounds index value.
12188 -- Right now, gigi blows up if given 'Address on a slice as a
12189 -- result of some incorrect freeze nodes generated by the front
12190 -- end, and this covers up that bug in one case, but the bug is
12191 -- likely still there in the cases not handled by this code ???
12193 -- It's not clear what 'Address *should* return for a null
12194 -- slice with out of bounds indexes, this might be worth an ARG
12195 -- discussion ???
12197 -- One approach would be to do a length check unconditionally,
12198 -- and then do the transformation below unconditionally, but
12199 -- analyze with checks off, avoiding the problem of the out of
12200 -- bounds index. This approach would interpret the address of
12201 -- an out of bounds null slice as being the address where the
12202 -- array element would be if there was one, which is probably
12203 -- as reasonable an interpretation as any ???
12205 declare
12206 Loc : constant Source_Ptr := Sloc (P);
12207 D : constant Node_Id := Discrete_Range (P);
12208 Lo : Node_Id;
12210 begin
12211 if Is_Entity_Name (D)
12212 and then
12213 Not_Null_Range
12214 (Type_Low_Bound (Entity (D)),
12215 Type_High_Bound (Entity (D)))
12216 then
12217 Lo :=
12218 Make_Attribute_Reference (Loc,
12219 Prefix => (New_Occurrence_Of (Entity (D), Loc)),
12220 Attribute_Name => Name_First);
12222 elsif Nkind (D) = N_Range
12223 and then Not_Null_Range (Low_Bound (D), High_Bound (D))
12224 then
12225 Lo := Low_Bound (D);
12227 else
12228 Lo := Empty;
12229 end if;
12231 if Present (Lo) then
12232 Rewrite (P,
12233 Make_Indexed_Component (Loc,
12234 Prefix => Relocate_Node (Prefix (P)),
12235 Expressions => New_List (Lo)));
12237 Analyze_And_Resolve (P);
12238 end if;
12239 end;
12240 end if;
12242 ------------------
12243 -- Body_Version --
12244 ------------------
12246 -- Prefix of Body_Version attribute can be a subprogram name which
12247 -- must not be resolved, since this is not a call.
12249 when Attribute_Body_Version =>
12250 null;
12252 ------------
12253 -- Caller --
12254 ------------
12256 -- Prefix of Caller attribute is an entry name which must not
12257 -- be resolved, since this is definitely not an entry call.
12259 when Attribute_Caller =>
12260 null;
12262 ------------------
12263 -- Code_Address --
12264 ------------------
12266 -- Shares processing with Address attribute
12268 -----------
12269 -- Count --
12270 -----------
12272 -- If the prefix of the Count attribute is an entry name it must not
12273 -- be resolved, since this is definitely not an entry call. However,
12274 -- if it is an element of an entry family, the index itself may
12275 -- have to be resolved because it can be a general expression.
12277 when Attribute_Count
12278 | Attribute_Index
12280 if Nkind (P) = N_Indexed_Component
12281 and then Is_Entity_Name (Prefix (P))
12282 then
12283 declare
12284 Indx : constant Node_Id := First (Expressions (P));
12285 Fam : constant Entity_Id := Entity (Prefix (P));
12286 begin
12287 Resolve (Indx, Entry_Index_Type (Fam));
12288 Apply_Scalar_Range_Check (Indx, Entry_Index_Type (Fam));
12289 end;
12290 end if;
12292 ----------------
12293 -- Elaborated --
12294 ----------------
12296 -- Prefix of the Elaborated attribute is a subprogram name which
12297 -- must not be resolved, since this is definitely not a call. Note
12298 -- that it is a library unit, so it cannot be overloaded here.
12300 when Attribute_Elaborated =>
12301 null;
12303 -------------
12304 -- Enabled --
12305 -------------
12307 -- Prefix of Enabled attribute is a check name, which must be treated
12308 -- specially and not touched by Resolve.
12310 when Attribute_Enabled =>
12311 null;
12313 -----------
12314 -- Index --
12315 -----------
12317 -- Processing is shared with Count
12319 ----------------
12320 -- Loop_Entry --
12321 ----------------
12323 -- Do not resolve the prefix of Loop_Entry, instead wait until the
12324 -- attribute has been expanded (see Expand_Loop_Entry_Attributes).
12325 -- The delay ensures that any generated checks or temporaries are
12326 -- inserted before the relocated prefix.
12328 when Attribute_Loop_Entry =>
12329 null;
12331 --------------------
12332 -- Mechanism_Code --
12333 --------------------
12335 -- Prefix of the Mechanism_Code attribute is a function name
12336 -- which must not be resolved. Should we check for overloaded ???
12338 when Attribute_Mechanism_Code =>
12339 null;
12341 ------------------
12342 -- Partition_ID --
12343 ------------------
12345 -- Most processing is done in sem_dist, after determining the
12346 -- context type. Node is rewritten as a conversion to a runtime call.
12348 when Attribute_Partition_ID =>
12349 Process_Partition_Id (N);
12350 return;
12352 ------------------
12353 -- Pool_Address --
12354 ------------------
12356 when Attribute_Pool_Address =>
12357 Resolve (P);
12359 -----------
12360 -- Range --
12361 -----------
12363 -- We replace the Range attribute node with a range expression whose
12364 -- bounds are the 'First and 'Last attributes applied to the same
12365 -- prefix. The reason that we do this transformation here instead of
12366 -- in the expander is that it simplifies other parts of the semantic
12367 -- analysis which assume that the Range has been replaced; thus it
12368 -- must be done even when in semantic-only mode (note that the RM
12369 -- specifically mentions this equivalence, we take care that the
12370 -- prefix is only evaluated once).
12372 when Attribute_Range => Range_Attribute : declare
12373 Dims : List_Id;
12374 HB : Node_Id;
12375 LB : Node_Id;
12377 begin
12378 if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then
12379 Resolve (P);
12381 -- If the prefix is a function call returning on the secondary
12382 -- stack, we must make sure to mark/release the stack.
12384 if Nkind (P) = N_Function_Call
12385 and then Nkind (Parent (N)) = N_Loop_Parameter_Specification
12386 and then Requires_Transient_Scope (Etype (P))
12387 then
12388 Set_Uses_Sec_Stack (Scope (Current_Scope));
12389 end if;
12390 end if;
12392 Dims := Expressions (N);
12394 HB :=
12395 Make_Attribute_Reference (Loc,
12396 Prefix => Duplicate_Subexpr (P, Name_Req => True),
12397 Attribute_Name => Name_Last,
12398 Expressions => Dims);
12400 LB :=
12401 Make_Attribute_Reference (Loc,
12402 Prefix => P,
12403 Attribute_Name => Name_First,
12404 Expressions => (Dims));
12406 -- Do not share the dimension indicator, if present. Even though
12407 -- it is a static constant, its source location may be modified
12408 -- when printing expanded code and node sharing will lead to chaos
12409 -- in Sprint.
12411 if Present (Dims) then
12412 Set_Expressions (LB, New_List (New_Copy_Tree (First (Dims))));
12413 end if;
12415 -- If the original was marked as Must_Not_Freeze (see code in
12416 -- Sem_Ch3.Make_Index), then make sure the rewriting does not
12417 -- freeze either.
12419 if Must_Not_Freeze (N) then
12420 Set_Must_Not_Freeze (HB);
12421 Set_Must_Not_Freeze (LB);
12422 Set_Must_Not_Freeze (Prefix (HB));
12423 Set_Must_Not_Freeze (Prefix (LB));
12424 end if;
12426 if Raises_Constraint_Error (Prefix (N)) then
12428 -- Preserve Sloc of prefix in the new bounds, so that the
12429 -- posted warning can be removed if we are within unreachable
12430 -- code.
12432 Set_Sloc (LB, Sloc (Prefix (N)));
12433 Set_Sloc (HB, Sloc (Prefix (N)));
12434 end if;
12436 Rewrite (N, Make_Range (Loc, LB, HB));
12437 Analyze_And_Resolve (N, Typ);
12439 -- Ensure that the expanded range does not have side effects
12441 Force_Evaluation (LB);
12442 Force_Evaluation (HB);
12444 -- Normally after resolving attribute nodes, Eval_Attribute
12445 -- is called to do any possible static evaluation of the node.
12446 -- However, here since the Range attribute has just been
12447 -- transformed into a range expression it is no longer an
12448 -- attribute node and therefore the call needs to be avoided
12449 -- and is accomplished by simply returning from the procedure.
12451 return;
12452 end Range_Attribute;
12454 -------------
12455 -- Reduce --
12456 -------------
12458 when Attribute_Reduce =>
12459 declare
12460 E1 : constant Node_Id := First (Expressions (N));
12461 E2 : constant Node_Id := Next (E1);
12462 Op : Entity_Id := Empty;
12464 Index : Interp_Index;
12465 It : Interp;
12466 function Proper_Op (Op : Entity_Id) return Boolean;
12468 ---------------
12469 -- Proper_Op --
12470 ---------------
12472 function Proper_Op (Op : Entity_Id) return Boolean is
12473 F1, F2 : Entity_Id;
12475 begin
12476 F1 := First_Formal (Op);
12477 if No (F1) then
12478 return False;
12479 else
12480 F2 := Next_Formal (F1);
12481 if No (F2)
12482 or else Present (Next_Formal (F2))
12483 then
12484 return False;
12486 elsif Ekind (Op) = E_Procedure then
12487 return Ekind (F1) = E_In_Out_Parameter
12488 and then Covers (Typ, Etype (F1));
12490 else
12491 return
12492 (Ekind (Op) = E_Operator
12493 and then Scope (Op) = Standard_Standard)
12494 or else Covers (Typ, Etype (Op));
12495 end if;
12496 end if;
12497 end Proper_Op;
12499 begin
12500 Resolve (E2, Typ);
12501 if Is_Overloaded (E1) then
12502 Get_First_Interp (E1, Index, It);
12503 while Present (It.Nam) loop
12504 if Proper_Op (It.Nam) then
12505 Op := It.Nam;
12506 Set_Entity (E1, Op);
12507 exit;
12508 end if;
12510 Get_Next_Interp (Index, It);
12511 end loop;
12513 elsif Nkind (E1) = N_Attribute_Reference
12514 and then (Attribute_Name (E1) = Name_Max
12515 or else Attribute_Name (E1) = Name_Min)
12516 then
12517 Op := E1;
12519 elsif Proper_Op (Entity (E1)) then
12520 Op := Entity (E1);
12521 Set_Etype (N, Typ);
12522 end if;
12524 if No (Op) then
12525 Error_Msg_N ("No visible subprogram for reduction", E1);
12526 end if;
12527 end;
12529 ------------
12530 -- Result --
12531 ------------
12533 -- We will only come here during the prescan of a spec expression
12534 -- containing a Result attribute. In that case the proper Etype has
12535 -- already been set, and nothing more needs to be done here.
12537 when Attribute_Result =>
12538 null;
12540 ----------------------
12541 -- Unchecked_Access --
12542 ----------------------
12544 -- Processing is shared with Access
12546 -------------------------
12547 -- Unrestricted_Access --
12548 -------------------------
12550 -- Processing is shared with Access
12552 ------------
12553 -- Update --
12554 ------------
12556 -- Resolve aggregate components in component associations
12558 when Attribute_Update => Update : declare
12559 Aggr : constant Node_Id := First (Expressions (N));
12560 Typ : constant Entity_Id := Etype (Prefix (N));
12561 Assoc : Node_Id;
12562 Comp : Node_Id;
12563 Expr : Node_Id;
12565 begin
12566 -- Set the Etype of the aggregate to that of the prefix, even
12567 -- though the aggregate may not be a proper representation of a
12568 -- value of the type (missing or duplicated associations, etc.)
12569 -- Complete resolution of the prefix. Note that in Ada 2012 it
12570 -- can be a qualified expression that is e.g. an aggregate.
12572 Set_Etype (Aggr, Typ);
12573 Resolve (Prefix (N), Typ);
12575 -- For an array type, resolve expressions with the component type
12576 -- of the array, and apply constraint checks when needed.
12578 if Is_Array_Type (Typ) then
12579 Assoc := First (Component_Associations (Aggr));
12580 while Present (Assoc) loop
12581 Expr := Expression (Assoc);
12582 Resolve (Expr, Component_Type (Typ));
12584 -- The choices in the association are static constants,
12585 -- or static aggregates each of whose components belongs
12586 -- to the proper index type. However, they must also
12587 -- belong to the index subtype (s) of the prefix, which
12588 -- may be a subtype (e.g. given by a slice).
12590 -- Choices may also be identifiers with no staticness
12591 -- requirements, in which case they must resolve to the
12592 -- index type.
12594 declare
12595 C : Node_Id;
12596 C_E : Node_Id;
12597 Indx : Node_Id;
12599 begin
12600 C := First (Choices (Assoc));
12601 while Present (C) loop
12602 Indx := First_Index (Etype (Prefix (N)));
12604 if Nkind (C) /= N_Aggregate then
12605 Analyze_And_Resolve (C, Etype (Indx));
12606 else
12607 C_E := First (Expressions (C));
12608 while Present (C_E) loop
12609 Analyze_And_Resolve (C_E, Etype (Indx));
12611 Next (C_E);
12612 Next_Index (Indx);
12613 end loop;
12614 end if;
12616 Next (C);
12617 end loop;
12618 end;
12620 Next (Assoc);
12621 end loop;
12623 -- For a record type, use type of each component, which is
12624 -- recorded during analysis.
12626 else
12627 Assoc := First (Component_Associations (Aggr));
12628 while Present (Assoc) loop
12629 Comp := First (Choices (Assoc));
12630 Expr := Expression (Assoc);
12632 if Nkind (Comp) /= N_Others_Choice
12633 and then not Error_Posted (Comp)
12634 then
12635 Resolve (Expr, Etype (Entity (Comp)));
12636 end if;
12638 Next (Assoc);
12639 end loop;
12640 end if;
12641 end Update;
12643 ---------
12644 -- Val --
12645 ---------
12647 -- Apply range check. Note that we did not do this during the
12648 -- analysis phase, since we wanted Eval_Attribute to have a
12649 -- chance at finding an illegal out of range value.
12651 when Attribute_Val =>
12653 -- Note that we do our own Eval_Attribute call here rather than
12654 -- use the common one, because we need to do processing after
12655 -- the call, as per above comment.
12657 Eval_Attribute (N);
12659 -- Eval_Attribute may replace the node with a raise CE, or
12660 -- fold it to a constant. Obviously we only apply a scalar
12661 -- range check if this did not happen.
12663 if Nkind (N) = N_Attribute_Reference
12664 and then Attribute_Name (N) = Name_Val
12665 then
12666 Apply_Scalar_Range_Check (First (Expressions (N)), Btyp);
12667 end if;
12669 return;
12671 -------------
12672 -- Version --
12673 -------------
12675 -- Prefix of Version attribute can be a subprogram name which
12676 -- must not be resolved, since this is not a call.
12678 when Attribute_Version =>
12679 null;
12681 ----------------------
12682 -- Other Attributes --
12683 ----------------------
12685 -- For other attributes, resolve prefix unless it is a type. If
12686 -- the attribute reference itself is a type name ('Base and 'Class)
12687 -- then this is only legal within a task or protected record.
12689 when others =>
12690 if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then
12691 Resolve (P);
12692 end if;
12694 -- If the attribute reference itself is a type name ('Base,
12695 -- 'Class) then this is only legal within a task or protected
12696 -- record. What is this all about ???
12698 if Is_Entity_Name (N) and then Is_Type (Entity (N)) then
12699 if Is_Concurrent_Type (Entity (N))
12700 and then In_Open_Scopes (Entity (P))
12701 then
12702 null;
12703 else
12704 Error_Msg_N
12705 ("invalid use of subtype name in expression or call", N);
12706 end if;
12707 end if;
12709 -- For attributes whose argument may be a string, complete
12710 -- resolution of argument now. This avoids premature expansion
12711 -- (and the creation of transient scopes) before the attribute
12712 -- reference is resolved.
12714 case Attr_Id is
12715 when Attribute_Valid_Value | Attribute_Value =>
12716 Resolve (First (Expressions (N)), Standard_String);
12718 when Attribute_Wide_Value =>
12719 Resolve (First (Expressions (N)), Standard_Wide_String);
12721 when Attribute_Wide_Wide_Value =>
12722 Resolve (First (Expressions (N)), Standard_Wide_Wide_String);
12724 when others => null;
12725 end case;
12727 -- Ensure that attribute expressions are resolved at this stage;
12728 -- required for preanalyzed references to discriminants since
12729 -- their resolution (and expansion) will take care of updating
12730 -- their Entity attribute to reference their discriminal.
12732 if Expander_Active
12733 and then Present (Expressions (N))
12734 then
12735 declare
12736 Expr : Node_Id := First (Expressions (N));
12738 begin
12739 while Present (Expr) loop
12740 if not Analyzed (Expr) then
12741 Resolve (Expr, Etype (Expr));
12742 end if;
12744 Next (Expr);
12745 end loop;
12746 end;
12747 end if;
12749 -- If the prefix of the attribute is a class-wide type then it
12750 -- will be expanded into a dispatching call to a predefined
12751 -- primitive. Therefore we must check for potential violation
12752 -- of such restriction.
12754 if Is_Class_Wide_Type (Etype (P)) then
12755 Check_Restriction (No_Dispatching_Calls, N);
12756 end if;
12757 end case;
12759 -- Mark use clauses of the original prefix if the attribute is applied
12760 -- to an entity.
12762 if Nkind (Original_Node (P)) in N_Has_Entity
12763 and then Present (Entity (Original_Node (P)))
12764 then
12765 Mark_Use_Clauses (Original_Node (P));
12766 end if;
12768 -- Normally the Freezing is done by Resolve but sometimes the Prefix
12769 -- is not resolved, in which case the freezing must be done now.
12771 -- For an elaboration check on a subprogram, we do not freeze its type.
12772 -- It may be declared in an unrelated scope, in particular in the case
12773 -- of a generic function whose type may remain unelaborated.
12775 if Attr_Id = Attribute_Elaborated then
12776 null;
12778 -- Should this be restricted to Expander_Active???
12780 else
12781 Freeze_Expression (P);
12782 end if;
12784 -- Finally perform static evaluation on the attribute reference
12786 Analyze_Dimension (N);
12787 Eval_Attribute (N);
12788 end Resolve_Attribute;
12790 ------------------------
12791 -- Set_Boolean_Result --
12792 ------------------------
12794 procedure Set_Boolean_Result (N : Node_Id; B : Boolean) is
12795 begin
12796 Rewrite (N, New_Occurrence_Of (Boolean_Literals (B), Sloc (N)));
12797 end Set_Boolean_Result;
12799 --------------------------------
12800 -- Stream_Attribute_Available --
12801 --------------------------------
12803 function Stream_Attribute_Available
12804 (Typ : Entity_Id;
12805 Nam : TSS_Name_Type;
12806 Partial_View : Entity_Id := Empty) return Boolean
12808 Etyp : Entity_Id := Typ;
12810 Real_Rep : Node_Id;
12812 -- Start of processing for Stream_Attribute_Available
12814 begin
12815 -- Test if the attribute is specified directly on the type
12817 if Has_Stream_Attribute_Definition (Typ, Nam, Real_Rep) then
12818 return True;
12819 end if;
12821 -- We assume class-wide types have stream attributes
12822 -- when they are not limited. Otherwise we recurse on the
12823 -- parent type.
12825 if Is_Class_Wide_Type (Typ) then
12826 return not Is_Limited_Type (Typ)
12827 or else Stream_Attribute_Available (Etype (Typ), Nam);
12828 end if;
12830 -- Non-class-wide abstract types cannot have Input streams
12831 -- specified.
12833 if Nam = TSS_Stream_Input
12834 and then Is_Abstract_Type (Typ)
12835 and then not Is_Class_Wide_Type (Typ)
12836 then
12837 return False;
12838 end if;
12840 -- Otherwise, nonlimited types have stream attributes
12842 if not (Is_Limited_Type (Typ)
12843 or else (Present (Partial_View)
12844 and then Is_Limited_Type (Partial_View)))
12845 then
12846 return True;
12847 end if;
12849 -- In Ada 2005, Input can invoke Read, and Output can invoke Write
12851 if Nam = TSS_Stream_Input
12852 and then Ada_Version >= Ada_2005
12853 and then Stream_Attribute_Available (Etyp, TSS_Stream_Read, Real_Rep)
12854 then
12855 return True;
12857 elsif Nam = TSS_Stream_Output
12858 and then Ada_Version >= Ada_2005
12859 and then Stream_Attribute_Available (Etyp, TSS_Stream_Write, Real_Rep)
12860 then
12861 return True;
12862 end if;
12864 -- Case of Read and Write: check for attribute definition clause that
12865 -- applies to an ancestor type.
12867 while Etype (Etyp) /= Etyp loop
12868 declare
12869 Derived_Type : constant Entity_Id := Etyp;
12870 begin
12871 Etyp := Etype (Etyp);
12873 if Has_Stream_Attribute_Definition (Etyp, Nam, Real_Rep) then
12874 if not Derivation_Too_Early_To_Inherit (Derived_Type, Nam) then
12875 return True;
12876 end if;
12877 end if;
12878 end;
12879 end loop;
12881 if Ada_Version < Ada_2005 then
12883 -- In Ada 95 mode, also consider a non-visible definition
12885 declare
12886 Btyp : constant Entity_Id := Implementation_Base_Type (Typ);
12887 begin
12888 return Btyp /= Typ
12889 and then Stream_Attribute_Available
12890 (Btyp, Nam, Partial_View => Typ);
12891 end;
12892 end if;
12894 return False;
12895 end Stream_Attribute_Available;
12897 end Sem_Attr;