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