File : sem_attr.adb
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-2016, 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 ------------------------------------------------------------------------------
25
26 with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
27
28 with Atree; use Atree;
29 with Casing; use Casing;
30 with Checks; use Checks;
31 with Debug; use Debug;
32 with Einfo; use Einfo;
33 with Elists; use Elists;
34 with Errout; use Errout;
35 with Eval_Fat;
36 with Exp_Dist; use Exp_Dist;
37 with Exp_Util; use Exp_Util;
38 with Expander; use Expander;
39 with Freeze; use Freeze;
40 with Gnatvsn; use Gnatvsn;
41 with Itypes; use Itypes;
42 with Lib; use Lib;
43 with Lib.Xref; use Lib.Xref;
44 with Nlists; use Nlists;
45 with Nmake; use Nmake;
46 with Opt; use Opt;
47 with Restrict; use Restrict;
48 with Rident; use Rident;
49 with Rtsfind; use Rtsfind;
50 with Sdefault; use Sdefault;
51 with Sem; use Sem;
52 with Sem_Aux; use Sem_Aux;
53 with Sem_Cat; use Sem_Cat;
54 with Sem_Ch6; use Sem_Ch6;
55 with Sem_Ch8; use Sem_Ch8;
56 with Sem_Ch10; use Sem_Ch10;
57 with Sem_Dim; use Sem_Dim;
58 with Sem_Dist; use Sem_Dist;
59 with Sem_Elab; use Sem_Elab;
60 with Sem_Elim; use Sem_Elim;
61 with Sem_Eval; use Sem_Eval;
62 with Sem_Prag; use Sem_Prag;
63 with Sem_Res; use Sem_Res;
64 with Sem_Type; use Sem_Type;
65 with Sem_Util; use Sem_Util;
66 with Sem_Warn;
67 with Stand; use Stand;
68 with Sinfo; use Sinfo;
69 with Sinput; use Sinput;
70 with System;
71 with Stringt; use Stringt;
72 with Style;
73 with Stylesw; use Stylesw;
74 with Targparm; use Targparm;
75 with Ttypes; use Ttypes;
76 with Tbuild; use Tbuild;
77 with Uintp; use Uintp;
78 with Uname; use Uname;
79 with Urealp; use Urealp;
80
81 package body Sem_Attr is
82
83 True_Value : constant Uint := Uint_1;
84 False_Value : constant Uint := Uint_0;
85 -- Synonyms to be used when these constants are used as Boolean values
86
87 Bad_Attribute : exception;
88 -- Exception raised if an error is detected during attribute processing,
89 -- used so that we can abandon the processing so we don't run into
90 -- trouble with cascaded errors.
91
92 -- The following array is the list of attributes defined in the Ada 83 RM.
93 -- In Ada 83 mode, these are the only recognized attributes. In other Ada
94 -- modes all these attributes are recognized, even if removed in Ada 95.
95
96 Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
97 Attribute_Address |
98 Attribute_Aft |
99 Attribute_Alignment |
100 Attribute_Base |
101 Attribute_Callable |
102 Attribute_Constrained |
103 Attribute_Count |
104 Attribute_Delta |
105 Attribute_Digits |
106 Attribute_Emax |
107 Attribute_Epsilon |
108 Attribute_First |
109 Attribute_First_Bit |
110 Attribute_Fore |
111 Attribute_Image |
112 Attribute_Large |
113 Attribute_Last |
114 Attribute_Last_Bit |
115 Attribute_Leading_Part |
116 Attribute_Length |
117 Attribute_Machine_Emax |
118 Attribute_Machine_Emin |
119 Attribute_Machine_Mantissa |
120 Attribute_Machine_Overflows |
121 Attribute_Machine_Radix |
122 Attribute_Machine_Rounds |
123 Attribute_Mantissa |
124 Attribute_Pos |
125 Attribute_Position |
126 Attribute_Pred |
127 Attribute_Range |
128 Attribute_Safe_Emax |
129 Attribute_Safe_Large |
130 Attribute_Safe_Small |
131 Attribute_Size |
132 Attribute_Small |
133 Attribute_Storage_Size |
134 Attribute_Succ |
135 Attribute_Terminated |
136 Attribute_Val |
137 Attribute_Value |
138 Attribute_Width => True,
139 others => False);
140
141 -- The following array is the list of attributes defined in the Ada 2005
142 -- RM which are not defined in Ada 95. These are recognized in Ada 95 mode,
143 -- but in Ada 95 they are considered to be implementation defined.
144
145 Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'(
146 Attribute_Machine_Rounding |
147 Attribute_Mod |
148 Attribute_Priority |
149 Attribute_Stream_Size |
150 Attribute_Wide_Wide_Width => True,
151 others => False);
152
153 -- The following array is the list of attributes defined in the Ada 2012
154 -- RM which are not defined in Ada 2005. These are recognized in Ada 95
155 -- and Ada 2005 modes, but are considered to be implementation defined.
156
157 Attribute_12 : constant Attribute_Class_Array := Attribute_Class_Array'(
158 Attribute_First_Valid |
159 Attribute_Has_Same_Storage |
160 Attribute_Last_Valid |
161 Attribute_Max_Alignment_For_Allocation => True,
162 others => False);
163
164 -- The following array contains all attributes that imply a modification
165 -- of their prefixes or result in an access value. Such prefixes can be
166 -- considered as lvalues.
167
168 Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array :=
169 Attribute_Class_Array'(
170 Attribute_Access |
171 Attribute_Address |
172 Attribute_Input |
173 Attribute_Read |
174 Attribute_Unchecked_Access |
175 Attribute_Unrestricted_Access => True,
176 others => False);
177
178 -----------------------
179 -- Local_Subprograms --
180 -----------------------
181
182 procedure Eval_Attribute (N : Node_Id);
183 -- Performs compile time evaluation of attributes where possible, leaving
184 -- the Is_Static_Expression/Raises_Constraint_Error flags appropriately
185 -- set, and replacing the node with a literal node if the value can be
186 -- computed at compile time. All static attribute references are folded,
187 -- as well as a number of cases of non-static attributes that can always
188 -- be computed at compile time (e.g. floating-point model attributes that
189 -- are applied to non-static subtypes). Of course in such cases, the
190 -- Is_Static_Expression flag will not be set on the resulting literal.
191 -- Note that the only required action of this procedure is to catch the
192 -- static expression cases as described in the RM. Folding of other cases
193 -- is done where convenient, but some additional non-static folding is in
194 -- Expand_N_Attribute_Reference in cases where this is more convenient.
195
196 function Is_Anonymous_Tagged_Base
197 (Anon : Entity_Id;
198 Typ : Entity_Id) return Boolean;
199 -- For derived tagged types that constrain parent discriminants we build
200 -- an anonymous unconstrained base type. We need to recognize the relation
201 -- between the two when analyzing an access attribute for a constrained
202 -- component, before the full declaration for Typ has been analyzed, and
203 -- where therefore the prefix of the attribute does not match the enclosing
204 -- scope.
205
206 procedure Set_Boolean_Result (N : Node_Id; B : Boolean);
207 -- Rewrites node N with an occurrence of either Standard_False or
208 -- Standard_True, depending on the value of the parameter B. The
209 -- result is marked as a static expression.
210
211 -----------------------
212 -- Analyze_Attribute --
213 -----------------------
214
215 procedure Analyze_Attribute (N : Node_Id) is
216 Loc : constant Source_Ptr := Sloc (N);
217 Aname : constant Name_Id := Attribute_Name (N);
218 P : constant Node_Id := Prefix (N);
219 Exprs : constant List_Id := Expressions (N);
220 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
221 E1 : Node_Id;
222 E2 : Node_Id;
223
224 P_Type : Entity_Id;
225 -- Type of prefix after analysis
226
227 P_Base_Type : Entity_Id;
228 -- Base type of prefix after analysis
229
230 -----------------------
231 -- Local Subprograms --
232 -----------------------
233
234 procedure Address_Checks;
235 -- Semantic checks for valid use of Address attribute. This was made
236 -- a separate routine with the idea of using it for unrestricted access
237 -- which seems like it should follow the same rules, but that turned
238 -- out to be impractical. So now this is only used for Address.
239
240 procedure Analyze_Access_Attribute;
241 -- Used for Access, Unchecked_Access, Unrestricted_Access attributes.
242 -- Internally, Id distinguishes which of the three cases is involved.
243
244 procedure Analyze_Attribute_Old_Result
245 (Legal : out Boolean;
246 Spec_Id : out Entity_Id);
247 -- Common processing for attributes 'Old and 'Result. The routine checks
248 -- that the attribute appears in a postcondition-like aspect or pragma
249 -- associated with a suitable subprogram or a body. Flag Legal is set
250 -- when the above criteria are met. Spec_Id denotes the entity of the
251 -- subprogram [body] or Empty if the attribute is illegal.
252
253 procedure Bad_Attribute_For_Predicate;
254 -- Output error message for use of a predicate (First, Last, Range) not
255 -- allowed with a type that has predicates. If the type is a generic
256 -- actual, then the message is a warning, and we generate code to raise
257 -- program error with an appropriate reason. No error message is given
258 -- for internally generated uses of the attributes. This legality rule
259 -- only applies to scalar types.
260
261 procedure Check_Array_Or_Scalar_Type;
262 -- Common procedure used by First, Last, Range attribute to check
263 -- that the prefix is a constrained array or scalar type, or a name
264 -- of an array object, and that an argument appears only if appropriate
265 -- (i.e. only in the array case).
266
267 procedure Check_Array_Type;
268 -- Common semantic checks for all array attributes. Checks that the
269 -- prefix is a constrained array type or the name of an array object.
270 -- The error message for non-arrays is specialized appropriately.
271
272 procedure Check_Asm_Attribute;
273 -- Common semantic checks for Asm_Input and Asm_Output attributes
274
275 procedure Check_Component;
276 -- Common processing for Bit_Position, First_Bit, Last_Bit, and
277 -- Position. Checks prefix is an appropriate selected component.
278
279 procedure Check_Decimal_Fixed_Point_Type;
280 -- Check that prefix of attribute N is a decimal fixed-point type
281
282 procedure Check_Dereference;
283 -- If the prefix of attribute is an object of an access type, then
284 -- introduce an explicit dereference, and adjust P_Type accordingly.
285
286 procedure Check_Discrete_Type;
287 -- Verify that prefix of attribute N is a discrete type
288
289 procedure Check_E0;
290 -- Check that no attribute arguments are present
291
292 procedure Check_Either_E0_Or_E1;
293 -- Check that there are zero or one attribute arguments present
294
295 procedure Check_E1;
296 -- Check that exactly one attribute argument is present
297
298 procedure Check_E2;
299 -- Check that two attribute arguments are present
300
301 procedure Check_Enum_Image;
302 -- If the prefix type of 'Image is an enumeration type, set all its
303 -- literals as referenced, since the image function could possibly end
304 -- up referencing any of the literals indirectly. Same for Enum_Val.
305 -- Set the flag only if the reference is in the main code unit. Same
306 -- restriction when resolving 'Value; otherwise an improperly set
307 -- reference when analyzing an inlined body will lose a proper
308 -- warning on a useless with_clause.
309
310 procedure Check_First_Last_Valid;
311 -- Perform all checks for First_Valid and Last_Valid attributes
312
313 procedure Check_Fixed_Point_Type;
314 -- Verify that prefix of attribute N is a fixed type
315
316 procedure Check_Fixed_Point_Type_0;
317 -- Verify that prefix of attribute N is a fixed type and that
318 -- no attribute expressions are present
319
320 procedure Check_Floating_Point_Type;
321 -- Verify that prefix of attribute N is a float type
322
323 procedure Check_Floating_Point_Type_0;
324 -- Verify that prefix of attribute N is a float type and that
325 -- no attribute expressions are present
326
327 procedure Check_Floating_Point_Type_1;
328 -- Verify that prefix of attribute N is a float type and that
329 -- exactly one attribute expression is present
330
331 procedure Check_Floating_Point_Type_2;
332 -- Verify that prefix of attribute N is a float type and that
333 -- two attribute expressions are present
334
335 procedure Check_SPARK_05_Restriction_On_Attribute;
336 -- Issue an error in formal mode because attribute N is allowed
337
338 procedure Check_Integer_Type;
339 -- Verify that prefix of attribute N is an integer type
340
341 procedure Check_Modular_Integer_Type;
342 -- Verify that prefix of attribute N is a modular integer type
343
344 procedure Check_Not_CPP_Type;
345 -- Check that P (the prefix of the attribute) is not an CPP type
346 -- for which no Ada predefined primitive is available.
347
348 procedure Check_Not_Incomplete_Type;
349 -- Check that P (the prefix of the attribute) is not an incomplete
350 -- type or a private type for which no full view has been given.
351
352 procedure Check_Object_Reference (P : Node_Id);
353 -- Check that P is an object reference
354
355 procedure Check_PolyORB_Attribute;
356 -- Validity checking for PolyORB/DSA attribute
357
358 procedure Check_Program_Unit;
359 -- Verify that prefix of attribute N is a program unit
360
361 procedure Check_Real_Type;
362 -- Verify that prefix of attribute N is fixed or float type
363
364 procedure Check_Scalar_Type;
365 -- Verify that prefix of attribute N is a scalar type
366
367 procedure Check_Standard_Prefix;
368 -- Verify that prefix of attribute N is package Standard. Also checks
369 -- that there are no arguments.
370
371 procedure Check_Stream_Attribute (Nam : TSS_Name_Type);
372 -- Validity checking for stream attribute. Nam is the TSS name of the
373 -- corresponding possible defined attribute function (e.g. for the
374 -- Read attribute, Nam will be TSS_Stream_Read).
375
376 procedure Check_System_Prefix;
377 -- Verify that prefix of attribute N is package System
378
379 procedure Check_Task_Prefix;
380 -- Verify that prefix of attribute N is a task or task type
381
382 procedure Check_Type;
383 -- Verify that the prefix of attribute N is a type
384
385 procedure Check_Unit_Name (Nod : Node_Id);
386 -- Check that Nod is of the form of a library unit name, i.e that
387 -- it is an identifier, or a selected component whose prefix is
388 -- itself of the form of a library unit name. Note that this is
389 -- quite different from Check_Program_Unit, since it only checks
390 -- the syntactic form of the name, not the semantic identity. This
391 -- is because it is used with attributes (Elab_Body, Elab_Spec and
392 -- Elaborated) which can refer to non-visible unit.
393
394 procedure Error_Attr (Msg : String; Error_Node : Node_Id);
395 pragma No_Return (Error_Attr);
396 procedure Error_Attr;
397 pragma No_Return (Error_Attr);
398 -- Posts error using Error_Msg_N at given node, sets type of attribute
399 -- node to Any_Type, and then raises Bad_Attribute to avoid any further
400 -- semantic processing. The message typically contains a % insertion
401 -- character which is replaced by the attribute name. The call with
402 -- no arguments is used when the caller has already generated the
403 -- required error messages.
404
405 procedure Error_Attr_P (Msg : String);
406 pragma No_Return (Error_Attr);
407 -- Like Error_Attr, but error is posted at the start of the prefix
408
409 procedure Legal_Formal_Attribute;
410 -- Common processing for attributes Definite and Has_Discriminants.
411 -- Checks that prefix is generic indefinite formal type.
412
413 procedure Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements;
414 -- Common processing for attributes Max_Alignment_For_Allocation and
415 -- Max_Size_In_Storage_Elements.
416
417 procedure Min_Max;
418 -- Common processing for attributes Max and Min
419
420 procedure Standard_Attribute (Val : Int);
421 -- Used to process attributes whose prefix is package Standard which
422 -- yield values of type Universal_Integer. The attribute reference
423 -- node is rewritten with an integer literal of the given value which
424 -- is marked as static.
425
426 procedure Uneval_Old_Msg;
427 -- Called when Loop_Entry or Old is used in a potentially unevaluated
428 -- expression. Generates appropriate message or warning depending on
429 -- the setting of Opt.Uneval_Old (or flags in an N_Aspect_Specification
430 -- node in the aspect case).
431
432 procedure Unexpected_Argument (En : Node_Id);
433 -- Signal unexpected attribute argument (En is the argument)
434
435 procedure Validate_Non_Static_Attribute_Function_Call;
436 -- Called when processing an attribute that is a function call to a
437 -- non-static function, i.e. an attribute function that either takes
438 -- non-scalar arguments or returns a non-scalar result. Verifies that
439 -- such a call does not appear in a preelaborable context.
440
441 --------------------
442 -- Address_Checks --
443 --------------------
444
445 procedure Address_Checks is
446 begin
447 -- An Address attribute created by expansion is legal even when it
448 -- applies to other entity-denoting expressions.
449
450 if not Comes_From_Source (N) then
451 return;
452
453 -- Address attribute on a protected object self reference is legal
454
455 elsif Is_Protected_Self_Reference (P) then
456 return;
457
458 -- Address applied to an entity
459
460 elsif Is_Entity_Name (P) then
461 declare
462 Ent : constant Entity_Id := Entity (P);
463
464 begin
465 if Is_Subprogram (Ent) then
466 Set_Address_Taken (Ent);
467 Kill_Current_Values (Ent);
468
469 -- An Address attribute is accepted when generated by the
470 -- compiler for dispatching operation, and an error is
471 -- issued once the subprogram is frozen (to avoid confusing
472 -- errors about implicit uses of Address in the dispatch
473 -- table initialization).
474
475 if Has_Pragma_Inline_Always (Entity (P))
476 and then Comes_From_Source (P)
477 then
478 Error_Attr_P
479 ("prefix of % attribute cannot be Inline_Always "
480 & "subprogram");
481
482 -- It is illegal to apply 'Address to an intrinsic
483 -- subprogram. This is now formalized in AI05-0095.
484 -- In an instance, an attempt to obtain 'Address of an
485 -- intrinsic subprogram (e.g the renaming of a predefined
486 -- operator that is an actual) raises Program_Error.
487
488 elsif Convention (Ent) = Convention_Intrinsic then
489 if In_Instance then
490 Rewrite (N,
491 Make_Raise_Program_Error (Loc,
492 Reason => PE_Address_Of_Intrinsic));
493
494 else
495 Error_Msg_Name_1 := Aname;
496 Error_Msg_N
497 ("cannot take % of intrinsic subprogram", N);
498 end if;
499
500 -- Issue an error if prefix denotes an eliminated subprogram
501
502 else
503 Check_For_Eliminated_Subprogram (P, Ent);
504 end if;
505
506 -- Object or label reference
507
508 elsif Is_Object (Ent) or else Ekind (Ent) = E_Label then
509 Set_Address_Taken (Ent);
510
511 -- Deal with No_Implicit_Aliasing restriction
512
513 if Restriction_Check_Required (No_Implicit_Aliasing) then
514 if not Is_Aliased_View (P) then
515 Check_Restriction (No_Implicit_Aliasing, P);
516 else
517 Check_No_Implicit_Aliasing (P);
518 end if;
519 end if;
520
521 -- If we have an address of an object, and the attribute
522 -- comes from source, then set the object as potentially
523 -- source modified. We do this because the resulting address
524 -- can potentially be used to modify the variable and we
525 -- might not detect this, leading to some junk warnings.
526
527 Set_Never_Set_In_Source (Ent, False);
528
529 -- Allow Address to be applied to task or protected type,
530 -- returning null address (what is that about???)
531
532 elsif (Is_Concurrent_Type (Etype (Ent))
533 and then Etype (Ent) = Base_Type (Ent))
534 or else Ekind (Ent) = E_Package
535 or else Is_Generic_Unit (Ent)
536 then
537 Rewrite (N,
538 New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
539
540 -- Anything else is illegal
541
542 else
543 Error_Attr ("invalid prefix for % attribute", P);
544 end if;
545 end;
546
547 -- Object is OK
548
549 elsif Is_Object_Reference (P) then
550 return;
551
552 -- Subprogram called using dot notation
553
554 elsif Nkind (P) = N_Selected_Component
555 and then Is_Subprogram (Entity (Selector_Name (P)))
556 then
557 return;
558
559 -- What exactly are we allowing here ??? and is this properly
560 -- documented in the sinfo documentation for this node ???
561
562 elsif Relaxed_RM_Semantics
563 and then Nkind (P) = N_Attribute_Reference
564 then
565 return;
566
567 -- All other non-entity name cases are illegal
568
569 else
570 Error_Attr ("invalid prefix for % attribute", P);
571 end if;
572 end Address_Checks;
573
574 ------------------------------
575 -- Analyze_Access_Attribute --
576 ------------------------------
577
578 procedure Analyze_Access_Attribute is
579 Acc_Type : Entity_Id;
580
581 Scop : Entity_Id;
582 Typ : Entity_Id;
583
584 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id;
585 -- Build an access-to-object type whose designated type is DT,
586 -- and whose Ekind is appropriate to the attribute type. The
587 -- type that is constructed is returned as the result.
588
589 procedure Build_Access_Subprogram_Type (P : Node_Id);
590 -- Build an access to subprogram whose designated type is the type of
591 -- the prefix. If prefix is overloaded, so is the node itself. The
592 -- result is stored in Acc_Type.
593
594 function OK_Self_Reference return Boolean;
595 -- An access reference whose prefix is a type can legally appear
596 -- within an aggregate, where it is obtained by expansion of
597 -- a defaulted aggregate. The enclosing aggregate that contains
598 -- the self-referenced is flagged so that the self-reference can
599 -- be expanded into a reference to the target object (see exp_aggr).
600
601 ------------------------------
602 -- Build_Access_Object_Type --
603 ------------------------------
604
605 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is
606 Typ : constant Entity_Id :=
607 New_Internal_Entity
608 (E_Access_Attribute_Type, Current_Scope, Loc, 'A');
609 begin
610 Set_Etype (Typ, Typ);
611 Set_Is_Itype (Typ);
612 Set_Associated_Node_For_Itype (Typ, N);
613 Set_Directly_Designated_Type (Typ, DT);
614 return Typ;
615 end Build_Access_Object_Type;
616
617 ----------------------------------
618 -- Build_Access_Subprogram_Type --
619 ----------------------------------
620
621 procedure Build_Access_Subprogram_Type (P : Node_Id) is
622 Index : Interp_Index;
623 It : Interp;
624
625 procedure Check_Local_Access (E : Entity_Id);
626 -- Deal with possible access to local subprogram. If we have such
627 -- an access, we set a flag to kill all tracked values on any call
628 -- because this access value may be passed around, and any called
629 -- code might use it to access a local procedure which clobbers a
630 -- tracked value. If the scope is a loop or block, indicate that
631 -- value tracking is disabled for the enclosing subprogram.
632
633 function Get_Kind (E : Entity_Id) return Entity_Kind;
634 -- Distinguish between access to regular/protected subprograms
635
636 ------------------------
637 -- Check_Local_Access --
638 ------------------------
639
640 procedure Check_Local_Access (E : Entity_Id) is
641 begin
642 if not Is_Library_Level_Entity (E) then
643 Set_Suppress_Value_Tracking_On_Call (Current_Scope);
644 Set_Suppress_Value_Tracking_On_Call
645 (Nearest_Dynamic_Scope (Current_Scope));
646 end if;
647 end Check_Local_Access;
648
649 --------------
650 -- Get_Kind --
651 --------------
652
653 function Get_Kind (E : Entity_Id) return Entity_Kind is
654 begin
655 if Convention (E) = Convention_Protected then
656 return E_Access_Protected_Subprogram_Type;
657 else
658 return E_Access_Subprogram_Type;
659 end if;
660 end Get_Kind;
661
662 -- Start of processing for Build_Access_Subprogram_Type
663
664 begin
665 -- In the case of an access to subprogram, use the name of the
666 -- subprogram itself as the designated type. Type-checking in
667 -- this case compares the signatures of the designated types.
668
669 -- Note: This fragment of the tree is temporarily malformed
670 -- because the correct tree requires an E_Subprogram_Type entity
671 -- as the designated type. In most cases this designated type is
672 -- later overridden by the semantics with the type imposed by the
673 -- context during the resolution phase. In the specific case of
674 -- the expression Address!(Prim'Unrestricted_Access), used to
675 -- initialize slots of dispatch tables, this work will be done by
676 -- the expander (see Exp_Aggr).
677
678 -- The reason to temporarily add this kind of node to the tree
679 -- instead of a proper E_Subprogram_Type itype, is the following:
680 -- in case of errors found in the source file we report better
681 -- error messages. For example, instead of generating the
682 -- following error:
683
684 -- "expected access to subprogram with profile
685 -- defined at line X"
686
687 -- we currently generate:
688
689 -- "expected access to function Z defined at line X"
690
691 Set_Etype (N, Any_Type);
692
693 if not Is_Overloaded (P) then
694 Check_Local_Access (Entity (P));
695
696 if not Is_Intrinsic_Subprogram (Entity (P)) then
697 Acc_Type := Create_Itype (Get_Kind (Entity (P)), N);
698 Set_Is_Public (Acc_Type, False);
699 Set_Etype (Acc_Type, Acc_Type);
700 Set_Convention (Acc_Type, Convention (Entity (P)));
701 Set_Directly_Designated_Type (Acc_Type, Entity (P));
702 Set_Etype (N, Acc_Type);
703 Freeze_Before (N, Acc_Type);
704 end if;
705
706 else
707 Get_First_Interp (P, Index, It);
708 while Present (It.Nam) loop
709 Check_Local_Access (It.Nam);
710
711 if not Is_Intrinsic_Subprogram (It.Nam) then
712 Acc_Type := Create_Itype (Get_Kind (It.Nam), N);
713 Set_Is_Public (Acc_Type, False);
714 Set_Etype (Acc_Type, Acc_Type);
715 Set_Convention (Acc_Type, Convention (It.Nam));
716 Set_Directly_Designated_Type (Acc_Type, It.Nam);
717 Add_One_Interp (N, Acc_Type, Acc_Type);
718 Freeze_Before (N, Acc_Type);
719 end if;
720
721 Get_Next_Interp (Index, It);
722 end loop;
723 end if;
724
725 -- Cannot be applied to intrinsic. Looking at the tests above,
726 -- the only way Etype (N) can still be set to Any_Type is if
727 -- Is_Intrinsic_Subprogram was True for some referenced entity.
728
729 if Etype (N) = Any_Type then
730 Error_Attr_P ("prefix of % attribute cannot be intrinsic");
731 end if;
732 end Build_Access_Subprogram_Type;
733
734 ----------------------
735 -- OK_Self_Reference --
736 ----------------------
737
738 function OK_Self_Reference return Boolean is
739 Par : Node_Id;
740
741 begin
742 Par := Parent (N);
743 while Present (Par)
744 and then
745 (Nkind (Par) = N_Component_Association
746 or else Nkind (Par) in N_Subexpr)
747 loop
748 if Nkind_In (Par, N_Aggregate, N_Extension_Aggregate) then
749 if Etype (Par) = Typ then
750 Set_Has_Self_Reference (Par);
751
752 -- Check the context: the aggregate must be part of the
753 -- initialization of a type or component, or it is the
754 -- resulting expansion in an initialization procedure.
755
756 if Is_Init_Proc (Current_Scope) then
757 return True;
758 else
759 Par := Parent (Par);
760 while Present (Par) loop
761 if Nkind (Par) = N_Full_Type_Declaration then
762 return True;
763 end if;
764
765 Par := Parent (Par);
766 end loop;
767 end if;
768
769 return False;
770 end if;
771 end if;
772
773 Par := Parent (Par);
774 end loop;
775
776 -- No enclosing aggregate, or not a self-reference
777
778 return False;
779 end OK_Self_Reference;
780
781 -- Start of processing for Analyze_Access_Attribute
782
783 begin
784 Check_SPARK_05_Restriction_On_Attribute;
785 Check_E0;
786
787 if Nkind (P) = N_Character_Literal then
788 Error_Attr_P
789 ("prefix of % attribute cannot be enumeration literal");
790 end if;
791
792 -- Case of access to subprogram
793
794 if Is_Entity_Name (P) and then Is_Overloadable (Entity (P)) then
795 if Has_Pragma_Inline_Always (Entity (P)) then
796 Error_Attr_P
797 ("prefix of % attribute cannot be Inline_Always subprogram");
798
799 elsif Aname = Name_Unchecked_Access then
800 Error_Attr ("attribute% cannot be applied to a subprogram", P);
801 end if;
802
803 -- Issue an error if the prefix denotes an eliminated subprogram
804
805 Check_For_Eliminated_Subprogram (P, Entity (P));
806
807 -- Check for obsolescent subprogram reference
808
809 Check_Obsolescent_2005_Entity (Entity (P), P);
810
811 -- Build the appropriate subprogram type
812
813 Build_Access_Subprogram_Type (P);
814
815 -- For P'Access or P'Unrestricted_Access, where P is a nested
816 -- subprogram, we might be passing P to another subprogram (but we
817 -- don't check that here), which might call P. P could modify
818 -- local variables, so we need to kill current values. It is
819 -- important not to do this for library-level subprograms, because
820 -- Kill_Current_Values is very inefficient in the case of library
821 -- level packages with lots of tagged types.
822
823 if Is_Library_Level_Entity (Entity (Prefix (N))) then
824 null;
825
826 -- Do not kill values on nodes initializing dispatch tables
827 -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access)
828 -- is currently generated by the expander only for this
829 -- purpose. Done to keep the quality of warnings currently
830 -- generated by the compiler (otherwise any declaration of
831 -- a tagged type cleans constant indications from its scope).
832
833 elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
834 and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr)
835 or else
836 Etype (Parent (N)) = RTE (RE_Size_Ptr))
837 and then Is_Dispatching_Operation
838 (Directly_Designated_Type (Etype (N)))
839 then
840 null;
841
842 else
843 Kill_Current_Values;
844 end if;
845
846 -- In the static elaboration model, treat the attribute reference
847 -- as a call for elaboration purposes. Suppress this treatment
848 -- under debug flag. In any case, we are all done.
849
850 if not Dynamic_Elaboration_Checks and not Debug_Flag_Dot_UU then
851 Check_Elab_Call (N);
852 end if;
853
854 return;
855
856 -- Component is an operation of a protected type
857
858 elsif Nkind (P) = N_Selected_Component
859 and then Is_Overloadable (Entity (Selector_Name (P)))
860 then
861 if Ekind (Entity (Selector_Name (P))) = E_Entry then
862 Error_Attr_P ("prefix of % attribute must be subprogram");
863 end if;
864
865 Build_Access_Subprogram_Type (Selector_Name (P));
866 return;
867 end if;
868
869 -- Deal with incorrect reference to a type, but note that some
870 -- accesses are allowed: references to the current type instance,
871 -- or in Ada 2005 self-referential pointer in a default-initialized
872 -- aggregate.
873
874 if Is_Entity_Name (P) then
875 Typ := Entity (P);
876
877 -- The reference may appear in an aggregate that has been expanded
878 -- into a loop. Locate scope of type definition, if any.
879
880 Scop := Current_Scope;
881 while Ekind (Scop) = E_Loop loop
882 Scop := Scope (Scop);
883 end loop;
884
885 if Is_Type (Typ) then
886
887 -- OK if we are within the scope of a limited type
888 -- let's mark the component as having per object constraint
889
890 if Is_Anonymous_Tagged_Base (Scop, Typ) then
891 Typ := Scop;
892 Set_Entity (P, Typ);
893 Set_Etype (P, Typ);
894 end if;
895
896 if Typ = Scop then
897 declare
898 Q : Node_Id := Parent (N);
899
900 begin
901 while Present (Q)
902 and then Nkind (Q) /= N_Component_Declaration
903 loop
904 Q := Parent (Q);
905 end loop;
906
907 if Present (Q) then
908 Set_Has_Per_Object_Constraint
909 (Defining_Identifier (Q), True);
910 end if;
911 end;
912
913 if Nkind (P) = N_Expanded_Name then
914 Error_Msg_F
915 ("current instance prefix must be a direct name", P);
916 end if;
917
918 -- If a current instance attribute appears in a component
919 -- constraint it must appear alone; other contexts (spec-
920 -- expressions, within a task body) are not subject to this
921 -- restriction.
922
923 if not In_Spec_Expression
924 and then not Has_Completion (Scop)
925 and then not
926 Nkind_In (Parent (N), N_Discriminant_Association,
927 N_Index_Or_Discriminant_Constraint)
928 then
929 Error_Msg_N
930 ("current instance attribute must appear alone", N);
931 end if;
932
933 if Is_CPP_Class (Root_Type (Typ)) then
934 Error_Msg_N
935 ("??current instance unsupported for derivations of "
936 & "'C'P'P types", N);
937 end if;
938
939 -- OK if we are in initialization procedure for the type
940 -- in question, in which case the reference to the type
941 -- is rewritten as a reference to the current object.
942
943 elsif Ekind (Scop) = E_Procedure
944 and then Is_Init_Proc (Scop)
945 and then Etype (First_Formal (Scop)) = Typ
946 then
947 Rewrite (N,
948 Make_Attribute_Reference (Loc,
949 Prefix => Make_Identifier (Loc, Name_uInit),
950 Attribute_Name => Name_Unrestricted_Access));
951 Analyze (N);
952 return;
953
954 -- OK if a task type, this test needs sharpening up ???
955
956 elsif Is_Task_Type (Typ) then
957 null;
958
959 -- OK if self-reference in an aggregate in Ada 2005, and
960 -- the reference comes from a copied default expression.
961
962 -- Note that we check legality of self-reference even if the
963 -- expression comes from source, e.g. when a single component
964 -- association in an aggregate has a box association.
965
966 elsif Ada_Version >= Ada_2005
967 and then OK_Self_Reference
968 then
969 null;
970
971 -- OK if reference to current instance of a protected object
972
973 elsif Is_Protected_Self_Reference (P) then
974 null;
975
976 -- Otherwise we have an error case
977
978 else
979 Error_Attr ("% attribute cannot be applied to type", P);
980 return;
981 end if;
982 end if;
983 end if;
984
985 -- If we fall through, we have a normal access to object case
986
987 -- Unrestricted_Access is (for now) legal wherever an allocator would
988 -- be legal, so its Etype is set to E_Allocator. The expected type
989 -- of the other attributes is a general access type, and therefore
990 -- we label them with E_Access_Attribute_Type.
991
992 if not Is_Overloaded (P) then
993 Acc_Type := Build_Access_Object_Type (P_Type);
994 Set_Etype (N, Acc_Type);
995
996 else
997 declare
998 Index : Interp_Index;
999 It : Interp;
1000 begin
1001 Set_Etype (N, Any_Type);
1002 Get_First_Interp (P, Index, It);
1003 while Present (It.Typ) loop
1004 Acc_Type := Build_Access_Object_Type (It.Typ);
1005 Add_One_Interp (N, Acc_Type, Acc_Type);
1006 Get_Next_Interp (Index, It);
1007 end loop;
1008 end;
1009 end if;
1010
1011 -- Special cases when we can find a prefix that is an entity name
1012
1013 declare
1014 PP : Node_Id;
1015 Ent : Entity_Id;
1016
1017 begin
1018 PP := P;
1019 loop
1020 if Is_Entity_Name (PP) then
1021 Ent := Entity (PP);
1022
1023 -- If we have an access to an object, and the attribute
1024 -- comes from source, then set the object as potentially
1025 -- source modified. We do this because the resulting access
1026 -- pointer can be used to modify the variable, and we might
1027 -- not detect this, leading to some junk warnings.
1028
1029 -- We only do this for source references, since otherwise
1030 -- we can suppress warnings, e.g. from the unrestricted
1031 -- access generated for validity checks in -gnatVa mode.
1032
1033 if Comes_From_Source (N) then
1034 Set_Never_Set_In_Source (Ent, False);
1035 end if;
1036
1037 -- Mark entity as address taken, and kill current values
1038
1039 Set_Address_Taken (Ent);
1040 Kill_Current_Values (Ent);
1041 exit;
1042
1043 elsif Nkind_In (PP, N_Selected_Component,
1044 N_Indexed_Component)
1045 then
1046 PP := Prefix (PP);
1047
1048 else
1049 exit;
1050 end if;
1051 end loop;
1052 end;
1053
1054 -- Check for aliased view.. We allow a nonaliased prefix when within
1055 -- an instance because the prefix may have been a tagged formal
1056 -- object, which is defined to be aliased even when the actual
1057 -- might not be (other instance cases will have been caught in the
1058 -- generic). Similarly, within an inlined body we know that the
1059 -- attribute is legal in the original subprogram, and therefore
1060 -- legal in the expansion.
1061
1062 if not Is_Aliased_View (P)
1063 and then not In_Instance
1064 and then not In_Inlined_Body
1065 and then Comes_From_Source (N)
1066 then
1067 -- Here we have a non-aliased view. This is illegal unless we
1068 -- have the case of Unrestricted_Access, where for now we allow
1069 -- this (we will reject later if expected type is access to an
1070 -- unconstrained array with a thin pointer).
1071
1072 -- No need for an error message on a generated access reference
1073 -- for the controlling argument in a dispatching call: error will
1074 -- be reported when resolving the call.
1075
1076 if Aname /= Name_Unrestricted_Access then
1077 Error_Attr_P ("prefix of % attribute must be aliased");
1078 Check_No_Implicit_Aliasing (P);
1079
1080 -- For Unrestricted_Access, record that prefix is not aliased
1081 -- to simplify legality check later on.
1082
1083 else
1084 Set_Non_Aliased_Prefix (N);
1085 end if;
1086
1087 -- If we have an aliased view, and we have Unrestricted_Access, then
1088 -- output a warning that Unchecked_Access would have been fine, and
1089 -- change the node to be Unchecked_Access.
1090
1091 else
1092 -- For now, hold off on this change ???
1093
1094 null;
1095 end if;
1096 end Analyze_Access_Attribute;
1097
1098 ----------------------------------
1099 -- Analyze_Attribute_Old_Result --
1100 ----------------------------------
1101
1102 procedure Analyze_Attribute_Old_Result
1103 (Legal : out Boolean;
1104 Spec_Id : out Entity_Id)
1105 is
1106 procedure Check_Placement_In_Check (Prag : Node_Id);
1107 -- Verify that the attribute appears within pragma Check that mimics
1108 -- a postcondition.
1109
1110 procedure Check_Placement_In_Contract_Cases (Prag : Node_Id);
1111 -- Verify that the attribute appears within a consequence of aspect
1112 -- or pragma Contract_Cases denoted by Prag.
1113
1114 procedure Check_Placement_In_Test_Case (Prag : Node_Id);
1115 -- Verify that the attribute appears within the "Ensures" argument of
1116 -- aspect or pragma Test_Case denoted by Prag.
1117
1118 function Is_Within
1119 (Nod : Node_Id;
1120 Encl_Nod : Node_Id) return Boolean;
1121 -- Subsidiary to Check_Placemenet_In_XXX. Determine whether arbitrary
1122 -- node Nod is within enclosing node Encl_Nod.
1123
1124 procedure Placement_Error;
1125 -- Emit a general error when the attributes does not appear in a
1126 -- postcondition-like aspect or pragma.
1127
1128 ------------------------------
1129 -- Check_Placement_In_Check --
1130 ------------------------------
1131
1132 procedure Check_Placement_In_Check (Prag : Node_Id) is
1133 Args : constant List_Id := Pragma_Argument_Associations (Prag);
1134 Nam : constant Name_Id := Chars (Get_Pragma_Arg (First (Args)));
1135
1136 begin
1137 -- The "Name" argument of pragma Check denotes a postcondition
1138
1139 if Nam_In (Nam, Name_Post,
1140 Name_Post_Class,
1141 Name_Postcondition,
1142 Name_Refined_Post)
1143 then
1144 null;
1145
1146 -- Otherwise the placement of the attribute is illegal
1147
1148 else
1149 Placement_Error;
1150 end if;
1151 end Check_Placement_In_Check;
1152
1153 ---------------------------------------
1154 -- Check_Placement_In_Contract_Cases --
1155 ---------------------------------------
1156
1157 procedure Check_Placement_In_Contract_Cases (Prag : Node_Id) is
1158 Arg : Node_Id;
1159 Cases : Node_Id;
1160 CCase : Node_Id;
1161
1162 begin
1163 -- Obtain the argument of the aspect or pragma
1164
1165 if Nkind (Prag) = N_Aspect_Specification then
1166 Arg := Prag;
1167 else
1168 Arg := First (Pragma_Argument_Associations (Prag));
1169 end if;
1170
1171 Cases := Expression (Arg);
1172
1173 if Present (Component_Associations (Cases)) then
1174 CCase := First (Component_Associations (Cases));
1175 while Present (CCase) loop
1176
1177 -- Detect whether the attribute appears within the
1178 -- consequence of the current contract case.
1179
1180 if Nkind (CCase) = N_Component_Association
1181 and then Is_Within (N, Expression (CCase))
1182 then
1183 return;
1184 end if;
1185
1186 Next (CCase);
1187 end loop;
1188 end if;
1189
1190 -- Otherwise aspect or pragma Contract_Cases is either malformed
1191 -- or the attribute does not appear within a consequence.
1192
1193 Error_Attr
1194 ("attribute % must appear in the consequence of a contract case",
1195 P);
1196 end Check_Placement_In_Contract_Cases;
1197
1198 ----------------------------------
1199 -- Check_Placement_In_Test_Case --
1200 ----------------------------------
1201
1202 procedure Check_Placement_In_Test_Case (Prag : Node_Id) is
1203 Arg : constant Node_Id :=
1204 Test_Case_Arg
1205 (Prag => Prag,
1206 Arg_Nam => Name_Ensures,
1207 From_Aspect => Nkind (Prag) = N_Aspect_Specification);
1208
1209 begin
1210 -- Detect whether the attribute appears within the "Ensures"
1211 -- expression of aspect or pragma Test_Case.
1212
1213 if Present (Arg) and then Is_Within (N, Arg) then
1214 null;
1215
1216 else
1217 Error_Attr
1218 ("attribute % must appear in the ensures expression of a "
1219 & "test case", P);
1220 end if;
1221 end Check_Placement_In_Test_Case;
1222
1223 ---------------
1224 -- Is_Within --
1225 ---------------
1226
1227 function Is_Within
1228 (Nod : Node_Id;
1229 Encl_Nod : Node_Id) return Boolean
1230 is
1231 Par : Node_Id;
1232
1233 begin
1234 Par := Nod;
1235 while Present (Par) loop
1236 if Par = Encl_Nod then
1237 return True;
1238
1239 -- Prevent the search from going too far
1240
1241 elsif Is_Body_Or_Package_Declaration (Par) then
1242 exit;
1243 end if;
1244
1245 Par := Parent (Par);
1246 end loop;
1247
1248 return False;
1249 end Is_Within;
1250
1251 ---------------------
1252 -- Placement_Error --
1253 ---------------------
1254
1255 procedure Placement_Error is
1256 begin
1257 if Aname = Name_Old then
1258 Error_Attr ("attribute % can only appear in postcondition", P);
1259
1260 -- Specialize the error message for attribute 'Result
1261
1262 else
1263 Error_Attr
1264 ("attribute % can only appear in postcondition of function",
1265 P);
1266 end if;
1267 end Placement_Error;
1268
1269 -- Local variables
1270
1271 Prag : Node_Id;
1272 Prag_Nam : Name_Id;
1273 Subp_Decl : Node_Id;
1274
1275 -- Start of processing for Analyze_Attribute_Old_Result
1276
1277 begin
1278 -- Assume that the attribute is illegal
1279
1280 Legal := False;
1281 Spec_Id := Empty;
1282
1283 -- Traverse the parent chain to find the aspect or pragma where the
1284 -- attribute resides.
1285
1286 Prag := N;
1287 while Present (Prag) loop
1288 if Nkind_In (Prag, N_Aspect_Specification, N_Pragma) then
1289 exit;
1290
1291 -- Prevent the search from going too far
1292
1293 elsif Is_Body_Or_Package_Declaration (Prag) then
1294 exit;
1295 end if;
1296
1297 Prag := Parent (Prag);
1298 end loop;
1299
1300 -- The attribute is allowed to appear only in postcondition-like
1301 -- aspects or pragmas.
1302
1303 if Nkind_In (Prag, N_Aspect_Specification, N_Pragma) then
1304 if Nkind (Prag) = N_Aspect_Specification then
1305 Prag_Nam := Chars (Identifier (Prag));
1306 else
1307 Prag_Nam := Pragma_Name (Prag);
1308 end if;
1309
1310 if Prag_Nam = Name_Check then
1311 Check_Placement_In_Check (Prag);
1312
1313 elsif Prag_Nam = Name_Contract_Cases then
1314 Check_Placement_In_Contract_Cases (Prag);
1315
1316 -- Attribute 'Result is allowed to appear in aspect or pragma
1317 -- [Refined_]Depends (SPARK RM 6.1.5(11)).
1318
1319 elsif Nam_In (Prag_Nam, Name_Depends, Name_Refined_Depends)
1320 and then Aname = Name_Result
1321 then
1322 null;
1323
1324 elsif Nam_In (Prag_Nam, Name_Post,
1325 Name_Post_Class,
1326 Name_Postcondition,
1327 Name_Refined_Post)
1328 then
1329 null;
1330
1331 elsif Prag_Nam = Name_Test_Case then
1332 Check_Placement_In_Test_Case (Prag);
1333
1334 else
1335 Placement_Error;
1336 return;
1337 end if;
1338
1339 -- Otherwise the placement of the attribute is illegal
1340
1341 else
1342 Placement_Error;
1343 return;
1344 end if;
1345
1346 -- Find the related subprogram subject to the aspect or pragma
1347
1348 if Nkind (Prag) = N_Aspect_Specification then
1349 Subp_Decl := Parent (Prag);
1350 else
1351 Subp_Decl := Find_Related_Declaration_Or_Body (Prag);
1352 end if;
1353
1354 -- The aspect or pragma where the attribute resides should be
1355 -- associated with a subprogram declaration or a body. If this is not
1356 -- the case, then the aspect or pragma is illegal. Return as analysis
1357 -- cannot be carried out. Note that it is legal to have the aspect
1358 -- appear on a subprogram renaming, when the renamed entity is an
1359 -- attribute reference.
1360
1361 if not Nkind_In (Subp_Decl, N_Abstract_Subprogram_Declaration,
1362 N_Entry_Declaration,
1363 N_Generic_Subprogram_Declaration,
1364 N_Subprogram_Body,
1365 N_Subprogram_Body_Stub,
1366 N_Subprogram_Declaration,
1367 N_Subprogram_Renaming_Declaration)
1368 then
1369 return;
1370 end if;
1371
1372 -- If we get here, then the attribute is legal
1373
1374 Legal := True;
1375 Spec_Id := Unique_Defining_Entity (Subp_Decl);
1376
1377 -- When generating C code, nested _postcondition subprograms are
1378 -- inlined by the front end to avoid problems (when unnested) with
1379 -- referenced itypes. Handle that here, since as part of inlining the
1380 -- expander nests subprogram within a dummy procedure named _parent
1381 -- (see Build_Postconditions_Procedure and Build_Body_To_Inline).
1382 -- Hence, in this context, the spec_id of _postconditions is the
1383 -- enclosing scope.
1384
1385 if Modify_Tree_For_C
1386 and then Chars (Spec_Id) = Name_uParent
1387 and then Chars (Scope (Spec_Id)) = Name_uPostconditions
1388 then
1389 -- This situation occurs only when preanalyzing the inlined body
1390
1391 pragma Assert (not Full_Analysis);
1392
1393 Spec_Id := Scope (Spec_Id);
1394 pragma Assert (Is_Inlined (Spec_Id));
1395 end if;
1396 end Analyze_Attribute_Old_Result;
1397
1398 ---------------------------------
1399 -- Bad_Attribute_For_Predicate --
1400 ---------------------------------
1401
1402 procedure Bad_Attribute_For_Predicate is
1403 begin
1404 if Is_Scalar_Type (P_Type)
1405 and then Comes_From_Source (N)
1406 then
1407 Error_Msg_Name_1 := Aname;
1408 Bad_Predicated_Subtype_Use
1409 ("type& has predicates, attribute % not allowed", N, P_Type);
1410 end if;
1411 end Bad_Attribute_For_Predicate;
1412
1413 --------------------------------
1414 -- Check_Array_Or_Scalar_Type --
1415 --------------------------------
1416
1417 procedure Check_Array_Or_Scalar_Type is
1418 function In_Aspect_Specification return Boolean;
1419 -- A current instance of a type in an aspect specification is an
1420 -- object and not a type, and therefore cannot be of a scalar type
1421 -- in the prefix of one of the array attributes if the attribute
1422 -- reference is part of an aspect expression.
1423
1424 -----------------------------
1425 -- In_Aspect_Specification --
1426 -----------------------------
1427
1428 function In_Aspect_Specification return Boolean is
1429 P : Node_Id;
1430
1431 begin
1432 P := Parent (N);
1433 while Present (P) loop
1434 if Nkind (P) = N_Aspect_Specification then
1435 return P_Type = Entity (P);
1436
1437 elsif Nkind (P) in N_Declaration then
1438 return False;
1439 end if;
1440
1441 P := Parent (P);
1442 end loop;
1443
1444 return False;
1445 end In_Aspect_Specification;
1446
1447 -- Local variables
1448
1449 Dims : Int;
1450 Index : Entity_Id;
1451
1452 -- Start of processing for Check_Array_Or_Scalar_Type
1453
1454 begin
1455 -- Case of string literal or string literal subtype. These cases
1456 -- cannot arise from legal Ada code, but the expander is allowed
1457 -- to generate them. They require special handling because string
1458 -- literal subtypes do not have standard bounds (the whole idea
1459 -- of these subtypes is to avoid having to generate the bounds)
1460
1461 if Ekind (P_Type) = E_String_Literal_Subtype then
1462 Set_Etype (N, Etype (First_Index (P_Base_Type)));
1463 return;
1464
1465 -- Scalar types
1466
1467 elsif Is_Scalar_Type (P_Type) then
1468 Check_Type;
1469
1470 if Present (E1) then
1471 Error_Attr ("invalid argument in % attribute", E1);
1472
1473 elsif In_Aspect_Specification then
1474 Error_Attr
1475 ("prefix of % attribute cannot be the current instance of a "
1476 & "scalar type", P);
1477
1478 else
1479 Set_Etype (N, P_Base_Type);
1480 return;
1481 end if;
1482
1483 -- The following is a special test to allow 'First to apply to
1484 -- private scalar types if the attribute comes from generated
1485 -- code. This occurs in the case of Normalize_Scalars code.
1486
1487 elsif Is_Private_Type (P_Type)
1488 and then Present (Full_View (P_Type))
1489 and then Is_Scalar_Type (Full_View (P_Type))
1490 and then not Comes_From_Source (N)
1491 then
1492 Set_Etype (N, Implementation_Base_Type (P_Type));
1493
1494 -- Array types other than string literal subtypes handled above
1495
1496 else
1497 Check_Array_Type;
1498
1499 -- We know prefix is an array type, or the name of an array
1500 -- object, and that the expression, if present, is static
1501 -- and within the range of the dimensions of the type.
1502
1503 pragma Assert (Is_Array_Type (P_Type));
1504 Index := First_Index (P_Base_Type);
1505
1506 if No (E1) then
1507
1508 -- First dimension assumed
1509
1510 Set_Etype (N, Base_Type (Etype (Index)));
1511
1512 else
1513 Dims := UI_To_Int (Intval (E1));
1514
1515 for J in 1 .. Dims - 1 loop
1516 Next_Index (Index);
1517 end loop;
1518
1519 Set_Etype (N, Base_Type (Etype (Index)));
1520 Set_Etype (E1, Standard_Integer);
1521 end if;
1522 end if;
1523 end Check_Array_Or_Scalar_Type;
1524
1525 ----------------------
1526 -- Check_Array_Type --
1527 ----------------------
1528
1529 procedure Check_Array_Type is
1530 D : Int;
1531 -- Dimension number for array attributes
1532
1533 begin
1534 -- If the type is a string literal type, then this must be generated
1535 -- internally, and no further check is required on its legality.
1536
1537 if Ekind (P_Type) = E_String_Literal_Subtype then
1538 return;
1539
1540 -- If the type is a composite, it is an illegal aggregate, no point
1541 -- in going on.
1542
1543 elsif P_Type = Any_Composite then
1544 raise Bad_Attribute;
1545 end if;
1546
1547 -- Normal case of array type or subtype
1548
1549 Check_Either_E0_Or_E1;
1550 Check_Dereference;
1551
1552 if Is_Array_Type (P_Type) then
1553 if not Is_Constrained (P_Type)
1554 and then Is_Entity_Name (P)
1555 and then Is_Type (Entity (P))
1556 then
1557 -- Note: we do not call Error_Attr here, since we prefer to
1558 -- continue, using the relevant index type of the array,
1559 -- even though it is unconstrained. This gives better error
1560 -- recovery behavior.
1561
1562 Error_Msg_Name_1 := Aname;
1563 Error_Msg_F
1564 ("prefix for % attribute must be constrained array", P);
1565 end if;
1566
1567 -- The attribute reference freezes the type, and thus the
1568 -- component type, even if the attribute may not depend on the
1569 -- component. Diagnose arrays with incomplete components now.
1570 -- If the prefix is an access to array, this does not freeze
1571 -- the designated type.
1572
1573 if Nkind (P) /= N_Explicit_Dereference then
1574 Check_Fully_Declared (Component_Type (P_Type), P);
1575 end if;
1576
1577 D := Number_Dimensions (P_Type);
1578
1579 else
1580 if Is_Private_Type (P_Type) then
1581 Error_Attr_P ("prefix for % attribute may not be private type");
1582
1583 elsif Is_Access_Type (P_Type)
1584 and then Is_Array_Type (Designated_Type (P_Type))
1585 and then Is_Entity_Name (P)
1586 and then Is_Type (Entity (P))
1587 then
1588 Error_Attr_P ("prefix of % attribute cannot be access type");
1589
1590 elsif Attr_Id = Attribute_First
1591 or else
1592 Attr_Id = Attribute_Last
1593 then
1594 Error_Attr ("invalid prefix for % attribute", P);
1595
1596 else
1597 Error_Attr_P ("prefix for % attribute must be array");
1598 end if;
1599 end if;
1600
1601 if Present (E1) then
1602 Resolve (E1, Any_Integer);
1603 Set_Etype (E1, Standard_Integer);
1604
1605 if not Is_OK_Static_Expression (E1)
1606 or else Raises_Constraint_Error (E1)
1607 then
1608 Flag_Non_Static_Expr
1609 ("expression for dimension must be static!", E1);
1610 Error_Attr;
1611
1612 elsif UI_To_Int (Expr_Value (E1)) > D
1613 or else UI_To_Int (Expr_Value (E1)) < 1
1614 then
1615 Error_Attr ("invalid dimension number for array type", E1);
1616 end if;
1617 end if;
1618
1619 if (Style_Check and Style_Check_Array_Attribute_Index)
1620 and then Comes_From_Source (N)
1621 then
1622 Style.Check_Array_Attribute_Index (N, E1, D);
1623 end if;
1624 end Check_Array_Type;
1625
1626 -------------------------
1627 -- Check_Asm_Attribute --
1628 -------------------------
1629
1630 procedure Check_Asm_Attribute is
1631 begin
1632 Check_Type;
1633 Check_E2;
1634
1635 -- Check first argument is static string expression
1636
1637 Analyze_And_Resolve (E1, Standard_String);
1638
1639 if Etype (E1) = Any_Type then
1640 return;
1641
1642 elsif not Is_OK_Static_Expression (E1) then
1643 Flag_Non_Static_Expr
1644 ("constraint argument must be static string expression!", E1);
1645 Error_Attr;
1646 end if;
1647
1648 -- Check second argument is right type
1649
1650 Analyze_And_Resolve (E2, Entity (P));
1651
1652 -- Note: that is all we need to do, we don't need to check
1653 -- that it appears in a correct context. The Ada type system
1654 -- will do that for us.
1655
1656 end Check_Asm_Attribute;
1657
1658 ---------------------
1659 -- Check_Component --
1660 ---------------------
1661
1662 procedure Check_Component is
1663 begin
1664 Check_E0;
1665
1666 if Nkind (P) /= N_Selected_Component
1667 or else
1668 (Ekind (Entity (Selector_Name (P))) /= E_Component
1669 and then
1670 Ekind (Entity (Selector_Name (P))) /= E_Discriminant)
1671 then
1672 Error_Attr_P ("prefix for % attribute must be selected component");
1673 end if;
1674 end Check_Component;
1675
1676 ------------------------------------
1677 -- Check_Decimal_Fixed_Point_Type --
1678 ------------------------------------
1679
1680 procedure Check_Decimal_Fixed_Point_Type is
1681 begin
1682 Check_Type;
1683
1684 if not Is_Decimal_Fixed_Point_Type (P_Type) then
1685 Error_Attr_P ("prefix of % attribute must be decimal type");
1686 end if;
1687 end Check_Decimal_Fixed_Point_Type;
1688
1689 -----------------------
1690 -- Check_Dereference --
1691 -----------------------
1692
1693 procedure Check_Dereference is
1694 begin
1695
1696 -- Case of a subtype mark
1697
1698 if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
1699 return;
1700 end if;
1701
1702 -- Case of an expression
1703
1704 Resolve (P);
1705
1706 if Is_Access_Type (P_Type) then
1707
1708 -- If there is an implicit dereference, then we must freeze the
1709 -- designated type of the access type, since the type of the
1710 -- referenced array is this type (see AI95-00106).
1711
1712 -- As done elsewhere, freezing must not happen when pre-analyzing
1713 -- a pre- or postcondition or a default value for an object or for
1714 -- a formal parameter.
1715
1716 if not In_Spec_Expression then
1717 Freeze_Before (N, Designated_Type (P_Type));
1718 end if;
1719
1720 Rewrite (P,
1721 Make_Explicit_Dereference (Sloc (P),
1722 Prefix => Relocate_Node (P)));
1723
1724 Analyze_And_Resolve (P);
1725 P_Type := Etype (P);
1726
1727 if P_Type = Any_Type then
1728 raise Bad_Attribute;
1729 end if;
1730
1731 P_Base_Type := Base_Type (P_Type);
1732 end if;
1733 end Check_Dereference;
1734
1735 -------------------------
1736 -- Check_Discrete_Type --
1737 -------------------------
1738
1739 procedure Check_Discrete_Type is
1740 begin
1741 Check_Type;
1742
1743 if not Is_Discrete_Type (P_Type) then
1744 Error_Attr_P ("prefix of % attribute must be discrete type");
1745 end if;
1746 end Check_Discrete_Type;
1747
1748 --------------
1749 -- Check_E0 --
1750 --------------
1751
1752 procedure Check_E0 is
1753 begin
1754 if Present (E1) then
1755 Unexpected_Argument (E1);
1756 end if;
1757 end Check_E0;
1758
1759 --------------
1760 -- Check_E1 --
1761 --------------
1762
1763 procedure Check_E1 is
1764 begin
1765 Check_Either_E0_Or_E1;
1766
1767 if No (E1) then
1768
1769 -- Special-case attributes that are functions and that appear as
1770 -- the prefix of another attribute. Error is posted on parent.
1771
1772 if Nkind (Parent (N)) = N_Attribute_Reference
1773 and then Nam_In (Attribute_Name (Parent (N)), Name_Address,
1774 Name_Code_Address,
1775 Name_Access)
1776 then
1777 Error_Msg_Name_1 := Attribute_Name (Parent (N));
1778 Error_Msg_N ("illegal prefix for % attribute", Parent (N));
1779 Set_Etype (Parent (N), Any_Type);
1780 Set_Entity (Parent (N), Any_Type);
1781 raise Bad_Attribute;
1782
1783 else
1784 Error_Attr ("missing argument for % attribute", N);
1785 end if;
1786 end if;
1787 end Check_E1;
1788
1789 --------------
1790 -- Check_E2 --
1791 --------------
1792
1793 procedure Check_E2 is
1794 begin
1795 if No (E1) then
1796 Error_Attr ("missing arguments for % attribute (2 required)", N);
1797 elsif No (E2) then
1798 Error_Attr ("missing argument for % attribute (2 required)", N);
1799 end if;
1800 end Check_E2;
1801
1802 ---------------------------
1803 -- Check_Either_E0_Or_E1 --
1804 ---------------------------
1805
1806 procedure Check_Either_E0_Or_E1 is
1807 begin
1808 if Present (E2) then
1809 Unexpected_Argument (E2);
1810 end if;
1811 end Check_Either_E0_Or_E1;
1812
1813 ----------------------
1814 -- Check_Enum_Image --
1815 ----------------------
1816
1817 procedure Check_Enum_Image is
1818 Lit : Entity_Id;
1819
1820 begin
1821 -- When an enumeration type appears in an attribute reference, all
1822 -- literals of the type are marked as referenced. This must only be
1823 -- done if the attribute reference appears in the current source.
1824 -- Otherwise the information on references may differ between a
1825 -- normal compilation and one that performs inlining.
1826
1827 if Is_Enumeration_Type (P_Base_Type)
1828 and then In_Extended_Main_Code_Unit (N)
1829 then
1830 Lit := First_Literal (P_Base_Type);
1831 while Present (Lit) loop
1832 Set_Referenced (Lit);
1833 Next_Literal (Lit);
1834 end loop;
1835 end if;
1836 end Check_Enum_Image;
1837
1838 ----------------------------
1839 -- Check_First_Last_Valid --
1840 ----------------------------
1841
1842 procedure Check_First_Last_Valid is
1843 begin
1844 Check_Discrete_Type;
1845
1846 -- Freeze the subtype now, so that the following test for predicates
1847 -- works (we set the predicates stuff up at freeze time)
1848
1849 Insert_Actions (N, Freeze_Entity (P_Type, P));
1850
1851 -- Now test for dynamic predicate
1852
1853 if Has_Predicates (P_Type)
1854 and then not (Has_Static_Predicate (P_Type))
1855 then
1856 Error_Attr_P
1857 ("prefix of % attribute may not have dynamic predicate");
1858 end if;
1859
1860 -- Check non-static subtype
1861
1862 if not Is_OK_Static_Subtype (P_Type) then
1863 Error_Attr_P ("prefix of % attribute must be a static subtype");
1864 end if;
1865
1866 -- Test case for no values
1867
1868 if Expr_Value (Type_Low_Bound (P_Type)) >
1869 Expr_Value (Type_High_Bound (P_Type))
1870 or else (Has_Predicates (P_Type)
1871 and then
1872 Is_Empty_List (Static_Discrete_Predicate (P_Type)))
1873 then
1874 Error_Attr_P
1875 ("prefix of % attribute must be subtype with at least one "
1876 & "value");
1877 end if;
1878 end Check_First_Last_Valid;
1879
1880 ----------------------------
1881 -- Check_Fixed_Point_Type --
1882 ----------------------------
1883
1884 procedure Check_Fixed_Point_Type is
1885 begin
1886 Check_Type;
1887
1888 if not Is_Fixed_Point_Type (P_Type) then
1889 Error_Attr_P ("prefix of % attribute must be fixed point type");
1890 end if;
1891 end Check_Fixed_Point_Type;
1892
1893 ------------------------------
1894 -- Check_Fixed_Point_Type_0 --
1895 ------------------------------
1896
1897 procedure Check_Fixed_Point_Type_0 is
1898 begin
1899 Check_Fixed_Point_Type;
1900 Check_E0;
1901 end Check_Fixed_Point_Type_0;
1902
1903 -------------------------------
1904 -- Check_Floating_Point_Type --
1905 -------------------------------
1906
1907 procedure Check_Floating_Point_Type is
1908 begin
1909 Check_Type;
1910
1911 if not Is_Floating_Point_Type (P_Type) then
1912 Error_Attr_P ("prefix of % attribute must be float type");
1913 end if;
1914 end Check_Floating_Point_Type;
1915
1916 ---------------------------------
1917 -- Check_Floating_Point_Type_0 --
1918 ---------------------------------
1919
1920 procedure Check_Floating_Point_Type_0 is
1921 begin
1922 Check_Floating_Point_Type;
1923 Check_E0;
1924 end Check_Floating_Point_Type_0;
1925
1926 ---------------------------------
1927 -- Check_Floating_Point_Type_1 --
1928 ---------------------------------
1929
1930 procedure Check_Floating_Point_Type_1 is
1931 begin
1932 Check_Floating_Point_Type;
1933 Check_E1;
1934 end Check_Floating_Point_Type_1;
1935
1936 ---------------------------------
1937 -- Check_Floating_Point_Type_2 --
1938 ---------------------------------
1939
1940 procedure Check_Floating_Point_Type_2 is
1941 begin
1942 Check_Floating_Point_Type;
1943 Check_E2;
1944 end Check_Floating_Point_Type_2;
1945
1946 ------------------------
1947 -- Check_Integer_Type --
1948 ------------------------
1949
1950 procedure Check_Integer_Type is
1951 begin
1952 Check_Type;
1953
1954 if not Is_Integer_Type (P_Type) then
1955 Error_Attr_P ("prefix of % attribute must be integer type");
1956 end if;
1957 end Check_Integer_Type;
1958
1959 --------------------------------
1960 -- Check_Modular_Integer_Type --
1961 --------------------------------
1962
1963 procedure Check_Modular_Integer_Type is
1964 begin
1965 Check_Type;
1966
1967 if not Is_Modular_Integer_Type (P_Type) then
1968 Error_Attr_P
1969 ("prefix of % attribute must be modular integer type");
1970 end if;
1971 end Check_Modular_Integer_Type;
1972
1973 ------------------------
1974 -- Check_Not_CPP_Type --
1975 ------------------------
1976
1977 procedure Check_Not_CPP_Type is
1978 begin
1979 if Is_Tagged_Type (Etype (P))
1980 and then Convention (Etype (P)) = Convention_CPP
1981 and then Is_CPP_Class (Root_Type (Etype (P)))
1982 then
1983 Error_Attr_P
1984 ("invalid use of % attribute with 'C'P'P tagged type");
1985 end if;
1986 end Check_Not_CPP_Type;
1987
1988 -------------------------------
1989 -- Check_Not_Incomplete_Type --
1990 -------------------------------
1991
1992 procedure Check_Not_Incomplete_Type is
1993 E : Entity_Id;
1994 Typ : Entity_Id;
1995
1996 begin
1997 -- Ada 2005 (AI-50217, AI-326): If the prefix is an explicit
1998 -- dereference we have to check wrong uses of incomplete types
1999 -- (other wrong uses are checked at their freezing point).
2000
2001 -- In Ada 2012, incomplete types can appear in subprogram
2002 -- profiles, but formals with incomplete types cannot be the
2003 -- prefix of attributes.
2004
2005 -- Example 1: Limited-with
2006
2007 -- limited with Pkg;
2008 -- package P is
2009 -- type Acc is access Pkg.T;
2010 -- X : Acc;
2011 -- S : Integer := X.all'Size; -- ERROR
2012 -- end P;
2013
2014 -- Example 2: Tagged incomplete
2015
2016 -- type T is tagged;
2017 -- type Acc is access all T;
2018 -- X : Acc;
2019 -- S : constant Integer := X.all'Size; -- ERROR
2020 -- procedure Q (Obj : Integer := X.all'Alignment); -- ERROR
2021
2022 if Ada_Version >= Ada_2005
2023 and then Nkind (P) = N_Explicit_Dereference
2024 then
2025 E := P;
2026 while Nkind (E) = N_Explicit_Dereference loop
2027 E := Prefix (E);
2028 end loop;
2029
2030 Typ := Etype (E);
2031
2032 if From_Limited_With (Typ) then
2033 Error_Attr_P
2034 ("prefix of % attribute cannot be an incomplete type");
2035
2036 -- If the prefix is an access type check the designated type
2037
2038 elsif Is_Access_Type (Typ)
2039 and then Nkind (P) = N_Explicit_Dereference
2040 then
2041 Typ := Directly_Designated_Type (Typ);
2042 end if;
2043
2044 if Is_Class_Wide_Type (Typ) then
2045 Typ := Root_Type (Typ);
2046 end if;
2047
2048 -- A legal use of a shadow entity occurs only when the unit where
2049 -- the non-limited view resides is imported via a regular with
2050 -- clause in the current body. Such references to shadow entities
2051 -- may occur in subprogram formals.
2052
2053 if Is_Incomplete_Type (Typ)
2054 and then From_Limited_With (Typ)
2055 and then Present (Non_Limited_View (Typ))
2056 and then Is_Legal_Shadow_Entity_In_Body (Typ)
2057 then
2058 Typ := Non_Limited_View (Typ);
2059 end if;
2060
2061 -- If still incomplete, it can be a local incomplete type, or a
2062 -- limited view whose scope is also a limited view.
2063
2064 if Ekind (Typ) = E_Incomplete_Type then
2065 if not From_Limited_With (Typ)
2066 and then No (Full_View (Typ))
2067 then
2068 Error_Attr_P
2069 ("prefix of % attribute cannot be an incomplete type");
2070
2071 -- The limited view may be available indirectly through
2072 -- an intermediate unit. If the non-limited view is available
2073 -- the attribute reference is legal.
2074
2075 elsif From_Limited_With (Typ)
2076 and then
2077 (No (Non_Limited_View (Typ))
2078 or else Is_Incomplete_Type (Non_Limited_View (Typ)))
2079 then
2080 Error_Attr_P
2081 ("prefix of % attribute cannot be an incomplete type");
2082 end if;
2083 end if;
2084
2085 -- Ada 2012 : formals in bodies may be incomplete, but no attribute
2086 -- legally applies.
2087
2088 elsif Is_Entity_Name (P)
2089 and then Is_Formal (Entity (P))
2090 and then Is_Incomplete_Type (Etype (Etype (P)))
2091 then
2092 Error_Attr_P
2093 ("prefix of % attribute cannot be an incomplete type");
2094 end if;
2095
2096 if not Is_Entity_Name (P)
2097 or else not Is_Type (Entity (P))
2098 or else In_Spec_Expression
2099 then
2100 return;
2101 else
2102 Check_Fully_Declared (P_Type, P);
2103 end if;
2104 end Check_Not_Incomplete_Type;
2105
2106 ----------------------------
2107 -- Check_Object_Reference --
2108 ----------------------------
2109
2110 procedure Check_Object_Reference (P : Node_Id) is
2111 Rtyp : Entity_Id;
2112
2113 begin
2114 -- If we need an object, and we have a prefix that is the name of
2115 -- a function entity, convert it into a function call.
2116
2117 if Is_Entity_Name (P)
2118 and then Ekind (Entity (P)) = E_Function
2119 then
2120 Rtyp := Etype (Entity (P));
2121
2122 Rewrite (P,
2123 Make_Function_Call (Sloc (P),
2124 Name => Relocate_Node (P)));
2125
2126 Analyze_And_Resolve (P, Rtyp);
2127
2128 -- Otherwise we must have an object reference
2129
2130 elsif not Is_Object_Reference (P) then
2131 Error_Attr_P ("prefix of % attribute must be object");
2132 end if;
2133 end Check_Object_Reference;
2134
2135 ----------------------------
2136 -- Check_PolyORB_Attribute --
2137 ----------------------------
2138
2139 procedure Check_PolyORB_Attribute is
2140 begin
2141 Validate_Non_Static_Attribute_Function_Call;
2142
2143 Check_Type;
2144 Check_Not_CPP_Type;
2145
2146 if Get_PCS_Name /= Name_PolyORB_DSA then
2147 Error_Attr
2148 ("attribute% requires the 'Poly'O'R'B 'P'C'S", N);
2149 end if;
2150 end Check_PolyORB_Attribute;
2151
2152 ------------------------
2153 -- Check_Program_Unit --
2154 ------------------------
2155
2156 procedure Check_Program_Unit is
2157 begin
2158 if Is_Entity_Name (P) then
2159 declare
2160 K : constant Entity_Kind := Ekind (Entity (P));
2161 T : constant Entity_Id := Etype (Entity (P));
2162
2163 begin
2164 if K in Subprogram_Kind
2165 or else K in Task_Kind
2166 or else K in Protected_Kind
2167 or else K = E_Package
2168 or else K in Generic_Unit_Kind
2169 or else (K = E_Variable
2170 and then
2171 (Is_Task_Type (T)
2172 or else
2173 Is_Protected_Type (T)))
2174 then
2175 return;
2176 end if;
2177 end;
2178 end if;
2179
2180 Error_Attr_P ("prefix of % attribute must be program unit");
2181 end Check_Program_Unit;
2182
2183 ---------------------
2184 -- Check_Real_Type --
2185 ---------------------
2186
2187 procedure Check_Real_Type is
2188 begin
2189 Check_Type;
2190
2191 if not Is_Real_Type (P_Type) then
2192 Error_Attr_P ("prefix of % attribute must be real type");
2193 end if;
2194 end Check_Real_Type;
2195
2196 -----------------------
2197 -- Check_Scalar_Type --
2198 -----------------------
2199
2200 procedure Check_Scalar_Type is
2201 begin
2202 Check_Type;
2203
2204 if not Is_Scalar_Type (P_Type) then
2205 Error_Attr_P ("prefix of % attribute must be scalar type");
2206 end if;
2207 end Check_Scalar_Type;
2208
2209 ------------------------------------------
2210 -- Check_SPARK_05_Restriction_On_Attribute --
2211 ------------------------------------------
2212
2213 procedure Check_SPARK_05_Restriction_On_Attribute is
2214 begin
2215 Error_Msg_Name_1 := Aname;
2216 Check_SPARK_05_Restriction ("attribute % is not allowed", P);
2217 end Check_SPARK_05_Restriction_On_Attribute;
2218
2219 ---------------------------
2220 -- Check_Standard_Prefix --
2221 ---------------------------
2222
2223 procedure Check_Standard_Prefix is
2224 begin
2225 Check_E0;
2226
2227 if Nkind (P) /= N_Identifier or else Chars (P) /= Name_Standard then
2228 Error_Attr ("only allowed prefix for % attribute is Standard", P);
2229 end if;
2230 end Check_Standard_Prefix;
2231
2232 ----------------------------
2233 -- Check_Stream_Attribute --
2234 ----------------------------
2235
2236 procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is
2237 Etyp : Entity_Id;
2238 Btyp : Entity_Id;
2239
2240 In_Shared_Var_Procs : Boolean;
2241 -- True when compiling System.Shared_Storage.Shared_Var_Procs body.
2242 -- For this runtime package (always compiled in GNAT mode), we allow
2243 -- stream attributes references for limited types for the case where
2244 -- shared passive objects are implemented using stream attributes,
2245 -- which is the default in GNAT's persistent storage implementation.
2246
2247 begin
2248 Validate_Non_Static_Attribute_Function_Call;
2249
2250 -- With the exception of 'Input, Stream attributes are procedures,
2251 -- and can only appear at the position of procedure calls. We check
2252 -- for this here, before they are rewritten, to give a more precise
2253 -- diagnostic.
2254
2255 if Nam = TSS_Stream_Input then
2256 null;
2257
2258 elsif Is_List_Member (N)
2259 and then not Nkind_In (Parent (N), N_Procedure_Call_Statement,
2260 N_Aggregate)
2261 then
2262 null;
2263
2264 else
2265 Error_Attr
2266 ("invalid context for attribute%, which is a procedure", N);
2267 end if;
2268
2269 Check_Type;
2270 Btyp := Implementation_Base_Type (P_Type);
2271
2272 -- Stream attributes not allowed on limited types unless the
2273 -- attribute reference was generated by the expander (in which
2274 -- case the underlying type will be used, as described in Sinfo),
2275 -- or the attribute was specified explicitly for the type itself
2276 -- or one of its ancestors (taking visibility rules into account if
2277 -- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp
2278 -- (with no visibility restriction).
2279
2280 declare
2281 Gen_Body : constant Node_Id := Enclosing_Generic_Body (N);
2282 begin
2283 if Present (Gen_Body) then
2284 In_Shared_Var_Procs :=
2285 Is_RTE (Corresponding_Spec (Gen_Body), RE_Shared_Var_Procs);
2286 else
2287 In_Shared_Var_Procs := False;
2288 end if;
2289 end;
2290
2291 if (Comes_From_Source (N)
2292 and then not (In_Shared_Var_Procs or In_Instance))
2293 and then not Stream_Attribute_Available (P_Type, Nam)
2294 and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert)
2295 then
2296 Error_Msg_Name_1 := Aname;
2297
2298 if Is_Limited_Type (P_Type) then
2299 Error_Msg_NE
2300 ("limited type& has no% attribute", P, P_Type);
2301 Explain_Limited_Type (P_Type, P);
2302 else
2303 Error_Msg_NE
2304 ("attribute% for type& is not available", P, P_Type);
2305 end if;
2306 end if;
2307
2308 -- Check for no stream operations allowed from No_Tagged_Streams
2309
2310 if Is_Tagged_Type (P_Type)
2311 and then Present (No_Tagged_Streams_Pragma (P_Type))
2312 then
2313 Error_Msg_Sloc := Sloc (No_Tagged_Streams_Pragma (P_Type));
2314 Error_Msg_NE
2315 ("no stream operations for & (No_Tagged_Streams #)", N, P_Type);
2316 return;
2317 end if;
2318
2319 -- Check restriction violations
2320
2321 -- First check the No_Streams restriction, which prohibits the use
2322 -- of explicit stream attributes in the source program. We do not
2323 -- prevent the occurrence of stream attributes in generated code,
2324 -- for instance those generated implicitly for dispatching purposes.
2325
2326 if Comes_From_Source (N) then
2327 Check_Restriction (No_Streams, P);
2328 end if;
2329
2330 -- AI05-0057: if restriction No_Default_Stream_Attributes is active,
2331 -- it is illegal to use a predefined elementary type stream attribute
2332 -- either by itself, or more importantly as part of the attribute
2333 -- subprogram for a composite type. However, if the broader
2334 -- restriction No_Streams is active, stream operations are not
2335 -- generated, and there is no error.
2336
2337 if Restriction_Active (No_Default_Stream_Attributes)
2338 and then not Restriction_Active (No_Streams)
2339 then
2340 declare
2341 T : Entity_Id;
2342
2343 begin
2344 if Nam = TSS_Stream_Input
2345 or else
2346 Nam = TSS_Stream_Read
2347 then
2348 T :=
2349 Type_Without_Stream_Operation (P_Type, TSS_Stream_Read);
2350 else
2351 T :=
2352 Type_Without_Stream_Operation (P_Type, TSS_Stream_Write);
2353 end if;
2354
2355 if Present (T) then
2356 Check_Restriction (No_Default_Stream_Attributes, N);
2357
2358 Error_Msg_NE
2359 ("missing user-defined Stream Read or Write for type&",
2360 N, T);
2361 if not Is_Elementary_Type (P_Type) then
2362 Error_Msg_NE
2363 ("\which is a component of type&", N, P_Type);
2364 end if;
2365 end if;
2366 end;
2367 end if;
2368
2369 -- Check special case of Exception_Id and Exception_Occurrence which
2370 -- are not allowed for restriction No_Exception_Registration.
2371
2372 if Restriction_Check_Required (No_Exception_Registration)
2373 and then (Is_RTE (P_Type, RE_Exception_Id)
2374 or else
2375 Is_RTE (P_Type, RE_Exception_Occurrence))
2376 then
2377 Check_Restriction (No_Exception_Registration, P);
2378 end if;
2379
2380 -- Here we must check that the first argument is an access type
2381 -- that is compatible with Ada.Streams.Root_Stream_Type'Class.
2382
2383 Analyze_And_Resolve (E1);
2384 Etyp := Etype (E1);
2385
2386 -- Note: the double call to Root_Type here is needed because the
2387 -- root type of a class-wide type is the corresponding type (e.g.
2388 -- X for X'Class, and we really want to go to the root.)
2389
2390 if not Is_Access_Type (Etyp)
2391 or else Root_Type (Root_Type (Designated_Type (Etyp))) /=
2392 RTE (RE_Root_Stream_Type)
2393 then
2394 Error_Attr
2395 ("expected access to Ada.Streams.Root_Stream_Type''Class", E1);
2396 end if;
2397
2398 -- Check that the second argument is of the right type if there is
2399 -- one (the Input attribute has only one argument so this is skipped)
2400
2401 if Present (E2) then
2402 Analyze (E2);
2403
2404 if Nam = TSS_Stream_Read
2405 and then not Is_OK_Variable_For_Out_Formal (E2)
2406 then
2407 Error_Attr
2408 ("second argument of % attribute must be a variable", E2);
2409 end if;
2410
2411 Resolve (E2, P_Type);
2412 end if;
2413
2414 Check_Not_CPP_Type;
2415 end Check_Stream_Attribute;
2416
2417 -------------------------
2418 -- Check_System_Prefix --
2419 -------------------------
2420
2421 procedure Check_System_Prefix is
2422 begin
2423 if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then
2424 Error_Attr ("only allowed prefix for % attribute is System", P);
2425 end if;
2426 end Check_System_Prefix;
2427
2428 -----------------------
2429 -- Check_Task_Prefix --
2430 -----------------------
2431
2432 procedure Check_Task_Prefix is
2433 begin
2434 Analyze (P);
2435
2436 -- Ada 2005 (AI-345): Attribute 'Terminated can be applied to
2437 -- task interface class-wide types.
2438
2439 if Is_Task_Type (Etype (P))
2440 or else (Is_Access_Type (Etype (P))
2441 and then Is_Task_Type (Designated_Type (Etype (P))))
2442 or else (Ada_Version >= Ada_2005
2443 and then Ekind (Etype (P)) = E_Class_Wide_Type
2444 and then Is_Interface (Etype (P))
2445 and then Is_Task_Interface (Etype (P)))
2446 then
2447 Resolve (P);
2448
2449 else
2450 if Ada_Version >= Ada_2005 then
2451 Error_Attr_P
2452 ("prefix of % attribute must be a task or a task " &
2453 "interface class-wide object");
2454
2455 else
2456 Error_Attr_P ("prefix of % attribute must be a task");
2457 end if;
2458 end if;
2459 end Check_Task_Prefix;
2460
2461 ----------------
2462 -- Check_Type --
2463 ----------------
2464
2465 -- The possibilities are an entity name denoting a type, or an
2466 -- attribute reference that denotes a type (Base or Class). If
2467 -- the type is incomplete, replace it with its full view.
2468
2469 procedure Check_Type is
2470 begin
2471 if not Is_Entity_Name (P)
2472 or else not Is_Type (Entity (P))
2473 then
2474 Error_Attr_P ("prefix of % attribute must be a type");
2475
2476 elsif Is_Protected_Self_Reference (P) then
2477 Error_Attr_P
2478 ("prefix of % attribute denotes current instance "
2479 & "(RM 9.4(21/2))");
2480
2481 elsif Ekind (Entity (P)) = E_Incomplete_Type
2482 and then Present (Full_View (Entity (P)))
2483 then
2484 P_Type := Full_View (Entity (P));
2485 Set_Entity (P, P_Type);
2486 end if;
2487 end Check_Type;
2488
2489 ---------------------
2490 -- Check_Unit_Name --
2491 ---------------------
2492
2493 procedure Check_Unit_Name (Nod : Node_Id) is
2494 begin
2495 if Nkind (Nod) = N_Identifier then
2496 return;
2497
2498 elsif Nkind_In (Nod, N_Selected_Component, N_Expanded_Name) then
2499 Check_Unit_Name (Prefix (Nod));
2500
2501 if Nkind (Selector_Name (Nod)) = N_Identifier then
2502 return;
2503 end if;
2504 end if;
2505
2506 Error_Attr ("argument for % attribute must be unit name", P);
2507 end Check_Unit_Name;
2508
2509 ----------------
2510 -- Error_Attr --
2511 ----------------
2512
2513 procedure Error_Attr is
2514 begin
2515 Set_Etype (N, Any_Type);
2516 Set_Entity (N, Any_Type);
2517 raise Bad_Attribute;
2518 end Error_Attr;
2519
2520 procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
2521 begin
2522 Error_Msg_Name_1 := Aname;
2523 Error_Msg_N (Msg, Error_Node);
2524 Error_Attr;
2525 end Error_Attr;
2526
2527 ------------------
2528 -- Error_Attr_P --
2529 ------------------
2530
2531 procedure Error_Attr_P (Msg : String) is
2532 begin
2533 Error_Msg_Name_1 := Aname;
2534 Error_Msg_F (Msg, P);
2535 Error_Attr;
2536 end Error_Attr_P;
2537
2538 ----------------------------
2539 -- Legal_Formal_Attribute --
2540 ----------------------------
2541
2542 procedure Legal_Formal_Attribute is
2543 begin
2544 Check_E0;
2545
2546 if not Is_Entity_Name (P)
2547 or else not Is_Type (Entity (P))
2548 then
2549 Error_Attr_P ("prefix of % attribute must be generic type");
2550
2551 elsif Is_Generic_Actual_Type (Entity (P))
2552 or else In_Instance
2553 or else In_Inlined_Body
2554 then
2555 null;
2556
2557 elsif Is_Generic_Type (Entity (P)) then
2558 if Is_Definite_Subtype (Entity (P)) then
2559 Error_Attr_P
2560 ("prefix of % attribute must be indefinite generic type");
2561 end if;
2562
2563 else
2564 Error_Attr_P
2565 ("prefix of % attribute must be indefinite generic type");
2566 end if;
2567
2568 Set_Etype (N, Standard_Boolean);
2569 end Legal_Formal_Attribute;
2570
2571 ---------------------------------------------------------------
2572 -- Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements --
2573 ---------------------------------------------------------------
2574
2575 procedure Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements is
2576 begin
2577 Check_E0;
2578 Check_Type;
2579 Check_Not_Incomplete_Type;
2580 Set_Etype (N, Universal_Integer);
2581 end Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements;
2582
2583 -------------
2584 -- Min_Max --
2585 -------------
2586
2587 procedure Min_Max is
2588 begin
2589 Check_E2;
2590 Check_Scalar_Type;
2591 Resolve (E1, P_Base_Type);
2592 Resolve (E2, P_Base_Type);
2593 Set_Etype (N, P_Base_Type);
2594
2595 -- Check for comparison on unordered enumeration type
2596
2597 if Bad_Unordered_Enumeration_Reference (N, P_Base_Type) then
2598 Error_Msg_Sloc := Sloc (P_Base_Type);
2599 Error_Msg_NE
2600 ("comparison on unordered enumeration type& declared#?U?",
2601 N, P_Base_Type);
2602 end if;
2603 end Min_Max;
2604
2605 ------------------------
2606 -- Standard_Attribute --
2607 ------------------------
2608
2609 procedure Standard_Attribute (Val : Int) is
2610 begin
2611 Check_Standard_Prefix;
2612 Rewrite (N, Make_Integer_Literal (Loc, Val));
2613 Analyze (N);
2614 Set_Is_Static_Expression (N, True);
2615 end Standard_Attribute;
2616
2617 --------------------
2618 -- Uneval_Old_Msg --
2619 --------------------
2620
2621 procedure Uneval_Old_Msg is
2622 Uneval_Old_Setting : Character;
2623 Prag : Node_Id;
2624
2625 begin
2626 -- If from aspect, then Uneval_Old_Setting comes from flags in the
2627 -- N_Aspect_Specification node that corresponds to the attribute.
2628
2629 -- First find the pragma in which we appear (note that at this stage,
2630 -- even if we appeared originally within an aspect specification, we
2631 -- are now within the corresponding pragma).
2632
2633 Prag := N;
2634 loop
2635 Prag := Parent (Prag);
2636 exit when No (Prag) or else Nkind (Prag) = N_Pragma;
2637 end loop;
2638
2639 if Present (Prag) then
2640 if Uneval_Old_Accept (Prag) then
2641 Uneval_Old_Setting := 'A';
2642 elsif Uneval_Old_Warn (Prag) then
2643 Uneval_Old_Setting := 'W';
2644 else
2645 Uneval_Old_Setting := 'E';
2646 end if;
2647
2648 -- If we did not find the pragma, that's odd, just use the setting
2649 -- from Opt.Uneval_Old. Perhaps this is due to a previous error?
2650
2651 else
2652 Uneval_Old_Setting := Opt.Uneval_Old;
2653 end if;
2654
2655 -- Processing depends on the setting of Uneval_Old
2656
2657 case Uneval_Old_Setting is
2658 when 'E' =>
2659 Error_Attr_P
2660 ("prefix of attribute % that is potentially "
2661 & "unevaluated must denote an entity");
2662
2663 when 'W' =>
2664 Error_Msg_Name_1 := Aname;
2665 Error_Msg_F
2666 ("??prefix of attribute % appears in potentially "
2667 & "unevaluated context, exception may be raised", P);
2668
2669 when 'A' =>
2670 null;
2671
2672 when others =>
2673 raise Program_Error;
2674 end case;
2675 end Uneval_Old_Msg;
2676
2677 -------------------------
2678 -- Unexpected Argument --
2679 -------------------------
2680
2681 procedure Unexpected_Argument (En : Node_Id) is
2682 begin
2683 Error_Attr ("unexpected argument for % attribute", En);
2684 end Unexpected_Argument;
2685
2686 -------------------------------------------------
2687 -- Validate_Non_Static_Attribute_Function_Call --
2688 -------------------------------------------------
2689
2690 -- This function should be moved to Sem_Dist ???
2691
2692 procedure Validate_Non_Static_Attribute_Function_Call is
2693 begin
2694 if In_Preelaborated_Unit
2695 and then not In_Subprogram_Or_Concurrent_Unit
2696 then
2697 Flag_Non_Static_Expr
2698 ("non-static function call in preelaborated unit!", N);
2699 end if;
2700 end Validate_Non_Static_Attribute_Function_Call;
2701
2702 -- Start of processing for Analyze_Attribute
2703
2704 begin
2705 -- Immediate return if unrecognized attribute (already diagnosed by
2706 -- parser, so there is nothing more that we need to do).
2707
2708 if not Is_Attribute_Name (Aname) then
2709 raise Bad_Attribute;
2710 end if;
2711
2712 Check_Restriction_No_Use_Of_Attribute (N);
2713
2714 -- Deal with Ada 83 issues
2715
2716 if Comes_From_Source (N) then
2717 if not Attribute_83 (Attr_Id) then
2718 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
2719 Error_Msg_Name_1 := Aname;
2720 Error_Msg_N ("(Ada 83) attribute% is not standard??", N);
2721 end if;
2722
2723 if Attribute_Impl_Def (Attr_Id) then
2724 Check_Restriction (No_Implementation_Attributes, N);
2725 end if;
2726 end if;
2727 end if;
2728
2729 -- Deal with Ada 2005 attributes that are implementation attributes
2730 -- because they appear in a version of Ada before Ada 2005, and
2731 -- similarly for Ada 2012 attributes appearing in an earlier version.
2732
2733 if (Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005)
2734 or else
2735 (Attribute_12 (Attr_Id) and then Ada_Version < Ada_2012)
2736 then
2737 Check_Restriction (No_Implementation_Attributes, N);
2738 end if;
2739
2740 -- Remote access to subprogram type access attribute reference needs
2741 -- unanalyzed copy for tree transformation. The analyzed copy is used
2742 -- for its semantic information (whether prefix is a remote subprogram
2743 -- name), the unanalyzed copy is used to construct new subtree rooted
2744 -- with N_Aggregate which represents a fat pointer aggregate.
2745
2746 if Aname = Name_Access then
2747 Discard_Node (Copy_Separate_Tree (N));
2748 end if;
2749
2750 -- Analyze prefix and exit if error in analysis. If the prefix is an
2751 -- incomplete type, use full view if available. Note that there are
2752 -- some attributes for which we do not analyze the prefix, since the
2753 -- prefix is not a normal name, or else needs special handling.
2754
2755 if Aname /= Name_Elab_Body and then
2756 Aname /= Name_Elab_Spec and then
2757 Aname /= Name_Elab_Subp_Body and then
2758 Aname /= Name_Enabled and then
2759 Aname /= Name_Old
2760 then
2761 Analyze (P);
2762 P_Type := Etype (P);
2763
2764 if Is_Entity_Name (P)
2765 and then Present (Entity (P))
2766 and then Is_Type (Entity (P))
2767 then
2768 if Ekind (Entity (P)) = E_Incomplete_Type then
2769 P_Type := Get_Full_View (P_Type);
2770 Set_Entity (P, P_Type);
2771 Set_Etype (P, P_Type);
2772
2773 elsif Entity (P) = Current_Scope
2774 and then Is_Record_Type (Entity (P))
2775 then
2776 -- Use of current instance within the type. Verify that if the
2777 -- attribute appears within a constraint, it yields an access
2778 -- type, other uses are illegal.
2779
2780 declare
2781 Par : Node_Id;
2782
2783 begin
2784 Par := Parent (N);
2785 while Present (Par)
2786 and then Nkind (Parent (Par)) /= N_Component_Definition
2787 loop
2788 Par := Parent (Par);
2789 end loop;
2790
2791 if Present (Par)
2792 and then Nkind (Par) = N_Subtype_Indication
2793 then
2794 if Attr_Id /= Attribute_Access
2795 and then Attr_Id /= Attribute_Unchecked_Access
2796 and then Attr_Id /= Attribute_Unrestricted_Access
2797 then
2798 Error_Msg_N
2799 ("in a constraint the current instance can only "
2800 & "be used with an access attribute", N);
2801 end if;
2802 end if;
2803 end;
2804 end if;
2805 end if;
2806
2807 if P_Type = Any_Type then
2808 raise Bad_Attribute;
2809 end if;
2810
2811 P_Base_Type := Base_Type (P_Type);
2812 end if;
2813
2814 -- Analyze expressions that may be present, exiting if an error occurs
2815
2816 if No (Exprs) then
2817 E1 := Empty;
2818 E2 := Empty;
2819
2820 else
2821 E1 := First (Exprs);
2822
2823 -- Skip analysis for case of Restriction_Set, we do not expect
2824 -- the argument to be analyzed in this case.
2825
2826 if Aname /= Name_Restriction_Set then
2827 Analyze (E1);
2828
2829 -- Check for missing/bad expression (result of previous error)
2830
2831 if No (E1) or else Etype (E1) = Any_Type then
2832 raise Bad_Attribute;
2833 end if;
2834 end if;
2835
2836 E2 := Next (E1);
2837
2838 if Present (E2) then
2839 Analyze (E2);
2840
2841 if Etype (E2) = Any_Type then
2842 raise Bad_Attribute;
2843 end if;
2844
2845 if Present (Next (E2)) then
2846 Unexpected_Argument (Next (E2));
2847 end if;
2848 end if;
2849 end if;
2850
2851 -- Cases where prefix must be resolvable by itself
2852
2853 if Is_Overloaded (P)
2854 and then Aname /= Name_Access
2855 and then Aname /= Name_Address
2856 and then Aname /= Name_Code_Address
2857 and then Aname /= Name_Result
2858 and then Aname /= Name_Unchecked_Access
2859 then
2860 -- The prefix must be resolvable by itself, without reference to the
2861 -- attribute. One case that requires special handling is a prefix
2862 -- that is a function name, where one interpretation may be a
2863 -- parameterless call. Entry attributes are handled specially below.
2864
2865 if Is_Entity_Name (P)
2866 and then not Nam_In (Aname, Name_Count, Name_Caller)
2867 then
2868 Check_Parameterless_Call (P);
2869 end if;
2870
2871 if Is_Overloaded (P) then
2872
2873 -- Ada 2005 (AI-345): Since protected and task types have
2874 -- primitive entry wrappers, the attributes Count, and Caller
2875 -- require a context check
2876
2877 if Nam_In (Aname, Name_Count, Name_Caller) then
2878 declare
2879 Count : Natural := 0;
2880 I : Interp_Index;
2881 It : Interp;
2882
2883 begin
2884 Get_First_Interp (P, I, It);
2885 while Present (It.Nam) loop
2886 if Comes_From_Source (It.Nam) then
2887 Count := Count + 1;
2888 else
2889 Remove_Interp (I);
2890 end if;
2891
2892 Get_Next_Interp (I, It);
2893 end loop;
2894
2895 if Count > 1 then
2896 Error_Attr ("ambiguous prefix for % attribute", P);
2897 else
2898 Set_Is_Overloaded (P, False);
2899 end if;
2900 end;
2901
2902 else
2903 Error_Attr ("ambiguous prefix for % attribute", P);
2904 end if;
2905 end if;
2906 end if;
2907
2908 -- In SPARK, attributes of private types are only allowed if the full
2909 -- type declaration is visible.
2910
2911 -- Note: the check for Present (Entity (P)) defends against some error
2912 -- conditions where the Entity field is not set.
2913
2914 if Is_Entity_Name (P) and then Present (Entity (P))
2915 and then Is_Type (Entity (P))
2916 and then Is_Private_Type (P_Type)
2917 and then not In_Open_Scopes (Scope (P_Type))
2918 and then not In_Spec_Expression
2919 then
2920 Check_SPARK_05_Restriction ("invisible attribute of type", N);
2921 end if;
2922
2923 -- Remaining processing depends on attribute
2924
2925 case Attr_Id is
2926
2927 -- Attributes related to Ada 2012 iterators. Attribute specifications
2928 -- exist for these, but they cannot be queried.
2929
2930 when Attribute_Constant_Indexing |
2931 Attribute_Default_Iterator |
2932 Attribute_Implicit_Dereference |
2933 Attribute_Iterator_Element |
2934 Attribute_Iterable |
2935 Attribute_Variable_Indexing =>
2936 Error_Msg_N ("illegal attribute", N);
2937
2938 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
2939 -- were already rejected by the parser. Thus they shouldn't appear here.
2940
2941 when Internal_Attribute_Id =>
2942 raise Program_Error;
2943
2944 ------------------
2945 -- Abort_Signal --
2946 ------------------
2947
2948 when Attribute_Abort_Signal =>
2949 Check_Standard_Prefix;
2950 Rewrite (N, New_Occurrence_Of (Stand.Abort_Signal, Loc));
2951 Analyze (N);
2952
2953 ------------
2954 -- Access --
2955 ------------
2956
2957 when Attribute_Access =>
2958 Analyze_Access_Attribute;
2959 Check_Not_Incomplete_Type;
2960
2961 -------------
2962 -- Address --
2963 -------------
2964
2965 when Attribute_Address =>
2966 Check_E0;
2967 Address_Checks;
2968 Check_Not_Incomplete_Type;
2969 Set_Etype (N, RTE (RE_Address));
2970
2971 ------------------
2972 -- Address_Size --
2973 ------------------
2974
2975 when Attribute_Address_Size =>
2976 Standard_Attribute (System_Address_Size);
2977
2978 --------------
2979 -- Adjacent --
2980 --------------
2981
2982 when Attribute_Adjacent =>
2983 Check_Floating_Point_Type_2;
2984 Set_Etype (N, P_Base_Type);
2985 Resolve (E1, P_Base_Type);
2986 Resolve (E2, P_Base_Type);
2987
2988 ---------
2989 -- Aft --
2990 ---------
2991
2992 when Attribute_Aft =>
2993 Check_Fixed_Point_Type_0;
2994 Set_Etype (N, Universal_Integer);
2995
2996 ---------------
2997 -- Alignment --
2998 ---------------
2999
3000 when Attribute_Alignment =>
3001
3002 -- Don't we need more checking here, cf Size ???
3003
3004 Check_E0;
3005 Check_Not_Incomplete_Type;
3006 Check_Not_CPP_Type;
3007 Set_Etype (N, Universal_Integer);
3008
3009 ---------------
3010 -- Asm_Input --
3011 ---------------
3012
3013 when Attribute_Asm_Input =>
3014 Check_Asm_Attribute;
3015
3016 -- The back-end may need to take the address of E2
3017
3018 if Is_Entity_Name (E2) then
3019 Set_Address_Taken (Entity (E2));
3020 end if;
3021
3022 Set_Etype (N, RTE (RE_Asm_Input_Operand));
3023
3024 ----------------
3025 -- Asm_Output --
3026 ----------------
3027
3028 when Attribute_Asm_Output =>
3029 Check_Asm_Attribute;
3030
3031 if Etype (E2) = Any_Type then
3032 return;
3033
3034 elsif Aname = Name_Asm_Output then
3035 if not Is_Variable (E2) then
3036 Error_Attr
3037 ("second argument for Asm_Output is not variable", E2);
3038 end if;
3039 end if;
3040
3041 Note_Possible_Modification (E2, Sure => True);
3042
3043 -- The back-end may need to take the address of E2
3044
3045 if Is_Entity_Name (E2) then
3046 Set_Address_Taken (Entity (E2));
3047 end if;
3048
3049 Set_Etype (N, RTE (RE_Asm_Output_Operand));
3050
3051 -----------------------------
3052 -- Atomic_Always_Lock_Free --
3053 -----------------------------
3054
3055 when Attribute_Atomic_Always_Lock_Free =>
3056 Check_E0;
3057 Check_Type;
3058 Set_Etype (N, Standard_Boolean);
3059
3060 ----------
3061 -- Base --
3062 ----------
3063
3064 -- Note: when the base attribute appears in the context of a subtype
3065 -- mark, the analysis is done by Sem_Ch8.Find_Type, rather than by
3066 -- the following circuit.
3067
3068 when Attribute_Base => Base : declare
3069 Typ : Entity_Id;
3070
3071 begin
3072 Check_E0;
3073 Find_Type (P);
3074 Typ := Entity (P);
3075
3076 if Ada_Version >= Ada_95
3077 and then not Is_Scalar_Type (Typ)
3078 and then not Is_Generic_Type (Typ)
3079 then
3080 Error_Attr_P ("prefix of Base attribute must be scalar type");
3081
3082 elsif Sloc (Typ) = Standard_Location
3083 and then Base_Type (Typ) = Typ
3084 and then Warn_On_Redundant_Constructs
3085 then
3086 Error_Msg_NE -- CODEFIX
3087 ("?r?redundant attribute, & is its own base type", N, Typ);
3088 end if;
3089
3090 if Nkind (Parent (N)) /= N_Attribute_Reference then
3091 Error_Msg_Name_1 := Aname;
3092 Check_SPARK_05_Restriction
3093 ("attribute% is only allowed as prefix of another attribute", P);
3094 end if;
3095
3096 Set_Etype (N, Base_Type (Entity (P)));
3097 Set_Entity (N, Base_Type (Entity (P)));
3098 Rewrite (N, New_Occurrence_Of (Entity (N), Loc));
3099 Analyze (N);
3100 end Base;
3101
3102 ---------
3103 -- Bit --
3104 ---------
3105
3106 when Attribute_Bit => Bit :
3107 begin
3108 Check_E0;
3109
3110 if not Is_Object_Reference (P) then
3111 Error_Attr_P ("prefix for % attribute must be object");
3112
3113 -- What about the access object cases ???
3114
3115 else
3116 null;
3117 end if;
3118
3119 Set_Etype (N, Universal_Integer);
3120 end Bit;
3121
3122 ---------------
3123 -- Bit_Order --
3124 ---------------
3125
3126 when Attribute_Bit_Order => Bit_Order :
3127 begin
3128 Check_E0;
3129 Check_Type;
3130
3131 if not Is_Record_Type (P_Type) then
3132 Error_Attr_P ("prefix of % attribute must be record type");
3133 end if;
3134
3135 if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then
3136 Rewrite (N,
3137 New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
3138 else
3139 Rewrite (N,
3140 New_Occurrence_Of (RTE (RE_Low_Order_First), Loc));
3141 end if;
3142
3143 Set_Etype (N, RTE (RE_Bit_Order));
3144 Resolve (N);
3145
3146 -- Reset incorrect indication of staticness
3147
3148 Set_Is_Static_Expression (N, False);
3149 end Bit_Order;
3150
3151 ------------------
3152 -- Bit_Position --
3153 ------------------
3154
3155 -- Note: in generated code, we can have a Bit_Position attribute
3156 -- applied to a (naked) record component (i.e. the prefix is an
3157 -- identifier that references an E_Component or E_Discriminant
3158 -- entity directly, and this is interpreted as expected by Gigi.
3159 -- The following code will not tolerate such usage, but when the
3160 -- expander creates this special case, it marks it as analyzed
3161 -- immediately and sets an appropriate type.
3162
3163 when Attribute_Bit_Position =>
3164 if Comes_From_Source (N) then
3165 Check_Component;
3166 end if;
3167
3168 Set_Etype (N, Universal_Integer);
3169
3170 ------------------
3171 -- Body_Version --
3172 ------------------
3173
3174 when Attribute_Body_Version =>
3175 Check_E0;
3176 Check_Program_Unit;
3177 Set_Etype (N, RTE (RE_Version_String));
3178
3179 --------------
3180 -- Callable --
3181 --------------
3182
3183 when Attribute_Callable =>
3184 Check_E0;
3185 Set_Etype (N, Standard_Boolean);
3186 Check_Task_Prefix;
3187
3188 ------------
3189 -- Caller --
3190 ------------
3191
3192 when Attribute_Caller => Caller : declare
3193 Ent : Entity_Id;
3194 S : Entity_Id;
3195
3196 begin
3197 Check_E0;
3198
3199 if Nkind_In (P, N_Identifier, N_Expanded_Name) then
3200 Ent := Entity (P);
3201
3202 if not Is_Entry (Ent) then
3203 Error_Attr ("invalid entry name", N);
3204 end if;
3205
3206 else
3207 Error_Attr ("invalid entry name", N);
3208 return;
3209 end if;
3210
3211 for J in reverse 0 .. Scope_Stack.Last loop
3212 S := Scope_Stack.Table (J).Entity;
3213
3214 if S = Scope (Ent) then
3215 Error_Attr ("Caller must appear in matching accept or body", N);
3216 elsif S = Ent then
3217 exit;
3218 end if;
3219 end loop;
3220
3221 Set_Etype (N, RTE (RO_AT_Task_Id));
3222 end Caller;
3223
3224 -------------
3225 -- Ceiling --
3226 -------------
3227
3228 when Attribute_Ceiling =>
3229 Check_Floating_Point_Type_1;
3230 Set_Etype (N, P_Base_Type);
3231 Resolve (E1, P_Base_Type);
3232
3233 -----------
3234 -- Class --
3235 -----------
3236
3237 when Attribute_Class =>
3238 Check_Restriction (No_Dispatch, N);
3239 Check_E0;
3240 Find_Type (N);
3241
3242 -- Applying Class to untagged incomplete type is obsolescent in Ada
3243 -- 2005. Note that we can't test Is_Tagged_Type here on P_Type, since
3244 -- this flag gets set by Find_Type in this situation.
3245
3246 if Restriction_Check_Required (No_Obsolescent_Features)
3247 and then Ada_Version >= Ada_2005
3248 and then Ekind (P_Type) = E_Incomplete_Type
3249 then
3250 declare
3251 DN : constant Node_Id := Declaration_Node (P_Type);
3252 begin
3253 if Nkind (DN) = N_Incomplete_Type_Declaration
3254 and then not Tagged_Present (DN)
3255 then
3256 Check_Restriction (No_Obsolescent_Features, P);
3257 end if;
3258 end;
3259 end if;
3260
3261 ------------------
3262 -- Code_Address --
3263 ------------------
3264
3265 when Attribute_Code_Address =>
3266 Check_E0;
3267
3268 if Nkind (P) = N_Attribute_Reference
3269 and then Nam_In (Attribute_Name (P), Name_Elab_Body, Name_Elab_Spec)
3270 then
3271 null;
3272
3273 elsif not Is_Entity_Name (P)
3274 or else (Ekind (Entity (P)) /= E_Function
3275 and then
3276 Ekind (Entity (P)) /= E_Procedure)
3277 then
3278 Error_Attr ("invalid prefix for % attribute", P);
3279 Set_Address_Taken (Entity (P));
3280
3281 -- Issue an error if the prefix denotes an eliminated subprogram
3282
3283 else
3284 Check_For_Eliminated_Subprogram (P, Entity (P));
3285 end if;
3286
3287 Set_Etype (N, RTE (RE_Address));
3288
3289 ----------------------
3290 -- Compiler_Version --
3291 ----------------------
3292
3293 when Attribute_Compiler_Version =>
3294 Check_E0;
3295 Check_Standard_Prefix;
3296 Rewrite (N, Make_String_Literal (Loc, "GNAT " & Gnat_Version_String));
3297 Analyze_And_Resolve (N, Standard_String);
3298 Set_Is_Static_Expression (N, True);
3299
3300 --------------------
3301 -- Component_Size --
3302 --------------------
3303
3304 when Attribute_Component_Size =>
3305 Check_E0;
3306 Set_Etype (N, Universal_Integer);
3307
3308 -- Note: unlike other array attributes, unconstrained arrays are OK
3309
3310 if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then
3311 null;
3312 else
3313 Check_Array_Type;
3314 end if;
3315
3316 -------------
3317 -- Compose --
3318 -------------
3319
3320 when Attribute_Compose =>
3321 Check_Floating_Point_Type_2;
3322 Set_Etype (N, P_Base_Type);
3323 Resolve (E1, P_Base_Type);
3324 Resolve (E2, Any_Integer);
3325
3326 -----------------
3327 -- Constrained --
3328 -----------------
3329
3330 when Attribute_Constrained =>
3331 Check_E0;
3332 Set_Etype (N, Standard_Boolean);
3333
3334 -- Case from RM J.4(2) of constrained applied to private type
3335
3336 if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
3337 Check_Restriction (No_Obsolescent_Features, P);
3338
3339 if Warn_On_Obsolescent_Feature then
3340 Error_Msg_N
3341 ("constrained for private type is an " &
3342 "obsolescent feature (RM J.4)?j?", N);
3343 end if;
3344
3345 -- If we are within an instance, the attribute must be legal
3346 -- because it was valid in the generic unit. Ditto if this is
3347 -- an inlining of a function declared in an instance.
3348
3349 if In_Instance or else In_Inlined_Body then
3350 return;
3351
3352 -- For sure OK if we have a real private type itself, but must
3353 -- be completed, cannot apply Constrained to incomplete type.
3354
3355 elsif Is_Private_Type (Entity (P)) then
3356
3357 -- Note: this is one of the Annex J features that does not
3358 -- generate a warning from -gnatwj, since in fact it seems
3359 -- very useful, and is used in the GNAT runtime.
3360
3361 Check_Not_Incomplete_Type;
3362 return;
3363 end if;
3364
3365 -- Normal (non-obsolescent case) of application to object of
3366 -- a discriminated type.
3367
3368 else
3369 Check_Object_Reference (P);
3370
3371 -- If N does not come from source, then we allow the
3372 -- the attribute prefix to be of a private type whose
3373 -- full type has discriminants. This occurs in cases
3374 -- involving expanded calls to stream attributes.
3375
3376 if not Comes_From_Source (N) then
3377 P_Type := Underlying_Type (P_Type);
3378 end if;
3379
3380 -- Must have discriminants or be an access type designating
3381 -- a type with discriminants. If it is a classwide type it
3382 -- has unknown discriminants.
3383
3384 if Has_Discriminants (P_Type)
3385 or else Has_Unknown_Discriminants (P_Type)
3386 or else
3387 (Is_Access_Type (P_Type)
3388 and then Has_Discriminants (Designated_Type (P_Type)))
3389 then
3390 return;
3391
3392 -- The rule given in 3.7.2 is part of static semantics, but the
3393 -- intent is clearly that it be treated as a legality rule, and
3394 -- rechecked in the visible part of an instance. Nevertheless
3395 -- the intent also seems to be it should legally apply to the
3396 -- actual of a formal with unknown discriminants, regardless of
3397 -- whether the actual has discriminants, in which case the value
3398 -- of the attribute is determined using the J.4 rules. This choice
3399 -- seems the most useful, and is compatible with existing tests.
3400
3401 elsif In_Instance then
3402 return;
3403
3404 -- Also allow an object of a generic type if extensions allowed
3405 -- and allow this for any type at all. (this may be obsolete ???)
3406
3407 elsif (Is_Generic_Type (P_Type)
3408 or else Is_Generic_Actual_Type (P_Type))
3409 and then Extensions_Allowed
3410 then
3411 return;
3412 end if;
3413 end if;
3414
3415 -- Fall through if bad prefix
3416
3417 Error_Attr_P
3418 ("prefix of % attribute must be object of discriminated type");
3419
3420 ---------------
3421 -- Copy_Sign --
3422 ---------------
3423
3424 when Attribute_Copy_Sign =>
3425 Check_Floating_Point_Type_2;
3426 Set_Etype (N, P_Base_Type);
3427 Resolve (E1, P_Base_Type);
3428 Resolve (E2, P_Base_Type);
3429
3430 -----------
3431 -- Count --
3432 -----------
3433
3434 when Attribute_Count => Count :
3435 declare
3436 Ent : Entity_Id;
3437 S : Entity_Id;
3438 Tsk : Entity_Id;
3439
3440 begin
3441 Check_E0;
3442
3443 if Nkind_In (P, N_Identifier, N_Expanded_Name) then
3444 Ent := Entity (P);
3445
3446 if Ekind (Ent) /= E_Entry then
3447 Error_Attr ("invalid entry name", N);
3448 end if;
3449
3450 elsif Nkind (P) = N_Indexed_Component then
3451 if not Is_Entity_Name (Prefix (P))
3452 or else No (Entity (Prefix (P)))
3453 or else Ekind (Entity (Prefix (P))) /= E_Entry_Family
3454 then
3455 if Nkind (Prefix (P)) = N_Selected_Component
3456 and then Present (Entity (Selector_Name (Prefix (P))))
3457 and then Ekind (Entity (Selector_Name (Prefix (P)))) =
3458 E_Entry_Family
3459 then
3460 Error_Attr
3461 ("attribute % must apply to entry of current task", P);
3462
3463 else
3464 Error_Attr ("invalid entry family name", P);
3465 end if;
3466 return;
3467
3468 else
3469 Ent := Entity (Prefix (P));
3470 end if;
3471
3472 elsif Nkind (P) = N_Selected_Component
3473 and then Present (Entity (Selector_Name (P)))
3474 and then Ekind (Entity (Selector_Name (P))) = E_Entry
3475 then
3476 Error_Attr
3477 ("attribute % must apply to entry of current task", P);
3478
3479 else
3480 Error_Attr ("invalid entry name", N);
3481 return;
3482 end if;
3483
3484 for J in reverse 0 .. Scope_Stack.Last loop
3485 S := Scope_Stack.Table (J).Entity;
3486
3487 if S = Scope (Ent) then
3488 if Nkind (P) = N_Expanded_Name then
3489 Tsk := Entity (Prefix (P));
3490
3491 -- The prefix denotes either the task type, or else a
3492 -- single task whose task type is being analyzed.
3493
3494 if (Is_Type (Tsk) and then Tsk = S)
3495 or else (not Is_Type (Tsk)
3496 and then Etype (Tsk) = S
3497 and then not (Comes_From_Source (S)))
3498 then
3499 null;
3500 else
3501 Error_Attr
3502 ("Attribute % must apply to entry of current task", N);
3503 end if;
3504 end if;
3505
3506 exit;
3507
3508 elsif Ekind (Scope (Ent)) in Task_Kind
3509 and then
3510 not Ekind_In (S, E_Loop, E_Block, E_Entry, E_Entry_Family)
3511 then
3512 Error_Attr ("Attribute % cannot appear in inner unit", N);
3513
3514 elsif Ekind (Scope (Ent)) = E_Protected_Type
3515 and then not Has_Completion (Scope (Ent))
3516 then
3517 Error_Attr ("attribute % can only be used inside body", N);
3518 end if;
3519 end loop;
3520
3521 if Is_Overloaded (P) then
3522 declare
3523 Index : Interp_Index;
3524 It : Interp;
3525
3526 begin
3527 Get_First_Interp (P, Index, It);
3528 while Present (It.Nam) loop
3529 if It.Nam = Ent then
3530 null;
3531
3532 -- Ada 2005 (AI-345): Do not consider primitive entry
3533 -- wrappers generated for task or protected types.
3534
3535 elsif Ada_Version >= Ada_2005
3536 and then not Comes_From_Source (It.Nam)
3537 then
3538 null;
3539
3540 else
3541 Error_Attr ("ambiguous entry name", N);
3542 end if;
3543
3544 Get_Next_Interp (Index, It);
3545 end loop;
3546 end;
3547 end if;
3548
3549 Set_Etype (N, Universal_Integer);
3550 end Count;
3551
3552 -----------------------
3553 -- Default_Bit_Order --
3554 -----------------------
3555
3556 when Attribute_Default_Bit_Order => Default_Bit_Order : declare
3557 Target_Default_Bit_Order : System.Bit_Order;
3558
3559 begin
3560 Check_Standard_Prefix;
3561
3562 if Bytes_Big_Endian then
3563 Target_Default_Bit_Order := System.High_Order_First;
3564 else
3565 Target_Default_Bit_Order := System.Low_Order_First;
3566 end if;
3567
3568 Rewrite (N,
3569 Make_Integer_Literal (Loc,
3570 UI_From_Int (System.Bit_Order'Pos (Target_Default_Bit_Order))));
3571
3572 Set_Etype (N, Universal_Integer);
3573 Set_Is_Static_Expression (N);
3574 end Default_Bit_Order;
3575
3576 ----------------------------------
3577 -- Default_Scalar_Storage_Order --
3578 ----------------------------------
3579
3580 when Attribute_Default_Scalar_Storage_Order => Default_SSO : declare
3581 RE_Default_SSO : RE_Id;
3582
3583 begin
3584 Check_Standard_Prefix;
3585
3586 case Opt.Default_SSO is
3587 when ' ' =>
3588 if Bytes_Big_Endian then
3589 RE_Default_SSO := RE_High_Order_First;
3590 else
3591 RE_Default_SSO := RE_Low_Order_First;
3592 end if;
3593
3594 when 'H' =>
3595 RE_Default_SSO := RE_High_Order_First;
3596
3597 when 'L' =>
3598 RE_Default_SSO := RE_Low_Order_First;
3599
3600 when others =>
3601 raise Program_Error;
3602 end case;
3603
3604 Rewrite (N, New_Occurrence_Of (RTE (RE_Default_SSO), Loc));
3605 end Default_SSO;
3606
3607 --------------
3608 -- Definite --
3609 --------------
3610
3611 when Attribute_Definite =>
3612 Legal_Formal_Attribute;
3613
3614 -----------
3615 -- Delta --
3616 -----------
3617
3618 when Attribute_Delta =>
3619 Check_Fixed_Point_Type_0;
3620 Set_Etype (N, Universal_Real);
3621
3622 ------------
3623 -- Denorm --
3624 ------------
3625
3626 when Attribute_Denorm =>
3627 Check_Floating_Point_Type_0;
3628 Set_Etype (N, Standard_Boolean);
3629
3630 -----------
3631 -- Deref --
3632 -----------
3633
3634 when Attribute_Deref =>
3635 Check_Type;
3636 Check_E1;
3637 Resolve (E1, RTE (RE_Address));
3638 Set_Etype (N, P_Type);
3639
3640 ---------------------
3641 -- Descriptor_Size --
3642 ---------------------
3643
3644 when Attribute_Descriptor_Size =>
3645 Check_E0;
3646
3647 if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then
3648 Error_Attr_P ("prefix of attribute % must denote a type");
3649 end if;
3650
3651 Set_Etype (N, Universal_Integer);
3652
3653 ------------
3654 -- Digits --
3655 ------------
3656
3657 when Attribute_Digits =>
3658 Check_E0;
3659 Check_Type;
3660
3661 if not Is_Floating_Point_Type (P_Type)
3662 and then not Is_Decimal_Fixed_Point_Type (P_Type)
3663 then
3664 Error_Attr_P
3665 ("prefix of % attribute must be float or decimal type");
3666 end if;
3667
3668 Set_Etype (N, Universal_Integer);
3669
3670 ---------------
3671 -- Elab_Body --
3672 ---------------
3673
3674 -- Also handles processing for Elab_Spec and Elab_Subp_Body
3675
3676 when Attribute_Elab_Body |
3677 Attribute_Elab_Spec |
3678 Attribute_Elab_Subp_Body =>
3679
3680 Check_E0;
3681 Check_Unit_Name (P);
3682 Set_Etype (N, Standard_Void_Type);
3683
3684 -- We have to manually call the expander in this case to get
3685 -- the necessary expansion (normally attributes that return
3686 -- entities are not expanded).
3687
3688 Expand (N);
3689
3690 ---------------
3691 -- Elab_Spec --
3692 ---------------
3693
3694 -- Shares processing with Elab_Body
3695
3696 ----------------
3697 -- Elaborated --
3698 ----------------
3699
3700 when Attribute_Elaborated =>
3701 Check_E0;
3702 Check_Unit_Name (P);
3703 Set_Etype (N, Standard_Boolean);
3704
3705 ----------
3706 -- Emax --
3707 ----------
3708
3709 when Attribute_Emax =>
3710 Check_Floating_Point_Type_0;
3711 Set_Etype (N, Universal_Integer);
3712
3713 -------------
3714 -- Enabled --
3715 -------------
3716
3717 when Attribute_Enabled =>
3718 Check_Either_E0_Or_E1;
3719
3720 if Present (E1) then
3721 if not Is_Entity_Name (E1) or else No (Entity (E1)) then
3722 Error_Msg_N ("entity name expected for Enabled attribute", E1);
3723 E1 := Empty;
3724 end if;
3725 end if;
3726
3727 if Nkind (P) /= N_Identifier then
3728 Error_Msg_N ("identifier expected (check name)", P);
3729 elsif Get_Check_Id (Chars (P)) = No_Check_Id then
3730 Error_Msg_N ("& is not a recognized check name", P);
3731 end if;
3732
3733 Set_Etype (N, Standard_Boolean);
3734
3735 --------------
3736 -- Enum_Rep --
3737 --------------
3738
3739 when Attribute_Enum_Rep => Enum_Rep : declare
3740 begin
3741 if Present (E1) then
3742 Check_E1;
3743 Check_Discrete_Type;
3744 Resolve (E1, P_Base_Type);
3745
3746 else
3747 if not Is_Entity_Name (P)
3748 or else (not Is_Object (Entity (P))
3749 and then Ekind (Entity (P)) /= E_Enumeration_Literal)
3750 then
3751 Error_Attr_P
3752 ("prefix of % attribute must be " &
3753 "discrete type/object or enum literal");
3754 end if;
3755 end if;
3756
3757 Set_Etype (N, Universal_Integer);
3758 end Enum_Rep;
3759
3760 --------------
3761 -- Enum_Val --
3762 --------------
3763
3764 when Attribute_Enum_Val => Enum_Val : begin
3765 Check_E1;
3766 Check_Type;
3767
3768 if not Is_Enumeration_Type (P_Type) then
3769 Error_Attr_P ("prefix of % attribute must be enumeration type");
3770 end if;
3771
3772 -- If the enumeration type has a standard representation, the effect
3773 -- is the same as 'Val, so rewrite the attribute as a 'Val.
3774
3775 if not Has_Non_Standard_Rep (P_Base_Type) then
3776 Rewrite (N,
3777 Make_Attribute_Reference (Loc,
3778 Prefix => Relocate_Node (Prefix (N)),
3779 Attribute_Name => Name_Val,
3780 Expressions => New_List (Relocate_Node (E1))));
3781 Analyze_And_Resolve (N, P_Base_Type);
3782
3783 -- Non-standard representation case (enumeration with holes)
3784
3785 else
3786 Check_Enum_Image;
3787 Resolve (E1, Any_Integer);
3788 Set_Etype (N, P_Base_Type);
3789 end if;
3790 end Enum_Val;
3791
3792 -------------
3793 -- Epsilon --
3794 -------------
3795
3796 when Attribute_Epsilon =>
3797 Check_Floating_Point_Type_0;
3798 Set_Etype (N, Universal_Real);
3799
3800 --------------
3801 -- Exponent --
3802 --------------
3803
3804 when Attribute_Exponent =>
3805 Check_Floating_Point_Type_1;
3806 Set_Etype (N, Universal_Integer);
3807 Resolve (E1, P_Base_Type);
3808
3809 ------------------
3810 -- External_Tag --
3811 ------------------
3812
3813 when Attribute_External_Tag =>
3814 Check_E0;
3815 Check_Type;
3816
3817 Set_Etype (N, Standard_String);
3818
3819 if not Is_Tagged_Type (P_Type) then
3820 Error_Attr_P ("prefix of % attribute must be tagged");
3821 end if;
3822
3823 ---------------
3824 -- Fast_Math --
3825 ---------------
3826
3827 when Attribute_Fast_Math =>
3828 Check_Standard_Prefix;
3829 Rewrite (N, New_Occurrence_Of (Boolean_Literals (Fast_Math), Loc));
3830
3831 -----------
3832 -- First --
3833 -----------
3834
3835 when Attribute_First =>
3836 Check_Array_Or_Scalar_Type;
3837 Bad_Attribute_For_Predicate;
3838
3839 ---------------
3840 -- First_Bit --
3841 ---------------
3842
3843 when Attribute_First_Bit =>
3844 Check_Component;
3845 Set_Etype (N, Universal_Integer);
3846
3847 -----------------
3848 -- First_Valid --
3849 -----------------
3850
3851 when Attribute_First_Valid =>
3852 Check_First_Last_Valid;
3853 Set_Etype (N, P_Type);
3854
3855 -----------------
3856 -- Fixed_Value --
3857 -----------------
3858
3859 when Attribute_Fixed_Value =>
3860 Check_E1;
3861 Check_Fixed_Point_Type;
3862 Resolve (E1, Any_Integer);
3863 Set_Etype (N, P_Base_Type);
3864
3865 -----------
3866 -- Floor --
3867 -----------
3868
3869 when Attribute_Floor =>
3870 Check_Floating_Point_Type_1;
3871 Set_Etype (N, P_Base_Type);
3872 Resolve (E1, P_Base_Type);
3873
3874 ----------
3875 -- Fore --
3876 ----------
3877
3878 when Attribute_Fore =>
3879 Check_Fixed_Point_Type_0;
3880 Set_Etype (N, Universal_Integer);
3881
3882 --------------
3883 -- Fraction --
3884 --------------
3885
3886 when Attribute_Fraction =>
3887 Check_Floating_Point_Type_1;
3888 Set_Etype (N, P_Base_Type);
3889 Resolve (E1, P_Base_Type);
3890
3891 --------------
3892 -- From_Any --
3893 --------------
3894
3895 when Attribute_From_Any =>
3896 Check_E1;
3897 Check_PolyORB_Attribute;
3898 Set_Etype (N, P_Base_Type);
3899
3900 -----------------------
3901 -- Has_Access_Values --
3902 -----------------------
3903
3904 when Attribute_Has_Access_Values =>
3905 Check_Type;
3906 Check_E0;
3907 Set_Etype (N, Standard_Boolean);
3908
3909 ----------------------
3910 -- Has_Same_Storage --
3911 ----------------------
3912
3913 when Attribute_Has_Same_Storage =>
3914 Check_E1;
3915
3916 -- The arguments must be objects of any type
3917
3918 Analyze_And_Resolve (P);
3919 Analyze_And_Resolve (E1);
3920 Check_Object_Reference (P);
3921 Check_Object_Reference (E1);
3922 Set_Etype (N, Standard_Boolean);
3923
3924 -----------------------
3925 -- Has_Tagged_Values --
3926 -----------------------
3927
3928 when Attribute_Has_Tagged_Values =>
3929 Check_Type;
3930 Check_E0;
3931 Set_Etype (N, Standard_Boolean);
3932
3933 -----------------------
3934 -- Has_Discriminants --
3935 -----------------------
3936
3937 when Attribute_Has_Discriminants =>
3938 Legal_Formal_Attribute;
3939
3940 --------------
3941 -- Identity --
3942 --------------
3943
3944 when Attribute_Identity =>
3945 Check_E0;
3946 Analyze (P);
3947
3948 if Etype (P) = Standard_Exception_Type then
3949 Set_Etype (N, RTE (RE_Exception_Id));
3950
3951 -- Ada 2005 (AI-345): Attribute 'Identity may be applied to task
3952 -- interface class-wide types.
3953
3954 elsif Is_Task_Type (Etype (P))
3955 or else (Is_Access_Type (Etype (P))
3956 and then Is_Task_Type (Designated_Type (Etype (P))))
3957 or else (Ada_Version >= Ada_2005
3958 and then Ekind (Etype (P)) = E_Class_Wide_Type
3959 and then Is_Interface (Etype (P))
3960 and then Is_Task_Interface (Etype (P)))
3961 then
3962 Resolve (P);
3963 Set_Etype (N, RTE (RO_AT_Task_Id));
3964
3965 else
3966 if Ada_Version >= Ada_2005 then
3967 Error_Attr_P
3968 ("prefix of % attribute must be an exception, a " &
3969 "task or a task interface class-wide object");
3970 else
3971 Error_Attr_P
3972 ("prefix of % attribute must be a task or an exception");
3973 end if;
3974 end if;
3975
3976 -----------
3977 -- Image --
3978 -----------
3979
3980 when Attribute_Image => Image : begin
3981 Check_SPARK_05_Restriction_On_Attribute;
3982
3983 -- AI12-00124-1 : The ARG has adopted the GNAT semantics of 'Img
3984 -- for scalar types, so that the prefix can be an object and not
3985 -- a type, and there is no need for an argument. Given this vote
3986 -- of confidence from the ARG, simplest is to transform this new
3987 -- usage of 'Image into a reference to 'Img.
3988
3989 if Ada_Version > Ada_2005
3990 and then Is_Object_Reference (P)
3991 and then Is_Scalar_Type (P_Type)
3992 then
3993 Rewrite (N,
3994 Make_Attribute_Reference (Loc,
3995 Prefix => Relocate_Node (P),
3996 Attribute_Name => Name_Img));
3997 Analyze (N);
3998 return;
3999
4000 else
4001 Check_Scalar_Type;
4002 end if;
4003
4004 Set_Etype (N, Standard_String);
4005
4006 if Is_Real_Type (P_Type) then
4007 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
4008 Error_Msg_Name_1 := Aname;
4009 Error_Msg_N
4010 ("(Ada 83) % attribute not allowed for real types", N);
4011 end if;
4012 end if;
4013
4014 if Is_Enumeration_Type (P_Type) then
4015 Check_Restriction (No_Enumeration_Maps, N);
4016 end if;
4017
4018 Check_E1;
4019 Resolve (E1, P_Base_Type);
4020 Check_Enum_Image;
4021 Validate_Non_Static_Attribute_Function_Call;
4022
4023 -- Check restriction No_Fixed_IO. Note the check of Comes_From_Source
4024 -- to avoid giving a duplicate message for Img expanded into Image.
4025
4026 if Restriction_Check_Required (No_Fixed_IO)
4027 and then Comes_From_Source (N)
4028 and then Is_Fixed_Point_Type (P_Type)
4029 then
4030 Check_Restriction (No_Fixed_IO, P);
4031 end if;
4032 end Image;
4033
4034 ---------
4035 -- Img --
4036 ---------
4037
4038 when Attribute_Img => Img :
4039 begin
4040 Check_E0;
4041 Set_Etype (N, Standard_String);
4042
4043 if not Is_Scalar_Type (P_Type)
4044 or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
4045 then
4046 Error_Attr_P
4047 ("prefix of % attribute must be scalar object name");
4048 end if;
4049
4050 Check_Enum_Image;
4051
4052 -- Check restriction No_Fixed_IO
4053
4054 if Restriction_Check_Required (No_Fixed_IO)
4055 and then Is_Fixed_Point_Type (P_Type)
4056 then
4057 Check_Restriction (No_Fixed_IO, P);
4058 end if;
4059 end Img;
4060
4061 -----------
4062 -- Input --
4063 -----------
4064
4065 when Attribute_Input =>
4066 Check_E1;
4067 Check_Stream_Attribute (TSS_Stream_Input);
4068 Set_Etype (N, P_Base_Type);
4069
4070 -------------------
4071 -- Integer_Value --
4072 -------------------
4073
4074 when Attribute_Integer_Value =>
4075 Check_E1;
4076 Check_Integer_Type;
4077 Resolve (E1, Any_Fixed);
4078
4079 -- Signal an error if argument type is not a specific fixed-point
4080 -- subtype. An error has been signalled already if the argument
4081 -- was not of a fixed-point type.
4082
4083 if Etype (E1) = Any_Fixed and then not Error_Posted (E1) then
4084 Error_Attr ("argument of % must be of a fixed-point type", E1);
4085 end if;
4086
4087 Set_Etype (N, P_Base_Type);
4088
4089 -------------------
4090 -- Invalid_Value --
4091 -------------------
4092
4093 when Attribute_Invalid_Value =>
4094 Check_E0;
4095 Check_Scalar_Type;
4096 Set_Etype (N, P_Base_Type);
4097 Invalid_Value_Used := True;
4098
4099 -----------
4100 -- Large --
4101 -----------
4102
4103 when Attribute_Large =>
4104 Check_E0;
4105 Check_Real_Type;
4106 Set_Etype (N, Universal_Real);
4107
4108 ----------
4109 -- Last --
4110 ----------
4111
4112 when Attribute_Last =>
4113 Check_Array_Or_Scalar_Type;
4114 Bad_Attribute_For_Predicate;
4115
4116 --------------
4117 -- Last_Bit --
4118 --------------
4119
4120 when Attribute_Last_Bit =>
4121 Check_Component;
4122 Set_Etype (N, Universal_Integer);
4123
4124 ----------------
4125 -- Last_Valid --
4126 ----------------
4127
4128 when Attribute_Last_Valid =>
4129 Check_First_Last_Valid;
4130 Set_Etype (N, P_Type);
4131
4132 ------------------
4133 -- Leading_Part --
4134 ------------------
4135
4136 when Attribute_Leading_Part =>
4137 Check_Floating_Point_Type_2;
4138 Set_Etype (N, P_Base_Type);
4139 Resolve (E1, P_Base_Type);
4140 Resolve (E2, Any_Integer);
4141
4142 ------------
4143 -- Length --
4144 ------------
4145
4146 when Attribute_Length =>
4147 Check_Array_Type;
4148 Set_Etype (N, Universal_Integer);
4149
4150 -------------------
4151 -- Library_Level --
4152 -------------------
4153
4154 when Attribute_Library_Level =>
4155 Check_E0;
4156
4157 if not Is_Entity_Name (P) then
4158 Error_Attr_P ("prefix of % attribute must be an entity name");
4159 end if;
4160
4161 if not Inside_A_Generic then
4162 Set_Boolean_Result (N,
4163 Is_Library_Level_Entity (Entity (P)));
4164 end if;
4165
4166 Set_Etype (N, Standard_Boolean);
4167
4168 ---------------
4169 -- Lock_Free --
4170 ---------------
4171
4172 when Attribute_Lock_Free =>
4173 Check_E0;
4174 Set_Etype (N, Standard_Boolean);
4175
4176 if not Is_Protected_Type (P_Type) then
4177 Error_Attr_P
4178 ("prefix of % attribute must be a protected object");
4179 end if;
4180
4181 ----------------
4182 -- Loop_Entry --
4183 ----------------
4184
4185 when Attribute_Loop_Entry => Loop_Entry : declare
4186 procedure Check_References_In_Prefix (Loop_Id : Entity_Id);
4187 -- Inspect the prefix for any uses of entities declared within the
4188 -- related loop. Loop_Id denotes the loop identifier.
4189
4190 --------------------------------
4191 -- Check_References_In_Prefix --
4192 --------------------------------
4193
4194 procedure Check_References_In_Prefix (Loop_Id : Entity_Id) is
4195 Loop_Decl : constant Node_Id := Label_Construct (Parent (Loop_Id));
4196
4197 function Check_Reference (Nod : Node_Id) return Traverse_Result;
4198 -- Determine whether a reference mentions an entity declared
4199 -- within the related loop.
4200
4201 function Declared_Within (Nod : Node_Id) return Boolean;
4202 -- Determine whether Nod appears in the subtree of Loop_Decl
4203
4204 ---------------------
4205 -- Check_Reference --
4206 ---------------------
4207
4208 function Check_Reference (Nod : Node_Id) return Traverse_Result is
4209 begin
4210 if Nkind (Nod) = N_Identifier
4211 and then Present (Entity (Nod))
4212 and then Declared_Within (Declaration_Node (Entity (Nod)))
4213 then
4214 Error_Attr
4215 ("prefix of attribute % cannot reference local entities",
4216 Nod);
4217 return Abandon;
4218 else
4219 return OK;
4220 end if;
4221 end Check_Reference;
4222
4223 procedure Check_References is new Traverse_Proc (Check_Reference);
4224
4225 ---------------------
4226 -- Declared_Within --
4227 ---------------------
4228
4229 function Declared_Within (Nod : Node_Id) return Boolean is
4230 Stmt : Node_Id;
4231
4232 begin
4233 Stmt := Nod;
4234 while Present (Stmt) loop
4235 if Stmt = Loop_Decl then
4236 return True;
4237
4238 -- Prevent the search from going too far
4239
4240 elsif Is_Body_Or_Package_Declaration (Stmt) then
4241 exit;
4242 end if;
4243
4244 Stmt := Parent (Stmt);
4245 end loop;
4246
4247 return False;
4248 end Declared_Within;
4249
4250 -- Start of processing for Check_Prefix_For_Local_References
4251
4252 begin
4253 Check_References (P);
4254 end Check_References_In_Prefix;
4255
4256 -- Local variables
4257
4258 Context : constant Node_Id := Parent (N);
4259 Attr : Node_Id;
4260 Enclosing_Loop : Node_Id;
4261 Loop_Id : Entity_Id := Empty;
4262 Scop : Entity_Id;
4263 Stmt : Node_Id;
4264 Enclosing_Pragma : Node_Id := Empty;
4265
4266 -- Start of processing for Loop_Entry
4267
4268 begin
4269 Attr := N;
4270
4271 -- Set the type of the attribute now to ensure the successfull
4272 -- continuation of analysis even if the attribute is misplaced.
4273
4274 Set_Etype (Attr, P_Type);
4275
4276 -- Attribute 'Loop_Entry may appear in several flavors:
4277
4278 -- * Prefix'Loop_Entry - in this form, the attribute applies to the
4279 -- nearest enclosing loop.
4280
4281 -- * Prefix'Loop_Entry (Expr) - depending on what Expr denotes, the
4282 -- attribute may be related to a loop denoted by label Expr or
4283 -- the prefix may denote an array object and Expr may act as an
4284 -- indexed component.
4285
4286 -- * Prefix'Loop_Entry (Expr1, ..., ExprN) - the attribute applies
4287 -- to the nearest enclosing loop, all expressions are part of
4288 -- an indexed component.
4289
4290 -- * Prefix'Loop_Entry (Expr) (...) (...) - depending on what Expr
4291 -- denotes, the attribute may be related to a loop denoted by
4292 -- label Expr or the prefix may denote a multidimensional array
4293 -- array object and Expr along with the rest of the expressions
4294 -- may act as indexed components.
4295
4296 -- Regardless of variations, the attribute reference does not have an
4297 -- expression list. Instead, all available expressions are stored as
4298 -- indexed components.
4299
4300 -- When the attribute is part of an indexed component, find the first
4301 -- expression as it will determine the semantics of 'Loop_Entry.
4302
4303 if Nkind (Context) = N_Indexed_Component then
4304 E1 := First (Expressions (Context));
4305 E2 := Next (E1);
4306
4307 -- The attribute reference appears in the following form:
4308
4309 -- Prefix'Loop_Entry (Exp1, Expr2, ..., ExprN) [(...)]
4310
4311 -- In this case, the loop name is omitted and no rewriting is
4312 -- required.
4313
4314 if Present (E2) then
4315 null;
4316
4317 -- The form of the attribute is:
4318
4319 -- Prefix'Loop_Entry (Expr) [(...)]
4320
4321 -- If Expr denotes a loop entry, the whole attribute and indexed
4322 -- component will have to be rewritten to reflect this relation.
4323
4324 else
4325 pragma Assert (Present (E1));
4326
4327 -- Do not expand the expression as it may have side effects.
4328 -- Simply preanalyze to determine whether it is a loop name or
4329 -- something else.
4330
4331 Preanalyze_And_Resolve (E1);
4332
4333 if Is_Entity_Name (E1)
4334 and then Present (Entity (E1))
4335 and then Ekind (Entity (E1)) = E_Loop
4336 then
4337 Loop_Id := Entity (E1);
4338
4339 -- Transform the attribute and enclosing indexed component
4340
4341 Set_Expressions (N, Expressions (Context));
4342 Rewrite (Context, N);
4343 Set_Etype (Context, P_Type);
4344
4345 Attr := Context;
4346 end if;
4347 end if;
4348 end if;
4349
4350 -- The prefix must denote an object
4351
4352 if not Is_Object_Reference (P) then
4353 Error_Attr_P ("prefix of attribute % must denote an object");
4354 end if;
4355
4356 -- The prefix cannot be of a limited type because the expansion of
4357 -- Loop_Entry must create a constant initialized by the evaluated
4358 -- prefix.
4359
4360 if Is_Limited_View (Etype (P)) then
4361 Error_Attr_P ("prefix of attribute % cannot be limited");
4362 end if;
4363
4364 -- Climb the parent chain to verify the location of the attribute and
4365 -- find the enclosing loop.
4366
4367 Stmt := Attr;
4368 while Present (Stmt) loop
4369
4370 -- Locate the corresponding enclosing pragma. Note that in the
4371 -- case of Assert[And_Cut] and Assume, we have already checked
4372 -- that the pragma appears in an appropriate loop location.
4373
4374 if Nkind (Original_Node (Stmt)) = N_Pragma
4375 and then Nam_In (Pragma_Name (Original_Node (Stmt)),
4376 Name_Loop_Invariant,
4377 Name_Loop_Variant,
4378 Name_Assert,
4379 Name_Assert_And_Cut,
4380 Name_Assume)
4381 then
4382 Enclosing_Pragma := Original_Node (Stmt);
4383
4384 -- Locate the enclosing loop (if any). Note that Ada 2012 array
4385 -- iteration may be expanded into several nested loops, we are
4386 -- interested in the outermost one which has the loop identifier,
4387 -- and comes from source.
4388
4389 elsif Nkind (Stmt) = N_Loop_Statement
4390 and then Present (Identifier (Stmt))
4391 and then Comes_From_Source (Original_Node (Stmt))
4392 and then Nkind (Original_Node (Stmt)) = N_Loop_Statement
4393 then
4394 Enclosing_Loop := Stmt;
4395
4396 -- The original attribute reference may lack a loop name. Use
4397 -- the name of the enclosing loop because it is the related
4398 -- loop.
4399
4400 if No (Loop_Id) then
4401 Loop_Id := Entity (Identifier (Enclosing_Loop));
4402 end if;
4403
4404 exit;
4405
4406 -- Prevent the search from going too far
4407
4408 elsif Is_Body_Or_Package_Declaration (Stmt) then
4409 exit;
4410 end if;
4411
4412 Stmt := Parent (Stmt);
4413 end loop;
4414
4415 -- Loop_Entry must appear within a Loop_Assertion pragma (Assert,
4416 -- Assert_And_Cut, Assume count as loop assertion pragmas for this
4417 -- purpose if they appear in an appropriate location in a loop,
4418 -- which was already checked by the top level pragma circuit).
4419
4420 if No (Enclosing_Pragma) then
4421 Error_Attr ("attribute% must appear within appropriate pragma", N);
4422 end if;
4423
4424 -- A Loop_Entry that applies to a given loop statement must not
4425 -- appear within a body of accept statement, if this construct is
4426 -- itself enclosed by the given loop statement.
4427
4428 for Index in reverse 0 .. Scope_Stack.Last loop
4429 Scop := Scope_Stack.Table (Index).Entity;
4430
4431 if Ekind (Scop) = E_Loop and then Scop = Loop_Id then
4432 exit;
4433 elsif Ekind_In (Scop, E_Block, E_Loop, E_Return_Statement) then
4434 null;
4435 else
4436 Error_Attr
4437 ("attribute % cannot appear in body or accept statement", N);
4438 exit;
4439 end if;
4440 end loop;
4441
4442 -- The prefix cannot mention entities declared within the related
4443 -- loop because they will not be visible once the prefix is moved
4444 -- outside the loop.
4445
4446 Check_References_In_Prefix (Loop_Id);
4447
4448 -- The prefix must denote a static entity if the pragma does not
4449 -- apply to the innermost enclosing loop statement, or if it appears
4450 -- within a potentially unevaluated epxression.
4451
4452 if Is_Entity_Name (P)
4453 or else Nkind (Parent (P)) = N_Object_Renaming_Declaration
4454 then
4455 null;
4456
4457 elsif Present (Enclosing_Loop)
4458 and then Entity (Identifier (Enclosing_Loop)) /= Loop_Id
4459 then
4460 Error_Attr_P
4461 ("prefix of attribute % that applies to outer loop must denote "
4462 & "an entity");
4463
4464 elsif Is_Potentially_Unevaluated (P) then
4465 Uneval_Old_Msg;
4466 end if;
4467
4468 -- Replace the Loop_Entry attribute reference by its prefix if the
4469 -- related pragma is ignored. This transformation is OK with respect
4470 -- to typing because Loop_Entry's type is that of its prefix. This
4471 -- early transformation also avoids the generation of a useless loop
4472 -- entry constant.
4473
4474 if Is_Ignored (Enclosing_Pragma) then
4475 Rewrite (N, Relocate_Node (P));
4476 end if;
4477
4478 Preanalyze_And_Resolve (P);
4479 end Loop_Entry;
4480
4481 -------------
4482 -- Machine --
4483 -------------
4484
4485 when Attribute_Machine =>
4486 Check_Floating_Point_Type_1;
4487 Set_Etype (N, P_Base_Type);
4488 Resolve (E1, P_Base_Type);
4489
4490 ------------------
4491 -- Machine_Emax --
4492 ------------------
4493
4494 when Attribute_Machine_Emax =>
4495 Check_Floating_Point_Type_0;
4496 Set_Etype (N, Universal_Integer);
4497
4498 ------------------
4499 -- Machine_Emin --
4500 ------------------
4501
4502 when Attribute_Machine_Emin =>
4503 Check_Floating_Point_Type_0;
4504 Set_Etype (N, Universal_Integer);
4505
4506 ----------------------
4507 -- Machine_Mantissa --
4508 ----------------------
4509
4510 when Attribute_Machine_Mantissa =>
4511 Check_Floating_Point_Type_0;
4512 Set_Etype (N, Universal_Integer);
4513
4514 -----------------------
4515 -- Machine_Overflows --
4516 -----------------------
4517
4518 when Attribute_Machine_Overflows =>
4519 Check_Real_Type;
4520 Check_E0;
4521 Set_Etype (N, Standard_Boolean);
4522
4523 -------------------
4524 -- Machine_Radix --
4525 -------------------
4526
4527 when Attribute_Machine_Radix =>
4528 Check_Real_Type;
4529 Check_E0;
4530 Set_Etype (N, Universal_Integer);
4531
4532 ----------------------
4533 -- Machine_Rounding --
4534 ----------------------
4535
4536 when Attribute_Machine_Rounding =>
4537 Check_Floating_Point_Type_1;
4538 Set_Etype (N, P_Base_Type);
4539 Resolve (E1, P_Base_Type);
4540
4541 --------------------
4542 -- Machine_Rounds --
4543 --------------------
4544
4545 when Attribute_Machine_Rounds =>
4546 Check_Real_Type;
4547 Check_E0;
4548 Set_Etype (N, Standard_Boolean);
4549
4550 ------------------
4551 -- Machine_Size --
4552 ------------------
4553
4554 when Attribute_Machine_Size =>
4555 Check_E0;
4556 Check_Type;
4557 Check_Not_Incomplete_Type;
4558 Set_Etype (N, Universal_Integer);
4559
4560 --------------
4561 -- Mantissa --
4562 --------------
4563
4564 when Attribute_Mantissa =>
4565 Check_E0;
4566 Check_Real_Type;
4567 Set_Etype (N, Universal_Integer);
4568
4569 ---------
4570 -- Max --
4571 ---------
4572
4573 when Attribute_Max =>
4574 Min_Max;
4575
4576 ----------------------------------
4577 -- Max_Alignment_For_Allocation --
4578 ----------------------------------
4579
4580 when Attribute_Max_Size_In_Storage_Elements =>
4581 Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements;
4582
4583 ----------------------------------
4584 -- Max_Size_In_Storage_Elements --
4585 ----------------------------------
4586
4587 when Attribute_Max_Alignment_For_Allocation =>
4588 Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements;
4589
4590 -----------------------
4591 -- Maximum_Alignment --
4592 -----------------------
4593
4594 when Attribute_Maximum_Alignment =>
4595 Standard_Attribute (Ttypes.Maximum_Alignment);
4596
4597 --------------------
4598 -- Mechanism_Code --
4599 --------------------
4600
4601 when Attribute_Mechanism_Code =>
4602 if not Is_Entity_Name (P)
4603 or else not Is_Subprogram (Entity (P))
4604 then
4605 Error_Attr_P ("prefix of % attribute must be subprogram");
4606 end if;
4607
4608 Check_Either_E0_Or_E1;
4609
4610 if Present (E1) then
4611 Resolve (E1, Any_Integer);
4612 Set_Etype (E1, Standard_Integer);
4613
4614 if not Is_OK_Static_Expression (E1) then
4615 Flag_Non_Static_Expr
4616 ("expression for parameter number must be static!", E1);
4617 Error_Attr;
4618
4619 elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
4620 or else UI_To_Int (Intval (E1)) < 0
4621 then
4622 Error_Attr ("invalid parameter number for % attribute", E1);
4623 end if;
4624 end if;
4625
4626 Set_Etype (N, Universal_Integer);
4627
4628 ---------
4629 -- Min --
4630 ---------
4631
4632 when Attribute_Min =>
4633 Min_Max;
4634
4635 ---------
4636 -- Mod --
4637 ---------
4638
4639 when Attribute_Mod =>
4640
4641 -- Note: this attribute is only allowed in Ada 2005 mode, but
4642 -- we do not need to test that here, since Mod is only recognized
4643 -- as an attribute name in Ada 2005 mode during the parse.
4644
4645 Check_E1;
4646 Check_Modular_Integer_Type;
4647 Resolve (E1, Any_Integer);
4648 Set_Etype (N, P_Base_Type);
4649
4650 -----------
4651 -- Model --
4652 -----------
4653
4654 when Attribute_Model =>
4655 Check_Floating_Point_Type_1;
4656 Set_Etype (N, P_Base_Type);
4657 Resolve (E1, P_Base_Type);
4658
4659 ----------------
4660 -- Model_Emin --
4661 ----------------
4662
4663 when Attribute_Model_Emin =>
4664 Check_Floating_Point_Type_0;
4665 Set_Etype (N, Universal_Integer);
4666
4667 -------------------
4668 -- Model_Epsilon --
4669 -------------------
4670
4671 when Attribute_Model_Epsilon =>
4672 Check_Floating_Point_Type_0;
4673 Set_Etype (N, Universal_Real);
4674
4675 --------------------
4676 -- Model_Mantissa --
4677 --------------------
4678
4679 when Attribute_Model_Mantissa =>
4680 Check_Floating_Point_Type_0;
4681 Set_Etype (N, Universal_Integer);
4682
4683 -----------------
4684 -- Model_Small --
4685 -----------------
4686
4687 when Attribute_Model_Small =>
4688 Check_Floating_Point_Type_0;
4689 Set_Etype (N, Universal_Real);
4690
4691 -------------
4692 -- Modulus --
4693 -------------
4694
4695 when Attribute_Modulus =>
4696 Check_E0;
4697 Check_Modular_Integer_Type;
4698 Set_Etype (N, Universal_Integer);
4699
4700 --------------------
4701 -- Null_Parameter --
4702 --------------------
4703
4704 when Attribute_Null_Parameter => Null_Parameter : declare
4705 Parnt : constant Node_Id := Parent (N);
4706 GParnt : constant Node_Id := Parent (Parnt);
4707
4708 procedure Bad_Null_Parameter (Msg : String);
4709 -- Used if bad Null parameter attribute node is found. Issues
4710 -- given error message, and also sets the type to Any_Type to
4711 -- avoid blowups later on from dealing with a junk node.
4712
4713 procedure Must_Be_Imported (Proc_Ent : Entity_Id);
4714 -- Called to check that Proc_Ent is imported subprogram
4715
4716 ------------------------
4717 -- Bad_Null_Parameter --
4718 ------------------------
4719
4720 procedure Bad_Null_Parameter (Msg : String) is
4721 begin
4722 Error_Msg_N (Msg, N);
4723 Set_Etype (N, Any_Type);
4724 end Bad_Null_Parameter;
4725
4726 ----------------------
4727 -- Must_Be_Imported --
4728 ----------------------
4729
4730 procedure Must_Be_Imported (Proc_Ent : Entity_Id) is
4731 Pent : constant Entity_Id := Ultimate_Alias (Proc_Ent);
4732
4733 begin
4734 -- Ignore check if procedure not frozen yet (we will get
4735 -- another chance when the default parameter is reanalyzed)
4736
4737 if not Is_Frozen (Pent) then
4738 return;
4739
4740 elsif not Is_Imported (Pent) then
4741 Bad_Null_Parameter
4742 ("Null_Parameter can only be used with imported subprogram");
4743
4744 else
4745 return;
4746 end if;
4747 end Must_Be_Imported;
4748
4749 -- Start of processing for Null_Parameter
4750
4751 begin
4752 Check_Type;
4753 Check_E0;
4754 Set_Etype (N, P_Type);
4755
4756 -- Case of attribute used as default expression
4757
4758 if Nkind (Parnt) = N_Parameter_Specification then
4759 Must_Be_Imported (Defining_Entity (GParnt));
4760
4761 -- Case of attribute used as actual for subprogram (positional)
4762
4763 elsif Nkind (Parnt) in N_Subprogram_Call
4764 and then Is_Entity_Name (Name (Parnt))
4765 then
4766 Must_Be_Imported (Entity (Name (Parnt)));
4767
4768 -- Case of attribute used as actual for subprogram (named)
4769
4770 elsif Nkind (Parnt) = N_Parameter_Association
4771 and then Nkind (GParnt) in N_Subprogram_Call
4772 and then Is_Entity_Name (Name (GParnt))
4773 then
4774 Must_Be_Imported (Entity (Name (GParnt)));
4775
4776 -- Not an allowed case
4777
4778 else
4779 Bad_Null_Parameter
4780 ("Null_Parameter must be actual or default parameter");
4781 end if;
4782 end Null_Parameter;
4783
4784 -----------------
4785 -- Object_Size --
4786 -----------------
4787
4788 when Attribute_Object_Size =>
4789 Check_E0;
4790 Check_Type;
4791 Check_Not_Incomplete_Type;
4792 Set_Etype (N, Universal_Integer);
4793
4794 ---------
4795 -- Old --
4796 ---------
4797
4798 when Attribute_Old => Old : declare
4799 procedure Check_References_In_Prefix (Subp_Id : Entity_Id);
4800 -- Inspect the contents of the prefix and detect illegal uses of a
4801 -- nested 'Old, attribute 'Result or a use of an entity declared in
4802 -- the related postcondition expression. Subp_Id is the subprogram to
4803 -- which the related postcondition applies.
4804
4805 --------------------------------
4806 -- Check_References_In_Prefix --
4807 --------------------------------
4808
4809 procedure Check_References_In_Prefix (Subp_Id : Entity_Id) is
4810 function Check_Reference (Nod : Node_Id) return Traverse_Result;
4811 -- Detect attribute 'Old, attribute 'Result of a use of an entity
4812 -- and perform the appropriate semantic check.
4813
4814 ---------------------
4815 -- Check_Reference --
4816 ---------------------
4817
4818 function Check_Reference (Nod : Node_Id) return Traverse_Result is
4819 begin
4820 -- Attributes 'Old and 'Result cannot appear in the prefix of
4821 -- another attribute 'Old.
4822
4823 if Nkind (Nod) = N_Attribute_Reference
4824 and then Nam_In (Attribute_Name (Nod), Name_Old,
4825 Name_Result)
4826 then
4827 Error_Msg_Name_1 := Attribute_Name (Nod);
4828 Error_Msg_Name_2 := Name_Old;
4829 Error_Msg_N
4830 ("attribute % cannot appear in the prefix of attribute %",
4831 Nod);
4832 return Abandon;
4833
4834 -- Entities mentioned within the prefix of attribute 'Old must
4835 -- be global to the related postcondition. If this is not the
4836 -- case, then the scope of the local entity is nested within
4837 -- that of the subprogram.
4838
4839 elsif Is_Entity_Name (Nod)
4840 and then Present (Entity (Nod))
4841 and then Scope_Within (Scope (Entity (Nod)), Subp_Id)
4842 then
4843 Error_Attr
4844 ("prefix of attribute % cannot reference local entities",
4845 Nod);
4846 return Abandon;
4847
4848 -- Otherwise keep inspecting the prefix
4849
4850 else
4851 return OK;
4852 end if;
4853 end Check_Reference;
4854
4855 procedure Check_References is new Traverse_Proc (Check_Reference);
4856
4857 -- Start of processing for Check_References_In_Prefix
4858
4859 begin
4860 Check_References (P);
4861 end Check_References_In_Prefix;
4862
4863 -- Local variables
4864
4865 Legal : Boolean;
4866 Pref_Id : Entity_Id;
4867 Pref_Typ : Entity_Id;
4868 Spec_Id : Entity_Id;
4869
4870 -- Start of processing for Old
4871
4872 begin
4873 -- The attribute reference is a primary. If any expressions follow,
4874 -- then the attribute reference is an indexable object. Transform the
4875 -- attribute into an indexed component and analyze it.
4876
4877 if Present (E1) then
4878 Rewrite (N,
4879 Make_Indexed_Component (Loc,
4880 Prefix =>
4881 Make_Attribute_Reference (Loc,
4882 Prefix => Relocate_Node (P),
4883 Attribute_Name => Name_Old),
4884 Expressions => Expressions (N)));
4885 Analyze (N);
4886 return;
4887 end if;
4888
4889 Analyze_Attribute_Old_Result (Legal, Spec_Id);
4890
4891 -- The aspect or pragma where attribute 'Old resides should be
4892 -- associated with a subprogram declaration or a body. If this is not
4893 -- the case, then the aspect or pragma is illegal. Return as analysis
4894 -- cannot be carried out.
4895
4896 -- The exception to this rule is when generating C since in this case
4897 -- postconditions are inlined.
4898
4899 if No (Spec_Id)
4900 and then Modify_Tree_For_C
4901 and then In_Inlined_Body
4902 then
4903 Spec_Id := Entity (P);
4904
4905 elsif not Legal then
4906 return;
4907 end if;
4908
4909 -- The prefix must be preanalyzed as the full analysis will take
4910 -- place during expansion.
4911
4912 Preanalyze_And_Resolve (P);
4913
4914 -- Ensure that the prefix does not contain attributes 'Old or 'Result
4915
4916 Check_References_In_Prefix (Spec_Id);
4917
4918 -- Set the type of the attribute now to prevent cascaded errors
4919
4920 Pref_Typ := Etype (P);
4921 Set_Etype (N, Pref_Typ);
4922
4923 -- Legality checks
4924
4925 if Is_Limited_Type (Pref_Typ) then
4926 Error_Attr ("attribute % cannot apply to limited objects", P);
4927 end if;
4928
4929 -- The prefix is a simple name
4930
4931 if Is_Entity_Name (P) and then Present (Entity (P)) then
4932 Pref_Id := Entity (P);
4933
4934 -- Emit a warning when the prefix is a constant. Note that the use
4935 -- of Error_Attr would reset the type of N to Any_Type even though
4936 -- this is a warning. Use Error_Msg_XXX instead.
4937
4938 if Is_Constant_Object (Pref_Id) then
4939 Error_Msg_Name_1 := Name_Old;
4940 Error_Msg_N
4941 ("??attribute % applied to constant has no effect", P);
4942 end if;
4943
4944 -- Otherwise the prefix is not a simple name
4945
4946 else
4947 -- Ensure that the prefix of attribute 'Old is an entity when it
4948 -- is potentially unevaluated (6.1.1 (27/3)).
4949
4950 if Is_Potentially_Unevaluated (N) then
4951 Uneval_Old_Msg;
4952
4953 -- Detect a possible infinite recursion when the prefix denotes
4954 -- the related function.
4955
4956 -- function Func (...) return ...
4957 -- with Post => Func'Old ...;
4958
4959 -- The function may be specified in qualified form X.Y where X is
4960 -- a protected object and Y is a protected function. In that case
4961 -- ensure that the qualified form has an entity.
4962
4963 elsif Nkind (P) = N_Function_Call
4964 and then Nkind (Name (P)) in N_Has_Entity
4965 then
4966 Pref_Id := Entity (Name (P));
4967
4968 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
4969 and then Pref_Id = Spec_Id
4970 then
4971 Error_Msg_Warn := SPARK_Mode /= On;
4972 Error_Msg_N ("!possible infinite recursion<<", P);
4973 Error_Msg_N ("\!??Storage_Error ]<<", P);
4974 end if;
4975 end if;
4976
4977 -- The prefix of attribute 'Old may refer to a component of a
4978 -- formal parameter. In this case its expansion may generate
4979 -- actual subtypes that are referenced in an inner context and
4980 -- that must be elaborated within the subprogram itself. If the
4981 -- prefix includes a function call, it may involve finalization
4982 -- actions that should be inserted when the attribute has been
4983 -- rewritten as a declaration. Create a declaration for the prefix
4984 -- and insert it at the start of the enclosing subprogram. This is
4985 -- an expansion activity that has to be performed now to prevent
4986 -- out-of-order issues.
4987
4988 -- This expansion is both harmful and not needed in SPARK mode,
4989 -- since the formal verification backend relies on the types of
4990 -- nodes (hence is not robust w.r.t. a change to base type here),
4991 -- and does not suffer from the out-of-order issue described
4992 -- above. Thus, this expansion is skipped in SPARK mode.
4993
4994 -- The expansion is not relevant for discrete types, which will
4995 -- not generate extra declarations, and where use of the base type
4996 -- may lead to spurious errors if context is a case.
4997
4998 if not GNATprove_Mode then
4999 if not Is_Discrete_Type (Pref_Typ) then
5000 Pref_Typ := Base_Type (Pref_Typ);
5001 end if;
5002
5003 Set_Etype (N, Pref_Typ);
5004 Set_Etype (P, Pref_Typ);
5005
5006 Analyze_Dimension (N);
5007 Expand (N);
5008 end if;
5009 end if;
5010 end Old;
5011
5012 ----------------------
5013 -- Overlaps_Storage --
5014 ----------------------
5015
5016 when Attribute_Overlaps_Storage =>
5017 Check_E1;
5018
5019 -- Both arguments must be objects of any type
5020
5021 Analyze_And_Resolve (P);
5022 Analyze_And_Resolve (E1);
5023 Check_Object_Reference (P);
5024 Check_Object_Reference (E1);
5025 Set_Etype (N, Standard_Boolean);
5026
5027 ------------
5028 -- Output --
5029 ------------
5030
5031 when Attribute_Output =>
5032 Check_E2;
5033 Check_Stream_Attribute (TSS_Stream_Output);
5034 Set_Etype (N, Standard_Void_Type);
5035 Resolve (N, Standard_Void_Type);
5036
5037 ------------------
5038 -- Partition_ID --
5039 ------------------
5040
5041 when Attribute_Partition_ID => Partition_Id :
5042 begin
5043 Check_E0;
5044
5045 if P_Type /= Any_Type then
5046 if not Is_Library_Level_Entity (Entity (P)) then
5047 Error_Attr_P
5048 ("prefix of % attribute must be library-level entity");
5049
5050 -- The defining entity of prefix should not be declared inside a
5051 -- Pure unit. RM E.1(8). Is_Pure was set during declaration.
5052
5053 elsif Is_Entity_Name (P)
5054 and then Is_Pure (Entity (P))
5055 then
5056 Error_Attr_P ("prefix of% attribute must not be declared pure");
5057 end if;
5058 end if;
5059
5060 Set_Etype (N, Universal_Integer);
5061 end Partition_Id;
5062
5063 -------------------------
5064 -- Passed_By_Reference --
5065 -------------------------
5066
5067 when Attribute_Passed_By_Reference =>
5068 Check_E0;
5069 Check_Type;
5070 Set_Etype (N, Standard_Boolean);
5071
5072 ------------------
5073 -- Pool_Address --
5074 ------------------
5075
5076 when Attribute_Pool_Address =>
5077 Check_E0;
5078 Set_Etype (N, RTE (RE_Address));
5079
5080 ---------
5081 -- Pos --
5082 ---------
5083
5084 when Attribute_Pos =>
5085 Check_Discrete_Type;
5086 Check_E1;
5087
5088 if Is_Boolean_Type (P_Type) then
5089 Error_Msg_Name_1 := Aname;
5090 Error_Msg_Name_2 := Chars (P_Type);
5091 Check_SPARK_05_Restriction
5092 ("attribute% is not allowed for type%", P);
5093 end if;
5094
5095 Resolve (E1, P_Base_Type);
5096 Set_Etype (N, Universal_Integer);
5097
5098 --------------
5099 -- Position --
5100 --------------
5101
5102 when Attribute_Position =>
5103 Check_Component;
5104 Set_Etype (N, Universal_Integer);
5105
5106 ----------
5107 -- Pred --
5108 ----------
5109
5110 when Attribute_Pred =>
5111 Check_Scalar_Type;
5112 Check_E1;
5113
5114 if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then
5115 Error_Msg_Name_1 := Aname;
5116 Error_Msg_Name_2 := Chars (P_Type);
5117 Check_SPARK_05_Restriction
5118 ("attribute% is not allowed for type%", P);
5119 end if;
5120
5121 Resolve (E1, P_Base_Type);
5122 Set_Etype (N, P_Base_Type);
5123
5124 -- Since Pred works on the base type, we normally do no check for the
5125 -- floating-point case, since the base type is unconstrained. But we
5126 -- make an exception in Check_Float_Overflow mode.
5127
5128 if Is_Floating_Point_Type (P_Type) then
5129 if not Range_Checks_Suppressed (P_Base_Type) then
5130 Set_Do_Range_Check (E1);
5131 end if;
5132
5133 -- If not modular type, test for overflow check required
5134
5135 else
5136 if not Is_Modular_Integer_Type (P_Type)
5137 and then not Range_Checks_Suppressed (P_Base_Type)
5138 then
5139 Enable_Range_Check (E1);
5140 end if;
5141 end if;
5142
5143 --------------
5144 -- Priority --
5145 --------------
5146
5147 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5148
5149 when Attribute_Priority =>
5150 if Ada_Version < Ada_2005 then
5151 Error_Attr ("% attribute is allowed only in Ada 2005 mode", P);
5152 end if;
5153
5154 Check_E0;
5155
5156 -- The prefix must be a protected object (AARM D.5.2 (2/2))
5157
5158 Analyze (P);
5159
5160 if Is_Protected_Type (Etype (P))
5161 or else (Is_Access_Type (Etype (P))
5162 and then Is_Protected_Type (Designated_Type (Etype (P))))
5163 then
5164 Resolve (P, Etype (P));
5165 else
5166 Error_Attr_P ("prefix of % attribute must be a protected object");
5167 end if;
5168
5169 Set_Etype (N, Standard_Integer);
5170
5171 -- Must be called from within a protected procedure or entry of the
5172 -- protected object.
5173
5174 declare
5175 S : Entity_Id;
5176
5177 begin
5178 S := Current_Scope;
5179 while S /= Etype (P)
5180 and then S /= Standard_Standard
5181 loop
5182 S := Scope (S);
5183 end loop;
5184
5185 if S = Standard_Standard then
5186 Error_Attr ("the attribute % is only allowed inside protected "
5187 & "operations", P);
5188 end if;
5189 end;
5190
5191 Validate_Non_Static_Attribute_Function_Call;
5192
5193 -----------
5194 -- Range --
5195 -----------
5196
5197 when Attribute_Range =>
5198 Check_Array_Or_Scalar_Type;
5199 Bad_Attribute_For_Predicate;
5200
5201 if Ada_Version = Ada_83
5202 and then Is_Scalar_Type (P_Type)
5203 and then Comes_From_Source (N)
5204 then
5205 Error_Attr
5206 ("(Ada 83) % attribute not allowed for scalar type", P);
5207 end if;
5208
5209 ------------
5210 -- Result --
5211 ------------
5212
5213 when Attribute_Result => Result : declare
5214 function Denote_Same_Function
5215 (Pref_Id : Entity_Id;
5216 Spec_Id : Entity_Id) return Boolean;
5217 -- Determine whether the entity of the prefix Pref_Id denotes the
5218 -- same entity as that of the related subprogram Spec_Id.
5219
5220 --------------------------
5221 -- Denote_Same_Function --
5222 --------------------------
5223
5224 function Denote_Same_Function
5225 (Pref_Id : Entity_Id;
5226 Spec_Id : Entity_Id) return Boolean
5227 is
5228 Over_Id : constant Entity_Id := Overridden_Operation (Spec_Id);
5229 Subp_Spec : constant Node_Id := Parent (Spec_Id);
5230
5231 begin
5232 -- The prefix denotes the related subprogram
5233
5234 if Pref_Id = Spec_Id then
5235 return True;
5236
5237 -- Account for a special case when attribute 'Result appears in
5238 -- the postcondition of a generic function.
5239
5240 -- generic
5241 -- function Gen_Func return ...
5242 -- with Post => Gen_Func'Result ...;
5243
5244 -- When the generic function is instantiated, the Chars field of
5245 -- the instantiated prefix still denotes the name of the generic
5246 -- function. Note that any preemptive transformation is impossible
5247 -- without a proper analysis. The structure of the wrapper package
5248 -- is as follows:
5249
5250 -- package Anon_Gen_Pack is
5251 -- <subtypes and renamings>
5252 -- function Subp_Decl return ...; -- (!)
5253 -- pragma Postcondition (Gen_Func'Result ...); -- (!)
5254 -- function Gen_Func ... renames Subp_Decl;
5255 -- end Anon_Gen_Pack;
5256
5257 elsif Nkind (Subp_Spec) = N_Function_Specification
5258 and then Present (Generic_Parent (Subp_Spec))
5259 and then Ekind_In (Pref_Id, E_Generic_Function, E_Function)
5260 then
5261 if Generic_Parent (Subp_Spec) = Pref_Id then
5262 return True;
5263
5264 elsif Present (Alias (Pref_Id))
5265 and then Alias (Pref_Id) = Spec_Id
5266 then
5267 return True;
5268 end if;
5269
5270 -- Account for a special case where a primitive of a tagged type
5271 -- inherits a class-wide postcondition from a parent type. In this
5272 -- case the prefix of attribute 'Result denotes the overriding
5273 -- primitive.
5274
5275 elsif Present (Over_Id) and then Pref_Id = Over_Id then
5276 return True;
5277 end if;
5278
5279 -- Otherwise the prefix does not denote the related subprogram
5280
5281 return False;
5282 end Denote_Same_Function;
5283
5284 -- Local variables
5285
5286 Legal : Boolean;
5287 Pref_Id : Entity_Id;
5288 Spec_Id : Entity_Id;
5289
5290 -- Start of processing for Result
5291
5292 begin
5293 -- The attribute reference is a primary. If any expressions follow,
5294 -- then the attribute reference is an indexable object. Transform the
5295 -- attribute into an indexed component and analyze it.
5296
5297 if Present (E1) then
5298 Rewrite (N,
5299 Make_Indexed_Component (Loc,
5300 Prefix =>
5301 Make_Attribute_Reference (Loc,
5302 Prefix => Relocate_Node (P),
5303 Attribute_Name => Name_Result),
5304 Expressions => Expressions (N)));
5305 Analyze (N);
5306 return;
5307 end if;
5308
5309 Analyze_Attribute_Old_Result (Legal, Spec_Id);
5310
5311 -- The aspect or pragma where attribute 'Result resides should be
5312 -- associated with a subprogram declaration or a body. If this is not
5313 -- the case, then the aspect or pragma is illegal. Return as analysis
5314 -- cannot be carried out.
5315
5316 -- The exception to this rule is when generating C since in this case
5317 -- postconditions are inlined.
5318
5319 if No (Spec_Id)
5320 and then Modify_Tree_For_C
5321 and then In_Inlined_Body
5322 then
5323 Spec_Id := Entity (P);
5324
5325 elsif not Legal then
5326 return;
5327 end if;
5328
5329 -- Attribute 'Result is part of a _Postconditions procedure. There is
5330 -- no need to perform the semantic checks below as they were already
5331 -- verified when the attribute was analyzed in its original context.
5332 -- Instead, rewrite the attribute as a reference to formal parameter
5333 -- _Result of the _Postconditions procedure.
5334
5335 if Chars (Spec_Id) = Name_uPostconditions then
5336 Rewrite (N, Make_Identifier (Loc, Name_uResult));
5337
5338 -- The type of formal parameter _Result is that of the function
5339 -- encapsulating the _Postconditions procedure. Resolution must
5340 -- be carried out against the function return type.
5341
5342 Analyze_And_Resolve (N, Etype (Scope (Spec_Id)));
5343
5344 -- Otherwise attribute 'Result appears in its original context and
5345 -- all semantic checks should be carried out.
5346
5347 else
5348 -- Verify the legality of the prefix. It must denotes the entity
5349 -- of the related [generic] function.
5350
5351 if Is_Entity_Name (P) then
5352 Pref_Id := Entity (P);
5353
5354 if Ekind_In (Pref_Id, E_Function, E_Generic_Function)
5355 and then Ekind (Spec_Id) = Ekind (Pref_Id)
5356 then
5357 if Denote_Same_Function (Pref_Id, Spec_Id) then
5358
5359 -- Correct the prefix of the attribute when the context
5360 -- is a generic function.
5361
5362 if Pref_Id /= Spec_Id then
5363 Rewrite (P, New_Occurrence_Of (Spec_Id, Loc));
5364 Analyze (P);
5365 end if;
5366
5367 Set_Etype (N, Etype (Spec_Id));
5368
5369 -- Otherwise the prefix denotes some unrelated function
5370
5371 else
5372 Error_Msg_Name_2 := Chars (Spec_Id);
5373 Error_Attr
5374 ("incorrect prefix for attribute %, expected %", P);
5375 end if;
5376
5377 -- Otherwise the prefix denotes some other form of subprogram
5378 -- entity.
5379
5380 else
5381 Error_Attr
5382 ("attribute % can only appear in postcondition of "
5383 & "function", P);
5384 end if;
5385
5386 -- Otherwise the prefix is illegal
5387
5388 else
5389 Error_Msg_Name_2 := Chars (Spec_Id);
5390 Error_Attr ("incorrect prefix for attribute %, expected %", P);
5391 end if;
5392 end if;
5393 end Result;
5394
5395 ------------------
5396 -- Range_Length --
5397 ------------------
5398
5399 when Attribute_Range_Length =>
5400 Check_E0;
5401 Check_Discrete_Type;
5402 Set_Etype (N, Universal_Integer);
5403
5404 ----------
5405 -- Read --
5406 ----------
5407
5408 when Attribute_Read =>
5409 Check_E2;
5410 Check_Stream_Attribute (TSS_Stream_Read);
5411 Set_Etype (N, Standard_Void_Type);
5412 Resolve (N, Standard_Void_Type);
5413 Note_Possible_Modification (E2, Sure => True);
5414
5415 ---------
5416 -- Ref --
5417 ---------
5418
5419 when Attribute_Ref =>
5420 Check_E1;
5421 Analyze (P);
5422
5423 if Nkind (P) /= N_Expanded_Name
5424 or else not Is_RTE (P_Type, RE_Address)
5425 then
5426 Error_Attr_P ("prefix of % attribute must be System.Address");
5427 end if;
5428
5429 Analyze_And_Resolve (E1, Any_Integer);
5430 Set_Etype (N, RTE (RE_Address));
5431
5432 ---------------
5433 -- Remainder --
5434 ---------------
5435
5436 when Attribute_Remainder =>
5437 Check_Floating_Point_Type_2;
5438 Set_Etype (N, P_Base_Type);
5439 Resolve (E1, P_Base_Type);
5440 Resolve (E2, P_Base_Type);
5441
5442 ---------------------
5443 -- Restriction_Set --
5444 ---------------------
5445
5446 when Attribute_Restriction_Set => Restriction_Set : declare
5447 R : Restriction_Id;
5448 U : Node_Id;
5449 Unam : Unit_Name_Type;
5450
5451 begin
5452 Check_E1;
5453 Analyze (P);
5454 Check_System_Prefix;
5455
5456 -- No_Dependence case
5457
5458 if Nkind (E1) = N_Parameter_Association then
5459 pragma Assert (Chars (Selector_Name (E1)) = Name_No_Dependence);
5460 U := Explicit_Actual_Parameter (E1);
5461
5462 if not OK_No_Dependence_Unit_Name (U) then
5463 Set_Boolean_Result (N, False);
5464 Error_Attr;
5465 end if;
5466
5467 -- See if there is an entry already in the table. That's the
5468 -- case in which we can return True.
5469
5470 for J in No_Dependences.First .. No_Dependences.Last loop
5471 if Designate_Same_Unit (U, No_Dependences.Table (J).Unit)
5472 and then No_Dependences.Table (J).Warn = False
5473 then
5474 Set_Boolean_Result (N, True);
5475 return;
5476 end if;
5477 end loop;
5478
5479 -- If not in the No_Dependence table, result is False
5480
5481 Set_Boolean_Result (N, False);
5482
5483 -- In this case, we must ensure that the binder will reject any
5484 -- other unit in the partition that sets No_Dependence for this
5485 -- unit. We do that by making an entry in the special table kept
5486 -- for this purpose (if the entry is not there already).
5487
5488 Unam := Get_Spec_Name (Get_Unit_Name (U));
5489
5490 for J in Restriction_Set_Dependences.First ..
5491 Restriction_Set_Dependences.Last
5492 loop
5493 if Restriction_Set_Dependences.Table (J) = Unam then
5494 return;
5495 end if;
5496 end loop;
5497
5498 Restriction_Set_Dependences.Append (Unam);
5499
5500 -- Normal restriction case
5501
5502 else
5503 if Nkind (E1) /= N_Identifier then
5504 Set_Boolean_Result (N, False);
5505 Error_Attr ("attribute % requires restriction identifier", E1);
5506
5507 else
5508 R := Get_Restriction_Id (Process_Restriction_Synonyms (E1));
5509
5510 if R = Not_A_Restriction_Id then
5511 Set_Boolean_Result (N, False);
5512 Error_Msg_Node_1 := E1;
5513 Error_Attr ("invalid restriction identifier &", E1);
5514
5515 elsif R not in Partition_Boolean_Restrictions then
5516 Set_Boolean_Result (N, False);
5517 Error_Msg_Node_1 := E1;
5518 Error_Attr
5519 ("& is not a boolean partition-wide restriction", E1);
5520 end if;
5521
5522 if Restriction_Active (R) then
5523 Set_Boolean_Result (N, True);
5524 else
5525 Check_Restriction (R, N);
5526 Set_Boolean_Result (N, False);
5527 end if;
5528 end if;
5529 end if;
5530 end Restriction_Set;
5531
5532 -----------
5533 -- Round --
5534 -----------
5535
5536 when Attribute_Round =>
5537 Check_E1;
5538 Check_Decimal_Fixed_Point_Type;
5539 Set_Etype (N, P_Base_Type);
5540
5541 -- Because the context is universal_real (3.5.10(12)) it is a
5542 -- legal context for a universal fixed expression. This is the
5543 -- only attribute whose functional description involves U_R.
5544
5545 if Etype (E1) = Universal_Fixed then
5546 declare
5547 Conv : constant Node_Id := Make_Type_Conversion (Loc,
5548 Subtype_Mark => New_Occurrence_Of (Universal_Real, Loc),
5549 Expression => Relocate_Node (E1));
5550
5551 begin
5552 Rewrite (E1, Conv);
5553 Analyze (E1);
5554 end;
5555 end if;
5556
5557 Resolve (E1, Any_Real);
5558
5559 --------------
5560 -- Rounding --
5561 --------------
5562
5563 when Attribute_Rounding =>
5564 Check_Floating_Point_Type_1;
5565 Set_Etype (N, P_Base_Type);
5566 Resolve (E1, P_Base_Type);
5567
5568 ---------------
5569 -- Safe_Emax --
5570 ---------------
5571
5572 when Attribute_Safe_Emax =>
5573 Check_Floating_Point_Type_0;
5574 Set_Etype (N, Universal_Integer);
5575
5576 ----------------
5577 -- Safe_First --
5578 ----------------
5579
5580 when Attribute_Safe_First =>
5581 Check_Floating_Point_Type_0;
5582 Set_Etype (N, Universal_Real);
5583
5584 ----------------
5585 -- Safe_Large --
5586 ----------------
5587
5588 when Attribute_Safe_Large =>
5589 Check_E0;
5590 Check_Real_Type;
5591 Set_Etype (N, Universal_Real);
5592
5593 ---------------
5594 -- Safe_Last --
5595 ---------------
5596
5597 when Attribute_Safe_Last =>
5598 Check_Floating_Point_Type_0;
5599 Set_Etype (N, Universal_Real);
5600
5601 ----------------
5602 -- Safe_Small --
5603 ----------------
5604
5605 when Attribute_Safe_Small =>
5606 Check_E0;
5607 Check_Real_Type;
5608 Set_Etype (N, Universal_Real);
5609
5610 --------------------------
5611 -- Scalar_Storage_Order --
5612 --------------------------
5613
5614 when Attribute_Scalar_Storage_Order => Scalar_Storage_Order :
5615 declare
5616 Ent : Entity_Id := Empty;
5617
5618 begin
5619 Check_E0;
5620 Check_Type;
5621
5622 if not (Is_Record_Type (P_Type) or else Is_Array_Type (P_Type)) then
5623
5624 -- In GNAT mode, the attribute applies to generic types as well
5625 -- as composite types, and for non-composite types always returns
5626 -- the default bit order for the target.
5627
5628 if not (GNAT_Mode and then Is_Generic_Type (P_Type))
5629 and then not In_Instance
5630 then
5631 Error_Attr_P
5632 ("prefix of % attribute must be record or array type");
5633
5634 elsif not Is_Generic_Type (P_Type) then
5635 if Bytes_Big_Endian then
5636 Ent := RTE (RE_High_Order_First);
5637 else
5638 Ent := RTE (RE_Low_Order_First);
5639 end if;
5640 end if;
5641
5642 elsif Bytes_Big_Endian xor Reverse_Storage_Order (P_Type) then
5643 Ent := RTE (RE_High_Order_First);
5644
5645 else
5646 Ent := RTE (RE_Low_Order_First);
5647 end if;
5648
5649 if Present (Ent) then
5650 Rewrite (N, New_Occurrence_Of (Ent, Loc));
5651 end if;
5652
5653 Set_Etype (N, RTE (RE_Bit_Order));
5654 Resolve (N);
5655
5656 -- Reset incorrect indication of staticness
5657
5658 Set_Is_Static_Expression (N, False);
5659 end Scalar_Storage_Order;
5660
5661 -----------
5662 -- Scale --
5663 -----------
5664
5665 when Attribute_Scale =>
5666 Check_E0;
5667 Check_Decimal_Fixed_Point_Type;
5668 Set_Etype (N, Universal_Integer);
5669
5670 -------------
5671 -- Scaling --
5672 -------------
5673
5674 when Attribute_Scaling =>
5675 Check_Floating_Point_Type_2;
5676 Set_Etype (N, P_Base_Type);
5677 Resolve (E1, P_Base_Type);
5678
5679 ------------------
5680 -- Signed_Zeros --
5681 ------------------
5682
5683 when Attribute_Signed_Zeros =>
5684 Check_Floating_Point_Type_0;
5685 Set_Etype (N, Standard_Boolean);
5686
5687 ----------
5688 -- Size --
5689 ----------
5690
5691 when Attribute_Size | Attribute_VADS_Size => Size :
5692 begin
5693 Check_E0;
5694
5695 -- If prefix is parameterless function call, rewrite and resolve
5696 -- as such.
5697
5698 if Is_Entity_Name (P)
5699 and then Ekind (Entity (P)) = E_Function
5700 then
5701 Resolve (P);
5702
5703 -- Similar processing for a protected function call
5704
5705 elsif Nkind (P) = N_Selected_Component
5706 and then Ekind (Entity (Selector_Name (P))) = E_Function
5707 then
5708 Resolve (P);
5709 end if;
5710
5711 if Is_Object_Reference (P) then
5712 Check_Object_Reference (P);
5713
5714 elsif Is_Entity_Name (P)
5715 and then (Is_Type (Entity (P))
5716 or else Ekind (Entity (P)) = E_Enumeration_Literal)
5717 then
5718 null;
5719
5720 elsif Nkind (P) = N_Type_Conversion
5721 and then not Comes_From_Source (P)
5722 then
5723 null;
5724
5725 -- Some other compilers allow dubious use of X'???'Size
5726
5727 elsif Relaxed_RM_Semantics
5728 and then Nkind (P) = N_Attribute_Reference
5729 then
5730 null;
5731
5732 else
5733 Error_Attr_P ("invalid prefix for % attribute");
5734 end if;
5735
5736 Check_Not_Incomplete_Type;
5737 Check_Not_CPP_Type;
5738 Set_Etype (N, Universal_Integer);
5739 end Size;
5740
5741 -----------
5742 -- Small --
5743 -----------
5744
5745 when Attribute_Small =>
5746 Check_E0;
5747 Check_Real_Type;
5748 Set_Etype (N, Universal_Real);
5749
5750 ------------------
5751 -- Storage_Pool --
5752 ------------------
5753
5754 when Attribute_Storage_Pool |
5755 Attribute_Simple_Storage_Pool => Storage_Pool :
5756 begin
5757 Check_E0;
5758
5759 if Is_Access_Type (P_Type) then
5760 if Ekind (P_Type) = E_Access_Subprogram_Type then
5761 Error_Attr_P
5762 ("cannot use % attribute for access-to-subprogram type");
5763 end if;
5764
5765 -- Set appropriate entity
5766
5767 if Present (Associated_Storage_Pool (Root_Type (P_Type))) then
5768 Set_Entity (N, Associated_Storage_Pool (Root_Type (P_Type)));
5769 else
5770 Set_Entity (N, RTE (RE_Global_Pool_Object));
5771 end if;
5772
5773 if Attr_Id = Attribute_Storage_Pool then
5774 if Present (Get_Rep_Pragma (Etype (Entity (N)),
5775 Name_Simple_Storage_Pool_Type))
5776 then
5777 Error_Msg_Name_1 := Aname;
5778 Error_Msg_Warn := SPARK_Mode /= On;
5779 Error_Msg_N ("cannot use % attribute for type with simple "
5780 & "storage pool<<", N);
5781 Error_Msg_N ("\Program_Error [<<", N);
5782
5783 Rewrite
5784 (N, Make_Raise_Program_Error
5785 (Sloc (N), Reason => PE_Explicit_Raise));
5786 end if;
5787
5788 Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
5789
5790 -- In the Simple_Storage_Pool case, verify that the pool entity is
5791 -- actually of a simple storage pool type, and set the attribute's
5792 -- type to the pool object's type.
5793
5794 else
5795 if not Present (Get_Rep_Pragma (Etype (Entity (N)),
5796 Name_Simple_Storage_Pool_Type))
5797 then
5798 Error_Attr_P
5799 ("cannot use % attribute for type without simple " &
5800 "storage pool");
5801 end if;
5802
5803 Set_Etype (N, Etype (Entity (N)));
5804 end if;
5805
5806 -- Validate_Remote_Access_To_Class_Wide_Type for attribute
5807 -- Storage_Pool since this attribute is not defined for such
5808 -- types (RM E.2.3(22)).
5809
5810 Validate_Remote_Access_To_Class_Wide_Type (N);
5811
5812 else
5813 Error_Attr_P ("prefix of % attribute must be access type");
5814 end if;
5815 end Storage_Pool;
5816
5817 ------------------
5818 -- Storage_Size --
5819 ------------------
5820
5821 when Attribute_Storage_Size => Storage_Size :
5822 begin
5823 Check_E0;
5824
5825 if Is_Task_Type (P_Type) then
5826 Set_Etype (N, Universal_Integer);
5827
5828 -- Use with tasks is an obsolescent feature
5829
5830 Check_Restriction (No_Obsolescent_Features, P);
5831
5832 elsif Is_Access_Type (P_Type) then
5833 if Ekind (P_Type) = E_Access_Subprogram_Type then
5834 Error_Attr_P
5835 ("cannot use % attribute for access-to-subprogram type");
5836 end if;
5837
5838 if Is_Entity_Name (P)
5839 and then Is_Type (Entity (P))
5840 then
5841 Check_Type;
5842 Set_Etype (N, Universal_Integer);
5843
5844 -- Validate_Remote_Access_To_Class_Wide_Type for attribute
5845 -- Storage_Size since this attribute is not defined for
5846 -- such types (RM E.2.3(22)).
5847
5848 Validate_Remote_Access_To_Class_Wide_Type (N);
5849
5850 -- The prefix is allowed to be an implicit dereference of an
5851 -- access value designating a task.
5852
5853 else
5854 Check_Task_Prefix;
5855 Set_Etype (N, Universal_Integer);
5856 end if;
5857
5858 else
5859 Error_Attr_P ("prefix of % attribute must be access or task type");
5860 end if;
5861 end Storage_Size;
5862
5863 ------------------
5864 -- Storage_Unit --
5865 ------------------
5866
5867 when Attribute_Storage_Unit =>
5868 Standard_Attribute (Ttypes.System_Storage_Unit);
5869
5870 -----------------
5871 -- Stream_Size --
5872 -----------------
5873
5874 when Attribute_Stream_Size =>
5875 Check_E0;
5876 Check_Type;
5877
5878 if Is_Entity_Name (P)
5879 and then Is_Elementary_Type (Entity (P))
5880 then
5881 Set_Etype (N, Universal_Integer);
5882 else
5883 Error_Attr_P ("invalid prefix for % attribute");
5884 end if;
5885
5886 ---------------
5887 -- Stub_Type --
5888 ---------------
5889
5890 when Attribute_Stub_Type =>
5891 Check_Type;
5892 Check_E0;
5893
5894 if Is_Remote_Access_To_Class_Wide_Type (Base_Type (P_Type)) then
5895
5896 -- For a real RACW [sub]type, use corresponding stub type
5897
5898 if not Is_Generic_Type (P_Type) then
5899 Rewrite (N,
5900 New_Occurrence_Of
5901 (Corresponding_Stub_Type (Base_Type (P_Type)), Loc));
5902
5903 -- For a generic type (that has been marked as an RACW using the
5904 -- Remote_Access_Type aspect or pragma), use a generic RACW stub
5905 -- type. Note that if the actual is not a remote access type, the
5906 -- instantiation will fail.
5907
5908 else
5909 -- Note: we go to the underlying type here because the view
5910 -- returned by RTE (RE_RACW_Stub_Type) might be incomplete.
5911
5912 Rewrite (N,
5913 New_Occurrence_Of
5914 (Underlying_Type (RTE (RE_RACW_Stub_Type)), Loc));
5915 end if;
5916
5917 else
5918 Error_Attr_P
5919 ("prefix of% attribute must be remote access to classwide");
5920 end if;
5921
5922 ----------
5923 -- Succ --
5924 ----------
5925
5926 when Attribute_Succ =>
5927 Check_Scalar_Type;
5928 Check_E1;
5929
5930 if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then
5931 Error_Msg_Name_1 := Aname;
5932 Error_Msg_Name_2 := Chars (P_Type);
5933 Check_SPARK_05_Restriction
5934 ("attribute% is not allowed for type%", P);
5935 end if;
5936
5937 Resolve (E1, P_Base_Type);
5938 Set_Etype (N, P_Base_Type);
5939
5940 -- Since Pred works on the base type, we normally do no check for the
5941 -- floating-point case, since the base type is unconstrained. But we
5942 -- make an exception in Check_Float_Overflow mode.
5943
5944 if Is_Floating_Point_Type (P_Type) then
5945 if not Range_Checks_Suppressed (P_Base_Type) then
5946 Set_Do_Range_Check (E1);
5947 end if;
5948
5949 -- If not modular type, test for overflow check required
5950
5951 else
5952 if not Is_Modular_Integer_Type (P_Type)
5953 and then not Range_Checks_Suppressed (P_Base_Type)
5954 then
5955 Enable_Range_Check (E1);
5956 end if;
5957 end if;
5958
5959 --------------------------------
5960 -- System_Allocator_Alignment --
5961 --------------------------------
5962
5963 when Attribute_System_Allocator_Alignment =>
5964 Standard_Attribute (Ttypes.System_Allocator_Alignment);
5965
5966 ---------
5967 -- Tag --
5968 ---------
5969
5970 when Attribute_Tag => Tag :
5971 begin
5972 Check_E0;
5973 Check_Dereference;
5974
5975 if not Is_Tagged_Type (P_Type) then
5976 Error_Attr_P ("prefix of % attribute must be tagged");
5977
5978 -- Next test does not apply to generated code why not, and what does
5979 -- the illegal reference mean???
5980
5981 elsif Is_Object_Reference (P)
5982 and then not Is_Class_Wide_Type (P_Type)
5983 and then Comes_From_Source (N)
5984 then
5985 Error_Attr_P
5986 ("% attribute can only be applied to objects " &
5987 "of class - wide type");
5988 end if;
5989
5990 -- The prefix cannot be an incomplete type. However, references to
5991 -- 'Tag can be generated when expanding interface conversions, and
5992 -- this is legal.
5993
5994 if Comes_From_Source (N) then
5995 Check_Not_Incomplete_Type;
5996 end if;
5997
5998 -- Set appropriate type
5999
6000 Set_Etype (N, RTE (RE_Tag));
6001 end Tag;
6002
6003 -----------------
6004 -- Target_Name --
6005 -----------------
6006
6007 when Attribute_Target_Name => Target_Name : declare
6008 TN : constant String := Sdefault.Target_Name.all;
6009 TL : Natural;
6010
6011 begin
6012 Check_Standard_Prefix;
6013
6014 TL := TN'Last;
6015
6016 if TN (TL) = '/' or else TN (TL) = '\' then
6017 TL := TL - 1;
6018 end if;
6019
6020 Rewrite (N,
6021 Make_String_Literal (Loc,
6022 Strval => TN (TN'First .. TL)));
6023 Analyze_And_Resolve (N, Standard_String);
6024 Set_Is_Static_Expression (N, True);
6025 end Target_Name;
6026
6027 ----------------
6028 -- Terminated --
6029 ----------------
6030
6031 when Attribute_Terminated =>
6032 Check_E0;
6033 Set_Etype (N, Standard_Boolean);
6034 Check_Task_Prefix;
6035
6036 ----------------
6037 -- To_Address --
6038 ----------------
6039
6040 when Attribute_To_Address => To_Address : declare
6041 Val : Uint;
6042
6043 begin
6044 Check_E1;
6045 Analyze (P);
6046 Check_System_Prefix;
6047
6048 Generate_Reference (RTE (RE_Address), P);
6049 Analyze_And_Resolve (E1, Any_Integer);
6050 Set_Etype (N, RTE (RE_Address));
6051
6052 if Is_Static_Expression (E1) then
6053 Set_Is_Static_Expression (N, True);
6054 end if;
6055
6056 -- OK static expression case, check range and set appropriate type
6057
6058 if Is_OK_Static_Expression (E1) then
6059 Val := Expr_Value (E1);
6060
6061 if Val < -(2 ** UI_From_Int (Standard'Address_Size - 1))
6062 or else
6063 Val > 2 ** UI_From_Int (Standard'Address_Size) - 1
6064 then
6065 Error_Attr ("address value out of range for % attribute", E1);
6066 end if;
6067
6068 -- In most cases the expression is a numeric literal or some other
6069 -- address expression, but if it is a declared constant it may be
6070 -- of a compatible type that must be left on the node.
6071
6072 if Is_Entity_Name (E1) then
6073 null;
6074
6075 -- Set type to universal integer if negative
6076
6077 elsif Val < 0 then
6078 Set_Etype (E1, Universal_Integer);
6079
6080 -- Otherwise set type to Unsigned_64 to accomodate max values
6081
6082 else
6083 Set_Etype (E1, Standard_Unsigned_64);
6084 end if;
6085 end if;
6086
6087 Set_Is_Static_Expression (N, True);
6088 end To_Address;
6089
6090 ------------
6091 -- To_Any --
6092 ------------
6093
6094 when Attribute_To_Any =>
6095 Check_E1;
6096 Check_PolyORB_Attribute;
6097 Set_Etype (N, RTE (RE_Any));
6098
6099 ----------------
6100 -- Truncation --
6101 ----------------
6102
6103 when Attribute_Truncation =>
6104 Check_Floating_Point_Type_1;
6105 Resolve (E1, P_Base_Type);
6106 Set_Etype (N, P_Base_Type);
6107
6108 ----------------
6109 -- Type_Class --
6110 ----------------
6111
6112 when Attribute_Type_Class =>
6113 Check_E0;
6114 Check_Type;
6115 Check_Not_Incomplete_Type;
6116 Set_Etype (N, RTE (RE_Type_Class));
6117
6118 --------------
6119 -- TypeCode --
6120 --------------
6121
6122 when Attribute_TypeCode =>
6123 Check_E0;
6124 Check_PolyORB_Attribute;
6125 Set_Etype (N, RTE (RE_TypeCode));
6126
6127 --------------
6128 -- Type_Key --
6129 --------------
6130
6131 when Attribute_Type_Key =>
6132 Check_E0;
6133 Check_Type;
6134
6135 -- This processing belongs in Eval_Attribute ???
6136
6137 declare
6138 function Type_Key return String_Id;
6139 -- A very preliminary implementation. For now, a signature
6140 -- consists of only the type name. This is clearly incomplete
6141 -- (e.g., adding a new field to a record type should change the
6142 -- type's Type_Key attribute).
6143
6144 --------------
6145 -- Type_Key --
6146 --------------
6147
6148 function Type_Key return String_Id is
6149 Full_Name : constant String_Id :=
6150 Fully_Qualified_Name_String (Entity (P));
6151
6152 begin
6153 -- Copy all characters in Full_Name but the trailing NUL
6154
6155 Start_String;
6156 for J in 1 .. String_Length (Full_Name) - 1 loop
6157 Store_String_Char (Get_String_Char (Full_Name, Pos (J)));
6158 end loop;
6159
6160 Store_String_Chars ("'Type_Key");
6161 return End_String;
6162 end Type_Key;
6163
6164 begin
6165 Rewrite (N, Make_String_Literal (Loc, Type_Key));
6166 end;
6167
6168 Analyze_And_Resolve (N, Standard_String);
6169
6170 -----------------------
6171 -- Unbiased_Rounding --
6172 -----------------------
6173
6174 when Attribute_Unbiased_Rounding =>
6175 Check_Floating_Point_Type_1;
6176 Set_Etype (N, P_Base_Type);
6177 Resolve (E1, P_Base_Type);
6178
6179 ----------------------
6180 -- Unchecked_Access --
6181 ----------------------
6182
6183 when Attribute_Unchecked_Access =>
6184 if Comes_From_Source (N) then
6185 Check_Restriction (No_Unchecked_Access, N);
6186 end if;
6187
6188 Analyze_Access_Attribute;
6189 Check_Not_Incomplete_Type;
6190
6191 -------------------------
6192 -- Unconstrained_Array --
6193 -------------------------
6194
6195 when Attribute_Unconstrained_Array =>
6196 Check_E0;
6197 Check_Type;
6198 Check_Not_Incomplete_Type;
6199 Set_Etype (N, Standard_Boolean);
6200 Set_Is_Static_Expression (N, True);
6201
6202 ------------------------------
6203 -- Universal_Literal_String --
6204 ------------------------------
6205
6206 -- This is a GNAT specific attribute whose prefix must be a named
6207 -- number where the expression is either a single numeric literal,
6208 -- or a numeric literal immediately preceded by a minus sign. The
6209 -- result is equivalent to a string literal containing the text of
6210 -- the literal as it appeared in the source program with a possible
6211 -- leading minus sign.
6212
6213 when Attribute_Universal_Literal_String => Universal_Literal_String :
6214 begin
6215 Check_E0;
6216
6217 if not Is_Entity_Name (P)
6218 or else Ekind (Entity (P)) not in Named_Kind
6219 then
6220 Error_Attr_P ("prefix for % attribute must be named number");
6221
6222 else
6223 declare
6224 Expr : Node_Id;
6225 Negative : Boolean;
6226 S : Source_Ptr;
6227 Src : Source_Buffer_Ptr;
6228
6229 begin
6230 Expr := Original_Node (Expression (Parent (Entity (P))));
6231
6232 if Nkind (Expr) = N_Op_Minus then
6233 Negative := True;
6234 Expr := Original_Node (Right_Opnd (Expr));
6235 else
6236 Negative := False;
6237 end if;
6238
6239 if not Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) then
6240 Error_Attr
6241 ("named number for % attribute must be simple literal", N);
6242 end if;
6243
6244 -- Build string literal corresponding to source literal text
6245
6246 Start_String;
6247
6248 if Negative then
6249 Store_String_Char (Get_Char_Code ('-'));
6250 end if;
6251
6252 S := Sloc (Expr);
6253 Src := Source_Text (Get_Source_File_Index (S));
6254
6255 while Src (S) /= ';' and then Src (S) /= ' ' loop
6256 Store_String_Char (Get_Char_Code (Src (S)));
6257 S := S + 1;
6258 end loop;
6259
6260 -- Now we rewrite the attribute with the string literal
6261
6262 Rewrite (N,
6263 Make_String_Literal (Loc, End_String));
6264 Analyze (N);
6265 Set_Is_Static_Expression (N, True);
6266 end;
6267 end if;
6268 end Universal_Literal_String;
6269
6270 -------------------------
6271 -- Unrestricted_Access --
6272 -------------------------
6273
6274 -- This is a GNAT specific attribute which is like Access except that
6275 -- all scope checks and checks for aliased views are omitted. It is
6276 -- documented as being equivalent to the use of the Address attribute
6277 -- followed by an unchecked conversion to the target access type.
6278
6279 when Attribute_Unrestricted_Access =>
6280
6281 -- If from source, deal with relevant restrictions
6282
6283 if Comes_From_Source (N) then
6284 Check_Restriction (No_Unchecked_Access, N);
6285
6286 if Nkind (P) in N_Has_Entity
6287 and then Present (Entity (P))
6288 and then Is_Object (Entity (P))
6289 then
6290 Check_Restriction (No_Implicit_Aliasing, N);
6291 end if;
6292 end if;
6293
6294 if Is_Entity_Name (P) then
6295 Set_Address_Taken (Entity (P));
6296 end if;
6297
6298 -- It might seem reasonable to call Address_Checks here to apply the
6299 -- same set of semantic checks that we enforce for 'Address (after
6300 -- all we document Unrestricted_Access as being equivalent to the
6301 -- use of Address followed by an Unchecked_Conversion). However, if
6302 -- we do enable these checks, we get multiple failures in both the
6303 -- compiler run-time and in our regression test suite, so we leave
6304 -- out these checks for now. To be investigated further some time???
6305
6306 -- Address_Checks;
6307
6308 -- Now complete analysis using common access processing
6309
6310 Analyze_Access_Attribute;
6311
6312 ------------
6313 -- Update --
6314 ------------
6315
6316 when Attribute_Update => Update : declare
6317 Common_Typ : Entity_Id;
6318 -- The common type of a multiple component update for a record
6319
6320 Comps : Elist_Id := No_Elist;
6321 -- A list used in the resolution of a record update. It contains the
6322 -- entities of all record components processed so far.
6323
6324 procedure Analyze_Array_Component_Update (Assoc : Node_Id);
6325 -- Analyze and resolve array_component_association Assoc against the
6326 -- index of array type P_Type.
6327
6328 procedure Analyze_Record_Component_Update (Comp : Node_Id);
6329 -- Analyze and resolve record_component_association Comp against
6330 -- record type P_Type.
6331
6332 ------------------------------------
6333 -- Analyze_Array_Component_Update --
6334 ------------------------------------
6335
6336 procedure Analyze_Array_Component_Update (Assoc : Node_Id) is
6337 Expr : Node_Id;
6338 High : Node_Id;
6339 Index : Node_Id;
6340 Index_Typ : Entity_Id;
6341 Low : Node_Id;
6342
6343 begin
6344 -- The current association contains a sequence of indexes denoting
6345 -- an element of a multidimensional array:
6346
6347 -- (Index_1, ..., Index_N)
6348
6349 -- Examine each individual index and resolve it against the proper
6350 -- index type of the array.
6351
6352 if Nkind (First (Choices (Assoc))) = N_Aggregate then
6353 Expr := First (Choices (Assoc));
6354 while Present (Expr) loop
6355
6356 -- The use of others is illegal (SPARK RM 4.4.1(12))
6357
6358 if Nkind (Expr) = N_Others_Choice then
6359 Error_Attr
6360 ("others choice not allowed in attribute %", Expr);
6361
6362 -- Otherwise analyze and resolve all indexes
6363
6364 else
6365 Index := First (Expressions (Expr));
6366 Index_Typ := First_Index (P_Type);
6367 while Present (Index) and then Present (Index_Typ) loop
6368 Analyze_And_Resolve (Index, Etype (Index_Typ));
6369 Next (Index);
6370 Next_Index (Index_Typ);
6371 end loop;
6372
6373 -- Detect a case where the association either lacks an
6374 -- index or contains an extra index.
6375
6376 if Present (Index) or else Present (Index_Typ) then
6377 Error_Msg_N
6378 ("dimension mismatch in index list", Assoc);
6379 end if;
6380 end if;
6381
6382 Next (Expr);
6383 end loop;
6384
6385 -- The current association denotes either a single component or a
6386 -- range of components of a one dimensional array:
6387
6388 -- 1, 2 .. 5
6389
6390 -- Resolve the index or its high and low bounds (if range) against
6391 -- the proper index type of the array.
6392
6393 else
6394 Index := First (Choices (Assoc));
6395 Index_Typ := First_Index (P_Type);
6396
6397 if Present (Next_Index (Index_Typ)) then
6398 Error_Msg_N ("too few subscripts in array reference", Assoc);
6399 end if;
6400
6401 while Present (Index) loop
6402
6403 -- The use of others is illegal (SPARK RM 4.4.1(12))
6404
6405 if Nkind (Index) = N_Others_Choice then
6406 Error_Attr
6407 ("others choice not allowed in attribute %", Index);
6408
6409 -- The index denotes a range of elements
6410
6411 elsif Nkind (Index) = N_Range then
6412 Low := Low_Bound (Index);
6413 High := High_Bound (Index);
6414
6415 Analyze_And_Resolve (Low, Etype (Index_Typ));
6416 Analyze_And_Resolve (High, Etype (Index_Typ));
6417
6418 -- Add a range check to ensure that the bounds of the
6419 -- range are within the index type when this cannot be
6420 -- determined statically.
6421
6422 if not Is_OK_Static_Expression (Low) then
6423 Set_Do_Range_Check (Low);
6424 end if;
6425
6426 if not Is_OK_Static_Expression (High) then
6427 Set_Do_Range_Check (High);
6428 end if;
6429
6430 -- Otherwise the index denotes a single element
6431
6432 else
6433 Analyze_And_Resolve (Index, Etype (Index_Typ));
6434
6435 -- Add a range check to ensure that the index is within
6436 -- the index type when it is not possible to determine
6437 -- this statically.
6438
6439 if not Is_OK_Static_Expression (Index) then
6440 Set_Do_Range_Check (Index);
6441 end if;
6442 end if;
6443
6444 Next (Index);
6445 end loop;
6446 end if;
6447 end Analyze_Array_Component_Update;
6448
6449 -------------------------------------
6450 -- Analyze_Record_Component_Update --
6451 -------------------------------------
6452
6453 procedure Analyze_Record_Component_Update (Comp : Node_Id) is
6454 Comp_Name : constant Name_Id := Chars (Comp);
6455 Base_Typ : Entity_Id;
6456 Comp_Or_Discr : Entity_Id;
6457
6458 begin
6459 -- Find the discriminant or component whose name corresponds to
6460 -- Comp. A simple character comparison is sufficient because all
6461 -- visible names within a record type are unique.
6462
6463 Comp_Or_Discr := First_Entity (P_Type);
6464 while Present (Comp_Or_Discr) loop
6465 if Chars (Comp_Or_Discr) = Comp_Name then
6466
6467 -- Decorate the component reference by setting its entity
6468 -- and type for resolution purposes.
6469
6470 Set_Entity (Comp, Comp_Or_Discr);
6471 Set_Etype (Comp, Etype (Comp_Or_Discr));
6472 exit;
6473 end if;
6474
6475 Comp_Or_Discr := Next_Entity (Comp_Or_Discr);
6476 end loop;
6477
6478 -- Diagnose an illegal reference
6479
6480 if Present (Comp_Or_Discr) then
6481 if Ekind (Comp_Or_Discr) = E_Discriminant then
6482 Error_Attr
6483 ("attribute % may not modify record discriminants", Comp);
6484
6485 else pragma Assert (Ekind (Comp_Or_Discr) = E_Component);
6486 if Contains (Comps, Comp_Or_Discr) then
6487 Error_Msg_N ("component & already updated", Comp);
6488
6489 -- Mark this component as processed
6490
6491 else
6492 Append_New_Elmt (Comp_Or_Discr, Comps);
6493 end if;
6494 end if;
6495
6496 -- The update aggregate mentions an entity that does not belong to
6497 -- the record type.
6498
6499 else
6500 Error_Msg_N ("& is not a component of aggregate subtype", Comp);
6501 end if;
6502
6503 -- Verify the consistency of types when the current component is
6504 -- part of a miltiple component update.
6505
6506 -- Comp_1, ..., Comp_N => <value>
6507
6508 if Present (Etype (Comp)) then
6509 Base_Typ := Base_Type (Etype (Comp));
6510
6511 -- Save the type of the first component reference as the
6512 -- remaning references (if any) must resolve to this type.
6513
6514 if No (Common_Typ) then
6515 Common_Typ := Base_Typ;
6516
6517 elsif Base_Typ /= Common_Typ then
6518 Error_Msg_N
6519 ("components in choice list must have same type", Comp);
6520 end if;
6521 end if;
6522 end Analyze_Record_Component_Update;
6523
6524 -- Local variables
6525
6526 Assoc : Node_Id;
6527 Comp : Node_Id;
6528
6529 -- Start of processing for Update
6530
6531 begin
6532 Check_E1;
6533
6534 if not Is_Object_Reference (P) then
6535 Error_Attr_P ("prefix of attribute % must denote an object");
6536
6537 elsif not Is_Array_Type (P_Type)
6538 and then not Is_Record_Type (P_Type)
6539 then
6540 Error_Attr_P ("prefix of attribute % must be a record or array");
6541
6542 elsif Is_Limited_View (P_Type) then
6543 Error_Attr ("prefix of attribute % cannot be limited", N);
6544
6545 elsif Nkind (E1) /= N_Aggregate then
6546 Error_Attr ("attribute % requires component association list", N);
6547 end if;
6548
6549 -- Inspect the update aggregate, looking at all the associations and
6550 -- choices. Perform the following checks:
6551
6552 -- 1) Legality of "others" in all cases
6553 -- 2) Legality of <>
6554 -- 3) Component legality for arrays
6555 -- 4) Component legality for records
6556
6557 -- The remaining checks are performed on the expanded attribute
6558
6559 Assoc := First (Component_Associations (E1));
6560 while Present (Assoc) loop
6561
6562 -- The use of <> is illegal (SPARK RM 4.4.1(1))
6563
6564 if Box_Present (Assoc) then
6565 Error_Attr
6566 ("default initialization not allowed in attribute %", Assoc);
6567
6568 -- Otherwise process the association
6569
6570 else
6571 Analyze (Expression (Assoc));
6572
6573 if Is_Array_Type (P_Type) then
6574 Analyze_Array_Component_Update (Assoc);
6575
6576 elsif Is_Record_Type (P_Type) then
6577
6578 -- Reset the common type used in a multiple component update
6579 -- as we are processing the contents of a new association.
6580
6581 Common_Typ := Empty;
6582
6583 Comp := First (Choices (Assoc));
6584 while Present (Comp) loop
6585 if Nkind (Comp) = N_Identifier then
6586 Analyze_Record_Component_Update (Comp);
6587
6588 -- The use of others is illegal (SPARK RM 4.4.1(5))
6589
6590 elsif Nkind (Comp) = N_Others_Choice then
6591 Error_Attr
6592 ("others choice not allowed in attribute %", Comp);
6593
6594 -- The name of a record component cannot appear in any
6595 -- other form.
6596
6597 else
6598 Error_Msg_N
6599 ("name should be identifier or OTHERS", Comp);
6600 end if;
6601
6602 Next (Comp);
6603 end loop;
6604 end if;
6605 end if;
6606
6607 Next (Assoc);
6608 end loop;
6609
6610 -- The type of attribute 'Update is that of the prefix
6611
6612 Set_Etype (N, P_Type);
6613
6614 Sem_Warn.Warn_On_Suspicious_Update (N);
6615 end Update;
6616
6617 ---------
6618 -- Val --
6619 ---------
6620
6621 when Attribute_Val => Val : declare
6622 begin
6623 Check_E1;
6624 Check_Discrete_Type;
6625
6626 if Is_Boolean_Type (P_Type) then
6627 Error_Msg_Name_1 := Aname;
6628 Error_Msg_Name_2 := Chars (P_Type);
6629 Check_SPARK_05_Restriction
6630 ("attribute% is not allowed for type%", P);
6631 end if;
6632
6633 Resolve (E1, Any_Integer);
6634 Set_Etype (N, P_Base_Type);
6635
6636 -- Note, we need a range check in general, but we wait for the
6637 -- Resolve call to do this, since we want to let Eval_Attribute
6638 -- have a chance to find an static illegality first.
6639 end Val;
6640
6641 -----------
6642 -- Valid --
6643 -----------
6644
6645 when Attribute_Valid =>
6646 Check_E0;
6647
6648 -- Ignore check for object if we have a 'Valid reference generated
6649 -- by the expanded code, since in some cases valid checks can occur
6650 -- on items that are names, but are not objects (e.g. attributes).
6651
6652 if Comes_From_Source (N) then
6653 Check_Object_Reference (P);
6654 end if;
6655
6656 if not Is_Scalar_Type (P_Type) then
6657 Error_Attr_P ("object for % attribute must be of scalar type");
6658 end if;
6659
6660 -- If the attribute appears within the subtype's own predicate
6661 -- function, then issue a warning that this will cause infinite
6662 -- recursion.
6663
6664 declare
6665 Pred_Func : constant Entity_Id := Predicate_Function (P_Type);
6666
6667 begin
6668 if Present (Pred_Func) and then Current_Scope = Pred_Func then
6669 Error_Msg_N
6670 ("attribute Valid requires a predicate check??", N);
6671 Error_Msg_N ("\and will result in infinite recursion??", N);
6672 end if;
6673 end;
6674
6675 Set_Etype (N, Standard_Boolean);
6676
6677 -------------------
6678 -- Valid_Scalars --
6679 -------------------
6680
6681 when Attribute_Valid_Scalars =>
6682 Check_E0;
6683 Check_Object_Reference (P);
6684 Set_Etype (N, Standard_Boolean);
6685
6686 -- Following checks are only for source types
6687
6688 if Comes_From_Source (N) then
6689 if not Scalar_Part_Present (P_Type) then
6690 Error_Attr_P
6691 ("??attribute % always True, no scalars to check");
6692 end if;
6693
6694 -- Not allowed for unchecked union type
6695
6696 if Has_Unchecked_Union (P_Type) then
6697 Error_Attr_P
6698 ("attribute % not allowed for Unchecked_Union type");
6699 end if;
6700 end if;
6701
6702 -----------
6703 -- Value --
6704 -----------
6705
6706 when Attribute_Value => Value :
6707 begin
6708 Check_SPARK_05_Restriction_On_Attribute;
6709 Check_E1;
6710 Check_Scalar_Type;
6711
6712 -- Case of enumeration type
6713
6714 -- When an enumeration type appears in an attribute reference, all
6715 -- literals of the type are marked as referenced. This must only be
6716 -- done if the attribute reference appears in the current source.
6717 -- Otherwise the information on references may differ between a
6718 -- normal compilation and one that performs inlining.
6719
6720 if Is_Enumeration_Type (P_Type)
6721 and then In_Extended_Main_Code_Unit (N)
6722 then
6723 Check_Restriction (No_Enumeration_Maps, N);
6724
6725 -- Mark all enumeration literals as referenced, since the use of
6726 -- the Value attribute can implicitly reference any of the
6727 -- literals of the enumeration base type.
6728
6729 declare
6730 Ent : Entity_Id := First_Literal (P_Base_Type);
6731 begin
6732 while Present (Ent) loop
6733 Set_Referenced (Ent);
6734 Next_Literal (Ent);
6735 end loop;
6736 end;
6737 end if;
6738
6739 -- Set Etype before resolving expression because expansion of
6740 -- expression may require enclosing type. Note that the type
6741 -- returned by 'Value is the base type of the prefix type.
6742
6743 Set_Etype (N, P_Base_Type);
6744 Validate_Non_Static_Attribute_Function_Call;
6745
6746 -- Check restriction No_Fixed_IO
6747
6748 if Restriction_Check_Required (No_Fixed_IO)
6749 and then Is_Fixed_Point_Type (P_Type)
6750 then
6751 Check_Restriction (No_Fixed_IO, P);
6752 end if;
6753 end Value;
6754
6755 ----------------
6756 -- Value_Size --
6757 ----------------
6758
6759 when Attribute_Value_Size =>
6760 Check_E0;
6761 Check_Type;
6762 Check_Not_Incomplete_Type;
6763 Set_Etype (N, Universal_Integer);
6764
6765 -------------
6766 -- Version --
6767 -------------
6768
6769 when Attribute_Version =>
6770 Check_E0;
6771 Check_Program_Unit;
6772 Set_Etype (N, RTE (RE_Version_String));
6773
6774 ------------------
6775 -- Wchar_T_Size --
6776 ------------------
6777
6778 when Attribute_Wchar_T_Size =>
6779 Standard_Attribute (Interfaces_Wchar_T_Size);
6780
6781 ----------------
6782 -- Wide_Image --
6783 ----------------
6784
6785 when Attribute_Wide_Image => Wide_Image :
6786 begin
6787 Check_SPARK_05_Restriction_On_Attribute;
6788 Check_Scalar_Type;
6789 Set_Etype (N, Standard_Wide_String);
6790 Check_E1;
6791 Resolve (E1, P_Base_Type);
6792 Validate_Non_Static_Attribute_Function_Call;
6793
6794 -- Check restriction No_Fixed_IO
6795
6796 if Restriction_Check_Required (No_Fixed_IO)
6797 and then Is_Fixed_Point_Type (P_Type)
6798 then
6799 Check_Restriction (No_Fixed_IO, P);
6800 end if;
6801 end Wide_Image;
6802
6803 ---------------------
6804 -- Wide_Wide_Image --
6805 ---------------------
6806
6807 when Attribute_Wide_Wide_Image => Wide_Wide_Image :
6808 begin
6809 Check_Scalar_Type;
6810 Set_Etype (N, Standard_Wide_Wide_String);
6811 Check_E1;
6812 Resolve (E1, P_Base_Type);
6813 Validate_Non_Static_Attribute_Function_Call;
6814
6815 -- Check restriction No_Fixed_IO
6816
6817 if Restriction_Check_Required (No_Fixed_IO)
6818 and then Is_Fixed_Point_Type (P_Type)
6819 then
6820 Check_Restriction (No_Fixed_IO, P);
6821 end if;
6822 end Wide_Wide_Image;
6823
6824 ----------------
6825 -- Wide_Value --
6826 ----------------
6827
6828 when Attribute_Wide_Value => Wide_Value :
6829 begin
6830 Check_SPARK_05_Restriction_On_Attribute;
6831 Check_E1;
6832 Check_Scalar_Type;
6833
6834 -- Set Etype before resolving expression because expansion
6835 -- of expression may require enclosing type.
6836
6837 Set_Etype (N, P_Type);
6838 Validate_Non_Static_Attribute_Function_Call;
6839
6840 -- Check restriction No_Fixed_IO
6841
6842 if Restriction_Check_Required (No_Fixed_IO)
6843 and then Is_Fixed_Point_Type (P_Type)
6844 then
6845 Check_Restriction (No_Fixed_IO, P);
6846 end if;
6847 end Wide_Value;
6848
6849 ---------------------
6850 -- Wide_Wide_Value --
6851 ---------------------
6852
6853 when Attribute_Wide_Wide_Value => Wide_Wide_Value :
6854 begin
6855 Check_E1;
6856 Check_Scalar_Type;
6857
6858 -- Set Etype before resolving expression because expansion
6859 -- of expression may require enclosing type.
6860
6861 Set_Etype (N, P_Type);
6862 Validate_Non_Static_Attribute_Function_Call;
6863
6864 -- Check restriction No_Fixed_IO
6865
6866 if Restriction_Check_Required (No_Fixed_IO)
6867 and then Is_Fixed_Point_Type (P_Type)
6868 then
6869 Check_Restriction (No_Fixed_IO, P);
6870 end if;
6871 end Wide_Wide_Value;
6872
6873 ---------------------
6874 -- Wide_Wide_Width --
6875 ---------------------
6876
6877 when Attribute_Wide_Wide_Width =>
6878 Check_E0;
6879 Check_Scalar_Type;
6880 Set_Etype (N, Universal_Integer);
6881
6882 ----------------
6883 -- Wide_Width --
6884 ----------------
6885
6886 when Attribute_Wide_Width =>
6887 Check_SPARK_05_Restriction_On_Attribute;
6888 Check_E0;
6889 Check_Scalar_Type;
6890 Set_Etype (N, Universal_Integer);
6891
6892 -----------
6893 -- Width --
6894 -----------
6895
6896 when Attribute_Width =>
6897 Check_SPARK_05_Restriction_On_Attribute;
6898 Check_E0;
6899 Check_Scalar_Type;
6900 Set_Etype (N, Universal_Integer);
6901
6902 ---------------
6903 -- Word_Size --
6904 ---------------
6905
6906 when Attribute_Word_Size =>
6907 Standard_Attribute (System_Word_Size);
6908
6909 -----------
6910 -- Write --
6911 -----------
6912
6913 when Attribute_Write =>
6914 Check_E2;
6915 Check_Stream_Attribute (TSS_Stream_Write);
6916 Set_Etype (N, Standard_Void_Type);
6917 Resolve (N, Standard_Void_Type);
6918
6919 end case;
6920
6921 -- All errors raise Bad_Attribute, so that we get out before any further
6922 -- damage occurs when an error is detected (for example, if we check for
6923 -- one attribute expression, and the check succeeds, we want to be able
6924 -- to proceed securely assuming that an expression is in fact present.
6925
6926 -- Note: we set the attribute analyzed in this case to prevent any
6927 -- attempt at reanalysis which could generate spurious error msgs.
6928
6929 exception
6930 when Bad_Attribute =>
6931 Set_Analyzed (N);
6932 Set_Etype (N, Any_Type);
6933 return;
6934 end Analyze_Attribute;
6935
6936 --------------------
6937 -- Eval_Attribute --
6938 --------------------
6939
6940 procedure Eval_Attribute (N : Node_Id) is
6941 Loc : constant Source_Ptr := Sloc (N);
6942 Aname : constant Name_Id := Attribute_Name (N);
6943 Id : constant Attribute_Id := Get_Attribute_Id (Aname);
6944 P : constant Node_Id := Prefix (N);
6945
6946 C_Type : constant Entity_Id := Etype (N);
6947 -- The type imposed by the context
6948
6949 E1 : Node_Id;
6950 -- First expression, or Empty if none
6951
6952 E2 : Node_Id;
6953 -- Second expression, or Empty if none
6954
6955 P_Entity : Entity_Id;
6956 -- Entity denoted by prefix
6957
6958 P_Type : Entity_Id;
6959 -- The type of the prefix
6960
6961 P_Base_Type : Entity_Id;
6962 -- The base type of the prefix type
6963
6964 P_Root_Type : Entity_Id;
6965 -- The root type of the prefix type
6966
6967 Static : Boolean;
6968 -- True if the result is Static. This is set by the general processing
6969 -- to true if the prefix is static, and all expressions are static. It
6970 -- can be reset as processing continues for particular attributes. This
6971 -- flag can still be True if the reference raises a constraint error.
6972 -- Is_Static_Expression (N) is set to follow this value as it is set
6973 -- and we could always reference this, but it is convenient to have a
6974 -- simple short name to use, since it is frequently referenced.
6975
6976 Lo_Bound, Hi_Bound : Node_Id;
6977 -- Expressions for low and high bounds of type or array index referenced
6978 -- by First, Last, or Length attribute for array, set by Set_Bounds.
6979
6980 CE_Node : Node_Id;
6981 -- Constraint error node used if we have an attribute reference has
6982 -- an argument that raises a constraint error. In this case we replace
6983 -- the attribute with a raise constraint_error node. This is important
6984 -- processing, since otherwise gigi might see an attribute which it is
6985 -- unprepared to deal with.
6986
6987 procedure Check_Concurrent_Discriminant (Bound : Node_Id);
6988 -- If Bound is a reference to a discriminant of a task or protected type
6989 -- occurring within the object's body, rewrite attribute reference into
6990 -- a reference to the corresponding discriminal. Use for the expansion
6991 -- of checks against bounds of entry family index subtypes.
6992
6993 procedure Check_Expressions;
6994 -- In case where the attribute is not foldable, the expressions, if
6995 -- any, of the attribute, are in a non-static context. This procedure
6996 -- performs the required additional checks.
6997
6998 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean;
6999 -- Determines if the given type has compile time known bounds. Note
7000 -- that we enter the case statement even in cases where the prefix
7001 -- type does NOT have known bounds, so it is important to guard any
7002 -- attempt to evaluate both bounds with a call to this function.
7003
7004 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint);
7005 -- This procedure is called when the attribute N has a non-static
7006 -- but compile time known value given by Val. It includes the
7007 -- necessary checks for out of range values.
7008
7009 function Fore_Value return Nat;
7010 -- Computes the Fore value for the current attribute prefix, which is
7011 -- known to be a static fixed-point type. Used by Fore and Width.
7012
7013 function Mantissa return Uint;
7014 -- Returns the Mantissa value for the prefix type
7015
7016 procedure Set_Bounds;
7017 -- Used for First, Last and Length attributes applied to an array or
7018 -- array subtype. Sets the variables Lo_Bound and Hi_Bound to the low
7019 -- and high bound expressions for the index referenced by the attribute
7020 -- designator (i.e. the first index if no expression is present, and the
7021 -- N'th index if the value N is present as an expression). Also used for
7022 -- First and Last of scalar types and for First_Valid and Last_Valid.
7023 -- Static is reset to False if the type or index type is not statically
7024 -- constrained.
7025
7026 function Statically_Denotes_Entity (N : Node_Id) return Boolean;
7027 -- Verify that the prefix of a potentially static array attribute
7028 -- satisfies the conditions of 4.9 (14).
7029
7030 -----------------------------------
7031 -- Check_Concurrent_Discriminant --
7032 -----------------------------------
7033
7034 procedure Check_Concurrent_Discriminant (Bound : Node_Id) is
7035 Tsk : Entity_Id;
7036 -- The concurrent (task or protected) type
7037
7038 begin
7039 if Nkind (Bound) = N_Identifier
7040 and then Ekind (Entity (Bound)) = E_Discriminant
7041 and then Is_Concurrent_Record_Type (Scope (Entity (Bound)))
7042 then
7043 Tsk := Corresponding_Concurrent_Type (Scope (Entity (Bound)));
7044
7045 if In_Open_Scopes (Tsk) and then Has_Completion (Tsk) then
7046
7047 -- Find discriminant of original concurrent type, and use
7048 -- its current discriminal, which is the renaming within
7049 -- the task/protected body.
7050
7051 Rewrite (N,
7052 New_Occurrence_Of
7053 (Find_Body_Discriminal (Entity (Bound)), Loc));
7054 end if;
7055 end if;
7056 end Check_Concurrent_Discriminant;
7057
7058 -----------------------
7059 -- Check_Expressions --
7060 -----------------------
7061
7062 procedure Check_Expressions is
7063 E : Node_Id;
7064 begin
7065 E := E1;
7066 while Present (E) loop
7067 Check_Non_Static_Context (E);
7068 Next (E);
7069 end loop;
7070 end Check_Expressions;
7071
7072 ----------------------------------
7073 -- Compile_Time_Known_Attribute --
7074 ----------------------------------
7075
7076 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint) is
7077 T : constant Entity_Id := Etype (N);
7078
7079 begin
7080 Fold_Uint (N, Val, False);
7081
7082 -- Check that result is in bounds of the type if it is static
7083
7084 if Is_In_Range (N, T, Assume_Valid => False) then
7085 null;
7086
7087 elsif Is_Out_Of_Range (N, T) then
7088 Apply_Compile_Time_Constraint_Error
7089 (N, "value not in range of}??", CE_Range_Check_Failed);
7090
7091 elsif not Range_Checks_Suppressed (T) then
7092 Enable_Range_Check (N);
7093
7094 else
7095 Set_Do_Range_Check (N, False);
7096 end if;
7097 end Compile_Time_Known_Attribute;
7098
7099 -------------------------------
7100 -- Compile_Time_Known_Bounds --
7101 -------------------------------
7102
7103 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean is
7104 begin
7105 return
7106 Compile_Time_Known_Value (Type_Low_Bound (Typ))
7107 and then
7108 Compile_Time_Known_Value (Type_High_Bound (Typ));
7109 end Compile_Time_Known_Bounds;
7110
7111 ----------------
7112 -- Fore_Value --
7113 ----------------
7114
7115 -- Note that the Fore calculation is based on the actual values
7116 -- of the bounds, and does not take into account possible rounding.
7117
7118 function Fore_Value return Nat is
7119 Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type));
7120 Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type));
7121 Small : constant Ureal := Small_Value (P_Type);
7122 Lo_Real : constant Ureal := Lo * Small;
7123 Hi_Real : constant Ureal := Hi * Small;
7124 T : Ureal;
7125 R : Nat;
7126
7127 begin
7128 -- Bounds are given in terms of small units, so first compute
7129 -- proper values as reals.
7130
7131 T := UR_Max (abs Lo_Real, abs Hi_Real);
7132 R := 2;
7133
7134 -- Loop to compute proper value if more than one digit required
7135
7136 while T >= Ureal_10 loop
7137 R := R + 1;
7138 T := T / Ureal_10;
7139 end loop;
7140
7141 return R;
7142 end Fore_Value;
7143
7144 --------------
7145 -- Mantissa --
7146 --------------
7147
7148 -- Table of mantissa values accessed by function Computed using
7149 -- the relation:
7150
7151 -- T'Mantissa = integer next above (D * log(10)/log(2)) + 1)
7152
7153 -- where D is T'Digits (RM83 3.5.7)
7154
7155 Mantissa_Value : constant array (Nat range 1 .. 40) of Nat := (
7156 1 => 5,
7157 2 => 8,
7158 3 => 11,
7159 4 => 15,
7160 5 => 18,
7161 6 => 21,
7162 7 => 25,
7163 8 => 28,
7164 9 => 31,
7165 10 => 35,
7166 11 => 38,
7167 12 => 41,
7168 13 => 45,
7169 14 => 48,
7170 15 => 51,
7171 16 => 55,
7172 17 => 58,
7173 18 => 61,
7174 19 => 65,
7175 20 => 68,
7176 21 => 71,
7177 22 => 75,
7178 23 => 78,
7179 24 => 81,
7180 25 => 85,
7181 26 => 88,
7182 27 => 91,
7183 28 => 95,
7184 29 => 98,
7185 30 => 101,
7186 31 => 104,
7187 32 => 108,
7188 33 => 111,
7189 34 => 114,
7190 35 => 118,
7191 36 => 121,
7192 37 => 124,
7193 38 => 128,
7194 39 => 131,
7195 40 => 134);
7196
7197 function Mantissa return Uint is
7198 begin
7199 return
7200 UI_From_Int (Mantissa_Value (UI_To_Int (Digits_Value (P_Type))));
7201 end Mantissa;
7202
7203 ----------------
7204 -- Set_Bounds --
7205 ----------------
7206
7207 procedure Set_Bounds is
7208 Ndim : Nat;
7209 Indx : Node_Id;
7210 Ityp : Entity_Id;
7211
7212 begin
7213 -- For a string literal subtype, we have to construct the bounds.
7214 -- Valid Ada code never applies attributes to string literals, but
7215 -- it is convenient to allow the expander to generate attribute
7216 -- references of this type (e.g. First and Last applied to a string
7217 -- literal).
7218
7219 -- Note that the whole point of the E_String_Literal_Subtype is to
7220 -- avoid this construction of bounds, but the cases in which we
7221 -- have to materialize them are rare enough that we don't worry.
7222
7223 -- The low bound is simply the low bound of the base type. The
7224 -- high bound is computed from the length of the string and this
7225 -- low bound.
7226
7227 if Ekind (P_Type) = E_String_Literal_Subtype then
7228 Ityp := Etype (First_Index (Base_Type (P_Type)));
7229 Lo_Bound := Type_Low_Bound (Ityp);
7230
7231 Hi_Bound :=
7232 Make_Integer_Literal (Sloc (P),
7233 Intval =>
7234 Expr_Value (Lo_Bound) + String_Literal_Length (P_Type) - 1);
7235
7236 Set_Parent (Hi_Bound, P);
7237 Analyze_And_Resolve (Hi_Bound, Etype (Lo_Bound));
7238 return;
7239
7240 -- For non-array case, just get bounds of scalar type
7241
7242 elsif Is_Scalar_Type (P_Type) then
7243 Ityp := P_Type;
7244
7245 -- For a fixed-point type, we must freeze to get the attributes
7246 -- of the fixed-point type set now so we can reference them.
7247
7248 if Is_Fixed_Point_Type (P_Type)
7249 and then not Is_Frozen (Base_Type (P_Type))
7250 and then Compile_Time_Known_Value (Type_Low_Bound (P_Type))
7251 and then Compile_Time_Known_Value (Type_High_Bound (P_Type))
7252 then
7253 Freeze_Fixed_Point_Type (Base_Type (P_Type));
7254 end if;
7255
7256 -- For array case, get type of proper index
7257
7258 else
7259 if No (E1) then
7260 Ndim := 1;
7261 else
7262 Ndim := UI_To_Int (Expr_Value (E1));
7263 end if;
7264
7265 Indx := First_Index (P_Type);
7266 for J in 1 .. Ndim - 1 loop
7267 Next_Index (Indx);
7268 end loop;
7269
7270 -- If no index type, get out (some other error occurred, and
7271 -- we don't have enough information to complete the job).
7272
7273 if No (Indx) then
7274 Lo_Bound := Error;
7275 Hi_Bound := Error;
7276 return;
7277 end if;
7278
7279 Ityp := Etype (Indx);
7280 end if;
7281
7282 -- A discrete range in an index constraint is allowed to be a
7283 -- subtype indication. This is syntactically a pain, but should
7284 -- not propagate to the entity for the corresponding index subtype.
7285 -- After checking that the subtype indication is legal, the range
7286 -- of the subtype indication should be transfered to the entity.
7287 -- The attributes for the bounds should remain the simple retrievals
7288 -- that they are now.
7289
7290 Lo_Bound := Type_Low_Bound (Ityp);
7291 Hi_Bound := Type_High_Bound (Ityp);
7292
7293 -- If subtype is non-static, result is definitely non-static
7294
7295 if not Is_Static_Subtype (Ityp) then
7296 Static := False;
7297 Set_Is_Static_Expression (N, False);
7298
7299 -- Subtype is static, does it raise CE?
7300
7301 elsif not Is_OK_Static_Subtype (Ityp) then
7302 Set_Raises_Constraint_Error (N);
7303 end if;
7304 end Set_Bounds;
7305
7306 -------------------------------
7307 -- Statically_Denotes_Entity --
7308 -------------------------------
7309
7310 function Statically_Denotes_Entity (N : Node_Id) return Boolean is
7311 E : Entity_Id;
7312
7313 begin
7314 if not Is_Entity_Name (N) then
7315 return False;
7316 else
7317 E := Entity (N);
7318 end if;
7319
7320 return
7321 Nkind (Parent (E)) /= N_Object_Renaming_Declaration
7322 or else Statically_Denotes_Entity (Renamed_Object (E));
7323 end Statically_Denotes_Entity;
7324
7325 -- Start of processing for Eval_Attribute
7326
7327 begin
7328 -- Initialize result as non-static, will be reset if appropriate
7329
7330 Set_Is_Static_Expression (N, False);
7331 Static := False;
7332
7333 -- Acquire first two expressions (at the moment, no attributes take more
7334 -- than two expressions in any case).
7335
7336 if Present (Expressions (N)) then
7337 E1 := First (Expressions (N));
7338 E2 := Next (E1);
7339 else
7340 E1 := Empty;
7341 E2 := Empty;
7342 end if;
7343
7344 -- Special processing for Enabled attribute. This attribute has a very
7345 -- special prefix, and the easiest way to avoid lots of special checks
7346 -- to protect this special prefix from causing trouble is to deal with
7347 -- this attribute immediately and be done with it.
7348
7349 if Id = Attribute_Enabled then
7350
7351 -- We skip evaluation if the expander is not active. This is not just
7352 -- an optimization. It is of key importance that we not rewrite the
7353 -- attribute in a generic template, since we want to pick up the
7354 -- setting of the check in the instance, Testing Expander_Active
7355 -- might seem an easy way of doing this, but we need to account for
7356 -- ASIS needs, so check explicitly for a generic context.
7357
7358 if not Inside_A_Generic then
7359 declare
7360 C : constant Check_Id := Get_Check_Id (Chars (P));
7361 R : Boolean;
7362
7363 begin
7364 if No (E1) then
7365 if C in Predefined_Check_Id then
7366 R := Scope_Suppress.Suppress (C);
7367 else
7368 R := Is_Check_Suppressed (Empty, C);
7369 end if;
7370
7371 else
7372 R := Is_Check_Suppressed (Entity (E1), C);
7373 end if;
7374
7375 Rewrite (N, New_Occurrence_Of (Boolean_Literals (not R), Loc));
7376 end;
7377 end if;
7378
7379 return;
7380 end if;
7381
7382 -- Attribute 'Img applied to a static enumeration value is static, and
7383 -- we will do the folding right here (things get confused if we let this
7384 -- case go through the normal circuitry).
7385
7386 if Attribute_Name (N) = Name_Img
7387 and then Is_Entity_Name (P)
7388 and then Is_Enumeration_Type (Etype (Entity (P)))
7389 and then Is_OK_Static_Expression (P)
7390 then
7391 declare
7392 Lit : constant Entity_Id := Expr_Value_E (P);
7393 Str : String_Id;
7394
7395 begin
7396 Start_String;
7397 Get_Unqualified_Decoded_Name_String (Chars (Lit));
7398 Set_Casing (All_Upper_Case);
7399 Store_String_Chars (Name_Buffer (1 .. Name_Len));
7400 Str := End_String;
7401
7402 Rewrite (N, Make_String_Literal (Loc, Strval => Str));
7403 Analyze_And_Resolve (N, Standard_String);
7404 Set_Is_Static_Expression (N, True);
7405 end;
7406
7407 return;
7408 end if;
7409
7410 -- Special processing for cases where the prefix is an object. For this
7411 -- purpose, a string literal counts as an object (attributes of string
7412 -- literals can only appear in generated code).
7413
7414 if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then
7415
7416 -- For Component_Size, the prefix is an array object, and we apply
7417 -- the attribute to the type of the object. This is allowed for both
7418 -- unconstrained and constrained arrays, since the bounds have no
7419 -- influence on the value of this attribute.
7420
7421 if Id = Attribute_Component_Size then
7422 P_Entity := Etype (P);
7423
7424 -- For Enum_Rep, evaluation depends on the nature of the prefix and
7425 -- the optional argument.
7426
7427 elsif Id = Attribute_Enum_Rep then
7428 if Is_Entity_Name (P) then
7429
7430 declare
7431 Enum_Expr : Node_Id;
7432 -- The enumeration-type expression of interest
7433
7434 begin
7435 -- P'Enum_Rep case
7436
7437 if Ekind_In (Entity (P), E_Constant,
7438 E_Enumeration_Literal)
7439 then
7440 Enum_Expr := P;
7441
7442 -- Enum_Type'Enum_Rep (E1) case
7443
7444 elsif Is_Enumeration_Type (Entity (P)) then
7445 Enum_Expr := E1;
7446
7447 -- Otherwise the attribute must be expanded into a
7448 -- conversion and evaluated at run time.
7449
7450 else
7451 Check_Expressions;
7452 return;
7453 end if;
7454
7455 -- We can fold if the expression is an enumeration
7456 -- literal, or if it denotes a constant whose value
7457 -- is known at compile time.
7458
7459 if Nkind (Enum_Expr) in N_Has_Entity
7460 and then (Ekind (Entity (Enum_Expr)) =
7461 E_Enumeration_Literal
7462 or else
7463 (Ekind (Entity (Enum_Expr)) = E_Constant
7464 and then Nkind (Parent (Entity (Enum_Expr))) =
7465 N_Object_Declaration
7466 and then Compile_Time_Known_Value
7467 (Expression (Parent (Entity (P))))))
7468 then
7469 P_Entity := Etype (P);
7470 else
7471 Check_Expressions;
7472 return;
7473 end if;
7474 end;
7475
7476 -- Otherwise the attribute is illegal, do not attempt to perform
7477 -- any kind of folding.
7478
7479 else
7480 return;
7481 end if;
7482
7483 -- For First and Last, the prefix is an array object, and we apply
7484 -- the attribute to the type of the array, but we need a constrained
7485 -- type for this, so we use the actual subtype if available.
7486
7487 elsif Id = Attribute_First or else
7488 Id = Attribute_Last or else
7489 Id = Attribute_Length
7490 then
7491 declare
7492 AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P);
7493
7494 begin
7495 if Present (AS) and then Is_Constrained (AS) then
7496 P_Entity := AS;
7497
7498 -- If we have an unconstrained type we cannot fold
7499
7500 else
7501 Check_Expressions;
7502 return;
7503 end if;
7504 end;
7505
7506 -- For Size, give size of object if available, otherwise we
7507 -- cannot fold Size.
7508
7509 elsif Id = Attribute_Size then
7510 if Is_Entity_Name (P)
7511 and then Known_Esize (Entity (P))
7512 then
7513 Compile_Time_Known_Attribute (N, Esize (Entity (P)));
7514 return;
7515
7516 else
7517 Check_Expressions;
7518 return;
7519 end if;
7520
7521 -- For Alignment, give size of object if available, otherwise we
7522 -- cannot fold Alignment.
7523
7524 elsif Id = Attribute_Alignment then
7525 if Is_Entity_Name (P)
7526 and then Known_Alignment (Entity (P))
7527 then
7528 Fold_Uint (N, Alignment (Entity (P)), Static);
7529 return;
7530
7531 else
7532 Check_Expressions;
7533 return;
7534 end if;
7535
7536 -- For Lock_Free, we apply the attribute to the type of the object.
7537 -- This is allowed since we have already verified that the type is a
7538 -- protected type.
7539
7540 elsif Id = Attribute_Lock_Free then
7541 P_Entity := Etype (P);
7542
7543 -- No other attributes for objects are folded
7544
7545 else
7546 Check_Expressions;
7547 return;
7548 end if;
7549
7550 -- Cases where P is not an object. Cannot do anything if P is not the
7551 -- name of an entity.
7552
7553 elsif not Is_Entity_Name (P) then
7554 Check_Expressions;
7555 return;
7556
7557 -- Otherwise get prefix entity
7558
7559 else
7560 P_Entity := Entity (P);
7561 end if;
7562
7563 -- If we are asked to evaluate an attribute where the prefix is a
7564 -- non-frozen generic actual type whose RM_Size is still set to zero,
7565 -- then abandon the effort.
7566
7567 if Is_Type (P_Entity)
7568 and then (not Is_Frozen (P_Entity)
7569 and then Is_Generic_Actual_Type (P_Entity)
7570 and then RM_Size (P_Entity) = 0)
7571
7572 -- However, the attribute Unconstrained_Array must be evaluated,
7573 -- since it is documented to be a static attribute (and can for
7574 -- example appear in a Compile_Time_Warning pragma). The frozen
7575 -- status of the type does not affect its evaluation.
7576
7577 and then Id /= Attribute_Unconstrained_Array
7578 then
7579 return;
7580 end if;
7581
7582 -- At this stage P_Entity is the entity to which the attribute
7583 -- is to be applied. This is usually simply the entity of the
7584 -- prefix, except in some cases of attributes for objects, where
7585 -- as described above, we apply the attribute to the object type.
7586
7587 -- Here is where we make sure that static attributes are properly
7588 -- marked as such. These are attributes whose prefix is a static
7589 -- scalar subtype, whose result is scalar, and whose arguments, if
7590 -- present, are static scalar expressions. Note that such references
7591 -- are static expressions even if they raise Constraint_Error.
7592
7593 -- For example, Boolean'Pos (1/0 = 0) is a static expression, even
7594 -- though evaluating it raises constraint error. This means that a
7595 -- declaration like:
7596
7597 -- X : constant := (if True then 1 else Boolean'Pos (1/0 = 0));
7598
7599 -- is legal, since here this expression appears in a statically
7600 -- unevaluated position, so it does not actually raise an exception.
7601
7602 if Is_Scalar_Type (P_Entity)
7603 and then (not Is_Generic_Type (P_Entity))
7604 and then Is_Static_Subtype (P_Entity)
7605 and then Is_Scalar_Type (Etype (N))
7606 and then
7607 (No (E1)
7608 or else (Is_Static_Expression (E1)
7609 and then Is_Scalar_Type (Etype (E1))))
7610 and then
7611 (No (E2)
7612 or else (Is_Static_Expression (E2)
7613 and then Is_Scalar_Type (Etype (E1))))
7614 then
7615 Static := True;
7616 Set_Is_Static_Expression (N, True);
7617 end if;
7618
7619 -- First foldable possibility is a scalar or array type (RM 4.9(7))
7620 -- that is not generic (generic types are eliminated by RM 4.9(25)).
7621 -- Note we allow non-static non-generic types at this stage as further
7622 -- described below.
7623
7624 if Is_Type (P_Entity)
7625 and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity))
7626 and then (not Is_Generic_Type (P_Entity))
7627 then
7628 P_Type := P_Entity;
7629
7630 -- Second foldable possibility is an array object (RM 4.9(8))
7631
7632 elsif Ekind_In (P_Entity, E_Variable, E_Constant)
7633 and then Is_Array_Type (Etype (P_Entity))
7634 and then (not Is_Generic_Type (Etype (P_Entity)))
7635 then
7636 P_Type := Etype (P_Entity);
7637
7638 -- If the entity is an array constant with an unconstrained nominal
7639 -- subtype then get the type from the initial value. If the value has
7640 -- been expanded into assignments, there is no expression and the
7641 -- attribute reference remains dynamic.
7642
7643 -- We could do better here and retrieve the type ???
7644
7645 if Ekind (P_Entity) = E_Constant
7646 and then not Is_Constrained (P_Type)
7647 then
7648 if No (Constant_Value (P_Entity)) then
7649 return;
7650 else
7651 P_Type := Etype (Constant_Value (P_Entity));
7652 end if;
7653 end if;
7654
7655 -- Definite must be folded if the prefix is not a generic type, that
7656 -- is to say if we are within an instantiation. Same processing applies
7657 -- to the GNAT attributes Atomic_Always_Lock_Free, Has_Discriminants,
7658 -- Lock_Free, Type_Class, Has_Tagged_Value, and Unconstrained_Array.
7659
7660 elsif (Id = Attribute_Atomic_Always_Lock_Free or else
7661 Id = Attribute_Definite or else
7662 Id = Attribute_Has_Access_Values or else
7663 Id = Attribute_Has_Discriminants or else
7664 Id = Attribute_Has_Tagged_Values or else
7665 Id = Attribute_Lock_Free or else
7666 Id = Attribute_Type_Class or else
7667 Id = Attribute_Unconstrained_Array or else
7668 Id = Attribute_Max_Alignment_For_Allocation)
7669 and then not Is_Generic_Type (P_Entity)
7670 then
7671 P_Type := P_Entity;
7672
7673 -- We can fold 'Size applied to a type if the size is known (as happens
7674 -- for a size from an attribute definition clause). At this stage, this
7675 -- can happen only for types (e.g. record types) for which the size is
7676 -- always non-static. We exclude generic types from consideration (since
7677 -- they have bogus sizes set within templates).
7678
7679 elsif Id = Attribute_Size
7680 and then Is_Type (P_Entity)
7681 and then (not Is_Generic_Type (P_Entity))
7682 and then Known_Static_RM_Size (P_Entity)
7683 then
7684 Compile_Time_Known_Attribute (N, RM_Size (P_Entity));
7685 return;
7686
7687 -- We can fold 'Alignment applied to a type if the alignment is known
7688 -- (as happens for an alignment from an attribute definition clause).
7689 -- At this stage, this can happen only for types (e.g. record types) for
7690 -- which the size is always non-static. We exclude generic types from
7691 -- consideration (since they have bogus sizes set within templates).
7692
7693 elsif Id = Attribute_Alignment
7694 and then Is_Type (P_Entity)
7695 and then (not Is_Generic_Type (P_Entity))
7696 and then Known_Alignment (P_Entity)
7697 then
7698 Compile_Time_Known_Attribute (N, Alignment (P_Entity));
7699 return;
7700
7701 -- If this is an access attribute that is known to fail accessibility
7702 -- check, rewrite accordingly.
7703
7704 elsif Attribute_Name (N) = Name_Access
7705 and then Raises_Constraint_Error (N)
7706 then
7707 Rewrite (N,
7708 Make_Raise_Program_Error (Loc,
7709 Reason => PE_Accessibility_Check_Failed));
7710 Set_Etype (N, C_Type);
7711 return;
7712
7713 -- No other cases are foldable (they certainly aren't static, and at
7714 -- the moment we don't try to fold any cases other than the ones above).
7715
7716 else
7717 Check_Expressions;
7718 return;
7719 end if;
7720
7721 -- If either attribute or the prefix is Any_Type, then propagate
7722 -- Any_Type to the result and don't do anything else at all.
7723
7724 if P_Type = Any_Type
7725 or else (Present (E1) and then Etype (E1) = Any_Type)
7726 or else (Present (E2) and then Etype (E2) = Any_Type)
7727 then
7728 Set_Etype (N, Any_Type);
7729 return;
7730 end if;
7731
7732 -- Scalar subtype case. We have not yet enforced the static requirement
7733 -- of (RM 4.9(7)) and we don't intend to just yet, since there are cases
7734 -- of non-static attribute references (e.g. S'Digits for a non-static
7735 -- floating-point type, which we can compute at compile time).
7736
7737 -- Note: this folding of non-static attributes is not simply a case of
7738 -- optimization. For many of the attributes affected, Gigi cannot handle
7739 -- the attribute and depends on the front end having folded them away.
7740
7741 -- Note: although we don't require staticness at this stage, we do set
7742 -- the Static variable to record the staticness, for easy reference by
7743 -- those attributes where it matters (e.g. Succ and Pred), and also to
7744 -- be used to ensure that non-static folded things are not marked as
7745 -- being static (a check that is done right at the end).
7746
7747 P_Root_Type := Root_Type (P_Type);
7748 P_Base_Type := Base_Type (P_Type);
7749
7750 -- If the root type or base type is generic, then we cannot fold. This
7751 -- test is needed because subtypes of generic types are not always
7752 -- marked as being generic themselves (which seems odd???)
7753
7754 if Is_Generic_Type (P_Root_Type)
7755 or else Is_Generic_Type (P_Base_Type)
7756 then
7757 return;
7758 end if;
7759
7760 if Is_Scalar_Type (P_Type) then
7761 if not Is_Static_Subtype (P_Type) then
7762 Static := False;
7763 Set_Is_Static_Expression (N, False);
7764 elsif not Is_OK_Static_Subtype (P_Type) then
7765 Set_Raises_Constraint_Error (N);
7766 end if;
7767
7768 -- Array case. We enforce the constrained requirement of (RM 4.9(7-8))
7769 -- since we can't do anything with unconstrained arrays. In addition,
7770 -- only the First, Last and Length attributes are possibly static.
7771
7772 -- Atomic_Always_Lock_Free, Definite, Has_Access_Values,
7773 -- Has_Discriminants, Has_Tagged_Values, Lock_Free, Type_Class, and
7774 -- Unconstrained_Array are again exceptions, because they apply as well
7775 -- to unconstrained types.
7776
7777 -- In addition Component_Size is an exception since it is possibly
7778 -- foldable, even though it is never static, and it does apply to
7779 -- unconstrained arrays. Furthermore, it is essential to fold this
7780 -- in the packed case, since otherwise the value will be incorrect.
7781
7782 elsif Id = Attribute_Atomic_Always_Lock_Free or else
7783 Id = Attribute_Definite or else
7784 Id = Attribute_Has_Access_Values or else
7785 Id = Attribute_Has_Discriminants or else
7786 Id = Attribute_Has_Tagged_Values or else
7787 Id = Attribute_Lock_Free or else
7788 Id = Attribute_Type_Class or else
7789 Id = Attribute_Unconstrained_Array or else
7790 Id = Attribute_Component_Size
7791 then
7792 Static := False;
7793 Set_Is_Static_Expression (N, False);
7794
7795 elsif Id /= Attribute_Max_Alignment_For_Allocation then
7796 if not Is_Constrained (P_Type)
7797 or else (Id /= Attribute_First and then
7798 Id /= Attribute_Last and then
7799 Id /= Attribute_Length)
7800 then
7801 Check_Expressions;
7802 return;
7803 end if;
7804
7805 -- The rules in (RM 4.9(7,8)) require a static array, but as in the
7806 -- scalar case, we hold off on enforcing staticness, since there are
7807 -- cases which we can fold at compile time even though they are not
7808 -- static (e.g. 'Length applied to a static index, even though other
7809 -- non-static indexes make the array type non-static). This is only
7810 -- an optimization, but it falls out essentially free, so why not.
7811 -- Again we compute the variable Static for easy reference later
7812 -- (note that no array attributes are static in Ada 83).
7813
7814 -- We also need to set Static properly for subsequent legality checks
7815 -- which might otherwise accept non-static constants in contexts
7816 -- where they are not legal.
7817
7818 Static :=
7819 Ada_Version >= Ada_95 and then Statically_Denotes_Entity (P);
7820 Set_Is_Static_Expression (N, Static);
7821
7822 declare
7823 Nod : Node_Id;
7824
7825 begin
7826 Nod := First_Index (P_Type);
7827
7828 -- The expression is static if the array type is constrained
7829 -- by given bounds, and not by an initial expression. Constant
7830 -- strings are static in any case.
7831
7832 if Root_Type (P_Type) /= Standard_String then
7833 Static :=
7834 Static and then not Is_Constr_Subt_For_U_Nominal (P_Type);
7835 Set_Is_Static_Expression (N, Static);
7836 end if;
7837
7838 while Present (Nod) loop
7839 if not Is_Static_Subtype (Etype (Nod)) then
7840 Static := False;
7841 Set_Is_Static_Expression (N, False);
7842
7843 elsif not Is_OK_Static_Subtype (Etype (Nod)) then
7844 Set_Raises_Constraint_Error (N);
7845 Static := False;
7846 Set_Is_Static_Expression (N, False);
7847 end if;
7848
7849 -- If however the index type is generic, or derived from
7850 -- one, attributes cannot be folded.
7851
7852 if Is_Generic_Type (Root_Type (Etype (Nod)))
7853 and then Id /= Attribute_Component_Size
7854 then
7855 return;
7856 end if;
7857
7858 Next_Index (Nod);
7859 end loop;
7860 end;
7861 end if;
7862
7863 -- Check any expressions that are present. Note that these expressions,
7864 -- depending on the particular attribute type, are either part of the
7865 -- attribute designator, or they are arguments in a case where the
7866 -- attribute reference returns a function. In the latter case, the
7867 -- rule in (RM 4.9(22)) applies and in particular requires the type
7868 -- of the expressions to be scalar in order for the attribute to be
7869 -- considered to be static.
7870
7871 declare
7872 E : Node_Id;
7873
7874 begin
7875 E := E1;
7876
7877 while Present (E) loop
7878
7879 -- If expression is not static, then the attribute reference
7880 -- result certainly cannot be static.
7881
7882 if not Is_Static_Expression (E) then
7883 Static := False;
7884 Set_Is_Static_Expression (N, False);
7885 end if;
7886
7887 if Raises_Constraint_Error (E) then
7888 Set_Raises_Constraint_Error (N);
7889 end if;
7890
7891 -- If the result is not known at compile time, or is not of
7892 -- a scalar type, then the result is definitely not static,
7893 -- so we can quit now.
7894
7895 if not Compile_Time_Known_Value (E)
7896 or else not Is_Scalar_Type (Etype (E))
7897 then
7898 -- An odd special case, if this is a Pos attribute, this
7899 -- is where we need to apply a range check since it does
7900 -- not get done anywhere else.
7901
7902 if Id = Attribute_Pos then
7903 if Is_Integer_Type (Etype (E)) then
7904 Apply_Range_Check (E, Etype (N));
7905 end if;
7906 end if;
7907
7908 Check_Expressions;
7909 return;
7910
7911 -- If the expression raises a constraint error, then so does
7912 -- the attribute reference. We keep going in this case because
7913 -- we are still interested in whether the attribute reference
7914 -- is static even if it is not static.
7915
7916 elsif Raises_Constraint_Error (E) then
7917 Set_Raises_Constraint_Error (N);
7918 end if;
7919
7920 Next (E);
7921 end loop;
7922
7923 if Raises_Constraint_Error (Prefix (N)) then
7924 Set_Is_Static_Expression (N, False);
7925 return;
7926 end if;
7927 end;
7928
7929 -- Deal with the case of a static attribute reference that raises
7930 -- constraint error. The Raises_Constraint_Error flag will already
7931 -- have been set, and the Static flag shows whether the attribute
7932 -- reference is static. In any case we certainly can't fold such an
7933 -- attribute reference.
7934
7935 -- Note that the rewriting of the attribute node with the constraint
7936 -- error node is essential in this case, because otherwise Gigi might
7937 -- blow up on one of the attributes it never expects to see.
7938
7939 -- The constraint_error node must have the type imposed by the context,
7940 -- to avoid spurious errors in the enclosing expression.
7941
7942 if Raises_Constraint_Error (N) then
7943 CE_Node :=
7944 Make_Raise_Constraint_Error (Sloc (N),
7945 Reason => CE_Range_Check_Failed);
7946 Set_Etype (CE_Node, Etype (N));
7947 Set_Raises_Constraint_Error (CE_Node);
7948 Check_Expressions;
7949 Rewrite (N, Relocate_Node (CE_Node));
7950 Set_Raises_Constraint_Error (N, True);
7951 return;
7952 end if;
7953
7954 -- At this point we have a potentially foldable attribute reference.
7955 -- If Static is set, then the attribute reference definitely obeys
7956 -- the requirements in (RM 4.9(7,8,22)), and it definitely can be
7957 -- folded. If Static is not set, then the attribute may or may not
7958 -- be foldable, and the individual attribute processing routines
7959 -- test Static as required in cases where it makes a difference.
7960
7961 -- In the case where Static is not set, we do know that all the
7962 -- expressions present are at least known at compile time (we assumed
7963 -- above that if this was not the case, then there was no hope of static
7964 -- evaluation). However, we did not require that the bounds of the
7965 -- prefix type be compile time known, let alone static). That's because
7966 -- there are many attributes that can be computed at compile time on
7967 -- non-static subtypes, even though such references are not static
7968 -- expressions.
7969
7970 -- For VAX float, the root type is an IEEE type. So make sure to use the
7971 -- base type instead of the root-type for floating point attributes.
7972
7973 case Id is
7974
7975 -- Attributes related to Ada 2012 iterators (placeholder ???)
7976
7977 when Attribute_Constant_Indexing |
7978 Attribute_Default_Iterator |
7979 Attribute_Implicit_Dereference |
7980 Attribute_Iterator_Element |
7981 Attribute_Iterable |
7982 Attribute_Variable_Indexing => null;
7983
7984 -- Internal attributes used to deal with Ada 2012 delayed aspects.
7985 -- These were already rejected by the parser. Thus they shouldn't
7986 -- appear here.
7987
7988 when Internal_Attribute_Id =>
7989 raise Program_Error;
7990
7991 --------------
7992 -- Adjacent --
7993 --------------
7994
7995 when Attribute_Adjacent =>
7996 Fold_Ureal
7997 (N,
7998 Eval_Fat.Adjacent
7999 (P_Base_Type, Expr_Value_R (E1), Expr_Value_R (E2)),
8000 Static);
8001
8002 ---------
8003 -- Aft --
8004 ---------
8005
8006 when Attribute_Aft =>
8007 Fold_Uint (N, Aft_Value (P_Type), Static);
8008
8009 ---------------
8010 -- Alignment --
8011 ---------------
8012
8013 when Attribute_Alignment => Alignment_Block : declare
8014 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
8015
8016 begin
8017 -- Fold if alignment is set and not otherwise
8018
8019 if Known_Alignment (P_TypeA) then
8020 Fold_Uint (N, Alignment (P_TypeA), Static);
8021 end if;
8022 end Alignment_Block;
8023
8024 -----------------------------
8025 -- Atomic_Always_Lock_Free --
8026 -----------------------------
8027
8028 -- Atomic_Always_Lock_Free attribute is a Boolean, thus no need to fold
8029 -- here.
8030
8031 when Attribute_Atomic_Always_Lock_Free => Atomic_Always_Lock_Free :
8032 declare
8033 V : constant Entity_Id :=
8034 Boolean_Literals
8035 (Support_Atomic_Primitives_On_Target
8036 and then Support_Atomic_Primitives (P_Type));
8037
8038 begin
8039 Rewrite (N, New_Occurrence_Of (V, Loc));
8040
8041 -- Analyze and resolve as boolean. Note that this attribute is a
8042 -- static attribute in GNAT.
8043
8044 Analyze_And_Resolve (N, Standard_Boolean);
8045 Static := True;
8046 Set_Is_Static_Expression (N, True);
8047 end Atomic_Always_Lock_Free;
8048
8049 ---------
8050 -- Bit --
8051 ---------
8052
8053 -- Bit can never be folded
8054
8055 when Attribute_Bit =>
8056 null;
8057
8058 ------------------
8059 -- Body_Version --
8060 ------------------
8061
8062 -- Body_version can never be static
8063
8064 when Attribute_Body_Version =>
8065 null;
8066
8067 -------------
8068 -- Ceiling --
8069 -------------
8070
8071 when Attribute_Ceiling =>
8072 Fold_Ureal
8073 (N, Eval_Fat.Ceiling (P_Base_Type, Expr_Value_R (E1)), Static);
8074
8075 --------------------
8076 -- Component_Size --
8077 --------------------
8078
8079 when Attribute_Component_Size =>
8080 if Known_Static_Component_Size (P_Type) then
8081 Fold_Uint (N, Component_Size (P_Type), Static);
8082 end if;
8083
8084 -------------
8085 -- Compose --
8086 -------------
8087
8088 when Attribute_Compose =>
8089 Fold_Ureal
8090 (N,
8091 Eval_Fat.Compose (P_Base_Type, Expr_Value_R (E1), Expr_Value (E2)),
8092 Static);
8093
8094 -----------------
8095 -- Constrained --
8096 -----------------
8097
8098 -- Constrained is never folded for now, there may be cases that
8099 -- could be handled at compile time. To be looked at later.
8100
8101 when Attribute_Constrained =>
8102
8103 -- The expander might fold it and set the static flag accordingly,
8104 -- but with expansion disabled (as in ASIS), it remains as an
8105 -- attribute reference, and this reference is not static.
8106
8107 Set_Is_Static_Expression (N, False);
8108 null;
8109
8110 ---------------
8111 -- Copy_Sign --
8112 ---------------
8113
8114 when Attribute_Copy_Sign =>
8115 Fold_Ureal
8116 (N,
8117 Eval_Fat.Copy_Sign
8118 (P_Base_Type, Expr_Value_R (E1), Expr_Value_R (E2)),
8119 Static);
8120
8121 --------------
8122 -- Definite --
8123 --------------
8124
8125 when Attribute_Definite =>
8126 Rewrite (N, New_Occurrence_Of (
8127 Boolean_Literals (Is_Definite_Subtype (P_Entity)), Loc));
8128 Analyze_And_Resolve (N, Standard_Boolean);
8129
8130 -----------
8131 -- Delta --
8132 -----------
8133
8134 when Attribute_Delta =>
8135 Fold_Ureal (N, Delta_Value (P_Type), True);
8136
8137 ------------
8138 -- Denorm --
8139 ------------
8140
8141 when Attribute_Denorm =>
8142 Fold_Uint
8143 (N, UI_From_Int (Boolean'Pos (Has_Denormals (P_Type))), Static);
8144
8145 ---------------------
8146 -- Descriptor_Size --
8147 ---------------------
8148
8149 when Attribute_Descriptor_Size =>
8150 null;
8151
8152 ------------
8153 -- Digits --
8154 ------------
8155
8156 when Attribute_Digits =>
8157 Fold_Uint (N, Digits_Value (P_Type), Static);
8158
8159 ----------
8160 -- Emax --
8161 ----------
8162
8163 when Attribute_Emax =>
8164
8165 -- Ada 83 attribute is defined as (RM83 3.5.8)
8166
8167 -- T'Emax = 4 * T'Mantissa
8168
8169 Fold_Uint (N, 4 * Mantissa, Static);
8170
8171 --------------
8172 -- Enum_Rep --
8173 --------------
8174
8175 when Attribute_Enum_Rep => Enum_Rep : declare
8176 Val : Node_Id;
8177
8178 begin
8179 -- The attribute appears in the form:
8180
8181 -- Enum_Typ'Enum_Rep (Const)
8182 -- Enum_Typ'Enum_Rep (Enum_Lit)
8183
8184 if Present (E1) then
8185 Val := E1;
8186
8187 -- Otherwise the prefix denotes a constant or enumeration literal:
8188
8189 -- Const'Enum_Rep
8190 -- Enum_Lit'Enum_Rep
8191
8192 else
8193 Val := P;
8194 end if;
8195
8196 -- For an enumeration type with a non-standard representation use
8197 -- the Enumeration_Rep field of the proper constant. Note that this
8198 -- will not work for types Character/Wide_[Wide-]Character, since no
8199 -- real entities are created for the enumeration literals, but that
8200 -- does not matter since these two types do not have non-standard
8201 -- representations anyway.
8202
8203 if Is_Enumeration_Type (P_Type)
8204 and then Has_Non_Standard_Rep (P_Type)
8205 then
8206 Fold_Uint (N, Enumeration_Rep (Expr_Value_E (Val)), Static);
8207
8208 -- For enumeration types with standard representations and all other
8209 -- cases (i.e. all integer and modular types), Enum_Rep is equivalent
8210 -- to Pos.
8211
8212 else
8213 Fold_Uint (N, Expr_Value (Val), Static);
8214 end if;
8215 end Enum_Rep;
8216
8217 --------------
8218 -- Enum_Val --
8219 --------------
8220
8221 when Attribute_Enum_Val => Enum_Val : declare
8222 Lit : Node_Id;
8223
8224 begin
8225 -- We have something like Enum_Type'Enum_Val (23), so search for a
8226 -- corresponding value in the list of Enum_Rep values for the type.
8227
8228 Lit := First_Literal (P_Base_Type);
8229 loop
8230 if Enumeration_Rep (Lit) = Expr_Value (E1) then
8231 Fold_Uint (N, Enumeration_Pos (Lit), Static);
8232 exit;
8233 end if;
8234
8235 Next_Literal (Lit);
8236
8237 if No (Lit) then
8238 Apply_Compile_Time_Constraint_Error
8239 (N, "no representation value matches",
8240 CE_Range_Check_Failed,
8241 Warn => not Static);
8242 exit;
8243 end if;
8244 end loop;
8245 end Enum_Val;
8246
8247 -------------
8248 -- Epsilon --
8249 -------------
8250
8251 when Attribute_Epsilon =>
8252
8253 -- Ada 83 attribute is defined as (RM83 3.5.8)
8254
8255 -- T'Epsilon = 2.0**(1 - T'Mantissa)
8256
8257 Fold_Ureal (N, Ureal_2 ** (1 - Mantissa), True);
8258
8259 --------------
8260 -- Exponent --
8261 --------------
8262
8263 when Attribute_Exponent =>
8264 Fold_Uint (N,
8265 Eval_Fat.Exponent (P_Base_Type, Expr_Value_R (E1)), Static);
8266
8267 -----------
8268 -- First --
8269 -----------
8270
8271 when Attribute_First => First_Attr :
8272 begin
8273 Set_Bounds;
8274
8275 if Compile_Time_Known_Value (Lo_Bound) then
8276 if Is_Real_Type (P_Type) then
8277 Fold_Ureal (N, Expr_Value_R (Lo_Bound), Static);
8278 else
8279 Fold_Uint (N, Expr_Value (Lo_Bound), Static);
8280 end if;
8281
8282 else
8283 Check_Concurrent_Discriminant (Lo_Bound);
8284 end if;
8285 end First_Attr;
8286
8287 -----------------
8288 -- First_Valid --
8289 -----------------
8290
8291 when Attribute_First_Valid => First_Valid :
8292 begin
8293 if Has_Predicates (P_Type)
8294 and then Has_Static_Predicate (P_Type)
8295 then
8296 declare
8297 FirstN : constant Node_Id :=
8298 First (Static_Discrete_Predicate (P_Type));
8299 begin
8300 if Nkind (FirstN) = N_Range then
8301 Fold_Uint (N, Expr_Value (Low_Bound (FirstN)), Static);
8302 else
8303 Fold_Uint (N, Expr_Value (FirstN), Static);
8304 end if;
8305 end;
8306
8307 else
8308 Set_Bounds;
8309 Fold_Uint (N, Expr_Value (Lo_Bound), Static);
8310 end if;
8311 end First_Valid;
8312
8313 -----------------
8314 -- Fixed_Value --
8315 -----------------
8316
8317 when Attribute_Fixed_Value =>
8318 null;
8319
8320 -----------
8321 -- Floor --
8322 -----------
8323
8324 when Attribute_Floor =>
8325 Fold_Ureal
8326 (N, Eval_Fat.Floor (P_Base_Type, Expr_Value_R (E1)), Static);
8327
8328 ----------
8329 -- Fore --
8330 ----------
8331
8332 when Attribute_Fore =>
8333 if Compile_Time_Known_Bounds (P_Type) then
8334 Fold_Uint (N, UI_From_Int (Fore_Value), Static);
8335 end if;
8336
8337 --------------
8338 -- Fraction --
8339 --------------
8340
8341 when Attribute_Fraction =>
8342 Fold_Ureal
8343 (N, Eval_Fat.Fraction (P_Base_Type, Expr_Value_R (E1)), Static);
8344
8345 -----------------------
8346 -- Has_Access_Values --
8347 -----------------------
8348
8349 when Attribute_Has_Access_Values =>
8350 Rewrite (N, New_Occurrence_Of
8351 (Boolean_Literals (Has_Access_Values (P_Root_Type)), Loc));
8352 Analyze_And_Resolve (N, Standard_Boolean);
8353
8354 -----------------------
8355 -- Has_Discriminants --
8356 -----------------------
8357
8358 when Attribute_Has_Discriminants =>
8359 Rewrite (N, New_Occurrence_Of (
8360 Boolean_Literals (Has_Discriminants (P_Entity)), Loc));
8361 Analyze_And_Resolve (N, Standard_Boolean);
8362
8363 ----------------------
8364 -- Has_Same_Storage --
8365 ----------------------
8366
8367 when Attribute_Has_Same_Storage =>
8368 null;
8369
8370 -----------------------
8371 -- Has_Tagged_Values --
8372 -----------------------
8373
8374 when Attribute_Has_Tagged_Values =>
8375 Rewrite (N, New_Occurrence_Of
8376 (Boolean_Literals (Has_Tagged_Component (P_Root_Type)), Loc));
8377 Analyze_And_Resolve (N, Standard_Boolean);
8378
8379 --------------
8380 -- Identity --
8381 --------------
8382
8383 when Attribute_Identity =>
8384 null;
8385
8386 -----------
8387 -- Image --
8388 -----------
8389
8390 -- Image is a scalar attribute, but is never static, because it is
8391 -- not a static function (having a non-scalar argument (RM 4.9(22))
8392 -- However, we can constant-fold the image of an enumeration literal
8393 -- if names are available.
8394
8395 when Attribute_Image =>
8396 if Is_Entity_Name (E1)
8397 and then Ekind (Entity (E1)) = E_Enumeration_Literal
8398 and then not Discard_Names (First_Subtype (Etype (E1)))
8399 and then not Global_Discard_Names
8400 then
8401 declare
8402 Lit : constant Entity_Id := Entity (E1);
8403 Str : String_Id;
8404 begin
8405 Start_String;
8406 Get_Unqualified_Decoded_Name_String (Chars (Lit));
8407 Set_Casing (All_Upper_Case);
8408 Store_String_Chars (Name_Buffer (1 .. Name_Len));
8409 Str := End_String;
8410 Rewrite (N, Make_String_Literal (Loc, Strval => Str));
8411 Analyze_And_Resolve (N, Standard_String);
8412 Set_Is_Static_Expression (N, False);
8413 end;
8414 end if;
8415
8416 -------------------
8417 -- Integer_Value --
8418 -------------------
8419
8420 -- We never try to fold Integer_Value (though perhaps we could???)
8421
8422 when Attribute_Integer_Value =>
8423 null;
8424
8425 -------------------
8426 -- Invalid_Value --
8427 -------------------
8428
8429 -- Invalid_Value is a scalar attribute that is never static, because
8430 -- the value is by design out of range.
8431
8432 when Attribute_Invalid_Value =>
8433 null;
8434
8435 -----------
8436 -- Large --
8437 -----------
8438
8439 when Attribute_Large =>
8440
8441 -- For fixed-point, we use the identity:
8442
8443 -- T'Large = (2.0**T'Mantissa - 1.0) * T'Small
8444
8445 if Is_Fixed_Point_Type (P_Type) then
8446 Rewrite (N,
8447 Make_Op_Multiply (Loc,
8448 Left_Opnd =>
8449 Make_Op_Subtract (Loc,
8450 Left_Opnd =>
8451 Make_Op_Expon (Loc,
8452 Left_Opnd =>
8453 Make_Real_Literal (Loc, Ureal_2),
8454 Right_Opnd =>
8455 Make_Attribute_Reference (Loc,
8456 Prefix => P,
8457 Attribute_Name => Name_Mantissa)),
8458 Right_Opnd => Make_Real_Literal (Loc, Ureal_1)),
8459
8460 Right_Opnd =>
8461 Make_Real_Literal (Loc, Small_Value (Entity (P)))));
8462
8463 Analyze_And_Resolve (N, C_Type);
8464
8465 -- Floating-point (Ada 83 compatibility)
8466
8467 else
8468 -- Ada 83 attribute is defined as (RM83 3.5.8)
8469
8470 -- T'Large = 2.0**T'Emax * (1.0 - 2.0**(-T'Mantissa))
8471
8472 -- where
8473
8474 -- T'Emax = 4 * T'Mantissa
8475
8476 Fold_Ureal
8477 (N,
8478 Ureal_2 ** (4 * Mantissa) * (Ureal_1 - Ureal_2 ** (-Mantissa)),
8479 True);
8480 end if;
8481
8482 ---------------
8483 -- Lock_Free --
8484 ---------------
8485
8486 when Attribute_Lock_Free => Lock_Free : declare
8487 V : constant Entity_Id := Boolean_Literals (Uses_Lock_Free (P_Type));
8488
8489 begin
8490 Rewrite (N, New_Occurrence_Of (V, Loc));
8491
8492 -- Analyze and resolve as boolean. Note that this attribute is a
8493 -- static attribute in GNAT.
8494
8495 Analyze_And_Resolve (N, Standard_Boolean);
8496 Static := True;
8497 Set_Is_Static_Expression (N, True);
8498 end Lock_Free;
8499
8500 ----------
8501 -- Last --
8502 ----------
8503
8504 when Attribute_Last => Last_Attr :
8505 begin
8506 Set_Bounds;
8507
8508 if Compile_Time_Known_Value (Hi_Bound) then
8509 if Is_Real_Type (P_Type) then
8510 Fold_Ureal (N, Expr_Value_R (Hi_Bound), Static);
8511 else
8512 Fold_Uint (N, Expr_Value (Hi_Bound), Static);
8513 end if;
8514
8515 else
8516 Check_Concurrent_Discriminant (Hi_Bound);
8517 end if;
8518 end Last_Attr;
8519
8520 ----------------
8521 -- Last_Valid --
8522 ----------------
8523
8524 when Attribute_Last_Valid => Last_Valid :
8525 begin
8526 if Has_Predicates (P_Type)
8527 and then Has_Static_Predicate (P_Type)
8528 then
8529 declare
8530 LastN : constant Node_Id :=
8531 Last (Static_Discrete_Predicate (P_Type));
8532 begin
8533 if Nkind (LastN) = N_Range then
8534 Fold_Uint (N, Expr_Value (High_Bound (LastN)), Static);
8535 else
8536 Fold_Uint (N, Expr_Value (LastN), Static);
8537 end if;
8538 end;
8539
8540 else
8541 Set_Bounds;
8542 Fold_Uint (N, Expr_Value (Hi_Bound), Static);
8543 end if;
8544 end Last_Valid;
8545
8546 ------------------
8547 -- Leading_Part --
8548 ------------------
8549
8550 when Attribute_Leading_Part =>
8551 Fold_Ureal
8552 (N,
8553 Eval_Fat.Leading_Part
8554 (P_Base_Type, Expr_Value_R (E1), Expr_Value (E2)),
8555 Static);
8556
8557 ------------
8558 -- Length --
8559 ------------
8560
8561 when Attribute_Length => Length : declare
8562 Ind : Node_Id;
8563
8564 begin
8565 -- If any index type is a formal type, or derived from one, the
8566 -- bounds are not static. Treating them as static can produce
8567 -- spurious warnings or improper constant folding.
8568
8569 Ind := First_Index (P_Type);
8570 while Present (Ind) loop
8571 if Is_Generic_Type (Root_Type (Etype (Ind))) then
8572 return;
8573 end if;
8574
8575 Next_Index (Ind);
8576 end loop;
8577
8578 Set_Bounds;
8579
8580 -- For two compile time values, we can compute length
8581
8582 if Compile_Time_Known_Value (Lo_Bound)
8583 and then Compile_Time_Known_Value (Hi_Bound)
8584 then
8585 Fold_Uint (N,
8586 UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))),
8587 Static);
8588 end if;
8589
8590 -- One more case is where Hi_Bound and Lo_Bound are compile-time
8591 -- comparable, and we can figure out the difference between them.
8592
8593 declare
8594 Diff : aliased Uint;
8595
8596 begin
8597 case
8598 Compile_Time_Compare
8599 (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
8600 is
8601 when EQ =>
8602 Fold_Uint (N, Uint_1, Static);
8603
8604 when GT =>
8605 Fold_Uint (N, Uint_0, Static);
8606
8607 when LT =>
8608 if Diff /= No_Uint then
8609 Fold_Uint (N, Diff + 1, Static);
8610 end if;
8611
8612 when others =>
8613 null;
8614 end case;
8615 end;
8616 end Length;
8617
8618 ----------------
8619 -- Loop_Entry --
8620 ----------------
8621
8622 -- Loop_Entry acts as an alias of a constant initialized to the prefix
8623 -- of the said attribute at the point of entry into the related loop. As
8624 -- such, the attribute reference does not need to be evaluated because
8625 -- the prefix is the one that is evaluted.
8626
8627 when Attribute_Loop_Entry =>
8628 null;
8629
8630 -------------
8631 -- Machine --
8632 -------------
8633
8634 when Attribute_Machine =>
8635 Fold_Ureal
8636 (N,
8637 Eval_Fat.Machine
8638 (P_Base_Type, Expr_Value_R (E1), Eval_Fat.Round, N),
8639 Static);
8640
8641 ------------------
8642 -- Machine_Emax --
8643 ------------------
8644
8645 when Attribute_Machine_Emax =>
8646 Fold_Uint (N, Machine_Emax_Value (P_Type), Static);
8647
8648 ------------------
8649 -- Machine_Emin --
8650 ------------------
8651
8652 when Attribute_Machine_Emin =>
8653 Fold_Uint (N, Machine_Emin_Value (P_Type), Static);
8654
8655 ----------------------
8656 -- Machine_Mantissa --
8657 ----------------------
8658
8659 when Attribute_Machine_Mantissa =>
8660 Fold_Uint (N, Machine_Mantissa_Value (P_Type), Static);
8661
8662 -----------------------
8663 -- Machine_Overflows --
8664 -----------------------
8665
8666 when Attribute_Machine_Overflows =>
8667
8668 -- Always true for fixed-point
8669
8670 if Is_Fixed_Point_Type (P_Type) then
8671 Fold_Uint (N, True_Value, Static);
8672
8673 -- Floating point case
8674
8675 else
8676 Fold_Uint (N,
8677 UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)),
8678 Static);
8679 end if;
8680
8681 -------------------
8682 -- Machine_Radix --
8683 -------------------
8684
8685 when Attribute_Machine_Radix =>
8686 if Is_Fixed_Point_Type (P_Type) then
8687 if Is_Decimal_Fixed_Point_Type (P_Type)
8688 and then Machine_Radix_10 (P_Type)
8689 then
8690 Fold_Uint (N, Uint_10, Static);
8691 else
8692 Fold_Uint (N, Uint_2, Static);
8693 end if;
8694
8695 -- All floating-point type always have radix 2
8696
8697 else
8698 Fold_Uint (N, Uint_2, Static);
8699 end if;
8700
8701 ----------------------
8702 -- Machine_Rounding --
8703 ----------------------
8704
8705 -- Note: for the folding case, it is fine to treat Machine_Rounding
8706 -- exactly the same way as Rounding, since this is one of the allowed
8707 -- behaviors, and performance is not an issue here. It might be a bit
8708 -- better to give the same result as it would give at run time, even
8709 -- though the non-determinism is certainly permitted.
8710
8711 when Attribute_Machine_Rounding =>
8712 Fold_Ureal
8713 (N, Eval_Fat.Rounding (P_Base_Type, Expr_Value_R (E1)), Static);
8714
8715 --------------------
8716 -- Machine_Rounds --
8717 --------------------
8718
8719 when Attribute_Machine_Rounds =>
8720
8721 -- Always False for fixed-point
8722
8723 if Is_Fixed_Point_Type (P_Type) then
8724 Fold_Uint (N, False_Value, Static);
8725
8726 -- Else yield proper floating-point result
8727
8728 else
8729 Fold_Uint
8730 (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)),
8731 Static);
8732 end if;
8733
8734 ------------------
8735 -- Machine_Size --
8736 ------------------
8737
8738 -- Note: Machine_Size is identical to Object_Size
8739
8740 when Attribute_Machine_Size => Machine_Size : declare
8741 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
8742
8743 begin
8744 if Known_Esize (P_TypeA) then
8745 Fold_Uint (N, Esize (P_TypeA), Static);
8746 end if;
8747 end Machine_Size;
8748
8749 --------------
8750 -- Mantissa --
8751 --------------
8752
8753 when Attribute_Mantissa =>
8754
8755 -- Fixed-point mantissa
8756
8757 if Is_Fixed_Point_Type (P_Type) then
8758
8759 -- Compile time foldable case
8760
8761 if Compile_Time_Known_Value (Type_Low_Bound (P_Type))
8762 and then
8763 Compile_Time_Known_Value (Type_High_Bound (P_Type))
8764 then
8765 -- The calculation of the obsolete Ada 83 attribute Mantissa
8766 -- is annoying, because of AI00143, quoted here:
8767
8768 -- !question 84-01-10
8769
8770 -- Consider the model numbers for F:
8771
8772 -- type F is delta 1.0 range -7.0 .. 8.0;
8773
8774 -- The wording requires that F'MANTISSA be the SMALLEST
8775 -- integer number for which each bound of the specified
8776 -- range is either a model number or lies at most small
8777 -- distant from a model number. This means F'MANTISSA
8778 -- is required to be 3 since the range -7.0 .. 7.0 fits
8779 -- in 3 signed bits, and 8 is "at most" 1.0 from a model
8780 -- number, namely, 7. Is this analysis correct? Note that
8781 -- this implies the upper bound of the range is not
8782 -- represented as a model number.
8783
8784 -- !response 84-03-17
8785
8786 -- The analysis is correct. The upper and lower bounds for
8787 -- a fixed point type can lie outside the range of model
8788 -- numbers.
8789
8790 declare
8791 Siz : Uint;
8792 LBound : Ureal;
8793 UBound : Ureal;
8794 Bound : Ureal;
8795 Max_Man : Uint;
8796
8797 begin
8798 LBound := Expr_Value_R (Type_Low_Bound (P_Type));
8799 UBound := Expr_Value_R (Type_High_Bound (P_Type));
8800 Bound := UR_Max (UR_Abs (LBound), UR_Abs (UBound));
8801 Max_Man := UR_Trunc (Bound / Small_Value (P_Type));
8802
8803 -- If the Bound is exactly a model number, i.e. a multiple
8804 -- of Small, then we back it off by one to get the integer
8805 -- value that must be representable.
8806
8807 if Small_Value (P_Type) * Max_Man = Bound then
8808 Max_Man := Max_Man - 1;
8809 end if;
8810
8811 -- Now find corresponding size = Mantissa value
8812
8813 Siz := Uint_0;
8814 while 2 ** Siz < Max_Man loop
8815 Siz := Siz + 1;
8816 end loop;
8817
8818 Fold_Uint (N, Siz, Static);
8819 end;
8820
8821 else
8822 -- The case of dynamic bounds cannot be evaluated at compile
8823 -- time. Instead we use a runtime routine (see Exp_Attr).
8824
8825 null;
8826 end if;
8827
8828 -- Floating-point Mantissa
8829
8830 else
8831 Fold_Uint (N, Mantissa, Static);
8832 end if;
8833
8834 ---------
8835 -- Max --
8836 ---------
8837
8838 when Attribute_Max => Max :
8839 begin
8840 if Is_Real_Type (P_Type) then
8841 Fold_Ureal
8842 (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
8843 else
8844 Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static);
8845 end if;
8846 end Max;
8847
8848 ----------------------------------
8849 -- Max_Alignment_For_Allocation --
8850 ----------------------------------
8851
8852 -- Max_Alignment_For_Allocation is usually the Alignment. However,
8853 -- arrays are allocated with dope, so we need to take into account both
8854 -- the alignment of the array, which comes from the component alignment,
8855 -- and the alignment of the dope. Also, if the alignment is unknown, we
8856 -- use the max (it's OK to be pessimistic).
8857
8858 when Attribute_Max_Alignment_For_Allocation =>
8859 declare
8860 A : Uint := UI_From_Int (Ttypes.Maximum_Alignment);
8861 begin
8862 if Known_Alignment (P_Type) and then
8863 (not Is_Array_Type (P_Type) or else Alignment (P_Type) > A)
8864 then
8865 A := Alignment (P_Type);
8866 end if;
8867
8868 Fold_Uint (N, A, Static);
8869 end;
8870
8871 ----------------------------------
8872 -- Max_Size_In_Storage_Elements --
8873 ----------------------------------
8874
8875 -- Max_Size_In_Storage_Elements is simply the Size rounded up to a
8876 -- Storage_Unit boundary. We can fold any cases for which the size
8877 -- is known by the front end.
8878
8879 when Attribute_Max_Size_In_Storage_Elements =>
8880 if Known_Esize (P_Type) then
8881 Fold_Uint (N,
8882 (Esize (P_Type) + System_Storage_Unit - 1) /
8883 System_Storage_Unit,
8884 Static);
8885 end if;
8886
8887 --------------------
8888 -- Mechanism_Code --
8889 --------------------
8890
8891 when Attribute_Mechanism_Code =>
8892 declare
8893 Val : Int;
8894 Formal : Entity_Id;
8895 Mech : Mechanism_Type;
8896
8897 begin
8898 if No (E1) then
8899 Mech := Mechanism (P_Entity);
8900
8901 else
8902 Val := UI_To_Int (Expr_Value (E1));
8903
8904 Formal := First_Formal (P_Entity);
8905 for J in 1 .. Val - 1 loop
8906 Next_Formal (Formal);
8907 end loop;
8908 Mech := Mechanism (Formal);
8909 end if;
8910
8911 if Mech < 0 then
8912 Fold_Uint (N, UI_From_Int (Int (-Mech)), Static);
8913 end if;
8914 end;
8915
8916 ---------
8917 -- Min --
8918 ---------
8919
8920 when Attribute_Min => Min :
8921 begin
8922 if Is_Real_Type (P_Type) then
8923 Fold_Ureal
8924 (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
8925 else
8926 Fold_Uint
8927 (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static);
8928 end if;
8929 end Min;
8930
8931 ---------
8932 -- Mod --
8933 ---------
8934
8935 when Attribute_Mod =>
8936 Fold_Uint
8937 (N, UI_Mod (Expr_Value (E1), Modulus (P_Base_Type)), Static);
8938
8939 -----------
8940 -- Model --
8941 -----------
8942
8943 when Attribute_Model =>
8944 Fold_Ureal
8945 (N, Eval_Fat.Model (P_Base_Type, Expr_Value_R (E1)), Static);
8946
8947 ----------------
8948 -- Model_Emin --
8949 ----------------
8950
8951 when Attribute_Model_Emin =>
8952 Fold_Uint (N, Model_Emin_Value (P_Base_Type), Static);
8953
8954 -------------------
8955 -- Model_Epsilon --
8956 -------------------
8957
8958 when Attribute_Model_Epsilon =>
8959 Fold_Ureal (N, Model_Epsilon_Value (P_Base_Type), Static);
8960
8961 --------------------
8962 -- Model_Mantissa --
8963 --------------------
8964
8965 when Attribute_Model_Mantissa =>
8966 Fold_Uint (N, Model_Mantissa_Value (P_Base_Type), Static);
8967
8968 -----------------
8969 -- Model_Small --
8970 -----------------
8971
8972 when Attribute_Model_Small =>
8973 Fold_Ureal (N, Model_Small_Value (P_Base_Type), Static);
8974
8975 -------------
8976 -- Modulus --
8977 -------------
8978
8979 when Attribute_Modulus =>
8980 Fold_Uint (N, Modulus (P_Type), Static);
8981
8982 --------------------
8983 -- Null_Parameter --
8984 --------------------
8985
8986 -- Cannot fold, we know the value sort of, but the whole point is
8987 -- that there is no way to talk about this imaginary value except
8988 -- by using the attribute, so we leave it the way it is.
8989
8990 when Attribute_Null_Parameter =>
8991 null;
8992
8993 -----------------
8994 -- Object_Size --
8995 -----------------
8996
8997 -- The Object_Size attribute for a type returns the Esize of the
8998 -- type and can be folded if this value is known.
8999
9000 when Attribute_Object_Size => Object_Size : declare
9001 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
9002
9003 begin
9004 if Known_Esize (P_TypeA) then
9005 Fold_Uint (N, Esize (P_TypeA), Static);
9006 end if;
9007 end Object_Size;
9008
9009 ----------------------
9010 -- Overlaps_Storage --
9011 ----------------------
9012
9013 when Attribute_Overlaps_Storage =>
9014 null;
9015
9016 -------------------------
9017 -- Passed_By_Reference --
9018 -------------------------
9019
9020 -- Scalar types are never passed by reference
9021
9022 when Attribute_Passed_By_Reference =>
9023 Fold_Uint (N, False_Value, Static);
9024
9025 ---------
9026 -- Pos --
9027 ---------
9028
9029 when Attribute_Pos =>
9030 Fold_Uint (N, Expr_Value (E1), Static);
9031
9032 ----------
9033 -- Pred --
9034 ----------
9035
9036 when Attribute_Pred => Pred :
9037 begin
9038 -- Floating-point case
9039
9040 if Is_Floating_Point_Type (P_Type) then
9041 Fold_Ureal
9042 (N, Eval_Fat.Pred (P_Base_Type, Expr_Value_R (E1)), Static);
9043
9044 -- Fixed-point case
9045
9046 elsif Is_Fixed_Point_Type (P_Type) then
9047 Fold_Ureal
9048 (N, Expr_Value_R (E1) - Small_Value (P_Type), True);
9049
9050 -- Modular integer case (wraps)
9051
9052 elsif Is_Modular_Integer_Type (P_Type) then
9053 Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type), Static);
9054
9055 -- Other scalar cases
9056
9057 else
9058 pragma Assert (Is_Scalar_Type (P_Type));
9059
9060 if Is_Enumeration_Type (P_Type)
9061 and then Expr_Value (E1) =
9062 Expr_Value (Type_Low_Bound (P_Base_Type))
9063 then
9064 Apply_Compile_Time_Constraint_Error
9065 (N, "Pred of `&''First`",
9066 CE_Overflow_Check_Failed,
9067 Ent => P_Base_Type,
9068 Warn => not Static);
9069
9070 Check_Expressions;
9071 return;
9072 end if;
9073
9074 Fold_Uint (N, Expr_Value (E1) - 1, Static);
9075 end if;
9076 end Pred;
9077
9078 -----------
9079 -- Range --
9080 -----------
9081
9082 -- No processing required, because by this stage, Range has been
9083 -- replaced by First .. Last, so this branch can never be taken.
9084
9085 when Attribute_Range =>
9086 raise Program_Error;
9087
9088 ------------------
9089 -- Range_Length --
9090 ------------------
9091
9092 when Attribute_Range_Length =>
9093 Set_Bounds;
9094
9095 -- Can fold if both bounds are compile time known
9096
9097 if Compile_Time_Known_Value (Hi_Bound)
9098 and then Compile_Time_Known_Value (Lo_Bound)
9099 then
9100 Fold_Uint (N,
9101 UI_Max
9102 (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1),
9103 Static);
9104 end if;
9105
9106 -- One more case is where Hi_Bound and Lo_Bound are compile-time
9107 -- comparable, and we can figure out the difference between them.
9108
9109 declare
9110 Diff : aliased Uint;
9111
9112 begin
9113 case
9114 Compile_Time_Compare
9115 (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
9116 is
9117 when EQ =>
9118 Fold_Uint (N, Uint_1, Static);
9119
9120 when GT =>
9121 Fold_Uint (N, Uint_0, Static);
9122
9123 when LT =>
9124 if Diff /= No_Uint then
9125 Fold_Uint (N, Diff + 1, Static);
9126 end if;
9127
9128 when others =>
9129 null;
9130 end case;
9131 end;
9132
9133 ---------
9134 -- Ref --
9135 ---------
9136
9137 when Attribute_Ref =>
9138 Fold_Uint (N, Expr_Value (E1), Static);
9139
9140 ---------------
9141 -- Remainder --
9142 ---------------
9143
9144 when Attribute_Remainder => Remainder : declare
9145 X : constant Ureal := Expr_Value_R (E1);
9146 Y : constant Ureal := Expr_Value_R (E2);
9147
9148 begin
9149 if UR_Is_Zero (Y) then
9150 Apply_Compile_Time_Constraint_Error
9151 (N, "division by zero in Remainder",
9152 CE_Overflow_Check_Failed,
9153 Warn => not Static);
9154
9155 Check_Expressions;
9156 return;
9157 end if;
9158
9159 Fold_Ureal (N, Eval_Fat.Remainder (P_Base_Type, X, Y), Static);
9160 end Remainder;
9161
9162 -----------------
9163 -- Restriction --
9164 -----------------
9165
9166 when Attribute_Restriction_Set => Restriction_Set : declare
9167 begin
9168 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
9169 Set_Is_Static_Expression (N);
9170 end Restriction_Set;
9171
9172 -----------
9173 -- Round --
9174 -----------
9175
9176 when Attribute_Round => Round :
9177 declare
9178 Sr : Ureal;
9179 Si : Uint;
9180
9181 begin
9182 -- First we get the (exact result) in units of small
9183
9184 Sr := Expr_Value_R (E1) / Small_Value (C_Type);
9185
9186 -- Now round that exactly to an integer
9187
9188 Si := UR_To_Uint (Sr);
9189
9190 -- Finally the result is obtained by converting back to real
9191
9192 Fold_Ureal (N, Si * Small_Value (C_Type), Static);
9193 end Round;
9194
9195 --------------
9196 -- Rounding --
9197 --------------
9198
9199 when Attribute_Rounding =>
9200 Fold_Ureal
9201 (N, Eval_Fat.Rounding (P_Base_Type, Expr_Value_R (E1)), Static);
9202
9203 ---------------
9204 -- Safe_Emax --
9205 ---------------
9206
9207 when Attribute_Safe_Emax =>
9208 Fold_Uint (N, Safe_Emax_Value (P_Type), Static);
9209
9210 ----------------
9211 -- Safe_First --
9212 ----------------
9213
9214 when Attribute_Safe_First =>
9215 Fold_Ureal (N, Safe_First_Value (P_Type), Static);
9216
9217 ----------------
9218 -- Safe_Large --
9219 ----------------
9220
9221 when Attribute_Safe_Large =>
9222 if Is_Fixed_Point_Type (P_Type) then
9223 Fold_Ureal
9224 (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static);
9225 else
9226 Fold_Ureal (N, Safe_Last_Value (P_Type), Static);
9227 end if;
9228
9229 ---------------
9230 -- Safe_Last --
9231 ---------------
9232
9233 when Attribute_Safe_Last =>
9234 Fold_Ureal (N, Safe_Last_Value (P_Type), Static);
9235
9236 ----------------
9237 -- Safe_Small --
9238 ----------------
9239
9240 when Attribute_Safe_Small =>
9241
9242 -- In Ada 95, the old Ada 83 attribute Safe_Small is redundant
9243 -- for fixed-point, since is the same as Small, but we implement
9244 -- it for backwards compatibility.
9245
9246 if Is_Fixed_Point_Type (P_Type) then
9247 Fold_Ureal (N, Small_Value (P_Type), Static);
9248
9249 -- Ada 83 Safe_Small for floating-point cases
9250
9251 else
9252 Fold_Ureal (N, Model_Small_Value (P_Type), Static);
9253 end if;
9254
9255 -----------
9256 -- Scale --
9257 -----------
9258
9259 when Attribute_Scale =>
9260 Fold_Uint (N, Scale_Value (P_Type), Static);
9261
9262 -------------
9263 -- Scaling --
9264 -------------
9265
9266 when Attribute_Scaling =>
9267 Fold_Ureal
9268 (N,
9269 Eval_Fat.Scaling
9270 (P_Base_Type, Expr_Value_R (E1), Expr_Value (E2)),
9271 Static);
9272
9273 ------------------
9274 -- Signed_Zeros --
9275 ------------------
9276
9277 when Attribute_Signed_Zeros =>
9278 Fold_Uint
9279 (N, UI_From_Int (Boolean'Pos (Has_Signed_Zeros (P_Type))), Static);
9280
9281 ----------
9282 -- Size --
9283 ----------
9284
9285 -- Size attribute returns the RM size. All scalar types can be folded,
9286 -- as well as any types for which the size is known by the front end,
9287 -- including any type for which a size attribute is specified. This is
9288 -- one of the places where it is annoying that a size of zero means two
9289 -- things (zero size for scalars, unspecified size for non-scalars).
9290
9291 when Attribute_Size | Attribute_VADS_Size => Size : declare
9292 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
9293
9294 begin
9295 if Is_Scalar_Type (P_TypeA) or else RM_Size (P_TypeA) /= Uint_0 then
9296
9297 -- VADS_Size case
9298
9299 if Id = Attribute_VADS_Size or else Use_VADS_Size then
9300 declare
9301 S : constant Node_Id := Size_Clause (P_TypeA);
9302
9303 begin
9304 -- If a size clause applies, then use the size from it.
9305 -- This is one of the rare cases where we can use the
9306 -- Size_Clause field for a subtype when Has_Size_Clause
9307 -- is False. Consider:
9308
9309 -- type x is range 1 .. 64;
9310 -- for x'size use 12;
9311 -- subtype y is x range 0 .. 3;
9312
9313 -- Here y has a size clause inherited from x, but normally
9314 -- it does not apply, and y'size is 2. However, y'VADS_Size
9315 -- is indeed 12 and not 2.
9316
9317 if Present (S)
9318 and then Is_OK_Static_Expression (Expression (S))
9319 then
9320 Fold_Uint (N, Expr_Value (Expression (S)), Static);
9321
9322 -- If no size is specified, then we simply use the object
9323 -- size in the VADS_Size case (e.g. Natural'Size is equal
9324 -- to Integer'Size, not one less).
9325
9326 else
9327 Fold_Uint (N, Esize (P_TypeA), Static);
9328 end if;
9329 end;
9330
9331 -- Normal case (Size) in which case we want the RM_Size
9332
9333 else
9334 Fold_Uint (N, RM_Size (P_TypeA), Static);
9335 end if;
9336 end if;
9337 end Size;
9338
9339 -----------
9340 -- Small --
9341 -----------
9342
9343 when Attribute_Small =>
9344
9345 -- The floating-point case is present only for Ada 83 compatibility.
9346 -- Note that strictly this is an illegal addition, since we are
9347 -- extending an Ada 95 defined attribute, but we anticipate an
9348 -- ARG ruling that will permit this.
9349
9350 if Is_Floating_Point_Type (P_Type) then
9351
9352 -- Ada 83 attribute is defined as (RM83 3.5.8)
9353
9354 -- T'Small = 2.0**(-T'Emax - 1)
9355
9356 -- where
9357
9358 -- T'Emax = 4 * T'Mantissa
9359
9360 Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1), Static);
9361
9362 -- Normal Ada 95 fixed-point case
9363
9364 else
9365 Fold_Ureal (N, Small_Value (P_Type), True);
9366 end if;
9367
9368 -----------------
9369 -- Stream_Size --
9370 -----------------
9371
9372 when Attribute_Stream_Size =>
9373 null;
9374
9375 ----------
9376 -- Succ --
9377 ----------
9378
9379 when Attribute_Succ => Succ :
9380 begin
9381 -- Floating-point case
9382
9383 if Is_Floating_Point_Type (P_Type) then
9384 Fold_Ureal
9385 (N, Eval_Fat.Succ (P_Base_Type, Expr_Value_R (E1)), Static);
9386
9387 -- Fixed-point case
9388
9389 elsif Is_Fixed_Point_Type (P_Type) then
9390 Fold_Ureal (N, Expr_Value_R (E1) + Small_Value (P_Type), Static);
9391
9392 -- Modular integer case (wraps)
9393
9394 elsif Is_Modular_Integer_Type (P_Type) then
9395 Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type), Static);
9396
9397 -- Other scalar cases
9398
9399 else
9400 pragma Assert (Is_Scalar_Type (P_Type));
9401
9402 if Is_Enumeration_Type (P_Type)
9403 and then Expr_Value (E1) =
9404 Expr_Value (Type_High_Bound (P_Base_Type))
9405 then
9406 Apply_Compile_Time_Constraint_Error
9407 (N, "Succ of `&''Last`",
9408 CE_Overflow_Check_Failed,
9409 Ent => P_Base_Type,
9410 Warn => not Static);
9411
9412 Check_Expressions;
9413 return;
9414 else
9415 Fold_Uint (N, Expr_Value (E1) + 1, Static);
9416 end if;
9417 end if;
9418 end Succ;
9419
9420 ----------------
9421 -- Truncation --
9422 ----------------
9423
9424 when Attribute_Truncation =>
9425 Fold_Ureal
9426 (N,
9427 Eval_Fat.Truncation (P_Base_Type, Expr_Value_R (E1)),
9428 Static);
9429
9430 ----------------
9431 -- Type_Class --
9432 ----------------
9433
9434 when Attribute_Type_Class => Type_Class : declare
9435 Typ : constant Entity_Id := Underlying_Type (P_Base_Type);
9436 Id : RE_Id;
9437
9438 begin
9439 if Is_Descendant_Of_Address (Typ) then
9440 Id := RE_Type_Class_Address;
9441
9442 elsif Is_Enumeration_Type (Typ) then
9443 Id := RE_Type_Class_Enumeration;
9444
9445 elsif Is_Integer_Type (Typ) then
9446 Id := RE_Type_Class_Integer;
9447
9448 elsif Is_Fixed_Point_Type (Typ) then
9449 Id := RE_Type_Class_Fixed_Point;
9450
9451 elsif Is_Floating_Point_Type (Typ) then
9452 Id := RE_Type_Class_Floating_Point;
9453
9454 elsif Is_Array_Type (Typ) then
9455 Id := RE_Type_Class_Array;
9456
9457 elsif Is_Record_Type (Typ) then
9458 Id := RE_Type_Class_Record;
9459
9460 elsif Is_Access_Type (Typ) then
9461 Id := RE_Type_Class_Access;
9462
9463 elsif Is_Enumeration_Type (Typ) then
9464 Id := RE_Type_Class_Enumeration;
9465
9466 elsif Is_Task_Type (Typ) then
9467 Id := RE_Type_Class_Task;
9468
9469 -- We treat protected types like task types. It would make more
9470 -- sense to have another enumeration value, but after all the
9471 -- whole point of this feature is to be exactly DEC compatible,
9472 -- and changing the type Type_Class would not meet this requirement.
9473
9474 elsif Is_Protected_Type (Typ) then
9475 Id := RE_Type_Class_Task;
9476
9477 -- Not clear if there are any other possibilities, but if there
9478 -- are, then we will treat them as the address case.
9479
9480 else
9481 Id := RE_Type_Class_Address;
9482 end if;
9483
9484 Rewrite (N, New_Occurrence_Of (RTE (Id), Loc));
9485 end Type_Class;
9486
9487 -----------------------
9488 -- Unbiased_Rounding --
9489 -----------------------
9490
9491 when Attribute_Unbiased_Rounding =>
9492 Fold_Ureal
9493 (N,
9494 Eval_Fat.Unbiased_Rounding (P_Base_Type, Expr_Value_R (E1)),
9495 Static);
9496
9497 -------------------------
9498 -- Unconstrained_Array --
9499 -------------------------
9500
9501 when Attribute_Unconstrained_Array => Unconstrained_Array : declare
9502 Typ : constant Entity_Id := Underlying_Type (P_Type);
9503
9504 begin
9505 Rewrite (N, New_Occurrence_Of (
9506 Boolean_Literals (
9507 Is_Array_Type (P_Type)
9508 and then not Is_Constrained (Typ)), Loc));
9509
9510 -- Analyze and resolve as boolean, note that this attribute is
9511 -- a static attribute in GNAT.
9512
9513 Analyze_And_Resolve (N, Standard_Boolean);
9514 Static := True;
9515 Set_Is_Static_Expression (N, True);
9516 end Unconstrained_Array;
9517
9518 -- Attribute Update is never static
9519
9520 when Attribute_Update =>
9521 return;
9522
9523 ---------------
9524 -- VADS_Size --
9525 ---------------
9526
9527 -- Processing is shared with Size
9528
9529 ---------
9530 -- Val --
9531 ---------
9532
9533 when Attribute_Val => Val :
9534 begin
9535 if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type))
9536 or else
9537 Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type))
9538 then
9539 Apply_Compile_Time_Constraint_Error
9540 (N, "Val expression out of range",
9541 CE_Range_Check_Failed,
9542 Warn => not Static);
9543
9544 Check_Expressions;
9545 return;
9546
9547 else
9548 Fold_Uint (N, Expr_Value (E1), Static);
9549 end if;
9550 end Val;
9551
9552 ----------------
9553 -- Value_Size --
9554 ----------------
9555
9556 -- The Value_Size attribute for a type returns the RM size of the type.
9557 -- This an always be folded for scalar types, and can also be folded for
9558 -- non-scalar types if the size is set. This is one of the places where
9559 -- it is annoying that a size of zero means two things!
9560
9561 when Attribute_Value_Size => Value_Size : declare
9562 P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
9563 begin
9564 if Is_Scalar_Type (P_TypeA) or else RM_Size (P_TypeA) /= Uint_0 then
9565 Fold_Uint (N, RM_Size (P_TypeA), Static);
9566 end if;
9567 end Value_Size;
9568
9569 -------------
9570 -- Version --
9571 -------------
9572
9573 -- Version can never be static
9574
9575 when Attribute_Version =>
9576 null;
9577
9578 ----------------
9579 -- Wide_Image --
9580 ----------------
9581
9582 -- Wide_Image is a scalar attribute, but is never static, because it
9583 -- is not a static function (having a non-scalar argument (RM 4.9(22))
9584
9585 when Attribute_Wide_Image =>
9586 null;
9587
9588 ---------------------
9589 -- Wide_Wide_Image --
9590 ---------------------
9591
9592 -- Wide_Wide_Image is a scalar attribute but is never static, because it
9593 -- is not a static function (having a non-scalar argument (RM 4.9(22)).
9594
9595 when Attribute_Wide_Wide_Image =>
9596 null;
9597
9598 ---------------------
9599 -- Wide_Wide_Width --
9600 ---------------------
9601
9602 -- Processing for Wide_Wide_Width is combined with Width
9603
9604 ----------------
9605 -- Wide_Width --
9606 ----------------
9607
9608 -- Processing for Wide_Width is combined with Width
9609
9610 -----------
9611 -- Width --
9612 -----------
9613
9614 -- This processing also handles the case of Wide_[Wide_]Width
9615
9616 when Attribute_Width |
9617 Attribute_Wide_Width |
9618 Attribute_Wide_Wide_Width => Width :
9619 begin
9620 if Compile_Time_Known_Bounds (P_Type) then
9621
9622 -- Floating-point types
9623
9624 if Is_Floating_Point_Type (P_Type) then
9625
9626 -- Width is zero for a null range (RM 3.5 (38))
9627
9628 if Expr_Value_R (Type_High_Bound (P_Type)) <
9629 Expr_Value_R (Type_Low_Bound (P_Type))
9630 then
9631 Fold_Uint (N, Uint_0, Static);
9632
9633 else
9634 -- For floating-point, we have +N.dddE+nnn where length
9635 -- of ddd is determined by type'Digits - 1, but is one
9636 -- if Digits is one (RM 3.5 (33)).
9637
9638 -- nnn is set to 2 for Short_Float and Float (32 bit
9639 -- floats), and 3 for Long_Float and Long_Long_Float.
9640 -- For machines where Long_Long_Float is the IEEE
9641 -- extended precision type, the exponent takes 4 digits.
9642
9643 declare
9644 Len : Int :=
9645 Int'Max (2, UI_To_Int (Digits_Value (P_Type)));
9646
9647 begin
9648 if Esize (P_Type) <= 32 then
9649 Len := Len + 6;
9650 elsif Esize (P_Type) = 64 then
9651 Len := Len + 7;
9652 else
9653 Len := Len + 8;
9654 end if;
9655
9656 Fold_Uint (N, UI_From_Int (Len), Static);
9657 end;
9658 end if;
9659
9660 -- Fixed-point types
9661
9662 elsif Is_Fixed_Point_Type (P_Type) then
9663
9664 -- Width is zero for a null range (RM 3.5 (38))
9665
9666 if Expr_Value (Type_High_Bound (P_Type)) <
9667 Expr_Value (Type_Low_Bound (P_Type))
9668 then
9669 Fold_Uint (N, Uint_0, Static);
9670
9671 -- The non-null case depends on the specific real type
9672
9673 else
9674 -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34))
9675
9676 Fold_Uint
9677 (N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type),
9678 Static);
9679 end if;
9680
9681 -- Discrete types
9682
9683 else
9684 declare
9685 R : constant Entity_Id := Root_Type (P_Type);
9686 Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type));
9687 Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type));
9688 W : Nat;
9689 Wt : Nat;
9690 T : Uint;
9691 L : Node_Id;
9692 C : Character;
9693
9694 begin
9695 -- Empty ranges
9696
9697 if Lo > Hi then
9698 W := 0;
9699
9700 -- Width for types derived from Standard.Character
9701 -- and Standard.Wide_[Wide_]Character.
9702
9703 elsif Is_Standard_Character_Type (P_Type) then
9704 W := 0;
9705
9706 -- Set W larger if needed
9707
9708 for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop
9709
9710 -- All wide characters look like Hex_hhhhhhhh
9711
9712 if J > 255 then
9713
9714 -- No need to compute this more than once
9715
9716 exit;
9717
9718 else
9719 C := Character'Val (J);
9720
9721 -- Test for all cases where Character'Image
9722 -- yields an image that is longer than three
9723 -- characters. First the cases of Reserved_xxx
9724 -- names (length = 12).
9725
9726 case C is
9727 when Reserved_128 | Reserved_129 |
9728 Reserved_132 | Reserved_153
9729 => Wt := 12;
9730
9731 when BS | HT | LF | VT | FF | CR |
9732 SO | SI | EM | FS | GS | RS |
9733 US | RI | MW | ST | PM
9734 => Wt := 2;
9735
9736 when NUL | SOH | STX | ETX | EOT |
9737 ENQ | ACK | BEL | DLE | DC1 |
9738 DC2 | DC3 | DC4 | NAK | SYN |
9739 ETB | CAN | SUB | ESC | DEL |
9740 BPH | NBH | NEL | SSA | ESA |
9741 HTS | HTJ | VTS | PLD | PLU |
9742 SS2 | SS3 | DCS | PU1 | PU2 |
9743 STS | CCH | SPA | EPA | SOS |
9744 SCI | CSI | OSC | APC
9745 => Wt := 3;
9746
9747 when Space .. Tilde |
9748 No_Break_Space .. LC_Y_Diaeresis
9749 =>
9750 -- Special case of soft hyphen in Ada 2005
9751
9752 if C = Character'Val (16#AD#)
9753 and then Ada_Version >= Ada_2005
9754 then
9755 Wt := 11;
9756 else
9757 Wt := 3;
9758 end if;
9759 end case;
9760
9761 W := Int'Max (W, Wt);
9762 end if;
9763 end loop;
9764
9765 -- Width for types derived from Standard.Boolean
9766
9767 elsif R = Standard_Boolean then
9768 if Lo = 0 then
9769 W := 5; -- FALSE
9770 else
9771 W := 4; -- TRUE
9772 end if;
9773
9774 -- Width for integer types
9775
9776 elsif Is_Integer_Type (P_Type) then
9777 T := UI_Max (abs Lo, abs Hi);
9778
9779 W := 2;
9780 while T >= 10 loop
9781 W := W + 1;
9782 T := T / 10;
9783 end loop;
9784
9785 -- User declared enum type with discard names
9786
9787 elsif Discard_Names (R) then
9788
9789 -- If range is null, result is zero, that has already
9790 -- been dealt with, so what we need is the power of ten
9791 -- that accomodates the Pos of the largest value, which
9792 -- is the high bound of the range + one for the space.
9793
9794 W := 1;
9795 T := Hi;
9796 while T /= 0 loop
9797 T := T / 10;
9798 W := W + 1;
9799 end loop;
9800
9801 -- Only remaining possibility is user declared enum type
9802 -- with normal case of Discard_Names not active.
9803
9804 else
9805 pragma Assert (Is_Enumeration_Type (P_Type));
9806
9807 W := 0;
9808 L := First_Literal (P_Type);
9809 while Present (L) loop
9810
9811 -- Only pay attention to in range characters
9812
9813 if Lo <= Enumeration_Pos (L)
9814 and then Enumeration_Pos (L) <= Hi
9815 then
9816 -- For Width case, use decoded name
9817
9818 if Id = Attribute_Width then
9819 Get_Decoded_Name_String (Chars (L));
9820 Wt := Nat (Name_Len);
9821
9822 -- For Wide_[Wide_]Width, use encoded name, and
9823 -- then adjust for the encoding.
9824
9825 else
9826 Get_Name_String (Chars (L));
9827
9828 -- Character literals are always of length 3
9829
9830 if Name_Buffer (1) = 'Q' then
9831 Wt := 3;
9832
9833 -- Otherwise loop to adjust for upper/wide chars
9834
9835 else
9836 Wt := Nat (Name_Len);
9837
9838 for J in 1 .. Name_Len loop
9839 if Name_Buffer (J) = 'U' then
9840 Wt := Wt - 2;
9841 elsif Name_Buffer (J) = 'W' then
9842 Wt := Wt - 4;
9843 end if;
9844 end loop;
9845 end if;
9846 end if;
9847
9848 W := Int'Max (W, Wt);
9849 end if;
9850
9851 Next_Literal (L);
9852 end loop;
9853 end if;
9854
9855 Fold_Uint (N, UI_From_Int (W), Static);
9856 end;
9857 end if;
9858 end if;
9859 end Width;
9860
9861 -- The following attributes denote functions that cannot be folded
9862
9863 when Attribute_From_Any |
9864 Attribute_To_Any |
9865 Attribute_TypeCode =>
9866 null;
9867
9868 -- The following attributes can never be folded, and furthermore we
9869 -- should not even have entered the case statement for any of these.
9870 -- Note that in some cases, the values have already been folded as
9871 -- a result of the processing in Analyze_Attribute or earlier in
9872 -- this procedure.
9873
9874 when Attribute_Abort_Signal |
9875 Attribute_Access |
9876 Attribute_Address |
9877 Attribute_Address_Size |
9878 Attribute_Asm_Input |
9879 Attribute_Asm_Output |
9880 Attribute_Base |
9881 Attribute_Bit_Order |
9882 Attribute_Bit_Position |
9883 Attribute_Callable |
9884 Attribute_Caller |
9885 Attribute_Class |
9886 Attribute_Code_Address |
9887 Attribute_Compiler_Version |
9888 Attribute_Count |
9889 Attribute_Default_Bit_Order |
9890 Attribute_Default_Scalar_Storage_Order |
9891 Attribute_Deref |
9892 Attribute_Elaborated |
9893 Attribute_Elab_Body |
9894 Attribute_Elab_Spec |
9895 Attribute_Elab_Subp_Body |
9896 Attribute_Enabled |
9897 Attribute_External_Tag |
9898 Attribute_Fast_Math |
9899 Attribute_First_Bit |
9900 Attribute_Img |
9901 Attribute_Input |
9902 Attribute_Last_Bit |
9903 Attribute_Library_Level |
9904 Attribute_Maximum_Alignment |
9905 Attribute_Old |
9906 Attribute_Output |
9907 Attribute_Partition_ID |
9908 Attribute_Pool_Address |
9909 Attribute_Position |
9910 Attribute_Priority |
9911 Attribute_Read |
9912 Attribute_Result |
9913 Attribute_Scalar_Storage_Order |
9914 Attribute_Simple_Storage_Pool |
9915 Attribute_Storage_Pool |
9916 Attribute_Storage_Size |
9917 Attribute_Storage_Unit |
9918 Attribute_Stub_Type |
9919 Attribute_System_Allocator_Alignment |
9920 Attribute_Tag |
9921 Attribute_Target_Name |
9922 Attribute_Terminated |
9923 Attribute_To_Address |
9924 Attribute_Type_Key |
9925 Attribute_Unchecked_Access |
9926 Attribute_Universal_Literal_String |
9927 Attribute_Unrestricted_Access |
9928 Attribute_Valid |
9929 Attribute_Valid_Scalars |
9930 Attribute_Value |
9931 Attribute_Wchar_T_Size |
9932 Attribute_Wide_Value |
9933 Attribute_Wide_Wide_Value |
9934 Attribute_Word_Size |
9935 Attribute_Write =>
9936
9937 raise Program_Error;
9938 end case;
9939
9940 -- At the end of the case, one more check. If we did a static evaluation
9941 -- so that the result is now a literal, then set Is_Static_Expression
9942 -- in the constant only if the prefix type is a static subtype. For
9943 -- non-static subtypes, the folding is still OK, but not static.
9944
9945 -- An exception is the GNAT attribute Constrained_Array which is
9946 -- defined to be a static attribute in all cases.
9947
9948 if Nkind_In (N, N_Integer_Literal,
9949 N_Real_Literal,
9950 N_Character_Literal,
9951 N_String_Literal)
9952 or else (Is_Entity_Name (N)
9953 and then Ekind (Entity (N)) = E_Enumeration_Literal)
9954 then
9955 Set_Is_Static_Expression (N, Static);
9956
9957 -- If this is still an attribute reference, then it has not been folded
9958 -- and that means that its expressions are in a non-static context.
9959
9960 elsif Nkind (N) = N_Attribute_Reference then
9961 Check_Expressions;
9962
9963 -- Note: the else case not covered here are odd cases where the
9964 -- processing has transformed the attribute into something other
9965 -- than a constant. Nothing more to do in such cases.
9966
9967 else
9968 null;
9969 end if;
9970 end Eval_Attribute;
9971
9972 ------------------------------
9973 -- Is_Anonymous_Tagged_Base --
9974 ------------------------------
9975
9976 function Is_Anonymous_Tagged_Base
9977 (Anon : Entity_Id;
9978 Typ : Entity_Id) return Boolean
9979 is
9980 begin
9981 return
9982 Anon = Current_Scope
9983 and then Is_Itype (Anon)
9984 and then Associated_Node_For_Itype (Anon) = Parent (Typ);
9985 end Is_Anonymous_Tagged_Base;
9986
9987 --------------------------------
9988 -- Name_Implies_Lvalue_Prefix --
9989 --------------------------------
9990
9991 function Name_Implies_Lvalue_Prefix (Nam : Name_Id) return Boolean is
9992 pragma Assert (Is_Attribute_Name (Nam));
9993 begin
9994 return Attribute_Name_Implies_Lvalue_Prefix (Get_Attribute_Id (Nam));
9995 end Name_Implies_Lvalue_Prefix;
9996
9997 -----------------------
9998 -- Resolve_Attribute --
9999 -----------------------
10000
10001 procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is
10002 Loc : constant Source_Ptr := Sloc (N);
10003 P : constant Node_Id := Prefix (N);
10004 Aname : constant Name_Id := Attribute_Name (N);
10005 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
10006 Btyp : constant Entity_Id := Base_Type (Typ);
10007 Des_Btyp : Entity_Id;
10008 Index : Interp_Index;
10009 It : Interp;
10010 Nom_Subt : Entity_Id;
10011
10012 procedure Accessibility_Message;
10013 -- Error, or warning within an instance, if the static accessibility
10014 -- rules of 3.10.2 are violated.
10015
10016 function Declared_Within_Generic_Unit
10017 (Entity : Entity_Id;
10018 Generic_Unit : Node_Id) return Boolean;
10019 -- Returns True if Declared_Entity is declared within the declarative
10020 -- region of Generic_Unit; otherwise returns False.
10021
10022 ---------------------------
10023 -- Accessibility_Message --
10024 ---------------------------
10025
10026 procedure Accessibility_Message is
10027 Indic : Node_Id := Parent (Parent (N));
10028
10029 begin
10030 -- In an instance, this is a runtime check, but one we
10031 -- know will fail, so generate an appropriate warning.
10032
10033 if In_Instance_Body then
10034 Error_Msg_Warn := SPARK_Mode /= On;
10035 Error_Msg_F
10036 ("non-local pointer cannot point to local object<<", P);
10037 Error_Msg_F ("\Program_Error [<<", P);
10038 Rewrite (N,
10039 Make_Raise_Program_Error (Loc,
10040 Reason => PE_Accessibility_Check_Failed));
10041 Set_Etype (N, Typ);
10042 return;
10043
10044 else
10045 Error_Msg_F ("non-local pointer cannot point to local object", P);
10046
10047 -- Check for case where we have a missing access definition
10048
10049 if Is_Record_Type (Current_Scope)
10050 and then
10051 Nkind_In (Parent (N), N_Discriminant_Association,
10052 N_Index_Or_Discriminant_Constraint)
10053 then
10054 Indic := Parent (Parent (N));
10055 while Present (Indic)
10056 and then Nkind (Indic) /= N_Subtype_Indication
10057 loop
10058 Indic := Parent (Indic);
10059 end loop;
10060
10061 if Present (Indic) then
10062 Error_Msg_NE
10063 ("\use an access definition for" &
10064 " the access discriminant of&",
10065 N, Entity (Subtype_Mark (Indic)));
10066 end if;
10067 end if;
10068 end if;
10069 end Accessibility_Message;
10070
10071 ----------------------------------
10072 -- Declared_Within_Generic_Unit --
10073 ----------------------------------
10074
10075 function Declared_Within_Generic_Unit
10076 (Entity : Entity_Id;
10077 Generic_Unit : Node_Id) return Boolean
10078 is
10079 Generic_Encloser : Node_Id := Enclosing_Generic_Unit (Entity);
10080
10081 begin
10082 while Present (Generic_Encloser) loop
10083 if Generic_Encloser = Generic_Unit then
10084 return True;
10085 end if;
10086
10087 -- We have to step to the scope of the generic's entity, because
10088 -- otherwise we'll just get back the same generic.
10089
10090 Generic_Encloser :=
10091 Enclosing_Generic_Unit
10092 (Scope (Defining_Entity (Generic_Encloser)));
10093 end loop;
10094
10095 return False;
10096 end Declared_Within_Generic_Unit;
10097
10098 -- Start of processing for Resolve_Attribute
10099
10100 begin
10101 -- If error during analysis, no point in continuing, except for array
10102 -- types, where we get better recovery by using unconstrained indexes
10103 -- than nothing at all (see Check_Array_Type).
10104
10105 if Error_Posted (N)
10106 and then Attr_Id /= Attribute_First
10107 and then Attr_Id /= Attribute_Last
10108 and then Attr_Id /= Attribute_Length
10109 and then Attr_Id /= Attribute_Range
10110 then
10111 return;
10112 end if;
10113
10114 -- If attribute was universal type, reset to actual type
10115
10116 if Etype (N) = Universal_Integer
10117 or else Etype (N) = Universal_Real
10118 then
10119 Set_Etype (N, Typ);
10120 end if;
10121
10122 -- Remaining processing depends on attribute
10123
10124 case Attr_Id is
10125
10126 ------------
10127 -- Access --
10128 ------------
10129
10130 -- For access attributes, if the prefix denotes an entity, it is
10131 -- interpreted as a name, never as a call. It may be overloaded,
10132 -- in which case resolution uses the profile of the context type.
10133 -- Otherwise prefix must be resolved.
10134
10135 when Attribute_Access
10136 | Attribute_Unchecked_Access
10137 | Attribute_Unrestricted_Access =>
10138
10139 Access_Attribute :
10140 begin
10141 -- Note possible modification if we have a variable
10142
10143 if Is_Variable (P) then
10144 declare
10145 PN : constant Node_Id := Parent (N);
10146 Nm : Node_Id;
10147
10148 Note : Boolean := True;
10149 -- Skip this for the case of Unrestricted_Access occuring in
10150 -- the context of a Valid check, since this otherwise leads
10151 -- to a missed warning (the Valid check does not really
10152 -- modify!) If this case, Note will be reset to False.
10153
10154 -- Skip it as well if the type is an Acccess_To_Constant,
10155 -- given that no use of the value can modify the prefix.
10156
10157 begin
10158 if Attr_Id = Attribute_Unrestricted_Access
10159 and then Nkind (PN) = N_Function_Call
10160 then
10161 Nm := Name (PN);
10162
10163 if Nkind (Nm) = N_Expanded_Name
10164 and then Chars (Nm) = Name_Valid
10165 and then Nkind (Prefix (Nm)) = N_Identifier
10166 and then Chars (Prefix (Nm)) = Name_Attr_Long_Float
10167 then
10168 Note := False;
10169 end if;
10170
10171 elsif Is_Access_Constant (Typ) then
10172 Note := False;
10173 end if;
10174
10175 if Note then
10176 Note_Possible_Modification (P, Sure => False);
10177 end if;
10178 end;
10179 end if;
10180
10181 -- The following comes from a query concerning improper use of
10182 -- universal_access in equality tests involving anonymous access
10183 -- types. Another good reason for 'Ref, but for now disable the
10184 -- test, which breaks several filed tests???
10185
10186 if Ekind (Typ) = E_Anonymous_Access_Type
10187 and then Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne)
10188 and then False
10189 then
10190 Error_Msg_N ("need unique type to resolve 'Access", N);
10191 Error_Msg_N ("\qualify attribute with some access type", N);
10192 end if;
10193
10194 -- Case where prefix is an entity name
10195
10196 if Is_Entity_Name (P) then
10197
10198 -- Deal with case where prefix itself is overloaded
10199
10200 if Is_Overloaded (P) then
10201 Get_First_Interp (P, Index, It);
10202 while Present (It.Nam) loop
10203 if Type_Conformant (Designated_Type (Typ), It.Nam) then
10204 Set_Entity (P, It.Nam);
10205
10206 -- The prefix is definitely NOT overloaded anymore at
10207 -- this point, so we reset the Is_Overloaded flag to
10208 -- avoid any confusion when reanalyzing the node.
10209
10210 Set_Is_Overloaded (P, False);
10211 Set_Is_Overloaded (N, False);
10212 Generate_Reference (Entity (P), P);
10213 exit;
10214 end if;
10215
10216 Get_Next_Interp (Index, It);
10217 end loop;
10218
10219 -- If Prefix is a subprogram name, this reference freezes,
10220 -- but not if within spec expression mode. The profile of
10221 -- the subprogram is not frozen at this point.
10222
10223 if not In_Spec_Expression then
10224 Freeze_Before (N, Entity (P), Do_Freeze_Profile => False);
10225 end if;
10226
10227 -- If it is a type, there is nothing to resolve.
10228 -- If it is a subprogram, do not freeze its profile.
10229 -- If it is an object, complete its resolution.
10230
10231 elsif Is_Overloadable (Entity (P)) then
10232 if not In_Spec_Expression then
10233 Freeze_Before (N, Entity (P), Do_Freeze_Profile => False);
10234 end if;
10235
10236 -- Nothing to do if prefix is a type name
10237
10238 elsif Is_Type (Entity (P)) then
10239 null;
10240
10241 -- Otherwise non-overloaded other case, resolve the prefix
10242
10243 else
10244 Resolve (P);
10245 end if;
10246
10247 -- Some further error checks
10248
10249 Error_Msg_Name_1 := Aname;
10250
10251 if not Is_Entity_Name (P) then
10252 null;
10253
10254 elsif Is_Overloadable (Entity (P))
10255 and then Is_Abstract_Subprogram (Entity (P))
10256 then
10257 Error_Msg_F ("prefix of % attribute cannot be abstract", P);
10258 Set_Etype (N, Any_Type);
10259
10260 elsif Ekind (Entity (P)) = E_Enumeration_Literal then
10261 Error_Msg_F
10262 ("prefix of % attribute cannot be enumeration literal", P);
10263 Set_Etype (N, Any_Type);
10264
10265 -- An attempt to take 'Access of a function that renames an
10266 -- enumeration literal. Issue a specialized error message.
10267
10268 elsif Ekind (Entity (P)) = E_Function
10269 and then Present (Alias (Entity (P)))
10270 and then Ekind (Alias (Entity (P))) = E_Enumeration_Literal
10271 then
10272 Error_Msg_F
10273 ("prefix of % attribute cannot be function renaming "
10274 & "an enumeration literal", P);
10275 Set_Etype (N, Any_Type);
10276
10277 elsif Convention (Entity (P)) = Convention_Intrinsic then
10278 Error_Msg_F ("prefix of % attribute cannot be intrinsic", P);
10279 Set_Etype (N, Any_Type);
10280 end if;
10281
10282 -- Assignments, return statements, components of aggregates,
10283 -- generic instantiations will require convention checks if
10284 -- the type is an access to subprogram. Given that there will
10285 -- also be accessibility checks on those, this is where the
10286 -- checks can eventually be centralized ???
10287
10288 if Ekind_In (Btyp, E_Access_Subprogram_Type,
10289 E_Anonymous_Access_Subprogram_Type,
10290 E_Access_Protected_Subprogram_Type,
10291 E_Anonymous_Access_Protected_Subprogram_Type)
10292 then
10293 -- Deal with convention mismatch
10294
10295 if Convention (Designated_Type (Btyp)) /=
10296 Convention (Entity (P))
10297 then
10298 Error_Msg_FE
10299 ("subprogram & has wrong convention", P, Entity (P));
10300 Error_Msg_Sloc := Sloc (Btyp);
10301 Error_Msg_FE ("\does not match & declared#", P, Btyp);
10302
10303 if not Is_Itype (Btyp)
10304 and then not Has_Convention_Pragma (Btyp)
10305 then
10306 Error_Msg_FE
10307 ("\probable missing pragma Convention for &",
10308 P, Btyp);
10309 end if;
10310
10311 else
10312 Check_Subtype_Conformant
10313 (New_Id => Entity (P),
10314 Old_Id => Designated_Type (Btyp),
10315 Err_Loc => P);
10316 end if;
10317
10318 if Attr_Id = Attribute_Unchecked_Access then
10319 Error_Msg_Name_1 := Aname;
10320 Error_Msg_F
10321 ("attribute% cannot be applied to a subprogram", P);
10322
10323 elsif Aname = Name_Unrestricted_Access then
10324 null; -- Nothing to check
10325
10326 -- Check the static accessibility rule of 3.10.2(32).
10327 -- This rule also applies within the private part of an
10328 -- instantiation. This rule does not apply to anonymous
10329 -- access-to-subprogram types in access parameters.
10330
10331 elsif Attr_Id = Attribute_Access
10332 and then not In_Instance_Body
10333 and then
10334 (Ekind (Btyp) = E_Access_Subprogram_Type
10335 or else Is_Local_Anonymous_Access (Btyp))
10336 and then Subprogram_Access_Level (Entity (P)) >
10337 Type_Access_Level (Btyp)
10338 then
10339 Error_Msg_F
10340 ("subprogram must not be deeper than access type", P);
10341
10342 -- Check the restriction of 3.10.2(32) that disallows the
10343 -- access attribute within a generic body when the ultimate
10344 -- ancestor of the type of the attribute is declared outside
10345 -- of the generic unit and the subprogram is declared within
10346 -- that generic unit. This includes any such attribute that
10347 -- occurs within the body of a generic unit that is a child
10348 -- of the generic unit where the subprogram is declared.
10349
10350 -- The rule also prohibits applying the attribute when the
10351 -- access type is a generic formal access type (since the
10352 -- level of the actual type is not known). This restriction
10353 -- does not apply when the attribute type is an anonymous
10354 -- access-to-subprogram type. Note that this check was
10355 -- revised by AI-229, because the original Ada 95 rule
10356 -- was too lax. The original rule only applied when the
10357 -- subprogram was declared within the body of the generic,
10358 -- which allowed the possibility of dangling references).
10359 -- The rule was also too strict in some cases, in that it
10360 -- didn't permit the access to be declared in the generic
10361 -- spec, whereas the revised rule does (as long as it's not
10362 -- a formal type).
10363
10364 -- There are a couple of subtleties of the test for applying
10365 -- the check that are worth noting. First, we only apply it
10366 -- when the levels of the subprogram and access type are the
10367 -- same (the case where the subprogram is statically deeper
10368 -- was applied above, and the case where the type is deeper
10369 -- is always safe). Second, we want the check to apply
10370 -- within nested generic bodies and generic child unit
10371 -- bodies, but not to apply to an attribute that appears in
10372 -- the generic unit's specification. This is done by testing
10373 -- that the attribute's innermost enclosing generic body is
10374 -- not the same as the innermost generic body enclosing the
10375 -- generic unit where the subprogram is declared (we don't
10376 -- want the check to apply when the access attribute is in
10377 -- the spec and there's some other generic body enclosing
10378 -- generic). Finally, there's no point applying the check
10379 -- when within an instance, because any violations will have
10380 -- been caught by the compilation of the generic unit.
10381
10382 -- We relax this check in Relaxed_RM_Semantics mode for
10383 -- compatibility with legacy code for use by Ada source
10384 -- code analyzers (e.g. CodePeer).
10385
10386 elsif Attr_Id = Attribute_Access
10387 and then not Relaxed_RM_Semantics
10388 and then not In_Instance
10389 and then Present (Enclosing_Generic_Unit (Entity (P)))
10390 and then Present (Enclosing_Generic_Body (N))
10391 and then Enclosing_Generic_Body (N) /=
10392 Enclosing_Generic_Body
10393 (Enclosing_Generic_Unit (Entity (P)))
10394 and then Subprogram_Access_Level (Entity (P)) =
10395 Type_Access_Level (Btyp)
10396 and then Ekind (Btyp) /=
10397 E_Anonymous_Access_Subprogram_Type
10398 and then Ekind (Btyp) /=
10399 E_Anonymous_Access_Protected_Subprogram_Type
10400 then
10401 -- The attribute type's ultimate ancestor must be
10402 -- declared within the same generic unit as the
10403 -- subprogram is declared (including within another
10404 -- nested generic unit). The error message is
10405 -- specialized to say "ancestor" for the case where the
10406 -- access type is not its own ancestor, since saying
10407 -- simply "access type" would be very confusing.
10408
10409 if not Declared_Within_Generic_Unit
10410 (Root_Type (Btyp),
10411 Enclosing_Generic_Unit (Entity (P)))
10412 then
10413 Error_Msg_N
10414 ("''Access attribute not allowed in generic body",
10415 N);
10416
10417 if Root_Type (Btyp) = Btyp then
10418 Error_Msg_NE
10419 ("\because " &
10420 "access type & is declared outside " &
10421 "generic unit (RM 3.10.2(32))", N, Btyp);
10422 else
10423 Error_Msg_NE
10424 ("\because ancestor of " &
10425 "access type & is declared outside " &
10426 "generic unit (RM 3.10.2(32))", N, Btyp);
10427 end if;
10428
10429 Error_Msg_NE
10430 ("\move ''Access to private part, or " &
10431 "(Ada 2005) use anonymous access type instead of &",
10432 N, Btyp);
10433
10434 -- If the ultimate ancestor of the attribute's type is
10435 -- a formal type, then the attribute is illegal because
10436 -- the actual type might be declared at a higher level.
10437 -- The error message is specialized to say "ancestor"
10438 -- for the case where the access type is not its own
10439 -- ancestor, since saying simply "access type" would be
10440 -- very confusing.
10441
10442 elsif Is_Generic_Type (Root_Type (Btyp)) then
10443 if Root_Type (Btyp) = Btyp then
10444 Error_Msg_N
10445 ("access type must not be a generic formal type",
10446 N);
10447 else
10448 Error_Msg_N
10449 ("ancestor access type must not be a generic " &
10450 "formal type", N);
10451 end if;
10452 end if;
10453 end if;
10454 end if;
10455
10456 -- If this is a renaming, an inherited operation, or a
10457 -- subprogram instance, use the original entity. This may make
10458 -- the node type-inconsistent, so this transformation can only
10459 -- be done if the node will not be reanalyzed. In particular,
10460 -- if it is within a default expression, the transformation
10461 -- must be delayed until the default subprogram is created for
10462 -- it, when the enclosing subprogram is frozen.
10463
10464 if Is_Entity_Name (P)
10465 and then Is_Overloadable (Entity (P))
10466 and then Present (Alias (Entity (P)))
10467 and then Expander_Active
10468 then
10469 Rewrite (P,
10470 New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
10471 end if;
10472
10473 elsif Nkind (P) = N_Selected_Component
10474 and then Is_Overloadable (Entity (Selector_Name (P)))
10475 then
10476 -- Protected operation. If operation is overloaded, must
10477 -- disambiguate. Prefix that denotes protected object itself
10478 -- is resolved with its own type.
10479
10480 if Attr_Id = Attribute_Unchecked_Access then
10481 Error_Msg_Name_1 := Aname;
10482 Error_Msg_F
10483 ("attribute% cannot be applied to protected operation", P);
10484 end if;
10485
10486 Resolve (Prefix (P));
10487 Generate_Reference (Entity (Selector_Name (P)), P);
10488
10489 -- Implement check implied by 3.10.2 (18.1/2) : F.all'access is
10490 -- statically illegal if F is an anonymous access to subprogram.
10491
10492 elsif Nkind (P) = N_Explicit_Dereference
10493 and then Is_Entity_Name (Prefix (P))
10494 and then Ekind (Etype (Entity (Prefix (P)))) =
10495 E_Anonymous_Access_Subprogram_Type
10496 then
10497 Error_Msg_N ("anonymous access to subprogram "
10498 & "has deeper accessibility than any master", P);
10499
10500 elsif Is_Overloaded (P) then
10501
10502 -- Use the designated type of the context to disambiguate
10503 -- Note that this was not strictly conformant to Ada 95,
10504 -- but was the implementation adopted by most Ada 95 compilers.
10505 -- The use of the context type to resolve an Access attribute
10506 -- reference is now mandated in AI-235 for Ada 2005.
10507
10508 declare
10509 Index : Interp_Index;
10510 It : Interp;
10511
10512 begin
10513 Get_First_Interp (P, Index, It);
10514 while Present (It.Typ) loop
10515 if Covers (Designated_Type (Typ), It.Typ) then
10516 Resolve (P, It.Typ);
10517 exit;
10518 end if;
10519
10520 Get_Next_Interp (Index, It);
10521 end loop;
10522 end;
10523 else
10524 Resolve (P);
10525 end if;
10526
10527 -- X'Access is illegal if X denotes a constant and the access type
10528 -- is access-to-variable. Same for 'Unchecked_Access. The rule
10529 -- does not apply to 'Unrestricted_Access. If the reference is a
10530 -- default-initialized aggregate component for a self-referential
10531 -- type the reference is legal.
10532
10533 if not (Ekind (Btyp) = E_Access_Subprogram_Type
10534 or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
10535 or else (Is_Record_Type (Btyp)
10536 and then
10537 Present (Corresponding_Remote_Type (Btyp)))
10538 or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type
10539 or else Ekind (Btyp)
10540 = E_Anonymous_Access_Protected_Subprogram_Type
10541 or else Is_Access_Constant (Btyp)
10542 or else Is_Variable (P)
10543 or else Attr_Id = Attribute_Unrestricted_Access)
10544 then
10545 if Is_Entity_Name (P)
10546 and then Is_Type (Entity (P))
10547 then
10548 -- Legality of a self-reference through an access
10549 -- attribute has been verified in Analyze_Access_Attribute.
10550
10551 null;
10552
10553 elsif Comes_From_Source (N) then
10554 Error_Msg_F ("access-to-variable designates constant", P);
10555 end if;
10556 end if;
10557
10558 Des_Btyp := Designated_Type (Btyp);
10559
10560 if Ada_Version >= Ada_2005
10561 and then Is_Incomplete_Type (Des_Btyp)
10562 then
10563 -- Ada 2005 (AI-412): If the (sub)type is a limited view of an
10564 -- imported entity, and the non-limited view is visible, make
10565 -- use of it. If it is an incomplete subtype, use the base type
10566 -- in any case.
10567
10568 if From_Limited_With (Des_Btyp)
10569 and then Present (Non_Limited_View (Des_Btyp))
10570 then
10571 Des_Btyp := Non_Limited_View (Des_Btyp);
10572
10573 elsif Ekind (Des_Btyp) = E_Incomplete_Subtype then
10574 Des_Btyp := Etype (Des_Btyp);
10575 end if;
10576 end if;
10577
10578 if (Attr_Id = Attribute_Access
10579 or else
10580 Attr_Id = Attribute_Unchecked_Access)
10581 and then (Ekind (Btyp) = E_General_Access_Type
10582 or else Ekind (Btyp) = E_Anonymous_Access_Type)
10583 then
10584 -- Ada 2005 (AI-230): Check the accessibility of anonymous
10585 -- access types for stand-alone objects, record and array
10586 -- components, and return objects. For a component definition
10587 -- the level is the same of the enclosing composite type.
10588
10589 if Ada_Version >= Ada_2005
10590 and then (Is_Local_Anonymous_Access (Btyp)
10591
10592 -- Handle cases where Btyp is the anonymous access
10593 -- type of an Ada 2012 stand-alone object.
10594
10595 or else Nkind (Associated_Node_For_Itype (Btyp)) =
10596 N_Object_Declaration)
10597 and then
10598 Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp)
10599 and then Attr_Id = Attribute_Access
10600 then
10601 -- In an instance, this is a runtime check, but one we know
10602 -- will fail, so generate an appropriate warning. As usual,
10603 -- this kind of warning is an error in SPARK mode.
10604
10605 if In_Instance_Body then
10606 Error_Msg_Warn := SPARK_Mode /= On;
10607 Error_Msg_F
10608 ("non-local pointer cannot point to local object<<", P);
10609 Error_Msg_F ("\Program_Error [<<", P);
10610
10611 Rewrite (N,
10612 Make_Raise_Program_Error (Loc,
10613 Reason => PE_Accessibility_Check_Failed));
10614 Set_Etype (N, Typ);
10615
10616 else
10617 Error_Msg_F
10618 ("non-local pointer cannot point to local object", P);
10619 end if;
10620 end if;
10621
10622 if Is_Dependent_Component_Of_Mutable_Object (P) then
10623 Error_Msg_F
10624 ("illegal attribute for discriminant-dependent component",
10625 P);
10626 end if;
10627
10628 -- Check static matching rule of 3.10.2(27). Nominal subtype
10629 -- of the prefix must statically match the designated type.
10630
10631 Nom_Subt := Etype (P);
10632
10633 if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then
10634 Nom_Subt := Base_Type (Nom_Subt);
10635 end if;
10636
10637 if Is_Tagged_Type (Designated_Type (Typ)) then
10638
10639 -- If the attribute is in the context of an access
10640 -- parameter, then the prefix is allowed to be of
10641 -- the class-wide type (by AI-127).
10642
10643 if Ekind (Typ) = E_Anonymous_Access_Type then
10644 if not Covers (Designated_Type (Typ), Nom_Subt)
10645 and then not Covers (Nom_Subt, Designated_Type (Typ))
10646 then
10647 declare
10648 Desig : Entity_Id;
10649
10650 begin
10651 Desig := Designated_Type (Typ);
10652
10653 if Is_Class_Wide_Type (Desig) then
10654 Desig := Etype (Desig);
10655 end if;
10656
10657 if Is_Anonymous_Tagged_Base (Nom_Subt, Desig) then
10658 null;
10659
10660 else
10661 Error_Msg_FE
10662 ("type of prefix: & not compatible",
10663 P, Nom_Subt);
10664 Error_Msg_FE
10665 ("\with &, the expected designated type",
10666 P, Designated_Type (Typ));
10667 end if;
10668 end;
10669 end if;
10670
10671 elsif not Covers (Designated_Type (Typ), Nom_Subt)
10672 or else
10673 (not Is_Class_Wide_Type (Designated_Type (Typ))
10674 and then Is_Class_Wide_Type (Nom_Subt))
10675 then
10676 Error_Msg_FE
10677 ("type of prefix: & is not covered", P, Nom_Subt);
10678 Error_Msg_FE
10679 ("\by &, the expected designated type" &
10680 " (RM 3.10.2 (27))", P, Designated_Type (Typ));
10681 end if;
10682
10683 if Is_Class_Wide_Type (Designated_Type (Typ))
10684 and then Has_Discriminants (Etype (Designated_Type (Typ)))
10685 and then Is_Constrained (Etype (Designated_Type (Typ)))
10686 and then Designated_Type (Typ) /= Nom_Subt
10687 then
10688 Apply_Discriminant_Check
10689 (N, Etype (Designated_Type (Typ)));
10690 end if;
10691
10692 -- Ada 2005 (AI-363): Require static matching when designated
10693 -- type has discriminants and a constrained partial view, since
10694 -- in general objects of such types are mutable, so we can't
10695 -- allow the access value to designate a constrained object
10696 -- (because access values must be assumed to designate mutable
10697 -- objects when designated type does not impose a constraint).
10698
10699 elsif Subtypes_Statically_Match (Des_Btyp, Nom_Subt) then
10700 null;
10701
10702 elsif Has_Discriminants (Designated_Type (Typ))
10703 and then not Is_Constrained (Des_Btyp)
10704 and then
10705 (Ada_Version < Ada_2005
10706 or else
10707 not Object_Type_Has_Constrained_Partial_View
10708 (Typ => Designated_Type (Base_Type (Typ)),
10709 Scop => Current_Scope))
10710 then
10711 null;
10712
10713 else
10714 Error_Msg_F
10715 ("object subtype must statically match "
10716 & "designated subtype", P);
10717
10718 if Is_Entity_Name (P)
10719 and then Is_Array_Type (Designated_Type (Typ))
10720 then
10721 declare
10722 D : constant Node_Id := Declaration_Node (Entity (P));
10723 begin
10724 Error_Msg_N
10725 ("aliased object has explicit bounds??", D);
10726 Error_Msg_N
10727 ("\declare without bounds (and with explicit "
10728 & "initialization)??", D);
10729 Error_Msg_N
10730 ("\for use with unconstrained access??", D);
10731 end;
10732 end if;
10733 end if;
10734
10735 -- Check the static accessibility rule of 3.10.2(28). Note that
10736 -- this check is not performed for the case of an anonymous
10737 -- access type, since the access attribute is always legal
10738 -- in such a context.
10739
10740 if Attr_Id /= Attribute_Unchecked_Access
10741 and then Ekind (Btyp) = E_General_Access_Type
10742 and then
10743 Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp)
10744 then
10745 Accessibility_Message;
10746 return;
10747 end if;
10748 end if;
10749
10750 if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type,
10751 E_Anonymous_Access_Protected_Subprogram_Type)
10752 then
10753 if Is_Entity_Name (P)
10754 and then not Is_Protected_Type (Scope (Entity (P)))
10755 then
10756 Error_Msg_F ("context requires a protected subprogram", P);
10757
10758 -- Check accessibility of protected object against that of the
10759 -- access type, but only on user code, because the expander
10760 -- creates access references for handlers. If the context is an
10761 -- anonymous_access_to_protected, there are no accessibility
10762 -- checks either. Omit check entirely for Unrestricted_Access.
10763
10764 elsif Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp)
10765 and then Comes_From_Source (N)
10766 and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type
10767 and then Attr_Id /= Attribute_Unrestricted_Access
10768 then
10769 Accessibility_Message;
10770 return;
10771
10772 -- AI05-0225: If the context is not an access to protected
10773 -- function, the prefix must be a variable, given that it may
10774 -- be used subsequently in a protected call.
10775
10776 elsif Nkind (P) = N_Selected_Component
10777 and then not Is_Variable (Prefix (P))
10778 and then Ekind (Entity (Selector_Name (P))) /= E_Function
10779 then
10780 Error_Msg_N
10781 ("target object of access to protected procedure "
10782 & "must be variable", N);
10783
10784 elsif Is_Entity_Name (P) then
10785 Check_Internal_Protected_Use (N, Entity (P));
10786 end if;
10787
10788 elsif Ekind_In (Btyp, E_Access_Subprogram_Type,
10789 E_Anonymous_Access_Subprogram_Type)
10790 and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type
10791 then
10792 Error_Msg_F ("context requires a non-protected subprogram", P);
10793 end if;
10794
10795 -- The context cannot be a pool-specific type, but this is a
10796 -- legality rule, not a resolution rule, so it must be checked
10797 -- separately, after possibly disambiguation (see AI-245).
10798
10799 if Ekind (Btyp) = E_Access_Type
10800 and then Attr_Id /= Attribute_Unrestricted_Access
10801 then
10802 Wrong_Type (N, Typ);
10803 end if;
10804
10805 -- The context may be a constrained access type (however ill-
10806 -- advised such subtypes might be) so in order to generate a
10807 -- constraint check when needed set the type of the attribute
10808 -- reference to the base type of the context.
10809
10810 Set_Etype (N, Btyp);
10811
10812 -- Check for incorrect atomic/volatile reference (RM C.6(12))
10813
10814 if Attr_Id /= Attribute_Unrestricted_Access then
10815 if Is_Atomic_Object (P)
10816 and then not Is_Atomic (Designated_Type (Typ))
10817 then
10818 Error_Msg_F
10819 ("access to atomic object cannot yield access-to-" &
10820 "non-atomic type", P);
10821
10822 elsif Is_Volatile_Object (P)
10823 and then not Is_Volatile (Designated_Type (Typ))
10824 then
10825 Error_Msg_F
10826 ("access to volatile object cannot yield access-to-" &
10827 "non-volatile type", P);
10828 end if;
10829 end if;
10830
10831 -- Check for unrestricted access where expected type is a thin
10832 -- pointer to an unconstrained array.
10833
10834 if Non_Aliased_Prefix (N)
10835 and then Has_Size_Clause (Typ)
10836 and then RM_Size (Typ) = System_Address_Size
10837 then
10838 declare
10839 DT : constant Entity_Id := Designated_Type (Typ);
10840 begin
10841 if Is_Array_Type (DT) and then not Is_Constrained (DT) then
10842 Error_Msg_N
10843 ("illegal use of Unrestricted_Access attribute", P);
10844 Error_Msg_N
10845 ("\attempt to generate thin pointer to unaliased "
10846 & "object", P);
10847 end if;
10848 end;
10849 end if;
10850
10851 -- Mark that address of entity is taken
10852
10853 if Is_Entity_Name (P) then
10854 Set_Address_Taken (Entity (P));
10855 end if;
10856
10857 -- Deal with possible elaboration check
10858
10859 if Is_Entity_Name (P) and then Is_Subprogram (Entity (P)) then
10860 declare
10861 Subp_Id : constant Entity_Id := Entity (P);
10862 Scop : constant Entity_Id := Scope (Subp_Id);
10863 Subp_Decl : constant Node_Id :=
10864 Unit_Declaration_Node (Subp_Id);
10865 Flag_Id : Entity_Id;
10866 Subp_Body : Node_Id;
10867
10868 -- If the access has been taken and the body of the subprogram
10869 -- has not been see yet, indirect calls must be protected with
10870 -- elaboration checks. We have the proper elaboration machinery
10871 -- for subprograms declared in packages, but within a block or
10872 -- a subprogram the body will appear in the same declarative
10873 -- part, and we must insert a check in the eventual body itself
10874 -- using the elaboration flag that we generate now. The check
10875 -- is then inserted when the body is expanded. This processing
10876 -- is not needed for a stand alone expression function because
10877 -- the internally generated spec and body are always inserted
10878 -- as a pair in the same declarative list.
10879
10880 begin
10881 if Expander_Active
10882 and then Comes_From_Source (Subp_Id)
10883 and then Comes_From_Source (N)
10884 and then In_Open_Scopes (Scop)
10885 and then Ekind_In (Scop, E_Block, E_Procedure, E_Function)
10886 and then not Has_Completion (Subp_Id)
10887 and then No (Elaboration_Entity (Subp_Id))
10888 and then Nkind (Subp_Decl) = N_Subprogram_Declaration
10889 and then Nkind (Original_Node (Subp_Decl)) /=
10890 N_Expression_Function
10891 then
10892 -- Create elaboration variable for it
10893
10894 Flag_Id := Make_Temporary (Loc, 'E');
10895 Set_Elaboration_Entity (Subp_Id, Flag_Id);
10896 Set_Is_Frozen (Flag_Id);
10897
10898 -- Insert declaration for flag after subprogram
10899 -- declaration. Note that attribute reference may
10900 -- appear within a nested scope.
10901
10902 Insert_After_And_Analyze (Subp_Decl,
10903 Make_Object_Declaration (Loc,
10904 Defining_Identifier => Flag_Id,
10905 Object_Definition =>
10906 New_Occurrence_Of (Standard_Short_Integer, Loc),
10907 Expression =>
10908 Make_Integer_Literal (Loc, Uint_0)));
10909 end if;
10910
10911 -- Taking the 'Access of an expression function freezes its
10912 -- expression (RM 13.14 10.3/3). This does not apply to an
10913 -- expression function that acts as a completion because the
10914 -- generated body is immediately analyzed and the expression
10915 -- is automatically frozen.
10916
10917 if Is_Expression_Function (Subp_Id)
10918 and then Present (Corresponding_Body (Subp_Decl))
10919 then
10920 Subp_Body :=
10921 Unit_Declaration_Node (Corresponding_Body (Subp_Decl));
10922
10923 -- The body has already been analyzed when the expression
10924 -- function acts as a completion.
10925
10926 if Analyzed (Subp_Body) then
10927 null;
10928
10929 -- Attribute 'Access may appear within the generated body
10930 -- of the expression function subject to the attribute:
10931
10932 -- function F is (... F'Access ...);
10933
10934 -- If the expression function is on the scope stack, then
10935 -- the body is currently being analyzed. Do not reanalyze
10936 -- it because this will lead to infinite recursion.
10937
10938 elsif In_Open_Scopes (Subp_Id) then
10939 null;
10940
10941 -- If reference to the expression function appears in an
10942 -- inner scope, for example as an actual in an instance,
10943 -- this is not a freeze point either.
10944
10945 elsif Scope (Subp_Id) /= Current_Scope then
10946 null;
10947
10948 -- Analyze the body of the expression function to freeze
10949 -- the expression. This takes care of the case where the
10950 -- 'Access is part of dispatch table initialization and
10951 -- the generated body of the expression function has not
10952 -- been analyzed yet.
10953
10954 else
10955 Analyze (Subp_Body);
10956 end if;
10957 end if;
10958 end;
10959 end if;
10960 end Access_Attribute;
10961
10962 -------------
10963 -- Address --
10964 -------------
10965
10966 -- Deal with resolving the type for Address attribute, overloading
10967 -- is not permitted here, since there is no context to resolve it.
10968
10969 when Attribute_Address | Attribute_Code_Address =>
10970 Address_Attribute : begin
10971
10972 -- To be safe, assume that if the address of a variable is taken,
10973 -- it may be modified via this address, so note modification.
10974
10975 if Is_Variable (P) then
10976 Note_Possible_Modification (P, Sure => False);
10977 end if;
10978
10979 if Nkind (P) in N_Subexpr
10980 and then Is_Overloaded (P)
10981 then
10982 Get_First_Interp (P, Index, It);
10983 Get_Next_Interp (Index, It);
10984
10985 if Present (It.Nam) then
10986 Error_Msg_Name_1 := Aname;
10987 Error_Msg_F
10988 ("prefix of % attribute cannot be overloaded", P);
10989 end if;
10990 end if;
10991
10992 if not Is_Entity_Name (P)
10993 or else not Is_Overloadable (Entity (P))
10994 then
10995 if not Is_Task_Type (Etype (P))
10996 or else Nkind (P) = N_Explicit_Dereference
10997 then
10998 Resolve (P);
10999 end if;
11000 end if;
11001
11002 -- If this is the name of a derived subprogram, or that of a
11003 -- generic actual, the address is that of the original entity.
11004
11005 if Is_Entity_Name (P)
11006 and then Is_Overloadable (Entity (P))
11007 and then Present (Alias (Entity (P)))
11008 then
11009 Rewrite (P,
11010 New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
11011 end if;
11012
11013 if Is_Entity_Name (P) then
11014 Set_Address_Taken (Entity (P));
11015 end if;
11016
11017 if Nkind (P) = N_Slice then
11018
11019 -- Arr (X .. Y)'address is identical to Arr (X)'address,
11020 -- even if the array is packed and the slice itself is not
11021 -- addressable. Transform the prefix into an indexed component.
11022
11023 -- Note that the transformation is safe only if we know that
11024 -- the slice is non-null. That is because a null slice can have
11025 -- an out of bounds index value.
11026
11027 -- Right now, gigi blows up if given 'Address on a slice as a
11028 -- result of some incorrect freeze nodes generated by the front
11029 -- end, and this covers up that bug in one case, but the bug is
11030 -- likely still there in the cases not handled by this code ???
11031
11032 -- It's not clear what 'Address *should* return for a null
11033 -- slice with out of bounds indexes, this might be worth an ARG
11034 -- discussion ???
11035
11036 -- One approach would be to do a length check unconditionally,
11037 -- and then do the transformation below unconditionally, but
11038 -- analyze with checks off, avoiding the problem of the out of
11039 -- bounds index. This approach would interpret the address of
11040 -- an out of bounds null slice as being the address where the
11041 -- array element would be if there was one, which is probably
11042 -- as reasonable an interpretation as any ???
11043
11044 declare
11045 Loc : constant Source_Ptr := Sloc (P);
11046 D : constant Node_Id := Discrete_Range (P);
11047 Lo : Node_Id;
11048
11049 begin
11050 if Is_Entity_Name (D)
11051 and then
11052 Not_Null_Range
11053 (Type_Low_Bound (Entity (D)),
11054 Type_High_Bound (Entity (D)))
11055 then
11056 Lo :=
11057 Make_Attribute_Reference (Loc,
11058 Prefix => (New_Occurrence_Of (Entity (D), Loc)),
11059 Attribute_Name => Name_First);
11060
11061 elsif Nkind (D) = N_Range
11062 and then Not_Null_Range (Low_Bound (D), High_Bound (D))
11063 then
11064 Lo := Low_Bound (D);
11065
11066 else
11067 Lo := Empty;
11068 end if;
11069
11070 if Present (Lo) then
11071 Rewrite (P,
11072 Make_Indexed_Component (Loc,
11073 Prefix => Relocate_Node (Prefix (P)),
11074 Expressions => New_List (Lo)));
11075
11076 Analyze_And_Resolve (P);
11077 end if;
11078 end;
11079 end if;
11080 end Address_Attribute;
11081
11082 ------------------
11083 -- Body_Version --
11084 ------------------
11085
11086 -- Prefix of Body_Version attribute can be a subprogram name which
11087 -- must not be resolved, since this is not a call.
11088
11089 when Attribute_Body_Version =>
11090 null;
11091
11092 ------------
11093 -- Caller --
11094 ------------
11095
11096 -- Prefix of Caller attribute is an entry name which must not
11097 -- be resolved, since this is definitely not an entry call.
11098
11099 when Attribute_Caller =>
11100 null;
11101
11102 ------------------
11103 -- Code_Address --
11104 ------------------
11105
11106 -- Shares processing with Address attribute
11107
11108 -----------
11109 -- Count --
11110 -----------
11111
11112 -- If the prefix of the Count attribute is an entry name it must not
11113 -- be resolved, since this is definitely not an entry call. However,
11114 -- if it is an element of an entry family, the index itself may
11115 -- have to be resolved because it can be a general expression.
11116
11117 when Attribute_Count =>
11118 if Nkind (P) = N_Indexed_Component
11119 and then Is_Entity_Name (Prefix (P))
11120 then
11121 declare
11122 Indx : constant Node_Id := First (Expressions (P));
11123 Fam : constant Entity_Id := Entity (Prefix (P));
11124 begin
11125 Resolve (Indx, Entry_Index_Type (Fam));
11126 Apply_Range_Check (Indx, Entry_Index_Type (Fam));
11127 end;
11128 end if;
11129
11130 ----------------
11131 -- Elaborated --
11132 ----------------
11133
11134 -- Prefix of the Elaborated attribute is a subprogram name which
11135 -- must not be resolved, since this is definitely not a call. Note
11136 -- that it is a library unit, so it cannot be overloaded here.
11137
11138 when Attribute_Elaborated =>
11139 null;
11140
11141 -------------
11142 -- Enabled --
11143 -------------
11144
11145 -- Prefix of Enabled attribute is a check name, which must be treated
11146 -- specially and not touched by Resolve.
11147
11148 when Attribute_Enabled =>
11149 null;
11150
11151 ----------------
11152 -- Loop_Entry --
11153 ----------------
11154
11155 -- Do not resolve the prefix of Loop_Entry, instead wait until the
11156 -- attribute has been expanded (see Expand_Loop_Entry_Attributes).
11157 -- The delay ensures that any generated checks or temporaries are
11158 -- inserted before the relocated prefix.
11159
11160 when Attribute_Loop_Entry =>
11161 null;
11162
11163 --------------------
11164 -- Mechanism_Code --
11165 --------------------
11166
11167 -- Prefix of the Mechanism_Code attribute is a function name
11168 -- which must not be resolved. Should we check for overloaded ???
11169
11170 when Attribute_Mechanism_Code =>
11171 null;
11172
11173 ------------------
11174 -- Partition_ID --
11175 ------------------
11176
11177 -- Most processing is done in sem_dist, after determining the
11178 -- context type. Node is rewritten as a conversion to a runtime call.
11179
11180 when Attribute_Partition_ID =>
11181 Process_Partition_Id (N);
11182 return;
11183
11184 ------------------
11185 -- Pool_Address --
11186 ------------------
11187
11188 when Attribute_Pool_Address =>
11189 Resolve (P);
11190
11191 -----------
11192 -- Range --
11193 -----------
11194
11195 -- We replace the Range attribute node with a range expression whose
11196 -- bounds are the 'First and 'Last attributes applied to the same
11197 -- prefix. The reason that we do this transformation here instead of
11198 -- in the expander is that it simplifies other parts of the semantic
11199 -- analysis which assume that the Range has been replaced; thus it
11200 -- must be done even when in semantic-only mode (note that the RM
11201 -- specifically mentions this equivalence, we take care that the
11202 -- prefix is only evaluated once).
11203
11204 when Attribute_Range => Range_Attribute :
11205 declare
11206 LB : Node_Id;
11207 HB : Node_Id;
11208 Dims : List_Id;
11209
11210 begin
11211 if not Is_Entity_Name (P)
11212 or else not Is_Type (Entity (P))
11213 then
11214 Resolve (P);
11215 end if;
11216
11217 Dims := Expressions (N);
11218
11219 HB :=
11220 Make_Attribute_Reference (Loc,
11221 Prefix => Duplicate_Subexpr (P, Name_Req => True),
11222 Attribute_Name => Name_Last,
11223 Expressions => Dims);
11224
11225 LB :=
11226 Make_Attribute_Reference (Loc,
11227 Prefix => P,
11228 Attribute_Name => Name_First,
11229 Expressions => (Dims));
11230
11231 -- Do not share the dimension indicator, if present. Even
11232 -- though it is a static constant, its source location
11233 -- may be modified when printing expanded code and node
11234 -- sharing will lead to chaos in Sprint.
11235
11236 if Present (Dims) then
11237 Set_Expressions (LB,
11238 New_List (New_Copy_Tree (First (Dims))));
11239 end if;
11240
11241 -- If the original was marked as Must_Not_Freeze (see code
11242 -- in Sem_Ch3.Make_Index), then make sure the rewriting
11243 -- does not freeze either.
11244
11245 if Must_Not_Freeze (N) then
11246 Set_Must_Not_Freeze (HB);
11247 Set_Must_Not_Freeze (LB);
11248 Set_Must_Not_Freeze (Prefix (HB));
11249 Set_Must_Not_Freeze (Prefix (LB));
11250 end if;
11251
11252 if Raises_Constraint_Error (Prefix (N)) then
11253
11254 -- Preserve Sloc of prefix in the new bounds, so that
11255 -- the posted warning can be removed if we are within
11256 -- unreachable code.
11257
11258 Set_Sloc (LB, Sloc (Prefix (N)));
11259 Set_Sloc (HB, Sloc (Prefix (N)));
11260 end if;
11261
11262 Rewrite (N, Make_Range (Loc, LB, HB));
11263 Analyze_And_Resolve (N, Typ);
11264
11265 -- Ensure that the expanded range does not have side effects
11266
11267 Force_Evaluation (LB);
11268 Force_Evaluation (HB);
11269
11270 -- Normally after resolving attribute nodes, Eval_Attribute
11271 -- is called to do any possible static evaluation of the node.
11272 -- However, here since the Range attribute has just been
11273 -- transformed into a range expression it is no longer an
11274 -- attribute node and therefore the call needs to be avoided
11275 -- and is accomplished by simply returning from the procedure.
11276
11277 return;
11278 end Range_Attribute;
11279
11280 ------------
11281 -- Result --
11282 ------------
11283
11284 -- We will only come here during the prescan of a spec expression
11285 -- containing a Result attribute. In that case the proper Etype has
11286 -- already been set, and nothing more needs to be done here.
11287
11288 when Attribute_Result =>
11289 null;
11290
11291 ----------------------
11292 -- Unchecked_Access --
11293 ----------------------
11294
11295 -- Processing is shared with Access
11296
11297 -------------------------
11298 -- Unrestricted_Access --
11299 -------------------------
11300
11301 -- Processing is shared with Access
11302
11303 ------------
11304 -- Update --
11305 ------------
11306
11307 -- Resolve aggregate components in component associations
11308
11309 when Attribute_Update =>
11310 declare
11311 Aggr : constant Node_Id := First (Expressions (N));
11312 Typ : constant Entity_Id := Etype (Prefix (N));
11313 Assoc : Node_Id;
11314 Comp : Node_Id;
11315 Expr : Node_Id;
11316
11317 begin
11318 -- Set the Etype of the aggregate to that of the prefix, even
11319 -- though the aggregate may not be a proper representation of a
11320 -- value of the type (missing or duplicated associations, etc.)
11321 -- Complete resolution of the prefix. Note that in Ada 2012 it
11322 -- can be a qualified expression that is e.g. an aggregate.
11323
11324 Set_Etype (Aggr, Typ);
11325 Resolve (Prefix (N), Typ);
11326
11327 -- For an array type, resolve expressions with the component
11328 -- type of the array, and apply constraint checks when needed.
11329
11330 if Is_Array_Type (Typ) then
11331 Assoc := First (Component_Associations (Aggr));
11332 while Present (Assoc) loop
11333 Expr := Expression (Assoc);
11334 Resolve (Expr, Component_Type (Typ));
11335
11336 -- For scalar array components set Do_Range_Check when
11337 -- needed. Constraint checking on non-scalar components
11338 -- is done in Aggregate_Constraint_Checks, but only if
11339 -- full analysis is enabled. These flags are not set in
11340 -- the front-end in GnatProve mode.
11341
11342 if Is_Scalar_Type (Component_Type (Typ))
11343 and then not Is_OK_Static_Expression (Expr)
11344 then
11345 if Is_Entity_Name (Expr)
11346 and then Etype (Expr) = Component_Type (Typ)
11347 then
11348 null;
11349
11350 else
11351 Set_Do_Range_Check (Expr);
11352 end if;
11353 end if;
11354
11355 -- The choices in the association are static constants,
11356 -- or static aggregates each of whose components belongs
11357 -- to the proper index type. However, they must also
11358 -- belong to the index subtype (s) of the prefix, which
11359 -- may be a subtype (e.g. given by a slice).
11360
11361 -- Choices may also be identifiers with no staticness
11362 -- requirements, in which case they must resolve to the
11363 -- index type.
11364
11365 declare
11366 C : Node_Id;
11367 C_E : Node_Id;
11368 Indx : Node_Id;
11369
11370 begin
11371 C := First (Choices (Assoc));
11372 while Present (C) loop
11373 Indx := First_Index (Etype (Prefix (N)));
11374
11375 if Nkind (C) /= N_Aggregate then
11376 Analyze_And_Resolve (C, Etype (Indx));
11377 Apply_Constraint_Check (C, Etype (Indx));
11378 Check_Non_Static_Context (C);
11379
11380 else
11381 C_E := First (Expressions (C));
11382 while Present (C_E) loop
11383 Analyze_And_Resolve (C_E, Etype (Indx));
11384 Apply_Constraint_Check (C_E, Etype (Indx));
11385 Check_Non_Static_Context (C_E);
11386
11387 Next (C_E);
11388 Next_Index (Indx);
11389 end loop;
11390 end if;
11391
11392 Next (C);
11393 end loop;
11394 end;
11395
11396 Next (Assoc);
11397 end loop;
11398
11399 -- For a record type, use type of each component, which is
11400 -- recorded during analysis.
11401
11402 else
11403 Assoc := First (Component_Associations (Aggr));
11404 while Present (Assoc) loop
11405 Comp := First (Choices (Assoc));
11406 Expr := Expression (Assoc);
11407
11408 if Nkind (Comp) /= N_Others_Choice
11409 and then not Error_Posted (Comp)
11410 then
11411 Resolve (Expr, Etype (Entity (Comp)));
11412
11413 if Is_Scalar_Type (Etype (Entity (Comp)))
11414 and then not Is_OK_Static_Expression (Expr)
11415 then
11416 Set_Do_Range_Check (Expr);
11417 end if;
11418 end if;
11419
11420 Next (Assoc);
11421 end loop;
11422 end if;
11423 end;
11424
11425 ---------
11426 -- Val --
11427 ---------
11428
11429 -- Apply range check. Note that we did not do this during the
11430 -- analysis phase, since we wanted Eval_Attribute to have a
11431 -- chance at finding an illegal out of range value.
11432
11433 when Attribute_Val =>
11434
11435 -- Note that we do our own Eval_Attribute call here rather than
11436 -- use the common one, because we need to do processing after
11437 -- the call, as per above comment.
11438
11439 Eval_Attribute (N);
11440
11441 -- Eval_Attribute may replace the node with a raise CE, or
11442 -- fold it to a constant. Obviously we only apply a scalar
11443 -- range check if this did not happen.
11444
11445 if Nkind (N) = N_Attribute_Reference
11446 and then Attribute_Name (N) = Name_Val
11447 then
11448 Apply_Scalar_Range_Check (First (Expressions (N)), Btyp);
11449 end if;
11450
11451 return;
11452
11453 -------------
11454 -- Version --
11455 -------------
11456
11457 -- Prefix of Version attribute can be a subprogram name which
11458 -- must not be resolved, since this is not a call.
11459
11460 when Attribute_Version =>
11461 null;
11462
11463 ----------------------
11464 -- Other Attributes --
11465 ----------------------
11466
11467 -- For other attributes, resolve prefix unless it is a type. If
11468 -- the attribute reference itself is a type name ('Base and 'Class)
11469 -- then this is only legal within a task or protected record.
11470
11471 when others =>
11472 if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then
11473 Resolve (P);
11474 end if;
11475
11476 -- If the attribute reference itself is a type name ('Base,
11477 -- 'Class) then this is only legal within a task or protected
11478 -- record. What is this all about ???
11479
11480 if Is_Entity_Name (N) and then Is_Type (Entity (N)) then
11481 if Is_Concurrent_Type (Entity (N))
11482 and then In_Open_Scopes (Entity (P))
11483 then
11484 null;
11485 else
11486 Error_Msg_N
11487 ("invalid use of subtype name in expression or call", N);
11488 end if;
11489 end if;
11490
11491 -- For attributes whose argument may be a string, complete
11492 -- resolution of argument now. This avoids premature expansion
11493 -- (and the creation of transient scopes) before the attribute
11494 -- reference is resolved.
11495
11496 case Attr_Id is
11497 when Attribute_Value =>
11498 Resolve (First (Expressions (N)), Standard_String);
11499
11500 when Attribute_Wide_Value =>
11501 Resolve (First (Expressions (N)), Standard_Wide_String);
11502
11503 when Attribute_Wide_Wide_Value =>
11504 Resolve (First (Expressions (N)), Standard_Wide_Wide_String);
11505
11506 when others => null;
11507 end case;
11508
11509 -- If the prefix of the attribute is a class-wide type then it
11510 -- will be expanded into a dispatching call to a predefined
11511 -- primitive. Therefore we must check for potential violation
11512 -- of such restriction.
11513
11514 if Is_Class_Wide_Type (Etype (P)) then
11515 Check_Restriction (No_Dispatching_Calls, N);
11516 end if;
11517 end case;
11518
11519 -- Normally the Freezing is done by Resolve but sometimes the Prefix
11520 -- is not resolved, in which case the freezing must be done now.
11521
11522 -- For an elaboration check on a subprogram, we do not freeze its type.
11523 -- It may be declared in an unrelated scope, in particular in the case
11524 -- of a generic function whose type may remain unelaborated.
11525
11526 if Attr_Id = Attribute_Elaborated then
11527 null;
11528
11529 else
11530 Freeze_Expression (P);
11531 end if;
11532
11533 -- Finally perform static evaluation on the attribute reference
11534
11535 Analyze_Dimension (N);
11536 Eval_Attribute (N);
11537 end Resolve_Attribute;
11538
11539 ------------------------
11540 -- Set_Boolean_Result --
11541 ------------------------
11542
11543 procedure Set_Boolean_Result (N : Node_Id; B : Boolean) is
11544 Loc : constant Source_Ptr := Sloc (N);
11545 begin
11546 if B then
11547 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
11548 else
11549 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
11550 end if;
11551 end Set_Boolean_Result;
11552
11553 --------------------------------
11554 -- Stream_Attribute_Available --
11555 --------------------------------
11556
11557 function Stream_Attribute_Available
11558 (Typ : Entity_Id;
11559 Nam : TSS_Name_Type;
11560 Partial_View : Node_Id := Empty) return Boolean
11561 is
11562 Etyp : Entity_Id := Typ;
11563
11564 -- Start of processing for Stream_Attribute_Available
11565
11566 begin
11567 -- We need some comments in this body ???
11568
11569 if Has_Stream_Attribute_Definition (Typ, Nam) then
11570 return True;
11571 end if;
11572
11573 if Is_Class_Wide_Type (Typ) then
11574 return not Is_Limited_Type (Typ)
11575 or else Stream_Attribute_Available (Etype (Typ), Nam);
11576 end if;
11577
11578 if Nam = TSS_Stream_Input
11579 and then Is_Abstract_Type (Typ)
11580 and then not Is_Class_Wide_Type (Typ)
11581 then
11582 return False;
11583 end if;
11584
11585 if not (Is_Limited_Type (Typ)
11586 or else (Present (Partial_View)
11587 and then Is_Limited_Type (Partial_View)))
11588 then
11589 return True;
11590 end if;
11591
11592 -- In Ada 2005, Input can invoke Read, and Output can invoke Write
11593
11594 if Nam = TSS_Stream_Input
11595 and then Ada_Version >= Ada_2005
11596 and then Stream_Attribute_Available (Etyp, TSS_Stream_Read)
11597 then
11598 return True;
11599
11600 elsif Nam = TSS_Stream_Output
11601 and then Ada_Version >= Ada_2005
11602 and then Stream_Attribute_Available (Etyp, TSS_Stream_Write)
11603 then
11604 return True;
11605 end if;
11606
11607 -- Case of Read and Write: check for attribute definition clause that
11608 -- applies to an ancestor type.
11609
11610 while Etype (Etyp) /= Etyp loop
11611 Etyp := Etype (Etyp);
11612
11613 if Has_Stream_Attribute_Definition (Etyp, Nam) then
11614 return True;
11615 end if;
11616 end loop;
11617
11618 if Ada_Version < Ada_2005 then
11619
11620 -- In Ada 95 mode, also consider a non-visible definition
11621
11622 declare
11623 Btyp : constant Entity_Id := Implementation_Base_Type (Typ);
11624 begin
11625 return Btyp /= Typ
11626 and then Stream_Attribute_Available
11627 (Btyp, Nam, Partial_View => Typ);
11628 end;
11629 end if;
11630
11631 return False;
11632 end Stream_Attribute_Available;
11633
11634 end Sem_Attr;