File : exp_attr.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ A T T R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Exp_Atag; use Exp_Atag;
32 with Exp_Ch2; use Exp_Ch2;
33 with Exp_Ch3; use Exp_Ch3;
34 with Exp_Ch6; use Exp_Ch6;
35 with Exp_Ch9; use Exp_Ch9;
36 with Exp_Dist; use Exp_Dist;
37 with Exp_Imgv; use Exp_Imgv;
38 with Exp_Pakd; use Exp_Pakd;
39 with Exp_Strm; use Exp_Strm;
40 with Exp_Tss; use Exp_Tss;
41 with Exp_Util; use Exp_Util;
42 with Fname; use Fname;
43 with Freeze; use Freeze;
44 with Gnatvsn; use Gnatvsn;
45 with Itypes; use Itypes;
46 with Lib; use Lib;
47 with Namet; use Namet;
48 with Nmake; use Nmake;
49 with Nlists; use Nlists;
50 with Opt; use Opt;
51 with Restrict; use Restrict;
52 with Rident; use Rident;
53 with Rtsfind; use Rtsfind;
54 with Sem; use Sem;
55 with Sem_Aux; use Sem_Aux;
56 with Sem_Ch6; use Sem_Ch6;
57 with Sem_Ch7; use Sem_Ch7;
58 with Sem_Ch8; use Sem_Ch8;
59 with Sem_Eval; use Sem_Eval;
60 with Sem_Res; use Sem_Res;
61 with Sem_Util; use Sem_Util;
62 with Sinfo; use Sinfo;
63 with Snames; use Snames;
64 with Stand; use Stand;
65 with Stringt; use Stringt;
66 with Targparm; use Targparm;
67 with Tbuild; use Tbuild;
68 with Ttypes; use Ttypes;
69 with Uintp; use Uintp;
70 with Uname; use Uname;
71 with Validsw; use Validsw;
72
73 package body Exp_Attr is
74
75 -----------------------
76 -- Local Subprograms --
77 -----------------------
78
79 function Build_Array_VS_Func
80 (A_Type : Entity_Id;
81 Nod : Node_Id) return Entity_Id;
82 -- Build function to test Valid_Scalars for array type A_Type. Nod is the
83 -- Valid_Scalars attribute node, used to insert the function body, and the
84 -- value returned is the entity of the constructed function body. We do not
85 -- bother to generate a separate spec for this subprogram.
86
87 function Build_Record_VS_Func
88 (R_Type : Entity_Id;
89 Nod : Node_Id) return Entity_Id;
90 -- Build function to test Valid_Scalars for record type A_Type. Nod is the
91 -- Valid_Scalars attribute node, used to insert the function body, and the
92 -- value returned is the entity of the constructed function body. We do not
93 -- bother to generate a separate spec for this subprogram.
94
95 procedure Compile_Stream_Body_In_Scope
96 (N : Node_Id;
97 Decl : Node_Id;
98 Arr : Entity_Id;
99 Check : Boolean);
100 -- The body for a stream subprogram may be generated outside of the scope
101 -- of the type. If the type is fully private, it may depend on the full
102 -- view of other types (e.g. indexes) that are currently private as well.
103 -- We install the declarations of the package in which the type is declared
104 -- before compiling the body in what is its proper environment. The Check
105 -- parameter indicates if checks are to be suppressed for the stream body.
106 -- We suppress checks for array/record reads, since the rule is that these
107 -- are like assignments, out of range values due to uninitialized storage,
108 -- or other invalid values do NOT cause a Constraint_Error to be raised.
109 -- If we are within an instance body all visibility has been established
110 -- already and there is no need to install the package.
111
112 -- This mechanism is now extended to the component types of the array type,
113 -- when the component type is not in scope and is private, to handle
114 -- properly the case when the full view has defaulted discriminants.
115
116 -- This special processing is ultimately caused by the fact that the
117 -- compiler lacks a well-defined phase when full views are visible
118 -- everywhere. Having such a separate pass would remove much of the
119 -- special-case code that shuffles partial and full views in the middle
120 -- of semantic analysis and expansion.
121
122 procedure Expand_Access_To_Protected_Op
123 (N : Node_Id;
124 Pref : Node_Id;
125 Typ : Entity_Id);
126 -- An attribute reference to a protected subprogram is transformed into
127 -- a pair of pointers: one to the object, and one to the operations.
128 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
129
130 procedure Expand_Fpt_Attribute
131 (N : Node_Id;
132 Pkg : RE_Id;
133 Nam : Name_Id;
134 Args : List_Id);
135 -- This procedure expands a call to a floating-point attribute function.
136 -- N is the attribute reference node, and Args is a list of arguments to
137 -- be passed to the function call. Pkg identifies the package containing
138 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
139 -- have already been converted to the floating-point type for which Pkg was
140 -- instantiated. The Nam argument is the relevant attribute processing
141 -- routine to be called. This is the same as the attribute name, except in
142 -- the Unaligned_Valid case.
143
144 procedure Expand_Fpt_Attribute_R (N : Node_Id);
145 -- This procedure expands a call to a floating-point attribute function
146 -- that takes a single floating-point argument. The function to be called
147 -- is always the same as the attribute name.
148
149 procedure Expand_Fpt_Attribute_RI (N : Node_Id);
150 -- This procedure expands a call to a floating-point attribute function
151 -- that takes one floating-point argument and one integer argument. The
152 -- function to be called is always the same as the attribute name.
153
154 procedure Expand_Fpt_Attribute_RR (N : Node_Id);
155 -- This procedure expands a call to a floating-point attribute function
156 -- that takes two floating-point arguments. The function to be called
157 -- is always the same as the attribute name.
158
159 procedure Expand_Loop_Entry_Attribute (N : Node_Id);
160 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
161 -- loop may be converted into a conditional block. See body for details.
162
163 procedure Expand_Min_Max_Attribute (N : Node_Id);
164 -- Handle the expansion of attributes 'Max and 'Min, including expanding
165 -- then out if we are in Modify_Tree_For_C mode.
166
167 procedure Expand_Pred_Succ_Attribute (N : Node_Id);
168 -- Handles expansion of Pred or Succ attributes for case of non-real
169 -- operand with overflow checking required.
170
171 procedure Expand_Update_Attribute (N : Node_Id);
172 -- Handle the expansion of attribute Update
173
174 function Get_Index_Subtype (N : Node_Id) return Entity_Id;
175 -- Used for Last, Last, and Length, when the prefix is an array type.
176 -- Obtains the corresponding index subtype.
177
178 procedure Find_Fat_Info
179 (T : Entity_Id;
180 Fat_Type : out Entity_Id;
181 Fat_Pkg : out RE_Id);
182 -- Given a floating-point type T, identifies the package containing the
183 -- attributes for this type (returned in Fat_Pkg), and the corresponding
184 -- type for which this package was instantiated from Fat_Gen. Error if T
185 -- is not a floating-point type.
186
187 function Find_Stream_Subprogram
188 (Typ : Entity_Id;
189 Nam : TSS_Name_Type) return Entity_Id;
190 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
191 -- types, the corresponding primitive operation is looked up, else the
192 -- appropriate TSS from the type itself, or from its closest ancestor
193 -- defining it, is returned. In both cases, inheritance of representation
194 -- aspects is thus taken into account.
195
196 function Full_Base (T : Entity_Id) return Entity_Id;
197 -- The stream functions need to examine the underlying representation of
198 -- composite types. In some cases T may be non-private but its base type
199 -- is, in which case the function returns the corresponding full view.
200
201 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id;
202 -- Given a type, find a corresponding stream convert pragma that applies to
203 -- the implementation base type of this type (Typ). If found, return the
204 -- pragma node, otherwise return Empty if no pragma is found.
205
206 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
207 -- Utility for array attributes, returns true on packed constrained
208 -- arrays, and on access to same.
209
210 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean;
211 -- Returns true iff the given node refers to an attribute call that
212 -- can be expanded directly by the back end and does not need front end
213 -- expansion. Typically used for rounding and truncation attributes that
214 -- appear directly inside a conversion to integer.
215
216 -------------------------
217 -- Build_Array_VS_Func --
218 -------------------------
219
220 function Build_Array_VS_Func
221 (A_Type : Entity_Id;
222 Nod : Node_Id) return Entity_Id
223 is
224 Loc : constant Source_Ptr := Sloc (Nod);
225 Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
226 Comp_Type : constant Entity_Id := Component_Type (A_Type);
227 Body_Stmts : List_Id;
228 Index_List : List_Id;
229 Formals : List_Id;
230
231 function Test_Component return List_Id;
232 -- Create one statement to test validity of one component designated by
233 -- a full set of indexes. Returns statement list containing test.
234
235 function Test_One_Dimension (N : Int) return List_Id;
236 -- Create loop to test one dimension of the array. The single statement
237 -- in the loop body tests the inner dimensions if any, or else the
238 -- single component. Note that this procedure is called recursively,
239 -- with N being the dimension to be initialized. A call with N greater
240 -- than the number of dimensions simply generates the component test,
241 -- terminating the recursion. Returns statement list containing tests.
242
243 --------------------
244 -- Test_Component --
245 --------------------
246
247 function Test_Component return List_Id is
248 Comp : Node_Id;
249 Anam : Name_Id;
250
251 begin
252 Comp :=
253 Make_Indexed_Component (Loc,
254 Prefix => Make_Identifier (Loc, Name_uA),
255 Expressions => Index_List);
256
257 if Is_Scalar_Type (Comp_Type) then
258 Anam := Name_Valid;
259 else
260 Anam := Name_Valid_Scalars;
261 end if;
262
263 return New_List (
264 Make_If_Statement (Loc,
265 Condition =>
266 Make_Op_Not (Loc,
267 Right_Opnd =>
268 Make_Attribute_Reference (Loc,
269 Attribute_Name => Anam,
270 Prefix => Comp)),
271 Then_Statements => New_List (
272 Make_Simple_Return_Statement (Loc,
273 Expression => New_Occurrence_Of (Standard_False, Loc)))));
274 end Test_Component;
275
276 ------------------------
277 -- Test_One_Dimension --
278 ------------------------
279
280 function Test_One_Dimension (N : Int) return List_Id is
281 Index : Entity_Id;
282
283 begin
284 -- If all dimensions dealt with, we simply test the component
285
286 if N > Number_Dimensions (A_Type) then
287 return Test_Component;
288
289 -- Here we generate the required loop
290
291 else
292 Index :=
293 Make_Defining_Identifier (Loc, New_External_Name ('J', N));
294
295 Append (New_Occurrence_Of (Index, Loc), Index_List);
296
297 return New_List (
298 Make_Implicit_Loop_Statement (Nod,
299 Identifier => Empty,
300 Iteration_Scheme =>
301 Make_Iteration_Scheme (Loc,
302 Loop_Parameter_Specification =>
303 Make_Loop_Parameter_Specification (Loc,
304 Defining_Identifier => Index,
305 Discrete_Subtype_Definition =>
306 Make_Attribute_Reference (Loc,
307 Prefix => Make_Identifier (Loc, Name_uA),
308 Attribute_Name => Name_Range,
309 Expressions => New_List (
310 Make_Integer_Literal (Loc, N))))),
311 Statements => Test_One_Dimension (N + 1)),
312 Make_Simple_Return_Statement (Loc,
313 Expression => New_Occurrence_Of (Standard_True, Loc)));
314 end if;
315 end Test_One_Dimension;
316
317 -- Start of processing for Build_Array_VS_Func
318
319 begin
320 Index_List := New_List;
321 Body_Stmts := Test_One_Dimension (1);
322
323 -- Parameter is always (A : A_Typ)
324
325 Formals := New_List (
326 Make_Parameter_Specification (Loc,
327 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uA),
328 In_Present => True,
329 Out_Present => False,
330 Parameter_Type => New_Occurrence_Of (A_Type, Loc)));
331
332 -- Build body
333
334 Set_Ekind (Func_Id, E_Function);
335 Set_Is_Internal (Func_Id);
336
337 Insert_Action (Nod,
338 Make_Subprogram_Body (Loc,
339 Specification =>
340 Make_Function_Specification (Loc,
341 Defining_Unit_Name => Func_Id,
342 Parameter_Specifications => Formals,
343 Result_Definition =>
344 New_Occurrence_Of (Standard_Boolean, Loc)),
345 Declarations => New_List,
346 Handled_Statement_Sequence =>
347 Make_Handled_Sequence_Of_Statements (Loc,
348 Statements => Body_Stmts)));
349
350 if not Debug_Generated_Code then
351 Set_Debug_Info_Off (Func_Id);
352 end if;
353
354 Set_Is_Pure (Func_Id);
355 return Func_Id;
356 end Build_Array_VS_Func;
357
358 --------------------------
359 -- Build_Record_VS_Func --
360 --------------------------
361
362 -- Generates:
363
364 -- function _Valid_Scalars (X : T) return Boolean is
365 -- begin
366 -- -- Check discriminants
367
368 -- if not X.D1'Valid_Scalars or else
369 -- not X.D2'Valid_Scalars or else
370 -- ...
371 -- then
372 -- return False;
373 -- end if;
374
375 -- -- Check components
376
377 -- if not X.C1'Valid_Scalars or else
378 -- not X.C2'Valid_Scalars or else
379 -- ...
380 -- then
381 -- return False;
382 -- end if;
383
384 -- -- Check variant part
385
386 -- case X.D1 is
387 -- when V1 =>
388 -- if not X.C2'Valid_Scalars or else
389 -- not X.C3'Valid_Scalars or else
390 -- ...
391 -- then
392 -- return False;
393 -- end if;
394 -- ...
395 -- when Vn =>
396 -- if not X.Cn'Valid_Scalars or else
397 -- ...
398 -- then
399 -- return False;
400 -- end if;
401 -- end case;
402
403 -- return True;
404 -- end _Valid_Scalars;
405
406 function Build_Record_VS_Func
407 (R_Type : Entity_Id;
408 Nod : Node_Id) return Entity_Id
409 is
410 Loc : constant Source_Ptr := Sloc (R_Type);
411 Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
412 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
413
414 function Make_VS_Case
415 (E : Entity_Id;
416 CL : Node_Id;
417 Discrs : Elist_Id := New_Elmt_List) return List_Id;
418 -- Building block for variant valid scalars. Given a Component_List node
419 -- CL, it generates an 'if' followed by a 'case' statement that compares
420 -- all components of local temporaries named X and Y (that are declared
421 -- as formals at some upper level). E provides the Sloc to be used for
422 -- the generated code.
423
424 function Make_VS_If
425 (E : Entity_Id;
426 L : List_Id) return Node_Id;
427 -- Building block for variant validate scalars. Given the list, L, of
428 -- components (or discriminants) L, it generates a return statement that
429 -- compares all components of local temporaries named X and Y (that are
430 -- declared as formals at some upper level). E provides the Sloc to be
431 -- used for the generated code.
432
433 ------------------
434 -- Make_VS_Case --
435 ------------------
436
437 -- <Make_VS_If on shared components>
438
439 -- case X.D1 is
440 -- when V1 => <Make_VS_Case> on subcomponents
441 -- ...
442 -- when Vn => <Make_VS_Case> on subcomponents
443 -- end case;
444
445 function Make_VS_Case
446 (E : Entity_Id;
447 CL : Node_Id;
448 Discrs : Elist_Id := New_Elmt_List) return List_Id
449 is
450 Loc : constant Source_Ptr := Sloc (E);
451 Result : constant List_Id := New_List;
452 Variant : Node_Id;
453 Alt_List : List_Id;
454
455 begin
456 Append_To (Result, Make_VS_If (E, Component_Items (CL)));
457
458 if No (Variant_Part (CL)) then
459 return Result;
460 end if;
461
462 Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
463
464 if No (Variant) then
465 return Result;
466 end if;
467
468 Alt_List := New_List;
469 while Present (Variant) loop
470 Append_To (Alt_List,
471 Make_Case_Statement_Alternative (Loc,
472 Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
473 Statements =>
474 Make_VS_Case (E, Component_List (Variant), Discrs)));
475 Next_Non_Pragma (Variant);
476 end loop;
477
478 Append_To (Result,
479 Make_Case_Statement (Loc,
480 Expression =>
481 Make_Selected_Component (Loc,
482 Prefix => Make_Identifier (Loc, Name_X),
483 Selector_Name => New_Copy (Name (Variant_Part (CL)))),
484 Alternatives => Alt_List));
485
486 return Result;
487 end Make_VS_Case;
488
489 ----------------
490 -- Make_VS_If --
491 ----------------
492
493 -- Generates:
494
495 -- if
496 -- not X.C1'Valid_Scalars
497 -- or else
498 -- not X.C2'Valid_Scalars
499 -- ...
500 -- then
501 -- return False;
502 -- end if;
503
504 -- or a null statement if the list L is empty
505
506 function Make_VS_If
507 (E : Entity_Id;
508 L : List_Id) return Node_Id
509 is
510 Loc : constant Source_Ptr := Sloc (E);
511 C : Node_Id;
512 Def_Id : Entity_Id;
513 Field_Name : Name_Id;
514 Cond : Node_Id;
515
516 begin
517 if No (L) then
518 return Make_Null_Statement (Loc);
519
520 else
521 Cond := Empty;
522
523 C := First_Non_Pragma (L);
524 while Present (C) loop
525 Def_Id := Defining_Identifier (C);
526 Field_Name := Chars (Def_Id);
527
528 -- The tags need not be checked since they will always be valid
529
530 -- Note also that in the following, we use Make_Identifier for
531 -- the component names. Use of New_Occurrence_Of to identify
532 -- the components would be incorrect because wrong entities for
533 -- discriminants could be picked up in the private type case.
534
535 -- Don't bother with abstract parent in interface case
536
537 if Field_Name = Name_uParent
538 and then Is_Interface (Etype (Def_Id))
539 then
540 null;
541
542 -- Don't bother with tag, always valid, and not scalar anyway
543
544 elsif Field_Name = Name_uTag then
545 null;
546
547 -- Don't bother with component with no scalar components
548
549 elsif not Scalar_Part_Present (Etype (Def_Id)) then
550 null;
551
552 -- Normal case, generate Valid_Scalars attribute reference
553
554 else
555 Evolve_Or_Else (Cond,
556 Make_Op_Not (Loc,
557 Right_Opnd =>
558 Make_Attribute_Reference (Loc,
559 Prefix =>
560 Make_Selected_Component (Loc,
561 Prefix =>
562 Make_Identifier (Loc, Name_X),
563 Selector_Name =>
564 Make_Identifier (Loc, Field_Name)),
565 Attribute_Name => Name_Valid_Scalars)));
566 end if;
567
568 Next_Non_Pragma (C);
569 end loop;
570
571 if No (Cond) then
572 return Make_Null_Statement (Loc);
573
574 else
575 return
576 Make_Implicit_If_Statement (E,
577 Condition => Cond,
578 Then_Statements => New_List (
579 Make_Simple_Return_Statement (Loc,
580 Expression =>
581 New_Occurrence_Of (Standard_False, Loc))));
582 end if;
583 end if;
584 end Make_VS_If;
585
586 -- Local variables
587
588 Def : constant Node_Id := Parent (R_Type);
589 Comps : constant Node_Id := Component_List (Type_Definition (Def));
590 Stmts : constant List_Id := New_List;
591 Pspecs : constant List_Id := New_List;
592
593 -- Start of processing for Build_Record_VS_Func
594
595 begin
596 Append_To (Pspecs,
597 Make_Parameter_Specification (Loc,
598 Defining_Identifier => X,
599 Parameter_Type => New_Occurrence_Of (R_Type, Loc)));
600
601 Append_To (Stmts,
602 Make_VS_If (R_Type, Discriminant_Specifications (Def)));
603 Append_List_To (Stmts, Make_VS_Case (R_Type, Comps));
604
605 Append_To (Stmts,
606 Make_Simple_Return_Statement (Loc,
607 Expression => New_Occurrence_Of (Standard_True, Loc)));
608
609 Insert_Action (Nod,
610 Make_Subprogram_Body (Loc,
611 Specification =>
612 Make_Function_Specification (Loc,
613 Defining_Unit_Name => Func_Id,
614 Parameter_Specifications => Pspecs,
615 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
616 Declarations => New_List,
617 Handled_Statement_Sequence =>
618 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)),
619 Suppress => Discriminant_Check);
620
621 if not Debug_Generated_Code then
622 Set_Debug_Info_Off (Func_Id);
623 end if;
624
625 Set_Is_Pure (Func_Id);
626 return Func_Id;
627 end Build_Record_VS_Func;
628
629 ----------------------------------
630 -- Compile_Stream_Body_In_Scope --
631 ----------------------------------
632
633 procedure Compile_Stream_Body_In_Scope
634 (N : Node_Id;
635 Decl : Node_Id;
636 Arr : Entity_Id;
637 Check : Boolean)
638 is
639 C_Type : constant Entity_Id := Base_Type (Component_Type (Arr));
640 Curr : constant Entity_Id := Current_Scope;
641 Install : Boolean := False;
642 Scop : Entity_Id := Scope (Arr);
643
644 begin
645 if Is_Hidden (Arr)
646 and then not In_Open_Scopes (Scop)
647 and then Ekind (Scop) = E_Package
648 then
649 Install := True;
650
651 else
652 -- The component type may be private, in which case we install its
653 -- full view to compile the subprogram.
654
655 -- The component type may be private, in which case we install its
656 -- full view to compile the subprogram. We do not do this if the
657 -- type has a Stream_Convert pragma, which indicates that there are
658 -- special stream-processing operations for that type (for example
659 -- Unbounded_String and its wide varieties).
660
661 Scop := Scope (C_Type);
662
663 if Is_Private_Type (C_Type)
664 and then Present (Full_View (C_Type))
665 and then not In_Open_Scopes (Scop)
666 and then Ekind (Scop) = E_Package
667 and then No (Get_Stream_Convert_Pragma (C_Type))
668 then
669 Install := True;
670 end if;
671 end if;
672
673 -- If we are within an instance body, then all visibility has been
674 -- established already and there is no need to install the package.
675
676 if Install and then not In_Instance_Body then
677 Push_Scope (Scop);
678 Install_Visible_Declarations (Scop);
679 Install_Private_Declarations (Scop);
680
681 -- The entities in the package are now visible, but the generated
682 -- stream entity must appear in the current scope (usually an
683 -- enclosing stream function) so that itypes all have their proper
684 -- scopes.
685
686 Push_Scope (Curr);
687 else
688 Install := False;
689 end if;
690
691 if Check then
692 Insert_Action (N, Decl);
693 else
694 Insert_Action (N, Decl, Suppress => All_Checks);
695 end if;
696
697 if Install then
698
699 -- Remove extra copy of current scope, and package itself
700
701 Pop_Scope;
702 End_Package_Scope (Scop);
703 end if;
704 end Compile_Stream_Body_In_Scope;
705
706 -----------------------------------
707 -- Expand_Access_To_Protected_Op --
708 -----------------------------------
709
710 procedure Expand_Access_To_Protected_Op
711 (N : Node_Id;
712 Pref : Node_Id;
713 Typ : Entity_Id)
714 is
715 -- The value of the attribute_reference is a record containing two
716 -- fields: an access to the protected object, and an access to the
717 -- subprogram itself. The prefix is a selected component.
718
719 Loc : constant Source_Ptr := Sloc (N);
720 Agg : Node_Id;
721 Btyp : constant Entity_Id := Base_Type (Typ);
722 Sub : Entity_Id;
723 Sub_Ref : Node_Id;
724 E_T : constant Entity_Id := Equivalent_Type (Btyp);
725 Acc : constant Entity_Id :=
726 Etype (Next_Component (First_Component (E_T)));
727 Obj_Ref : Node_Id;
728 Curr : Entity_Id;
729
730 -- Start of processing for Expand_Access_To_Protected_Op
731
732 begin
733 -- Within the body of the protected type, the prefix designates a local
734 -- operation, and the object is the first parameter of the corresponding
735 -- protected body of the current enclosing operation.
736
737 if Is_Entity_Name (Pref) then
738 -- All indirect calls are external calls, so must do locking and
739 -- barrier reevaluation, even if the 'Access occurs within the
740 -- protected body. Hence the call to External_Subprogram, as opposed
741 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means
742 -- that indirect calls from within the same protected body will
743 -- deadlock, as allowed by RM-9.5.1(8,15,17).
744
745 Sub := New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc);
746
747 -- Don't traverse the scopes when the attribute occurs within an init
748 -- proc, because we directly use the _init formal of the init proc in
749 -- that case.
750
751 Curr := Current_Scope;
752 if not Is_Init_Proc (Curr) then
753 pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
754
755 while Scope (Curr) /= Scope (Entity (Pref)) loop
756 Curr := Scope (Curr);
757 end loop;
758 end if;
759
760 -- In case of protected entries the first formal of its Protected_
761 -- Body_Subprogram is the address of the object.
762
763 if Ekind (Curr) = E_Entry then
764 Obj_Ref :=
765 New_Occurrence_Of
766 (First_Formal
767 (Protected_Body_Subprogram (Curr)), Loc);
768
769 -- If the current scope is an init proc, then use the address of the
770 -- _init formal as the object reference.
771
772 elsif Is_Init_Proc (Curr) then
773 Obj_Ref :=
774 Make_Attribute_Reference (Loc,
775 Prefix => New_Occurrence_Of (First_Formal (Curr), Loc),
776 Attribute_Name => Name_Address);
777
778 -- In case of protected subprograms the first formal of its
779 -- Protected_Body_Subprogram is the object and we get its address.
780
781 else
782 Obj_Ref :=
783 Make_Attribute_Reference (Loc,
784 Prefix =>
785 New_Occurrence_Of
786 (First_Formal
787 (Protected_Body_Subprogram (Curr)), Loc),
788 Attribute_Name => Name_Address);
789 end if;
790
791 -- Case where the prefix is not an entity name. Find the
792 -- version of the protected operation to be called from
793 -- outside the protected object.
794
795 else
796 Sub :=
797 New_Occurrence_Of
798 (External_Subprogram
799 (Entity (Selector_Name (Pref))), Loc);
800
801 Obj_Ref :=
802 Make_Attribute_Reference (Loc,
803 Prefix => Relocate_Node (Prefix (Pref)),
804 Attribute_Name => Name_Address);
805 end if;
806
807 Sub_Ref :=
808 Make_Attribute_Reference (Loc,
809 Prefix => Sub,
810 Attribute_Name => Name_Access);
811
812 -- We set the type of the access reference to the already generated
813 -- access_to_subprogram type, and declare the reference analyzed, to
814 -- prevent further expansion when the enclosing aggregate is analyzed.
815
816 Set_Etype (Sub_Ref, Acc);
817 Set_Analyzed (Sub_Ref);
818
819 Agg :=
820 Make_Aggregate (Loc,
821 Expressions => New_List (Obj_Ref, Sub_Ref));
822
823 -- Sub_Ref has been marked as analyzed, but we still need to make sure
824 -- Sub is correctly frozen.
825
826 Freeze_Before (N, Entity (Sub));
827
828 Rewrite (N, Agg);
829 Analyze_And_Resolve (N, E_T);
830
831 -- For subsequent analysis, the node must retain its type. The backend
832 -- will replace it with the equivalent type where needed.
833
834 Set_Etype (N, Typ);
835 end Expand_Access_To_Protected_Op;
836
837 --------------------------
838 -- Expand_Fpt_Attribute --
839 --------------------------
840
841 procedure Expand_Fpt_Attribute
842 (N : Node_Id;
843 Pkg : RE_Id;
844 Nam : Name_Id;
845 Args : List_Id)
846 is
847 Loc : constant Source_Ptr := Sloc (N);
848 Typ : constant Entity_Id := Etype (N);
849 Fnm : Node_Id;
850
851 begin
852 -- The function name is the selected component Attr_xxx.yyy where
853 -- Attr_xxx is the package name, and yyy is the argument Nam.
854
855 -- Note: it would be more usual to have separate RE entries for each
856 -- of the entities in the Fat packages, but first they have identical
857 -- names (so we would have to have lots of renaming declarations to
858 -- meet the normal RE rule of separate names for all runtime entities),
859 -- and second there would be an awful lot of them.
860
861 Fnm :=
862 Make_Selected_Component (Loc,
863 Prefix => New_Occurrence_Of (RTE (Pkg), Loc),
864 Selector_Name => Make_Identifier (Loc, Nam));
865
866 -- The generated call is given the provided set of parameters, and then
867 -- wrapped in a conversion which converts the result to the target type
868 -- We use the base type as the target because a range check may be
869 -- required.
870
871 Rewrite (N,
872 Unchecked_Convert_To (Base_Type (Etype (N)),
873 Make_Function_Call (Loc,
874 Name => Fnm,
875 Parameter_Associations => Args)));
876
877 Analyze_And_Resolve (N, Typ);
878 end Expand_Fpt_Attribute;
879
880 ----------------------------
881 -- Expand_Fpt_Attribute_R --
882 ----------------------------
883
884 -- The single argument is converted to its root type to call the
885 -- appropriate runtime function, with the actual call being built
886 -- by Expand_Fpt_Attribute
887
888 procedure Expand_Fpt_Attribute_R (N : Node_Id) is
889 E1 : constant Node_Id := First (Expressions (N));
890 Ftp : Entity_Id;
891 Pkg : RE_Id;
892 begin
893 Find_Fat_Info (Etype (E1), Ftp, Pkg);
894 Expand_Fpt_Attribute
895 (N, Pkg, Attribute_Name (N),
896 New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1))));
897 end Expand_Fpt_Attribute_R;
898
899 -----------------------------
900 -- Expand_Fpt_Attribute_RI --
901 -----------------------------
902
903 -- The first argument is converted to its root type and the second
904 -- argument is converted to standard long long integer to call the
905 -- appropriate runtime function, with the actual call being built
906 -- by Expand_Fpt_Attribute
907
908 procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
909 E1 : constant Node_Id := First (Expressions (N));
910 Ftp : Entity_Id;
911 Pkg : RE_Id;
912 E2 : constant Node_Id := Next (E1);
913 begin
914 Find_Fat_Info (Etype (E1), Ftp, Pkg);
915 Expand_Fpt_Attribute
916 (N, Pkg, Attribute_Name (N),
917 New_List (
918 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
919 Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
920 end Expand_Fpt_Attribute_RI;
921
922 -----------------------------
923 -- Expand_Fpt_Attribute_RR --
924 -----------------------------
925
926 -- The two arguments are converted to their root types to call the
927 -- appropriate runtime function, with the actual call being built
928 -- by Expand_Fpt_Attribute
929
930 procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
931 E1 : constant Node_Id := First (Expressions (N));
932 E2 : constant Node_Id := Next (E1);
933 Ftp : Entity_Id;
934 Pkg : RE_Id;
935
936 begin
937 Find_Fat_Info (Etype (E1), Ftp, Pkg);
938 Expand_Fpt_Attribute
939 (N, Pkg, Attribute_Name (N),
940 New_List (
941 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
942 Unchecked_Convert_To (Ftp, Relocate_Node (E2))));
943 end Expand_Fpt_Attribute_RR;
944
945 ---------------------------------
946 -- Expand_Loop_Entry_Attribute --
947 ---------------------------------
948
949 procedure Expand_Loop_Entry_Attribute (N : Node_Id) is
950 procedure Build_Conditional_Block
951 (Loc : Source_Ptr;
952 Cond : Node_Id;
953 Loop_Stmt : Node_Id;
954 If_Stmt : out Node_Id;
955 Blk_Stmt : out Node_Id);
956 -- Create a block Blk_Stmt with an empty declarative list and a single
957 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
958 -- condition Cond. If_Stmt is Empty when there is no condition provided.
959
960 function Is_Array_Iteration (N : Node_Id) return Boolean;
961 -- Determine whether loop statement N denotes an Ada 2012 iteration over
962 -- an array object.
963
964 -----------------------------
965 -- Build_Conditional_Block --
966 -----------------------------
967
968 procedure Build_Conditional_Block
969 (Loc : Source_Ptr;
970 Cond : Node_Id;
971 Loop_Stmt : Node_Id;
972 If_Stmt : out Node_Id;
973 Blk_Stmt : out Node_Id)
974 is
975 begin
976 -- Do not reanalyze the original loop statement because it is simply
977 -- being relocated.
978
979 Set_Analyzed (Loop_Stmt);
980
981 Blk_Stmt :=
982 Make_Block_Statement (Loc,
983 Declarations => New_List,
984 Handled_Statement_Sequence =>
985 Make_Handled_Sequence_Of_Statements (Loc,
986 Statements => New_List (Loop_Stmt)));
987
988 if Present (Cond) then
989 If_Stmt :=
990 Make_If_Statement (Loc,
991 Condition => Cond,
992 Then_Statements => New_List (Blk_Stmt));
993 else
994 If_Stmt := Empty;
995 end if;
996 end Build_Conditional_Block;
997
998 ------------------------
999 -- Is_Array_Iteration --
1000 ------------------------
1001
1002 function Is_Array_Iteration (N : Node_Id) return Boolean is
1003 Stmt : constant Node_Id := Original_Node (N);
1004 Iter : Node_Id;
1005
1006 begin
1007 if Nkind (Stmt) = N_Loop_Statement
1008 and then Present (Iteration_Scheme (Stmt))
1009 and then Present (Iterator_Specification (Iteration_Scheme (Stmt)))
1010 then
1011 Iter := Iterator_Specification (Iteration_Scheme (Stmt));
1012
1013 return
1014 Of_Present (Iter) and then Is_Array_Type (Etype (Name (Iter)));
1015 end if;
1016
1017 return False;
1018 end Is_Array_Iteration;
1019
1020 -- Local variables
1021
1022 Exprs : constant List_Id := Expressions (N);
1023 Pref : constant Node_Id := Prefix (N);
1024 Typ : constant Entity_Id := Etype (Pref);
1025 Blk : Node_Id;
1026 CW_Decl : Node_Id;
1027 CW_Temp : Entity_Id;
1028 CW_Typ : Entity_Id;
1029 Decls : List_Id;
1030 Installed : Boolean;
1031 Loc : Source_Ptr;
1032 Loop_Id : Entity_Id;
1033 Loop_Stmt : Node_Id;
1034 Result : Node_Id;
1035 Scheme : Node_Id;
1036 Temp_Decl : Node_Id;
1037 Temp_Id : Entity_Id;
1038
1039 -- Start of processing for Expand_Loop_Entry_Attribute
1040
1041 begin
1042 -- Step 1: Find the related loop
1043
1044 -- The loop label variant of attribute 'Loop_Entry already has all the
1045 -- information in its expression.
1046
1047 if Present (Exprs) then
1048 Loop_Id := Entity (First (Exprs));
1049 Loop_Stmt := Label_Construct (Parent (Loop_Id));
1050
1051 -- Climb the parent chain to find the nearest enclosing loop. Skip all
1052 -- internally generated loops for quantified expressions and for
1053 -- element iterators over multidimensional arrays: pragma applies to
1054 -- source loop.
1055
1056 else
1057 Loop_Stmt := N;
1058 while Present (Loop_Stmt) loop
1059 if Nkind (Loop_Stmt) = N_Loop_Statement
1060 and then Comes_From_Source (Loop_Stmt)
1061 then
1062 exit;
1063 end if;
1064
1065 Loop_Stmt := Parent (Loop_Stmt);
1066 end loop;
1067
1068 Loop_Id := Entity (Identifier (Loop_Stmt));
1069 end if;
1070
1071 Loc := Sloc (Loop_Stmt);
1072
1073 -- Step 2: Transform the loop
1074
1075 -- The loop has already been transformed during the expansion of a prior
1076 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
1077
1078 if Has_Loop_Entry_Attributes (Loop_Id) then
1079
1080 -- When the related loop name appears as the argument of attribute
1081 -- Loop_Entry, the corresponding label construct is the generated
1082 -- block statement. This is because the expander reuses the label.
1083
1084 if Nkind (Loop_Stmt) = N_Block_Statement then
1085 Decls := Declarations (Loop_Stmt);
1086
1087 -- In all other cases, the loop must appear in the handled sequence
1088 -- of statements of the generated block.
1089
1090 else
1091 pragma Assert
1092 (Nkind (Parent (Loop_Stmt)) = N_Handled_Sequence_Of_Statements
1093 and then
1094 Nkind (Parent (Parent (Loop_Stmt))) = N_Block_Statement);
1095
1096 Decls := Declarations (Parent (Parent (Loop_Stmt)));
1097 end if;
1098
1099 Result := Empty;
1100
1101 -- Transform the loop into a conditional block
1102
1103 else
1104 Set_Has_Loop_Entry_Attributes (Loop_Id);
1105 Scheme := Iteration_Scheme (Loop_Stmt);
1106
1107 -- Infinite loops are transformed into:
1108
1109 -- declare
1110 -- Temp1 : constant <type of Pref1> := <Pref1>;
1111 -- . . .
1112 -- TempN : constant <type of PrefN> := <PrefN>;
1113 -- begin
1114 -- loop
1115 -- <original source statements with attribute rewrites>
1116 -- end loop;
1117 -- end;
1118
1119 if No (Scheme) then
1120 Build_Conditional_Block (Loc,
1121 Cond => Empty,
1122 Loop_Stmt => Relocate_Node (Loop_Stmt),
1123 If_Stmt => Result,
1124 Blk_Stmt => Blk);
1125
1126 Result := Blk;
1127
1128 -- While loops are transformed into:
1129
1130 -- function Fnn return Boolean is
1131 -- begin
1132 -- <condition actions>
1133 -- return <condition>;
1134 -- end Fnn;
1135
1136 -- if Fnn then
1137 -- declare
1138 -- Temp1 : constant <type of Pref1> := <Pref1>;
1139 -- . . .
1140 -- TempN : constant <type of PrefN> := <PrefN>;
1141 -- begin
1142 -- loop
1143 -- <original source statements with attribute rewrites>
1144 -- exit when not Fnn;
1145 -- end loop;
1146 -- end;
1147 -- end if;
1148
1149 -- Note that loops over iterators and containers are already
1150 -- converted into while loops.
1151
1152 elsif Present (Condition (Scheme)) then
1153 declare
1154 Func_Decl : Node_Id;
1155 Func_Id : Entity_Id;
1156 Stmts : List_Id;
1157
1158 begin
1159 -- Wrap the condition of the while loop in a Boolean function.
1160 -- This avoids the duplication of the same code which may lead
1161 -- to gigi issues with respect to multiple declaration of the
1162 -- same entity in the presence of side effects or checks. Note
1163 -- that the condition actions must also be relocated to the
1164 -- wrapping function.
1165
1166 -- Generate:
1167 -- <condition actions>
1168 -- return <condition>;
1169
1170 if Present (Condition_Actions (Scheme)) then
1171 Stmts := Condition_Actions (Scheme);
1172 else
1173 Stmts := New_List;
1174 end if;
1175
1176 Append_To (Stmts,
1177 Make_Simple_Return_Statement (Loc,
1178 Expression => Relocate_Node (Condition (Scheme))));
1179
1180 -- Generate:
1181 -- function Fnn return Boolean is
1182 -- begin
1183 -- <Stmts>
1184 -- end Fnn;
1185
1186 Func_Id := Make_Temporary (Loc, 'F');
1187 Func_Decl :=
1188 Make_Subprogram_Body (Loc,
1189 Specification =>
1190 Make_Function_Specification (Loc,
1191 Defining_Unit_Name => Func_Id,
1192 Result_Definition =>
1193 New_Occurrence_Of (Standard_Boolean, Loc)),
1194 Declarations => Empty_List,
1195 Handled_Statement_Sequence =>
1196 Make_Handled_Sequence_Of_Statements (Loc,
1197 Statements => Stmts));
1198
1199 -- The function is inserted before the related loop. Make sure
1200 -- to analyze it in the context of the loop's enclosing scope.
1201
1202 Push_Scope (Scope (Loop_Id));
1203 Insert_Action (Loop_Stmt, Func_Decl);
1204 Pop_Scope;
1205
1206 -- Transform the original while loop into an infinite loop
1207 -- where the last statement checks the negated condition. This
1208 -- placement ensures that the condition will not be evaluated
1209 -- twice on the first iteration.
1210
1211 Set_Iteration_Scheme (Loop_Stmt, Empty);
1212 Scheme := Empty;
1213
1214 -- Generate:
1215 -- exit when not Fnn;
1216
1217 Append_To (Statements (Loop_Stmt),
1218 Make_Exit_Statement (Loc,
1219 Condition =>
1220 Make_Op_Not (Loc,
1221 Right_Opnd =>
1222 Make_Function_Call (Loc,
1223 Name => New_Occurrence_Of (Func_Id, Loc)))));
1224
1225 Build_Conditional_Block (Loc,
1226 Cond =>
1227 Make_Function_Call (Loc,
1228 Name => New_Occurrence_Of (Func_Id, Loc)),
1229 Loop_Stmt => Relocate_Node (Loop_Stmt),
1230 If_Stmt => Result,
1231 Blk_Stmt => Blk);
1232 end;
1233
1234 -- Ada 2012 iteration over an array is transformed into:
1235
1236 -- if <Array_Nam>'Length (1) > 0
1237 -- and then <Array_Nam>'Length (N) > 0
1238 -- then
1239 -- declare
1240 -- Temp1 : constant <type of Pref1> := <Pref1>;
1241 -- . . .
1242 -- TempN : constant <type of PrefN> := <PrefN>;
1243 -- begin
1244 -- for X in ... loop -- multiple loops depending on dims
1245 -- <original source statements with attribute rewrites>
1246 -- end loop;
1247 -- end;
1248 -- end if;
1249
1250 elsif Is_Array_Iteration (Loop_Stmt) then
1251 declare
1252 Array_Nam : constant Entity_Id :=
1253 Entity (Name (Iterator_Specification
1254 (Iteration_Scheme (Original_Node (Loop_Stmt)))));
1255 Num_Dims : constant Pos :=
1256 Number_Dimensions (Etype (Array_Nam));
1257 Cond : Node_Id := Empty;
1258 Check : Node_Id;
1259
1260 begin
1261 -- Generate a check which determines whether all dimensions of
1262 -- the array are non-null.
1263
1264 for Dim in 1 .. Num_Dims loop
1265 Check :=
1266 Make_Op_Gt (Loc,
1267 Left_Opnd =>
1268 Make_Attribute_Reference (Loc,
1269 Prefix => New_Occurrence_Of (Array_Nam, Loc),
1270 Attribute_Name => Name_Length,
1271 Expressions => New_List (
1272 Make_Integer_Literal (Loc, Dim))),
1273 Right_Opnd =>
1274 Make_Integer_Literal (Loc, 0));
1275
1276 if No (Cond) then
1277 Cond := Check;
1278 else
1279 Cond :=
1280 Make_And_Then (Loc,
1281 Left_Opnd => Cond,
1282 Right_Opnd => Check);
1283 end if;
1284 end loop;
1285
1286 Build_Conditional_Block (Loc,
1287 Cond => Cond,
1288 Loop_Stmt => Relocate_Node (Loop_Stmt),
1289 If_Stmt => Result,
1290 Blk_Stmt => Blk);
1291 end;
1292
1293 -- For loops are transformed into:
1294
1295 -- if <Low> <= <High> then
1296 -- declare
1297 -- Temp1 : constant <type of Pref1> := <Pref1>;
1298 -- . . .
1299 -- TempN : constant <type of PrefN> := <PrefN>;
1300 -- begin
1301 -- for <Def_Id> in <Low> .. <High> loop
1302 -- <original source statements with attribute rewrites>
1303 -- end loop;
1304 -- end;
1305 -- end if;
1306
1307 elsif Present (Loop_Parameter_Specification (Scheme)) then
1308 declare
1309 Loop_Spec : constant Node_Id :=
1310 Loop_Parameter_Specification (Scheme);
1311 Cond : Node_Id;
1312 Subt_Def : Node_Id;
1313
1314 begin
1315 Subt_Def := Discrete_Subtype_Definition (Loop_Spec);
1316
1317 -- When the loop iterates over a subtype indication with a
1318 -- range, use the low and high bounds of the subtype itself.
1319
1320 if Nkind (Subt_Def) = N_Subtype_Indication then
1321 Subt_Def := Scalar_Range (Etype (Subt_Def));
1322 end if;
1323
1324 pragma Assert (Nkind (Subt_Def) = N_Range);
1325
1326 -- Generate
1327 -- Low <= High
1328
1329 Cond :=
1330 Make_Op_Le (Loc,
1331 Left_Opnd => New_Copy_Tree (Low_Bound (Subt_Def)),
1332 Right_Opnd => New_Copy_Tree (High_Bound (Subt_Def)));
1333
1334 Build_Conditional_Block (Loc,
1335 Cond => Cond,
1336 Loop_Stmt => Relocate_Node (Loop_Stmt),
1337 If_Stmt => Result,
1338 Blk_Stmt => Blk);
1339 end;
1340 end if;
1341
1342 Decls := Declarations (Blk);
1343 end if;
1344
1345 -- Step 3: Create a constant to capture the value of the prefix at the
1346 -- entry point into the loop.
1347
1348 Temp_Id := Make_Temporary (Loc, 'P');
1349
1350 -- Preserve the tag of the prefix by offering a specific view of the
1351 -- class-wide version of the prefix.
1352
1353 if Is_Tagged_Type (Typ) then
1354
1355 -- Generate:
1356 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
1357
1358 CW_Temp := Make_Temporary (Loc, 'T');
1359 CW_Typ := Class_Wide_Type (Typ);
1360
1361 CW_Decl :=
1362 Make_Object_Declaration (Loc,
1363 Defining_Identifier => CW_Temp,
1364 Constant_Present => True,
1365 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
1366 Expression =>
1367 Convert_To (CW_Typ, Relocate_Node (Pref)));
1368 Append_To (Decls, CW_Decl);
1369
1370 -- Generate:
1371 -- Temp : Typ renames Typ (CW_Temp);
1372
1373 Temp_Decl :=
1374 Make_Object_Renaming_Declaration (Loc,
1375 Defining_Identifier => Temp_Id,
1376 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
1377 Name =>
1378 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)));
1379 Append_To (Decls, Temp_Decl);
1380
1381 -- Non-tagged case
1382
1383 else
1384 CW_Decl := Empty;
1385
1386 -- Generate:
1387 -- Temp : constant Typ := Pref;
1388
1389 Temp_Decl :=
1390 Make_Object_Declaration (Loc,
1391 Defining_Identifier => Temp_Id,
1392 Constant_Present => True,
1393 Object_Definition => New_Occurrence_Of (Typ, Loc),
1394 Expression => Relocate_Node (Pref));
1395 Append_To (Decls, Temp_Decl);
1396 end if;
1397
1398 -- Step 4: Analyze all bits
1399
1400 Installed := Current_Scope = Scope (Loop_Id);
1401
1402 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1403 -- associated loop, ensure the proper visibility for analysis.
1404
1405 if not Installed then
1406 Push_Scope (Scope (Loop_Id));
1407 end if;
1408
1409 -- The analysis of the conditional block takes care of the constant
1410 -- declaration.
1411
1412 if Present (Result) then
1413 Rewrite (Loop_Stmt, Result);
1414 Analyze (Loop_Stmt);
1415
1416 -- The conditional block was analyzed when a previous 'Loop_Entry was
1417 -- expanded. There is no point in reanalyzing the block, simply analyze
1418 -- the declaration of the constant.
1419
1420 else
1421 if Present (CW_Decl) then
1422 Analyze (CW_Decl);
1423 end if;
1424
1425 Analyze (Temp_Decl);
1426 end if;
1427
1428 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
1429 Analyze (N);
1430
1431 if not Installed then
1432 Pop_Scope;
1433 end if;
1434 end Expand_Loop_Entry_Attribute;
1435
1436 ------------------------------
1437 -- Expand_Min_Max_Attribute --
1438 ------------------------------
1439
1440 procedure Expand_Min_Max_Attribute (N : Node_Id) is
1441 begin
1442 -- Min and Max are handled by the back end (except that static cases
1443 -- have already been evaluated during semantic processing, although the
1444 -- back end should not count on this). The one bit of special processing
1445 -- required in the normal case is that these two attributes typically
1446 -- generate conditionals in the code, so check the relevant restriction.
1447
1448 Check_Restriction (No_Implicit_Conditionals, N);
1449
1450 -- In Modify_Tree_For_C mode, we rewrite as an if expression
1451
1452 if Modify_Tree_For_C then
1453 declare
1454 Loc : constant Source_Ptr := Sloc (N);
1455 Typ : constant Entity_Id := Etype (N);
1456 Expr : constant Node_Id := First (Expressions (N));
1457 Left : constant Node_Id := Relocate_Node (Expr);
1458 Right : constant Node_Id := Relocate_Node (Next (Expr));
1459
1460 function Make_Compare (Left, Right : Node_Id) return Node_Id;
1461 -- Returns Left >= Right for Max, Left <= Right for Min
1462
1463 ------------------
1464 -- Make_Compare --
1465 ------------------
1466
1467 function Make_Compare (Left, Right : Node_Id) return Node_Id is
1468 begin
1469 if Attribute_Name (N) = Name_Max then
1470 return
1471 Make_Op_Ge (Loc,
1472 Left_Opnd => Left,
1473 Right_Opnd => Right);
1474 else
1475 return
1476 Make_Op_Le (Loc,
1477 Left_Opnd => Left,
1478 Right_Opnd => Right);
1479 end if;
1480 end Make_Compare;
1481
1482 -- Start of processing for Min_Max
1483
1484 begin
1485 -- If both Left and Right are side effect free, then we can just
1486 -- use Duplicate_Expr to duplicate the references and return
1487
1488 -- (if Left >=|<= Right then Left else Right)
1489
1490 if Side_Effect_Free (Left) and then Side_Effect_Free (Right) then
1491 Rewrite (N,
1492 Make_If_Expression (Loc,
1493 Expressions => New_List (
1494 Make_Compare (Left, Right),
1495 Duplicate_Subexpr_No_Checks (Left),
1496 Duplicate_Subexpr_No_Checks (Right))));
1497
1498 -- Otherwise we generate declarations to capture the values.
1499
1500 -- The translation is
1501
1502 -- do
1503 -- T1 : constant typ := Left;
1504 -- T2 : constant typ := Right;
1505 -- in
1506 -- (if T1 >=|<= T2 then T1 else T2)
1507 -- end;
1508
1509 else
1510 declare
1511 T1 : constant Entity_Id := Make_Temporary (Loc, 'T', Left);
1512 T2 : constant Entity_Id := Make_Temporary (Loc, 'T', Right);
1513
1514 begin
1515 Rewrite (N,
1516 Make_Expression_With_Actions (Loc,
1517 Actions => New_List (
1518 Make_Object_Declaration (Loc,
1519 Defining_Identifier => T1,
1520 Constant_Present => True,
1521 Object_Definition =>
1522 New_Occurrence_Of (Etype (Left), Loc),
1523 Expression => Relocate_Node (Left)),
1524
1525 Make_Object_Declaration (Loc,
1526 Defining_Identifier => T2,
1527 Constant_Present => True,
1528 Object_Definition =>
1529 New_Occurrence_Of (Etype (Right), Loc),
1530 Expression => Relocate_Node (Right))),
1531
1532 Expression =>
1533 Make_If_Expression (Loc,
1534 Expressions => New_List (
1535 Make_Compare
1536 (New_Occurrence_Of (T1, Loc),
1537 New_Occurrence_Of (T2, Loc)),
1538 New_Occurrence_Of (T1, Loc),
1539 New_Occurrence_Of (T2, Loc)))));
1540 end;
1541 end if;
1542
1543 Analyze_And_Resolve (N, Typ);
1544 end;
1545 end if;
1546 end Expand_Min_Max_Attribute;
1547
1548 ----------------------------------
1549 -- Expand_N_Attribute_Reference --
1550 ----------------------------------
1551
1552 procedure Expand_N_Attribute_Reference (N : Node_Id) is
1553 Loc : constant Source_Ptr := Sloc (N);
1554 Typ : constant Entity_Id := Etype (N);
1555 Btyp : constant Entity_Id := Base_Type (Typ);
1556 Pref : constant Node_Id := Prefix (N);
1557 Ptyp : constant Entity_Id := Etype (Pref);
1558 Exprs : constant List_Id := Expressions (N);
1559 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
1560
1561 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
1562 -- Rewrites a stream attribute for Read, Write or Output with the
1563 -- procedure call. Pname is the entity for the procedure to call.
1564
1565 ------------------------------
1566 -- Rewrite_Stream_Proc_Call --
1567 ------------------------------
1568
1569 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
1570 Item : constant Node_Id := Next (First (Exprs));
1571 Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
1572 Formal_Typ : constant Entity_Id := Etype (Formal);
1573 Is_Written : constant Boolean := (Ekind (Formal) /= E_In_Parameter);
1574
1575 begin
1576 -- The expansion depends on Item, the second actual, which is
1577 -- the object being streamed in or out.
1578
1579 -- If the item is a component of a packed array type, and
1580 -- a conversion is needed on exit, we introduce a temporary to
1581 -- hold the value, because otherwise the packed reference will
1582 -- not be properly expanded.
1583
1584 if Nkind (Item) = N_Indexed_Component
1585 and then Is_Packed (Base_Type (Etype (Prefix (Item))))
1586 and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
1587 and then Is_Written
1588 then
1589 declare
1590 Temp : constant Entity_Id := Make_Temporary (Loc, 'V');
1591 Decl : Node_Id;
1592 Assn : Node_Id;
1593
1594 begin
1595 Decl :=
1596 Make_Object_Declaration (Loc,
1597 Defining_Identifier => Temp,
1598 Object_Definition =>
1599 New_Occurrence_Of (Formal_Typ, Loc));
1600 Set_Etype (Temp, Formal_Typ);
1601
1602 Assn :=
1603 Make_Assignment_Statement (Loc,
1604 Name => New_Copy_Tree (Item),
1605 Expression =>
1606 Unchecked_Convert_To
1607 (Etype (Item), New_Occurrence_Of (Temp, Loc)));
1608
1609 Rewrite (Item, New_Occurrence_Of (Temp, Loc));
1610 Insert_Actions (N,
1611 New_List (
1612 Decl,
1613 Make_Procedure_Call_Statement (Loc,
1614 Name => New_Occurrence_Of (Pname, Loc),
1615 Parameter_Associations => Exprs),
1616 Assn));
1617
1618 Rewrite (N, Make_Null_Statement (Loc));
1619 return;
1620 end;
1621 end if;
1622
1623 -- For the class-wide dispatching cases, and for cases in which
1624 -- the base type of the second argument matches the base type of
1625 -- the corresponding formal parameter (that is to say the stream
1626 -- operation is not inherited), we are all set, and can use the
1627 -- argument unchanged.
1628
1629 -- For all other cases we do an unchecked conversion of the second
1630 -- parameter to the type of the formal of the procedure we are
1631 -- calling. This deals with the private type cases, and with going
1632 -- to the root type as required in elementary type case.
1633
1634 if not Is_Class_Wide_Type (Entity (Pref))
1635 and then not Is_Class_Wide_Type (Etype (Item))
1636 and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
1637 then
1638 Rewrite (Item,
1639 Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
1640
1641 -- For untagged derived types set Assignment_OK, to prevent
1642 -- copies from being created when the unchecked conversion
1643 -- is expanded (which would happen in Remove_Side_Effects
1644 -- if Expand_N_Unchecked_Conversion were allowed to call
1645 -- Force_Evaluation). The copy could violate Ada semantics in
1646 -- cases such as an actual that is an out parameter. Note that
1647 -- this approach is also used in exp_ch7 for calls to controlled
1648 -- type operations to prevent problems with actuals wrapped in
1649 -- unchecked conversions.
1650
1651 if Is_Untagged_Derivation (Etype (Expression (Item))) then
1652 Set_Assignment_OK (Item);
1653 end if;
1654 end if;
1655
1656 -- The stream operation to call may be a renaming created by an
1657 -- attribute definition clause, and may not be frozen yet. Ensure
1658 -- that it has the necessary extra formals.
1659
1660 if not Is_Frozen (Pname) then
1661 Create_Extra_Formals (Pname);
1662 end if;
1663
1664 -- And now rewrite the call
1665
1666 Rewrite (N,
1667 Make_Procedure_Call_Statement (Loc,
1668 Name => New_Occurrence_Of (Pname, Loc),
1669 Parameter_Associations => Exprs));
1670
1671 Analyze (N);
1672 end Rewrite_Stream_Proc_Call;
1673
1674 -- Start of processing for Expand_N_Attribute_Reference
1675
1676 begin
1677 -- Do required validity checking, if enabled. Do not apply check to
1678 -- output parameters of an Asm instruction, since the value of this
1679 -- is not set till after the attribute has been elaborated, and do
1680 -- not apply the check to the arguments of a 'Read or 'Input attribute
1681 -- reference since the scalar argument is an OUT scalar.
1682
1683 if Validity_Checks_On and then Validity_Check_Operands
1684 and then Id /= Attribute_Asm_Output
1685 and then Id /= Attribute_Read
1686 and then Id /= Attribute_Input
1687 then
1688 declare
1689 Expr : Node_Id;
1690 begin
1691 Expr := First (Expressions (N));
1692 while Present (Expr) loop
1693 Ensure_Valid (Expr);
1694 Next (Expr);
1695 end loop;
1696 end;
1697 end if;
1698
1699 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
1700 -- place function, then a temporary return object needs to be created
1701 -- and access to it must be passed to the function. Currently we limit
1702 -- such functions to those with inherently limited result subtypes, but
1703 -- eventually we plan to expand the functions that are treated as
1704 -- build-in-place to include other composite result types.
1705
1706 if Ada_Version >= Ada_2005
1707 and then Is_Build_In_Place_Function_Call (Pref)
1708 then
1709 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
1710 end if;
1711
1712 -- If prefix is a protected type name, this is a reference to the
1713 -- current instance of the type. For a component definition, nothing
1714 -- to do (expansion will occur in the init proc). In other contexts,
1715 -- rewrite into reference to current instance.
1716
1717 if Is_Protected_Self_Reference (Pref)
1718 and then not
1719 (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint,
1720 N_Discriminant_Association)
1721 and then Nkind (Parent (Parent (Parent (Parent (N))))) =
1722 N_Component_Definition)
1723
1724 -- No action needed for these attributes since the current instance
1725 -- will be rewritten to be the name of the _object parameter
1726 -- associated with the enclosing protected subprogram (see below).
1727
1728 and then Id /= Attribute_Access
1729 and then Id /= Attribute_Unchecked_Access
1730 and then Id /= Attribute_Unrestricted_Access
1731 then
1732 Rewrite (Pref, Concurrent_Ref (Pref));
1733 Analyze (Pref);
1734 end if;
1735
1736 -- Remaining processing depends on specific attribute
1737
1738 -- Note: individual sections of the following case statement are
1739 -- allowed to assume there is no code after the case statement, and
1740 -- are legitimately allowed to execute return statements if they have
1741 -- nothing more to do.
1742
1743 case Id is
1744
1745 -- Attributes related to Ada 2012 iterators
1746
1747 when Attribute_Constant_Indexing |
1748 Attribute_Default_Iterator |
1749 Attribute_Implicit_Dereference |
1750 Attribute_Iterable |
1751 Attribute_Iterator_Element |
1752 Attribute_Variable_Indexing =>
1753 null;
1754
1755 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
1756 -- were already rejected by the parser. Thus they shouldn't appear here.
1757
1758 when Internal_Attribute_Id =>
1759 raise Program_Error;
1760
1761 ------------
1762 -- Access --
1763 ------------
1764
1765 when Attribute_Access |
1766 Attribute_Unchecked_Access |
1767 Attribute_Unrestricted_Access =>
1768
1769 Access_Cases : declare
1770 Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
1771 Btyp_DDT : Entity_Id;
1772
1773 function Enclosing_Object (N : Node_Id) return Node_Id;
1774 -- If N denotes a compound name (selected component, indexed
1775 -- component, or slice), returns the name of the outermost such
1776 -- enclosing object. Otherwise returns N. If the object is a
1777 -- renaming, then the renamed object is returned.
1778
1779 ----------------------
1780 -- Enclosing_Object --
1781 ----------------------
1782
1783 function Enclosing_Object (N : Node_Id) return Node_Id is
1784 Obj_Name : Node_Id;
1785
1786 begin
1787 Obj_Name := N;
1788 while Nkind_In (Obj_Name, N_Selected_Component,
1789 N_Indexed_Component,
1790 N_Slice)
1791 loop
1792 Obj_Name := Prefix (Obj_Name);
1793 end loop;
1794
1795 return Get_Referenced_Object (Obj_Name);
1796 end Enclosing_Object;
1797
1798 -- Local declarations
1799
1800 Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
1801
1802 -- Start of processing for Access_Cases
1803
1804 begin
1805 Btyp_DDT := Designated_Type (Btyp);
1806
1807 -- Handle designated types that come from the limited view
1808
1809 if From_Limited_With (Btyp_DDT)
1810 and then Has_Non_Limited_View (Btyp_DDT)
1811 then
1812 Btyp_DDT := Non_Limited_View (Btyp_DDT);
1813 end if;
1814
1815 -- In order to improve the text of error messages, the designated
1816 -- type of access-to-subprogram itypes is set by the semantics as
1817 -- the associated subprogram entity (see sem_attr). Now we replace
1818 -- such node with the proper E_Subprogram_Type itype.
1819
1820 if Id = Attribute_Unrestricted_Access
1821 and then Is_Subprogram (Directly_Designated_Type (Typ))
1822 then
1823 -- The following conditions ensure that this special management
1824 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
1825 -- At this stage other cases in which the designated type is
1826 -- still a subprogram (instead of an E_Subprogram_Type) are
1827 -- wrong because the semantics must have overridden the type of
1828 -- the node with the type imposed by the context.
1829
1830 if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
1831 and then Etype (Parent (N)) = RTE (RE_Prim_Ptr)
1832 then
1833 Set_Etype (N, RTE (RE_Prim_Ptr));
1834
1835 else
1836 declare
1837 Subp : constant Entity_Id :=
1838 Directly_Designated_Type (Typ);
1839 Etyp : Entity_Id;
1840 Extra : Entity_Id := Empty;
1841 New_Formal : Entity_Id;
1842 Old_Formal : Entity_Id := First_Formal (Subp);
1843 Subp_Typ : Entity_Id;
1844
1845 begin
1846 Subp_Typ := Create_Itype (E_Subprogram_Type, N);
1847 Set_Etype (Subp_Typ, Etype (Subp));
1848 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
1849
1850 if Present (Old_Formal) then
1851 New_Formal := New_Copy (Old_Formal);
1852 Set_First_Entity (Subp_Typ, New_Formal);
1853
1854 loop
1855 Set_Scope (New_Formal, Subp_Typ);
1856 Etyp := Etype (New_Formal);
1857
1858 -- Handle itypes. There is no need to duplicate
1859 -- here the itypes associated with record types
1860 -- (i.e the implicit full view of private types).
1861
1862 if Is_Itype (Etyp)
1863 and then Ekind (Base_Type (Etyp)) /= E_Record_Type
1864 then
1865 Extra := New_Copy (Etyp);
1866 Set_Parent (Extra, New_Formal);
1867 Set_Etype (New_Formal, Extra);
1868 Set_Scope (Extra, Subp_Typ);
1869 end if;
1870
1871 Extra := New_Formal;
1872 Next_Formal (Old_Formal);
1873 exit when No (Old_Formal);
1874
1875 Set_Next_Entity (New_Formal,
1876 New_Copy (Old_Formal));
1877 Next_Entity (New_Formal);
1878 end loop;
1879
1880 Set_Next_Entity (New_Formal, Empty);
1881 Set_Last_Entity (Subp_Typ, Extra);
1882 end if;
1883
1884 -- Now that the explicit formals have been duplicated,
1885 -- any extra formals needed by the subprogram must be
1886 -- created.
1887
1888 if Present (Extra) then
1889 Set_Extra_Formal (Extra, Empty);
1890 end if;
1891
1892 Create_Extra_Formals (Subp_Typ);
1893 Set_Directly_Designated_Type (Typ, Subp_Typ);
1894 end;
1895 end if;
1896 end if;
1897
1898 if Is_Access_Protected_Subprogram_Type (Btyp) then
1899 Expand_Access_To_Protected_Op (N, Pref, Typ);
1900
1901 -- If prefix is a type name, this is a reference to the current
1902 -- instance of the type, within its initialization procedure.
1903
1904 elsif Is_Entity_Name (Pref)
1905 and then Is_Type (Entity (Pref))
1906 then
1907 declare
1908 Par : Node_Id;
1909 Formal : Entity_Id;
1910
1911 begin
1912 -- If the current instance name denotes a task type, then
1913 -- the access attribute is rewritten to be the name of the
1914 -- "_task" parameter associated with the task type's task
1915 -- procedure. An unchecked conversion is applied to ensure
1916 -- a type match in cases of expander-generated calls (e.g.
1917 -- init procs).
1918
1919 if Is_Task_Type (Entity (Pref)) then
1920 Formal :=
1921 First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
1922 while Present (Formal) loop
1923 exit when Chars (Formal) = Name_uTask;
1924 Next_Entity (Formal);
1925 end loop;
1926
1927 pragma Assert (Present (Formal));
1928
1929 Rewrite (N,
1930 Unchecked_Convert_To (Typ,
1931 New_Occurrence_Of (Formal, Loc)));
1932 Set_Etype (N, Typ);
1933
1934 elsif Is_Protected_Type (Entity (Pref)) then
1935
1936 -- No action needed for current instance located in a
1937 -- component definition (expansion will occur in the
1938 -- init proc)
1939
1940 if Is_Protected_Type (Current_Scope) then
1941 null;
1942
1943 -- If the current instance reference is located in a
1944 -- protected subprogram or entry then rewrite the access
1945 -- attribute to be the name of the "_object" parameter.
1946 -- An unchecked conversion is applied to ensure a type
1947 -- match in cases of expander-generated calls (e.g. init
1948 -- procs).
1949
1950 -- The code may be nested in a block, so find enclosing
1951 -- scope that is a protected operation.
1952
1953 else
1954 declare
1955 Subp : Entity_Id;
1956
1957 begin
1958 Subp := Current_Scope;
1959 while Ekind_In (Subp, E_Loop, E_Block) loop
1960 Subp := Scope (Subp);
1961 end loop;
1962
1963 Formal :=
1964 First_Entity
1965 (Protected_Body_Subprogram (Subp));
1966
1967 -- For a protected subprogram the _Object parameter
1968 -- is the protected record, so we create an access
1969 -- to it. The _Object parameter of an entry is an
1970 -- address.
1971
1972 if Ekind (Subp) = E_Entry then
1973 Rewrite (N,
1974 Unchecked_Convert_To (Typ,
1975 New_Occurrence_Of (Formal, Loc)));
1976 Set_Etype (N, Typ);
1977
1978 else
1979 Rewrite (N,
1980 Unchecked_Convert_To (Typ,
1981 Make_Attribute_Reference (Loc,
1982 Attribute_Name => Name_Unrestricted_Access,
1983 Prefix =>
1984 New_Occurrence_Of (Formal, Loc))));
1985 Analyze_And_Resolve (N);
1986 end if;
1987 end;
1988 end if;
1989
1990 -- The expression must appear in a default expression,
1991 -- (which in the initialization procedure is the right-hand
1992 -- side of an assignment), and not in a discriminant
1993 -- constraint.
1994
1995 else
1996 Par := Parent (N);
1997 while Present (Par) loop
1998 exit when Nkind (Par) = N_Assignment_Statement;
1999
2000 if Nkind (Par) = N_Component_Declaration then
2001 return;
2002 end if;
2003
2004 Par := Parent (Par);
2005 end loop;
2006
2007 if Present (Par) then
2008 Rewrite (N,
2009 Make_Attribute_Reference (Loc,
2010 Prefix => Make_Identifier (Loc, Name_uInit),
2011 Attribute_Name => Attribute_Name (N)));
2012
2013 Analyze_And_Resolve (N, Typ);
2014 end if;
2015 end if;
2016 end;
2017
2018 -- If the prefix of an Access attribute is a dereference of an
2019 -- access parameter (or a renaming of such a dereference, or a
2020 -- subcomponent of such a dereference) and the context is a
2021 -- general access type (including the type of an object or
2022 -- component with an access_definition, but not the anonymous
2023 -- type of an access parameter or access discriminant), then
2024 -- apply an accessibility check to the access parameter. We used
2025 -- to rewrite the access parameter as a type conversion, but that
2026 -- could only be done if the immediate prefix of the Access
2027 -- attribute was the dereference, and didn't handle cases where
2028 -- the attribute is applied to a subcomponent of the dereference,
2029 -- since there's generally no available, appropriate access type
2030 -- to convert to in that case. The attribute is passed as the
2031 -- point to insert the check, because the access parameter may
2032 -- come from a renaming, possibly in a different scope, and the
2033 -- check must be associated with the attribute itself.
2034
2035 elsif Id = Attribute_Access
2036 and then Nkind (Enc_Object) = N_Explicit_Dereference
2037 and then Is_Entity_Name (Prefix (Enc_Object))
2038 and then (Ekind (Btyp) = E_General_Access_Type
2039 or else Is_Local_Anonymous_Access (Btyp))
2040 and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind
2041 and then Ekind (Etype (Entity (Prefix (Enc_Object))))
2042 = E_Anonymous_Access_Type
2043 and then Present (Extra_Accessibility
2044 (Entity (Prefix (Enc_Object))))
2045 then
2046 Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N);
2047
2048 -- Ada 2005 (AI-251): If the designated type is an interface we
2049 -- add an implicit conversion to force the displacement of the
2050 -- pointer to reference the secondary dispatch table.
2051
2052 elsif Is_Interface (Btyp_DDT)
2053 and then (Comes_From_Source (N)
2054 or else Comes_From_Source (Ref_Object)
2055 or else (Nkind (Ref_Object) in N_Has_Chars
2056 and then Chars (Ref_Object) = Name_uInit))
2057 then
2058 if Nkind (Ref_Object) /= N_Explicit_Dereference then
2059
2060 -- No implicit conversion required if types match, or if
2061 -- the prefix is the class_wide_type of the interface. In
2062 -- either case passing an object of the interface type has
2063 -- already set the pointer correctly.
2064
2065 if Btyp_DDT = Etype (Ref_Object)
2066 or else (Is_Class_Wide_Type (Etype (Ref_Object))
2067 and then
2068 Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object))
2069 then
2070 null;
2071
2072 else
2073 Rewrite (Prefix (N),
2074 Convert_To (Btyp_DDT,
2075 New_Copy_Tree (Prefix (N))));
2076
2077 Analyze_And_Resolve (Prefix (N), Btyp_DDT);
2078 end if;
2079
2080 -- When the object is an explicit dereference, convert the
2081 -- dereference's prefix.
2082
2083 else
2084 declare
2085 Obj_DDT : constant Entity_Id :=
2086 Base_Type
2087 (Directly_Designated_Type
2088 (Etype (Prefix (Ref_Object))));
2089 begin
2090 -- No implicit conversion required if designated types
2091 -- match, or if we have an unrestricted access.
2092
2093 if Obj_DDT /= Btyp_DDT
2094 and then Id /= Attribute_Unrestricted_Access
2095 and then not (Is_Class_Wide_Type (Obj_DDT)
2096 and then Etype (Obj_DDT) = Btyp_DDT)
2097 then
2098 Rewrite (N,
2099 Convert_To (Typ,
2100 New_Copy_Tree (Prefix (Ref_Object))));
2101 Analyze_And_Resolve (N, Typ);
2102 end if;
2103 end;
2104 end if;
2105 end if;
2106 end Access_Cases;
2107
2108 --------------
2109 -- Adjacent --
2110 --------------
2111
2112 -- Transforms 'Adjacent into a call to the floating-point attribute
2113 -- function Adjacent in Fat_xxx (where xxx is the root type)
2114
2115 when Attribute_Adjacent =>
2116 Expand_Fpt_Attribute_RR (N);
2117
2118 -------------
2119 -- Address --
2120 -------------
2121
2122 when Attribute_Address => Address : declare
2123 Task_Proc : Entity_Id;
2124
2125 begin
2126 -- If the prefix is a task or a task type, the useful address is that
2127 -- of the procedure for the task body, i.e. the actual program unit.
2128 -- We replace the original entity with that of the procedure.
2129
2130 if Is_Entity_Name (Pref)
2131 and then Is_Task_Type (Entity (Pref))
2132 then
2133 Task_Proc := Next_Entity (Root_Type (Ptyp));
2134
2135 while Present (Task_Proc) loop
2136 exit when Ekind (Task_Proc) = E_Procedure
2137 and then Etype (First_Formal (Task_Proc)) =
2138 Corresponding_Record_Type (Ptyp);
2139 Next_Entity (Task_Proc);
2140 end loop;
2141
2142 if Present (Task_Proc) then
2143 Set_Entity (Pref, Task_Proc);
2144 Set_Etype (Pref, Etype (Task_Proc));
2145 end if;
2146
2147 -- Similarly, the address of a protected operation is the address
2148 -- of the corresponding protected body, regardless of the protected
2149 -- object from which it is selected.
2150
2151 elsif Nkind (Pref) = N_Selected_Component
2152 and then Is_Subprogram (Entity (Selector_Name (Pref)))
2153 and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref))))
2154 then
2155 Rewrite (Pref,
2156 New_Occurrence_Of (
2157 External_Subprogram (Entity (Selector_Name (Pref))), Loc));
2158
2159 elsif Nkind (Pref) = N_Explicit_Dereference
2160 and then Ekind (Ptyp) = E_Subprogram_Type
2161 and then Convention (Ptyp) = Convention_Protected
2162 then
2163 -- The prefix is be a dereference of an access_to_protected_
2164 -- subprogram. The desired address is the second component of
2165 -- the record that represents the access.
2166
2167 declare
2168 Addr : constant Entity_Id := Etype (N);
2169 Ptr : constant Node_Id := Prefix (Pref);
2170 T : constant Entity_Id :=
2171 Equivalent_Type (Base_Type (Etype (Ptr)));
2172
2173 begin
2174 Rewrite (N,
2175 Unchecked_Convert_To (Addr,
2176 Make_Selected_Component (Loc,
2177 Prefix => Unchecked_Convert_To (T, Ptr),
2178 Selector_Name => New_Occurrence_Of (
2179 Next_Entity (First_Entity (T)), Loc))));
2180
2181 Analyze_And_Resolve (N, Addr);
2182 end;
2183
2184 -- Ada 2005 (AI-251): Class-wide interface objects are always
2185 -- "displaced" to reference the tag associated with the interface
2186 -- type. In order to obtain the real address of such objects we
2187 -- generate a call to a run-time subprogram that returns the base
2188 -- address of the object.
2189
2190 -- This processing is not needed in the VM case, where dispatching
2191 -- issues are taken care of by the virtual machine.
2192
2193 elsif Is_Class_Wide_Type (Ptyp)
2194 and then Is_Interface (Ptyp)
2195 and then Tagged_Type_Expansion
2196 and then not (Nkind (Pref) in N_Has_Entity
2197 and then Is_Subprogram (Entity (Pref)))
2198 then
2199 Rewrite (N,
2200 Make_Function_Call (Loc,
2201 Name => New_Occurrence_Of (RTE (RE_Base_Address), Loc),
2202 Parameter_Associations => New_List (
2203 Relocate_Node (N))));
2204 Analyze (N);
2205 return;
2206 end if;
2207
2208 -- Deal with packed array reference, other cases are handled by
2209 -- the back end.
2210
2211 if Involves_Packed_Array_Reference (Pref) then
2212 Expand_Packed_Address_Reference (N);
2213 end if;
2214 end Address;
2215
2216 ---------------
2217 -- Alignment --
2218 ---------------
2219
2220 when Attribute_Alignment => Alignment : declare
2221 New_Node : Node_Id;
2222
2223 begin
2224 -- For class-wide types, X'Class'Alignment is transformed into a
2225 -- direct reference to the Alignment of the class type, so that the
2226 -- back end does not have to deal with the X'Class'Alignment
2227 -- reference.
2228
2229 if Is_Entity_Name (Pref)
2230 and then Is_Class_Wide_Type (Entity (Pref))
2231 then
2232 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
2233 return;
2234
2235 -- For x'Alignment applied to an object of a class wide type,
2236 -- transform X'Alignment into a call to the predefined primitive
2237 -- operation _Alignment applied to X.
2238
2239 elsif Is_Class_Wide_Type (Ptyp) then
2240 New_Node :=
2241 Make_Attribute_Reference (Loc,
2242 Prefix => Pref,
2243 Attribute_Name => Name_Tag);
2244
2245 New_Node := Build_Get_Alignment (Loc, New_Node);
2246
2247 -- Case where the context is a specific integer type with which
2248 -- the original attribute was compatible. The function has a
2249 -- specific type as well, so to preserve the compatibility we
2250 -- must convert explicitly.
2251
2252 if Typ /= Standard_Integer then
2253 New_Node := Convert_To (Typ, New_Node);
2254 end if;
2255
2256 Rewrite (N, New_Node);
2257 Analyze_And_Resolve (N, Typ);
2258 return;
2259
2260 -- For all other cases, we just have to deal with the case of
2261 -- the fact that the result can be universal.
2262
2263 else
2264 Apply_Universal_Integer_Attribute_Checks (N);
2265 end if;
2266 end Alignment;
2267
2268 ---------
2269 -- Bit --
2270 ---------
2271
2272 -- We compute this if a packed array reference was present, otherwise we
2273 -- leave the computation up to the back end.
2274
2275 when Attribute_Bit =>
2276 if Involves_Packed_Array_Reference (Pref) then
2277 Expand_Packed_Bit_Reference (N);
2278 else
2279 Apply_Universal_Integer_Attribute_Checks (N);
2280 end if;
2281
2282 ------------------
2283 -- Bit_Position --
2284 ------------------
2285
2286 -- We compute this if a component clause was present, otherwise we leave
2287 -- the computation up to the back end, since we don't know what layout
2288 -- will be chosen.
2289
2290 -- Note that the attribute can apply to a naked record component
2291 -- in generated code (i.e. the prefix is an identifier that
2292 -- references the component or discriminant entity).
2293
2294 when Attribute_Bit_Position => Bit_Position : declare
2295 CE : Entity_Id;
2296
2297 begin
2298 if Nkind (Pref) = N_Identifier then
2299 CE := Entity (Pref);
2300 else
2301 CE := Entity (Selector_Name (Pref));
2302 end if;
2303
2304 if Known_Static_Component_Bit_Offset (CE) then
2305 Rewrite (N,
2306 Make_Integer_Literal (Loc,
2307 Intval => Component_Bit_Offset (CE)));
2308 Analyze_And_Resolve (N, Typ);
2309
2310 else
2311 Apply_Universal_Integer_Attribute_Checks (N);
2312 end if;
2313 end Bit_Position;
2314
2315 ------------------
2316 -- Body_Version --
2317 ------------------
2318
2319 -- A reference to P'Body_Version or P'Version is expanded to
2320
2321 -- Vnn : Unsigned;
2322 -- pragma Import (C, Vnn, "uuuuT");
2323 -- ...
2324 -- Get_Version_String (Vnn)
2325
2326 -- where uuuu is the unit name (dots replaced by double underscore)
2327 -- and T is B for the cases of Body_Version, or Version applied to a
2328 -- subprogram acting as its own spec, and S for Version applied to a
2329 -- subprogram spec or package. This sequence of code references the
2330 -- unsigned constant created in the main program by the binder.
2331
2332 -- A special exception occurs for Standard, where the string returned
2333 -- is a copy of the library string in gnatvsn.ads.
2334
2335 when Attribute_Body_Version | Attribute_Version => Version : declare
2336 E : constant Entity_Id := Make_Temporary (Loc, 'V');
2337 Pent : Entity_Id;
2338 S : String_Id;
2339
2340 begin
2341 -- If not library unit, get to containing library unit
2342
2343 Pent := Entity (Pref);
2344 while Pent /= Standard_Standard
2345 and then Scope (Pent) /= Standard_Standard
2346 and then not Is_Child_Unit (Pent)
2347 loop
2348 Pent := Scope (Pent);
2349 end loop;
2350
2351 -- Special case Standard and Standard.ASCII
2352
2353 if Pent = Standard_Standard or else Pent = Standard_ASCII then
2354 Rewrite (N,
2355 Make_String_Literal (Loc,
2356 Strval => Verbose_Library_Version));
2357
2358 -- All other cases
2359
2360 else
2361 -- Build required string constant
2362
2363 Get_Name_String (Get_Unit_Name (Pent));
2364
2365 Start_String;
2366 for J in 1 .. Name_Len - 2 loop
2367 if Name_Buffer (J) = '.' then
2368 Store_String_Chars ("__");
2369 else
2370 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
2371 end if;
2372 end loop;
2373
2374 -- Case of subprogram acting as its own spec, always use body
2375
2376 if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
2377 and then Nkind (Parent (Declaration_Node (Pent))) =
2378 N_Subprogram_Body
2379 and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
2380 then
2381 Store_String_Chars ("B");
2382
2383 -- Case of no body present, always use spec
2384
2385 elsif not Unit_Requires_Body (Pent) then
2386 Store_String_Chars ("S");
2387
2388 -- Otherwise use B for Body_Version, S for spec
2389
2390 elsif Id = Attribute_Body_Version then
2391 Store_String_Chars ("B");
2392 else
2393 Store_String_Chars ("S");
2394 end if;
2395
2396 S := End_String;
2397 Lib.Version_Referenced (S);
2398
2399 -- Insert the object declaration
2400
2401 Insert_Actions (N, New_List (
2402 Make_Object_Declaration (Loc,
2403 Defining_Identifier => E,
2404 Object_Definition =>
2405 New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
2406
2407 -- Set entity as imported with correct external name
2408
2409 Set_Is_Imported (E);
2410 Set_Interface_Name (E, Make_String_Literal (Loc, S));
2411
2412 -- Set entity as internal to ensure proper Sprint output of its
2413 -- implicit importation.
2414
2415 Set_Is_Internal (E);
2416
2417 -- And now rewrite original reference
2418
2419 Rewrite (N,
2420 Make_Function_Call (Loc,
2421 Name => New_Occurrence_Of (RTE (RE_Get_Version_String), Loc),
2422 Parameter_Associations => New_List (
2423 New_Occurrence_Of (E, Loc))));
2424 end if;
2425
2426 Analyze_And_Resolve (N, RTE (RE_Version_String));
2427 end Version;
2428
2429 -------------
2430 -- Ceiling --
2431 -------------
2432
2433 -- Transforms 'Ceiling into a call to the floating-point attribute
2434 -- function Ceiling in Fat_xxx (where xxx is the root type)
2435
2436 when Attribute_Ceiling =>
2437 Expand_Fpt_Attribute_R (N);
2438
2439 --------------
2440 -- Callable --
2441 --------------
2442
2443 -- Transforms 'Callable attribute into a call to the Callable function
2444
2445 when Attribute_Callable => Callable :
2446 begin
2447 -- We have an object of a task interface class-wide type as a prefix
2448 -- to Callable. Generate:
2449 -- callable (Task_Id (Pref._disp_get_task_id));
2450
2451 if Ada_Version >= Ada_2005
2452 and then Ekind (Ptyp) = E_Class_Wide_Type
2453 and then Is_Interface (Ptyp)
2454 and then Is_Task_Interface (Ptyp)
2455 then
2456 Rewrite (N,
2457 Make_Function_Call (Loc,
2458 Name =>
2459 New_Occurrence_Of (RTE (RE_Callable), Loc),
2460 Parameter_Associations => New_List (
2461 Make_Unchecked_Type_Conversion (Loc,
2462 Subtype_Mark =>
2463 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
2464 Expression =>
2465 Make_Selected_Component (Loc,
2466 Prefix =>
2467 New_Copy_Tree (Pref),
2468 Selector_Name =>
2469 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
2470
2471 else
2472 Rewrite (N,
2473 Build_Call_With_Task (Pref, RTE (RE_Callable)));
2474 end if;
2475
2476 Analyze_And_Resolve (N, Standard_Boolean);
2477 end Callable;
2478
2479 ------------
2480 -- Caller --
2481 ------------
2482
2483 -- Transforms 'Caller attribute into a call to either the
2484 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2485
2486 when Attribute_Caller => Caller : declare
2487 Id_Kind : constant Entity_Id := RTE (RO_AT_Task_Id);
2488 Ent : constant Entity_Id := Entity (Pref);
2489 Conctype : constant Entity_Id := Scope (Ent);
2490 Nest_Depth : Integer := 0;
2491 Name : Node_Id;
2492 S : Entity_Id;
2493
2494 begin
2495 -- Protected case
2496
2497 if Is_Protected_Type (Conctype) then
2498 case Corresponding_Runtime_Package (Conctype) is
2499 when System_Tasking_Protected_Objects_Entries =>
2500 Name :=
2501 New_Occurrence_Of
2502 (RTE (RE_Protected_Entry_Caller), Loc);
2503
2504 when System_Tasking_Protected_Objects_Single_Entry =>
2505 Name :=
2506 New_Occurrence_Of
2507 (RTE (RE_Protected_Single_Entry_Caller), Loc);
2508
2509 when others =>
2510 raise Program_Error;
2511 end case;
2512
2513 Rewrite (N,
2514 Unchecked_Convert_To (Id_Kind,
2515 Make_Function_Call (Loc,
2516 Name => Name,
2517 Parameter_Associations => New_List (
2518 New_Occurrence_Of
2519 (Find_Protection_Object (Current_Scope), Loc)))));
2520
2521 -- Task case
2522
2523 else
2524 -- Determine the nesting depth of the E'Caller attribute, that
2525 -- is, how many accept statements are nested within the accept
2526 -- statement for E at the point of E'Caller. The runtime uses
2527 -- this depth to find the specified entry call.
2528
2529 for J in reverse 0 .. Scope_Stack.Last loop
2530 S := Scope_Stack.Table (J).Entity;
2531
2532 -- We should not reach the scope of the entry, as it should
2533 -- already have been checked in Sem_Attr that this attribute
2534 -- reference is within a matching accept statement.
2535
2536 pragma Assert (S /= Conctype);
2537
2538 if S = Ent then
2539 exit;
2540
2541 elsif Is_Entry (S) then
2542 Nest_Depth := Nest_Depth + 1;
2543 end if;
2544 end loop;
2545
2546 Rewrite (N,
2547 Unchecked_Convert_To (Id_Kind,
2548 Make_Function_Call (Loc,
2549 Name =>
2550 New_Occurrence_Of (RTE (RE_Task_Entry_Caller), Loc),
2551 Parameter_Associations => New_List (
2552 Make_Integer_Literal (Loc,
2553 Intval => Int (Nest_Depth))))));
2554 end if;
2555
2556 Analyze_And_Resolve (N, Id_Kind);
2557 end Caller;
2558
2559 -------------
2560 -- Compose --
2561 -------------
2562
2563 -- Transforms 'Compose into a call to the floating-point attribute
2564 -- function Compose in Fat_xxx (where xxx is the root type)
2565
2566 -- Note: we strictly should have special code here to deal with the
2567 -- case of absurdly negative arguments (less than Integer'First)
2568 -- which will return a (signed) zero value, but it hardly seems
2569 -- worth the effort. Absurdly large positive arguments will raise
2570 -- constraint error which is fine.
2571
2572 when Attribute_Compose =>
2573 Expand_Fpt_Attribute_RI (N);
2574
2575 -----------------
2576 -- Constrained --
2577 -----------------
2578
2579 when Attribute_Constrained => Constrained : declare
2580 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
2581
2582 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
2583 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
2584 -- view of an aliased object whose subtype is constrained.
2585
2586 ---------------------------------
2587 -- Is_Constrained_Aliased_View --
2588 ---------------------------------
2589
2590 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
2591 E : Entity_Id;
2592
2593 begin
2594 if Is_Entity_Name (Obj) then
2595 E := Entity (Obj);
2596
2597 if Present (Renamed_Object (E)) then
2598 return Is_Constrained_Aliased_View (Renamed_Object (E));
2599 else
2600 return Is_Aliased (E) and then Is_Constrained (Etype (E));
2601 end if;
2602
2603 else
2604 return Is_Aliased_View (Obj)
2605 and then
2606 (Is_Constrained (Etype (Obj))
2607 or else
2608 (Nkind (Obj) = N_Explicit_Dereference
2609 and then
2610 not Object_Type_Has_Constrained_Partial_View
2611 (Typ => Base_Type (Etype (Obj)),
2612 Scop => Current_Scope)));
2613 end if;
2614 end Is_Constrained_Aliased_View;
2615
2616 -- Start of processing for Constrained
2617
2618 begin
2619 -- Reference to a parameter where the value is passed as an extra
2620 -- actual, corresponding to the extra formal referenced by the
2621 -- Extra_Constrained field of the corresponding formal. If this
2622 -- is an entry in-parameter, it is replaced by a constant renaming
2623 -- for which Extra_Constrained is never created.
2624
2625 if Present (Formal_Ent)
2626 and then Ekind (Formal_Ent) /= E_Constant
2627 and then Present (Extra_Constrained (Formal_Ent))
2628 then
2629 Rewrite (N,
2630 New_Occurrence_Of
2631 (Extra_Constrained (Formal_Ent), Sloc (N)));
2632
2633 -- For variables with a Extra_Constrained field, we use the
2634 -- corresponding entity.
2635
2636 elsif Nkind (Pref) = N_Identifier
2637 and then Ekind (Entity (Pref)) = E_Variable
2638 and then Present (Extra_Constrained (Entity (Pref)))
2639 then
2640 Rewrite (N,
2641 New_Occurrence_Of
2642 (Extra_Constrained (Entity (Pref)), Sloc (N)));
2643
2644 -- For all other entity names, we can tell at compile time
2645
2646 elsif Is_Entity_Name (Pref) then
2647 declare
2648 Ent : constant Entity_Id := Entity (Pref);
2649 Res : Boolean;
2650
2651 begin
2652 -- (RM J.4) obsolescent cases
2653
2654 if Is_Type (Ent) then
2655
2656 -- Private type
2657
2658 if Is_Private_Type (Ent) then
2659 Res := not Has_Discriminants (Ent)
2660 or else Is_Constrained (Ent);
2661
2662 -- It not a private type, must be a generic actual type
2663 -- that corresponded to a private type. We know that this
2664 -- correspondence holds, since otherwise the reference
2665 -- within the generic template would have been illegal.
2666
2667 else
2668 if Is_Composite_Type (Underlying_Type (Ent)) then
2669 Res := Is_Constrained (Ent);
2670 else
2671 Res := True;
2672 end if;
2673 end if;
2674
2675 -- If the prefix is not a variable or is aliased, then
2676 -- definitely true; if it's a formal parameter without an
2677 -- associated extra formal, then treat it as constrained.
2678
2679 -- Ada 2005 (AI-363): An aliased prefix must be known to be
2680 -- constrained in order to set the attribute to True.
2681
2682 elsif not Is_Variable (Pref)
2683 or else Present (Formal_Ent)
2684 or else (Ada_Version < Ada_2005
2685 and then Is_Aliased_View (Pref))
2686 or else (Ada_Version >= Ada_2005
2687 and then Is_Constrained_Aliased_View (Pref))
2688 then
2689 Res := True;
2690
2691 -- Variable case, look at type to see if it is constrained.
2692 -- Note that the one case where this is not accurate (the
2693 -- procedure formal case), has been handled above.
2694
2695 -- We use the Underlying_Type here (and below) in case the
2696 -- type is private without discriminants, but the full type
2697 -- has discriminants. This case is illegal, but we generate it
2698 -- internally for passing to the Extra_Constrained parameter.
2699
2700 else
2701 -- In Ada 2012, test for case of a limited tagged type, in
2702 -- which case the attribute is always required to return
2703 -- True. The underlying type is tested, to make sure we also
2704 -- return True for cases where there is an unconstrained
2705 -- object with an untagged limited partial view which has
2706 -- defaulted discriminants (such objects always produce a
2707 -- False in earlier versions of Ada). (Ada 2012: AI05-0214)
2708
2709 Res := Is_Constrained (Underlying_Type (Etype (Ent)))
2710 or else
2711 (Ada_Version >= Ada_2012
2712 and then Is_Tagged_Type (Underlying_Type (Ptyp))
2713 and then Is_Limited_Type (Ptyp));
2714 end if;
2715
2716 Rewrite (N, New_Occurrence_Of (Boolean_Literals (Res), Loc));
2717 end;
2718
2719 -- Prefix is not an entity name. These are also cases where we can
2720 -- always tell at compile time by looking at the form and type of the
2721 -- prefix. If an explicit dereference of an object with constrained
2722 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
2723 -- underlying type is a limited tagged type, then Constrained is
2724 -- required to always return True (Ada 2012: AI05-0214).
2725
2726 else
2727 Rewrite (N,
2728 New_Occurrence_Of (
2729 Boolean_Literals (
2730 not Is_Variable (Pref)
2731 or else
2732 (Nkind (Pref) = N_Explicit_Dereference
2733 and then
2734 not Object_Type_Has_Constrained_Partial_View
2735 (Typ => Base_Type (Ptyp),
2736 Scop => Current_Scope))
2737 or else Is_Constrained (Underlying_Type (Ptyp))
2738 or else (Ada_Version >= Ada_2012
2739 and then Is_Tagged_Type (Underlying_Type (Ptyp))
2740 and then Is_Limited_Type (Ptyp))),
2741 Loc));
2742 end if;
2743
2744 Analyze_And_Resolve (N, Standard_Boolean);
2745 end Constrained;
2746
2747 ---------------
2748 -- Copy_Sign --
2749 ---------------
2750
2751 -- Transforms 'Copy_Sign into a call to the floating-point attribute
2752 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
2753
2754 when Attribute_Copy_Sign =>
2755 Expand_Fpt_Attribute_RR (N);
2756
2757 -----------
2758 -- Count --
2759 -----------
2760
2761 -- Transforms 'Count attribute into a call to the Count function
2762
2763 when Attribute_Count => Count : declare
2764 Call : Node_Id;
2765 Conctyp : Entity_Id;
2766 Entnam : Node_Id;
2767 Entry_Id : Entity_Id;
2768 Index : Node_Id;
2769 Name : Node_Id;
2770
2771 begin
2772 -- If the prefix is a member of an entry family, retrieve both
2773 -- entry name and index. For a simple entry there is no index.
2774
2775 if Nkind (Pref) = N_Indexed_Component then
2776 Entnam := Prefix (Pref);
2777 Index := First (Expressions (Pref));
2778 else
2779 Entnam := Pref;
2780 Index := Empty;
2781 end if;
2782
2783 Entry_Id := Entity (Entnam);
2784
2785 -- Find the concurrent type in which this attribute is referenced
2786 -- (there had better be one).
2787
2788 Conctyp := Current_Scope;
2789 while not Is_Concurrent_Type (Conctyp) loop
2790 Conctyp := Scope (Conctyp);
2791 end loop;
2792
2793 -- Protected case
2794
2795 if Is_Protected_Type (Conctyp) then
2796 case Corresponding_Runtime_Package (Conctyp) is
2797 when System_Tasking_Protected_Objects_Entries =>
2798 Name := New_Occurrence_Of (RTE (RE_Protected_Count), Loc);
2799
2800 Call :=
2801 Make_Function_Call (Loc,
2802 Name => Name,
2803 Parameter_Associations => New_List (
2804 New_Occurrence_Of
2805 (Find_Protection_Object (Current_Scope), Loc),
2806 Entry_Index_Expression
2807 (Loc, Entry_Id, Index, Scope (Entry_Id))));
2808
2809 when System_Tasking_Protected_Objects_Single_Entry =>
2810 Name :=
2811 New_Occurrence_Of (RTE (RE_Protected_Count_Entry), Loc);
2812
2813 Call :=
2814 Make_Function_Call (Loc,
2815 Name => Name,
2816 Parameter_Associations => New_List (
2817 New_Occurrence_Of
2818 (Find_Protection_Object (Current_Scope), Loc)));
2819
2820 when others =>
2821 raise Program_Error;
2822 end case;
2823
2824 -- Task case
2825
2826 else
2827 Call :=
2828 Make_Function_Call (Loc,
2829 Name => New_Occurrence_Of (RTE (RE_Task_Count), Loc),
2830 Parameter_Associations => New_List (
2831 Entry_Index_Expression (Loc,
2832 Entry_Id, Index, Scope (Entry_Id))));
2833 end if;
2834
2835 -- The call returns type Natural but the context is universal integer
2836 -- so any integer type is allowed. The attribute was already resolved
2837 -- so its Etype is the required result type. If the base type of the
2838 -- context type is other than Standard.Integer we put in a conversion
2839 -- to the required type. This can be a normal typed conversion since
2840 -- both input and output types of the conversion are integer types
2841
2842 if Base_Type (Typ) /= Base_Type (Standard_Integer) then
2843 Rewrite (N, Convert_To (Typ, Call));
2844 else
2845 Rewrite (N, Call);
2846 end if;
2847
2848 Analyze_And_Resolve (N, Typ);
2849 end Count;
2850
2851 ---------------------
2852 -- Descriptor_Size --
2853 ---------------------
2854
2855 when Attribute_Descriptor_Size =>
2856
2857 -- Attribute Descriptor_Size is handled by the back end when applied
2858 -- to an unconstrained array type.
2859
2860 if Is_Array_Type (Ptyp)
2861 and then not Is_Constrained (Ptyp)
2862 then
2863 Apply_Universal_Integer_Attribute_Checks (N);
2864
2865 -- For any other type, the descriptor size is 0 because there is no
2866 -- actual descriptor, but the result is not formally static.
2867
2868 else
2869 Rewrite (N, Make_Integer_Literal (Loc, 0));
2870 Analyze (N);
2871 Set_Is_Static_Expression (N, False);
2872 end if;
2873
2874 ---------------
2875 -- Elab_Body --
2876 ---------------
2877
2878 -- This processing is shared by Elab_Spec
2879
2880 -- What we do is to insert the following declarations
2881
2882 -- procedure tnn;
2883 -- pragma Import (C, enn, "name___elabb/s");
2884
2885 -- and then the Elab_Body/Spec attribute is replaced by a reference
2886 -- to this defining identifier.
2887
2888 when Attribute_Elab_Body |
2889 Attribute_Elab_Spec =>
2890
2891 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
2892 -- back-end knows how to handle these attributes directly.
2893
2894 if CodePeer_Mode then
2895 return;
2896 end if;
2897
2898 Elab_Body : declare
2899 Ent : constant Entity_Id := Make_Temporary (Loc, 'E');
2900 Str : String_Id;
2901 Lang : Node_Id;
2902
2903 procedure Make_Elab_String (Nod : Node_Id);
2904 -- Given Nod, an identifier, or a selected component, put the
2905 -- image into the current string literal, with double underline
2906 -- between components.
2907
2908 ----------------------
2909 -- Make_Elab_String --
2910 ----------------------
2911
2912 procedure Make_Elab_String (Nod : Node_Id) is
2913 begin
2914 if Nkind (Nod) = N_Selected_Component then
2915 Make_Elab_String (Prefix (Nod));
2916 Store_String_Char ('_');
2917 Store_String_Char ('_');
2918 Get_Name_String (Chars (Selector_Name (Nod)));
2919
2920 else
2921 pragma Assert (Nkind (Nod) = N_Identifier);
2922 Get_Name_String (Chars (Nod));
2923 end if;
2924
2925 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2926 end Make_Elab_String;
2927
2928 -- Start of processing for Elab_Body/Elab_Spec
2929
2930 begin
2931 -- First we need to prepare the string literal for the name of
2932 -- the elaboration routine to be referenced.
2933
2934 Start_String;
2935 Make_Elab_String (Pref);
2936 Store_String_Chars ("___elab");
2937 Lang := Make_Identifier (Loc, Name_C);
2938
2939 if Id = Attribute_Elab_Body then
2940 Store_String_Char ('b');
2941 else
2942 Store_String_Char ('s');
2943 end if;
2944
2945 Str := End_String;
2946
2947 Insert_Actions (N, New_List (
2948 Make_Subprogram_Declaration (Loc,
2949 Specification =>
2950 Make_Procedure_Specification (Loc,
2951 Defining_Unit_Name => Ent)),
2952
2953 Make_Pragma (Loc,
2954 Chars => Name_Import,
2955 Pragma_Argument_Associations => New_List (
2956 Make_Pragma_Argument_Association (Loc, Expression => Lang),
2957
2958 Make_Pragma_Argument_Association (Loc,
2959 Expression => Make_Identifier (Loc, Chars (Ent))),
2960
2961 Make_Pragma_Argument_Association (Loc,
2962 Expression => Make_String_Literal (Loc, Str))))));
2963
2964 Set_Entity (N, Ent);
2965 Rewrite (N, New_Occurrence_Of (Ent, Loc));
2966 end Elab_Body;
2967
2968 --------------------
2969 -- Elab_Subp_Body --
2970 --------------------
2971
2972 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
2973 -- this attribute directly, and if we are not in CodePeer mode it is
2974 -- entirely ignored ???
2975
2976 when Attribute_Elab_Subp_Body =>
2977 return;
2978
2979 ----------------
2980 -- Elaborated --
2981 ----------------
2982
2983 -- Elaborated is always True for preelaborated units, predefined units,
2984 -- pure units and units which have Elaborate_Body pragmas. These units
2985 -- have no elaboration entity.
2986
2987 -- Note: The Elaborated attribute is never passed to the back end
2988
2989 when Attribute_Elaborated => Elaborated : declare
2990 Ent : constant Entity_Id := Entity (Pref);
2991
2992 begin
2993 if Present (Elaboration_Entity (Ent)) then
2994 Rewrite (N,
2995 Make_Op_Ne (Loc,
2996 Left_Opnd =>
2997 New_Occurrence_Of (Elaboration_Entity (Ent), Loc),
2998 Right_Opnd =>
2999 Make_Integer_Literal (Loc, Uint_0)));
3000 Analyze_And_Resolve (N, Typ);
3001 else
3002 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
3003 end if;
3004 end Elaborated;
3005
3006 --------------
3007 -- Enum_Rep --
3008 --------------
3009
3010 when Attribute_Enum_Rep => Enum_Rep :
3011 begin
3012 -- X'Enum_Rep (Y) expands to
3013
3014 -- target-type (Y)
3015
3016 -- This is simply a direct conversion from the enumeration type to
3017 -- the target integer type, which is treated by the back end as a
3018 -- normal integer conversion, treating the enumeration type as an
3019 -- integer, which is exactly what we want. We set Conversion_OK to
3020 -- make sure that the analyzer does not complain about what otherwise
3021 -- might be an illegal conversion.
3022
3023 if Is_Non_Empty_List (Exprs) then
3024 Rewrite (N,
3025 OK_Convert_To (Typ, Relocate_Node (First (Exprs))));
3026
3027 -- X'Enum_Rep where X is an enumeration literal is replaced by
3028 -- the literal value.
3029
3030 elsif Ekind (Entity (Pref)) = E_Enumeration_Literal then
3031 Rewrite (N,
3032 Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref))));
3033
3034 -- If this is a renaming of a literal, recover the representation
3035 -- of the original. If it renames an expression there is nothing
3036 -- to fold.
3037
3038 elsif Ekind (Entity (Pref)) = E_Constant
3039 and then Present (Renamed_Object (Entity (Pref)))
3040 and then Is_Entity_Name (Renamed_Object (Entity (Pref)))
3041 and then Ekind (Entity (Renamed_Object (Entity (Pref)))) =
3042 E_Enumeration_Literal
3043 then
3044 Rewrite (N,
3045 Make_Integer_Literal (Loc,
3046 Enumeration_Rep (Entity (Renamed_Object (Entity (Pref))))));
3047
3048 -- X'Enum_Rep where X is an object does a direct unchecked conversion
3049 -- of the object value, as described for the type case above.
3050
3051 else
3052 Rewrite (N,
3053 OK_Convert_To (Typ, Relocate_Node (Pref)));
3054 end if;
3055
3056 Set_Etype (N, Typ);
3057 Analyze_And_Resolve (N, Typ);
3058 end Enum_Rep;
3059
3060 --------------
3061 -- Enum_Val --
3062 --------------
3063
3064 when Attribute_Enum_Val => Enum_Val : declare
3065 Expr : Node_Id;
3066 Btyp : constant Entity_Id := Base_Type (Ptyp);
3067
3068 begin
3069 -- X'Enum_Val (Y) expands to
3070
3071 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
3072 -- X!(Y);
3073
3074 Expr := Unchecked_Convert_To (Ptyp, First (Exprs));
3075
3076 Insert_Action (N,
3077 Make_Raise_Constraint_Error (Loc,
3078 Condition =>
3079 Make_Op_Eq (Loc,
3080 Left_Opnd =>
3081 Make_Function_Call (Loc,
3082 Name =>
3083 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
3084 Parameter_Associations => New_List (
3085 Relocate_Node (Duplicate_Subexpr (Expr)),
3086 New_Occurrence_Of (Standard_False, Loc))),
3087
3088 Right_Opnd => Make_Integer_Literal (Loc, -1)),
3089 Reason => CE_Range_Check_Failed));
3090
3091 Rewrite (N, Expr);
3092 Analyze_And_Resolve (N, Ptyp);
3093 end Enum_Val;
3094
3095 --------------
3096 -- Exponent --
3097 --------------
3098
3099 -- Transforms 'Exponent into a call to the floating-point attribute
3100 -- function Exponent in Fat_xxx (where xxx is the root type)
3101
3102 when Attribute_Exponent =>
3103 Expand_Fpt_Attribute_R (N);
3104
3105 ------------------
3106 -- External_Tag --
3107 ------------------
3108
3109 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
3110
3111 when Attribute_External_Tag => External_Tag :
3112 begin
3113 Rewrite (N,
3114 Make_Function_Call (Loc,
3115 Name => New_Occurrence_Of (RTE (RE_External_Tag), Loc),
3116 Parameter_Associations => New_List (
3117 Make_Attribute_Reference (Loc,
3118 Attribute_Name => Name_Tag,
3119 Prefix => Prefix (N)))));
3120
3121 Analyze_And_Resolve (N, Standard_String);
3122 end External_Tag;
3123
3124 -----------
3125 -- First --
3126 -----------
3127
3128 when Attribute_First =>
3129
3130 -- If the prefix type is a constrained packed array type which
3131 -- already has a Packed_Array_Impl_Type representation defined, then
3132 -- replace this attribute with a direct reference to 'First of the
3133 -- appropriate index subtype (since otherwise the back end will try
3134 -- to give us the value of 'First for this implementation type).
3135
3136 if Is_Constrained_Packed_Array (Ptyp) then
3137 Rewrite (N,
3138 Make_Attribute_Reference (Loc,
3139 Attribute_Name => Name_First,
3140 Prefix =>
3141 New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
3142 Analyze_And_Resolve (N, Typ);
3143
3144 -- For access type, apply access check as needed
3145
3146 elsif Is_Access_Type (Ptyp) then
3147 Apply_Access_Check (N);
3148
3149 -- For scalar type, if low bound is a reference to an entity, just
3150 -- replace with a direct reference. Note that we can only have a
3151 -- reference to a constant entity at this stage, anything else would
3152 -- have already been rewritten.
3153
3154 elsif Is_Scalar_Type (Ptyp) then
3155 declare
3156 Lo : constant Node_Id := Type_Low_Bound (Ptyp);
3157 begin
3158 if Is_Entity_Name (Lo) then
3159 Rewrite (N, New_Occurrence_Of (Entity (Lo), Loc));
3160 end if;
3161 end;
3162 end if;
3163
3164 ---------------
3165 -- First_Bit --
3166 ---------------
3167
3168 -- Compute this if component clause was present, otherwise we leave the
3169 -- computation to be completed in the back-end, since we don't know what
3170 -- layout will be chosen.
3171
3172 when Attribute_First_Bit => First_Bit_Attr : declare
3173 CE : constant Entity_Id := Entity (Selector_Name (Pref));
3174
3175 begin
3176 -- In Ada 2005 (or later) if we have the non-default bit order, then
3177 -- we return the original value as given in the component clause
3178 -- (RM 2005 13.5.2(3/2)).
3179
3180 if Present (Component_Clause (CE))
3181 and then Ada_Version >= Ada_2005
3182 and then Reverse_Bit_Order (Scope (CE))
3183 then
3184 Rewrite (N,
3185 Make_Integer_Literal (Loc,
3186 Intval => Expr_Value (First_Bit (Component_Clause (CE)))));
3187 Analyze_And_Resolve (N, Typ);
3188
3189 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3190 -- rewrite with normalized value if we know it statically.
3191
3192 elsif Known_Static_Component_Bit_Offset (CE) then
3193 Rewrite (N,
3194 Make_Integer_Literal (Loc,
3195 Component_Bit_Offset (CE) mod System_Storage_Unit));
3196 Analyze_And_Resolve (N, Typ);
3197
3198 -- Otherwise left to back end, just do universal integer checks
3199
3200 else
3201 Apply_Universal_Integer_Attribute_Checks (N);
3202 end if;
3203 end First_Bit_Attr;
3204
3205 -----------------
3206 -- Fixed_Value --
3207 -----------------
3208
3209 -- We transform:
3210
3211 -- fixtype'Fixed_Value (integer-value)
3212
3213 -- into
3214
3215 -- fixtype(integer-value)
3216
3217 -- We do all the required analysis of the conversion here, because we do
3218 -- not want this to go through the fixed-point conversion circuits. Note
3219 -- that the back end always treats fixed-point as equivalent to the
3220 -- corresponding integer type anyway.
3221
3222 when Attribute_Fixed_Value => Fixed_Value :
3223 begin
3224 Rewrite (N,
3225 Make_Type_Conversion (Loc,
3226 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
3227 Expression => Relocate_Node (First (Exprs))));
3228 Set_Etype (N, Entity (Pref));
3229 Set_Analyzed (N);
3230
3231 -- Note: it might appear that a properly analyzed unchecked conversion
3232 -- would be just fine here, but that's not the case, since the full
3233 -- range checks performed by the following call are critical.
3234
3235 Apply_Type_Conversion_Checks (N);
3236 end Fixed_Value;
3237
3238 -----------
3239 -- Floor --
3240 -----------
3241
3242 -- Transforms 'Floor into a call to the floating-point attribute
3243 -- function Floor in Fat_xxx (where xxx is the root type)
3244
3245 when Attribute_Floor =>
3246 Expand_Fpt_Attribute_R (N);
3247
3248 ----------
3249 -- Fore --
3250 ----------
3251
3252 -- For the fixed-point type Typ:
3253
3254 -- Typ'Fore
3255
3256 -- expands into
3257
3258 -- Result_Type (System.Fore (Universal_Real (Type'First)),
3259 -- Universal_Real (Type'Last))
3260
3261 -- Note that we know that the type is a non-static subtype, or Fore
3262 -- would have itself been computed dynamically in Eval_Attribute.
3263
3264 when Attribute_Fore => Fore : begin
3265 Rewrite (N,
3266 Convert_To (Typ,
3267 Make_Function_Call (Loc,
3268 Name => New_Occurrence_Of (RTE (RE_Fore), Loc),
3269
3270 Parameter_Associations => New_List (
3271 Convert_To (Universal_Real,
3272 Make_Attribute_Reference (Loc,
3273 Prefix => New_Occurrence_Of (Ptyp, Loc),
3274 Attribute_Name => Name_First)),
3275
3276 Convert_To (Universal_Real,
3277 Make_Attribute_Reference (Loc,
3278 Prefix => New_Occurrence_Of (Ptyp, Loc),
3279 Attribute_Name => Name_Last))))));
3280
3281 Analyze_And_Resolve (N, Typ);
3282 end Fore;
3283
3284 --------------
3285 -- Fraction --
3286 --------------
3287
3288 -- Transforms 'Fraction into a call to the floating-point attribute
3289 -- function Fraction in Fat_xxx (where xxx is the root type)
3290
3291 when Attribute_Fraction =>
3292 Expand_Fpt_Attribute_R (N);
3293
3294 --------------
3295 -- From_Any --
3296 --------------
3297
3298 when Attribute_From_Any => From_Any : declare
3299 P_Type : constant Entity_Id := Etype (Pref);
3300 Decls : constant List_Id := New_List;
3301 begin
3302 Rewrite (N,
3303 Build_From_Any_Call (P_Type,
3304 Relocate_Node (First (Exprs)),
3305 Decls));
3306 Insert_Actions (N, Decls);
3307 Analyze_And_Resolve (N, P_Type);
3308 end From_Any;
3309
3310 ----------------------
3311 -- Has_Same_Storage --
3312 ----------------------
3313
3314 when Attribute_Has_Same_Storage => Has_Same_Storage : declare
3315 Loc : constant Source_Ptr := Sloc (N);
3316
3317 X : constant Node_Id := Prefix (N);
3318 Y : constant Node_Id := First (Expressions (N));
3319 -- The arguments
3320
3321 X_Addr, Y_Addr : Node_Id;
3322 -- Rhe expressions for their addresses
3323
3324 X_Size, Y_Size : Node_Id;
3325 -- Rhe expressions for their sizes
3326
3327 begin
3328 -- The attribute is expanded as:
3329
3330 -- (X'address = Y'address)
3331 -- and then (X'Size = Y'Size)
3332
3333 -- If both arguments have the same Etype the second conjunct can be
3334 -- omitted.
3335
3336 X_Addr :=
3337 Make_Attribute_Reference (Loc,
3338 Attribute_Name => Name_Address,
3339 Prefix => New_Copy_Tree (X));
3340
3341 Y_Addr :=
3342 Make_Attribute_Reference (Loc,
3343 Attribute_Name => Name_Address,
3344 Prefix => New_Copy_Tree (Y));
3345
3346 X_Size :=
3347 Make_Attribute_Reference (Loc,
3348 Attribute_Name => Name_Size,
3349 Prefix => New_Copy_Tree (X));
3350
3351 Y_Size :=
3352 Make_Attribute_Reference (Loc,
3353 Attribute_Name => Name_Size,
3354 Prefix => New_Copy_Tree (Y));
3355
3356 if Etype (X) = Etype (Y) then
3357 Rewrite (N,
3358 (Make_Op_Eq (Loc,
3359 Left_Opnd => X_Addr,
3360 Right_Opnd => Y_Addr)));
3361 else
3362 Rewrite (N,
3363 Make_Op_And (Loc,
3364 Left_Opnd =>
3365 Make_Op_Eq (Loc,
3366 Left_Opnd => X_Addr,
3367 Right_Opnd => Y_Addr),
3368 Right_Opnd =>
3369 Make_Op_Eq (Loc,
3370 Left_Opnd => X_Size,
3371 Right_Opnd => Y_Size)));
3372 end if;
3373
3374 Analyze_And_Resolve (N, Standard_Boolean);
3375 end Has_Same_Storage;
3376
3377 --------------
3378 -- Identity --
3379 --------------
3380
3381 -- For an exception returns a reference to the exception data:
3382 -- Exception_Id!(Prefix'Reference)
3383
3384 -- For a task it returns a reference to the _task_id component of
3385 -- corresponding record:
3386
3387 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
3388
3389 -- in Ada.Task_Identification
3390
3391 when Attribute_Identity => Identity : declare
3392 Id_Kind : Entity_Id;
3393
3394 begin
3395 if Ptyp = Standard_Exception_Type then
3396 Id_Kind := RTE (RE_Exception_Id);
3397
3398 if Present (Renamed_Object (Entity (Pref))) then
3399 Set_Entity (Pref, Renamed_Object (Entity (Pref)));
3400 end if;
3401
3402 Rewrite (N,
3403 Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref)));
3404 else
3405 Id_Kind := RTE (RO_AT_Task_Id);
3406
3407 -- If the prefix is a task interface, the Task_Id is obtained
3408 -- dynamically through a dispatching call, as for other task
3409 -- attributes applied to interfaces.
3410
3411 if Ada_Version >= Ada_2005
3412 and then Ekind (Ptyp) = E_Class_Wide_Type
3413 and then Is_Interface (Ptyp)
3414 and then Is_Task_Interface (Ptyp)
3415 then
3416 Rewrite (N,
3417 Unchecked_Convert_To (Id_Kind,
3418 Make_Selected_Component (Loc,
3419 Prefix =>
3420 New_Copy_Tree (Pref),
3421 Selector_Name =>
3422 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))));
3423
3424 else
3425 Rewrite (N,
3426 Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
3427 end if;
3428 end if;
3429
3430 Analyze_And_Resolve (N, Id_Kind);
3431 end Identity;
3432
3433 -----------
3434 -- Image --
3435 -----------
3436
3437 -- Image attribute is handled in separate unit Exp_Imgv
3438
3439 when Attribute_Image =>
3440 Exp_Imgv.Expand_Image_Attribute (N);
3441
3442 ---------
3443 -- Img --
3444 ---------
3445
3446 -- X'Img is expanded to typ'Image (X), where typ is the type of X
3447
3448 when Attribute_Img => Img :
3449 begin
3450 Rewrite (N,
3451 Make_Attribute_Reference (Loc,
3452 Prefix => New_Occurrence_Of (Ptyp, Loc),
3453 Attribute_Name => Name_Image,
3454 Expressions => New_List (Relocate_Node (Pref))));
3455
3456 Analyze_And_Resolve (N, Standard_String);
3457 end Img;
3458
3459 -----------
3460 -- Input --
3461 -----------
3462
3463 when Attribute_Input => Input : declare
3464 P_Type : constant Entity_Id := Entity (Pref);
3465 B_Type : constant Entity_Id := Base_Type (P_Type);
3466 U_Type : constant Entity_Id := Underlying_Type (P_Type);
3467 Strm : constant Node_Id := First (Exprs);
3468 Fname : Entity_Id;
3469 Decl : Node_Id;
3470 Call : Node_Id;
3471 Prag : Node_Id;
3472 Arg2 : Node_Id;
3473 Rfunc : Node_Id;
3474
3475 Cntrl : Node_Id := Empty;
3476 -- Value for controlling argument in call. Always Empty except in
3477 -- the dispatching (class-wide type) case, where it is a reference
3478 -- to the dummy object initialized to the right internal tag.
3479
3480 procedure Freeze_Stream_Subprogram (F : Entity_Id);
3481 -- The expansion of the attribute reference may generate a call to
3482 -- a user-defined stream subprogram that is frozen by the call. This
3483 -- can lead to access-before-elaboration problem if the reference
3484 -- appears in an object declaration and the subprogram body has not
3485 -- been seen. The freezing of the subprogram requires special code
3486 -- because it appears in an expanded context where expressions do
3487 -- not freeze their constituents.
3488
3489 ------------------------------
3490 -- Freeze_Stream_Subprogram --
3491 ------------------------------
3492
3493 procedure Freeze_Stream_Subprogram (F : Entity_Id) is
3494 Decl : constant Node_Id := Unit_Declaration_Node (F);
3495 Bod : Node_Id;
3496
3497 begin
3498 -- If this is user-defined subprogram, the corresponding
3499 -- stream function appears as a renaming-as-body, and the
3500 -- user subprogram must be retrieved by tree traversal.
3501
3502 if Present (Decl)
3503 and then Nkind (Decl) = N_Subprogram_Declaration
3504 and then Present (Corresponding_Body (Decl))
3505 then
3506 Bod := Corresponding_Body (Decl);
3507
3508 if Nkind (Unit_Declaration_Node (Bod)) =
3509 N_Subprogram_Renaming_Declaration
3510 then
3511 Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod))));
3512 end if;
3513 end if;
3514 end Freeze_Stream_Subprogram;
3515
3516 -- Start of processing for Input
3517
3518 begin
3519 -- If no underlying type, we have an error that will be diagnosed
3520 -- elsewhere, so here we just completely ignore the expansion.
3521
3522 if No (U_Type) then
3523 return;
3524 end if;
3525
3526 -- Stream operations can appear in user code even if the restriction
3527 -- No_Streams is active (for example, when instantiating a predefined
3528 -- container). In that case rewrite the attribute as a Raise to
3529 -- prevent any run-time use.
3530
3531 if Restriction_Active (No_Streams) then
3532 Rewrite (N,
3533 Make_Raise_Program_Error (Sloc (N),
3534 Reason => PE_Stream_Operation_Not_Allowed));
3535 Set_Etype (N, B_Type);
3536 return;
3537 end if;
3538
3539 -- If there is a TSS for Input, just call it
3540
3541 Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
3542
3543 if Present (Fname) then
3544 null;
3545
3546 else
3547 -- If there is a Stream_Convert pragma, use it, we rewrite
3548
3549 -- sourcetyp'Input (stream)
3550
3551 -- as
3552
3553 -- sourcetyp (streamread (strmtyp'Input (stream)));
3554
3555 -- where streamread is the given Read function that converts an
3556 -- argument of type strmtyp to type sourcetyp or a type from which
3557 -- it is derived (extra conversion required for the derived case).
3558
3559 Prag := Get_Stream_Convert_Pragma (P_Type);
3560
3561 if Present (Prag) then
3562 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
3563 Rfunc := Entity (Expression (Arg2));
3564
3565 Rewrite (N,
3566 Convert_To (B_Type,
3567 Make_Function_Call (Loc,
3568 Name => New_Occurrence_Of (Rfunc, Loc),
3569 Parameter_Associations => New_List (
3570 Make_Attribute_Reference (Loc,
3571 Prefix =>
3572 New_Occurrence_Of
3573 (Etype (First_Formal (Rfunc)), Loc),
3574 Attribute_Name => Name_Input,
3575 Expressions => Exprs)))));
3576
3577 Analyze_And_Resolve (N, B_Type);
3578 return;
3579
3580 -- Elementary types
3581
3582 elsif Is_Elementary_Type (U_Type) then
3583
3584 -- A special case arises if we have a defined _Read routine,
3585 -- since in this case we are required to call this routine.
3586
3587 if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then
3588 Build_Record_Or_Elementary_Input_Function
3589 (Loc, U_Type, Decl, Fname);
3590 Insert_Action (N, Decl);
3591
3592 -- For normal cases, we call the I_xxx routine directly
3593
3594 else
3595 Rewrite (N, Build_Elementary_Input_Call (N));
3596 Analyze_And_Resolve (N, P_Type);
3597 return;
3598 end if;
3599
3600 -- Array type case
3601
3602 elsif Is_Array_Type (U_Type) then
3603 Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
3604 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3605
3606 -- Dispatching case with class-wide type
3607
3608 elsif Is_Class_Wide_Type (P_Type) then
3609
3610 -- No need to do anything else compiling under restriction
3611 -- No_Dispatching_Calls. During the semantic analysis we
3612 -- already notified such violation.
3613
3614 if Restriction_Active (No_Dispatching_Calls) then
3615 return;
3616 end if;
3617
3618 declare
3619 Rtyp : constant Entity_Id := Root_Type (P_Type);
3620 Expr : Node_Id;
3621
3622 begin
3623 -- Read the internal tag (RM 13.13.2(34)) and use it to
3624 -- initialize a dummy tag value:
3625
3626 -- Descendant_Tag (String'Input (Strm), P_Type);
3627
3628 -- This value is used only to provide a controlling
3629 -- argument for the eventual _Input call. Descendant_Tag is
3630 -- called rather than Internal_Tag to ensure that we have a
3631 -- tag for a type that is descended from the prefix type and
3632 -- declared at the same accessibility level (the exception
3633 -- Tag_Error will be raised otherwise). The level check is
3634 -- required for Ada 2005 because tagged types can be
3635 -- extended in nested scopes (AI-344).
3636
3637 -- Note: we used to generate an explicit declaration of a
3638 -- constant Ada.Tags.Tag object, and use an occurrence of
3639 -- this constant in Cntrl, but this caused a secondary stack
3640 -- leak.
3641
3642 Expr :=
3643 Make_Function_Call (Loc,
3644 Name =>
3645 New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
3646 Parameter_Associations => New_List (
3647 Make_Attribute_Reference (Loc,
3648 Prefix =>
3649 New_Occurrence_Of (Standard_String, Loc),
3650 Attribute_Name => Name_Input,
3651 Expressions => New_List (
3652 Relocate_Node (Duplicate_Subexpr (Strm)))),
3653 Make_Attribute_Reference (Loc,
3654 Prefix => New_Occurrence_Of (P_Type, Loc),
3655 Attribute_Name => Name_Tag)));
3656 Set_Etype (Expr, RTE (RE_Tag));
3657
3658 -- Now we need to get the entity for the call, and construct
3659 -- a function call node, where we preset a reference to Dnn
3660 -- as the controlling argument (doing an unchecked convert
3661 -- to the class-wide tagged type to make it look like a real
3662 -- tagged object).
3663
3664 Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
3665 Cntrl := Unchecked_Convert_To (P_Type, Expr);
3666 Set_Etype (Cntrl, P_Type);
3667 Set_Parent (Cntrl, N);
3668 end;
3669
3670 -- For tagged types, use the primitive Input function
3671
3672 elsif Is_Tagged_Type (U_Type) then
3673 Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
3674
3675 -- All other record type cases, including protected records. The
3676 -- latter only arise for expander generated code for handling
3677 -- shared passive partition access.
3678
3679 else
3680 pragma Assert
3681 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
3682
3683 -- Ada 2005 (AI-216): Program_Error is raised executing default
3684 -- implementation of the Input attribute of an unchecked union
3685 -- type if the type lacks default discriminant values.
3686
3687 if Is_Unchecked_Union (Base_Type (U_Type))
3688 and then No (Discriminant_Constraint (U_Type))
3689 then
3690 Insert_Action (N,
3691 Make_Raise_Program_Error (Loc,
3692 Reason => PE_Unchecked_Union_Restriction));
3693
3694 return;
3695 end if;
3696
3697 -- Build the type's Input function, passing the subtype rather
3698 -- than its base type, because checks are needed in the case of
3699 -- constrained discriminants (see Ada 2012 AI05-0192).
3700
3701 Build_Record_Or_Elementary_Input_Function
3702 (Loc, U_Type, Decl, Fname);
3703 Insert_Action (N, Decl);
3704
3705 if Nkind (Parent (N)) = N_Object_Declaration
3706 and then Is_Record_Type (U_Type)
3707 then
3708 -- The stream function may contain calls to user-defined
3709 -- Read procedures for individual components.
3710
3711 declare
3712 Comp : Entity_Id;
3713 Func : Entity_Id;
3714
3715 begin
3716 Comp := First_Component (U_Type);
3717 while Present (Comp) loop
3718 Func :=
3719 Find_Stream_Subprogram
3720 (Etype (Comp), TSS_Stream_Read);
3721
3722 if Present (Func) then
3723 Freeze_Stream_Subprogram (Func);
3724 end if;
3725
3726 Next_Component (Comp);
3727 end loop;
3728 end;
3729 end if;
3730 end if;
3731 end if;
3732
3733 -- If we fall through, Fname is the function to be called. The result
3734 -- is obtained by calling the appropriate function, then converting
3735 -- the result. The conversion does a subtype check.
3736
3737 Call :=
3738 Make_Function_Call (Loc,
3739 Name => New_Occurrence_Of (Fname, Loc),
3740 Parameter_Associations => New_List (
3741 Relocate_Node (Strm)));
3742
3743 Set_Controlling_Argument (Call, Cntrl);
3744 Rewrite (N, Unchecked_Convert_To (P_Type, Call));
3745 Analyze_And_Resolve (N, P_Type);
3746
3747 if Nkind (Parent (N)) = N_Object_Declaration then
3748 Freeze_Stream_Subprogram (Fname);
3749 end if;
3750 end Input;
3751
3752 -------------------
3753 -- Integer_Value --
3754 -------------------
3755
3756 -- We transform
3757
3758 -- inttype'Fixed_Value (fixed-value)
3759
3760 -- into
3761
3762 -- inttype(integer-value))
3763
3764 -- we do all the required analysis of the conversion here, because we do
3765 -- not want this to go through the fixed-point conversion circuits. Note
3766 -- that the back end always treats fixed-point as equivalent to the
3767 -- corresponding integer type anyway.
3768
3769 when Attribute_Integer_Value => Integer_Value :
3770 begin
3771 Rewrite (N,
3772 Make_Type_Conversion (Loc,
3773 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
3774 Expression => Relocate_Node (First (Exprs))));
3775 Set_Etype (N, Entity (Pref));
3776 Set_Analyzed (N);
3777
3778 -- Note: it might appear that a properly analyzed unchecked conversion
3779 -- would be just fine here, but that's not the case, since the full
3780 -- range checks performed by the following call are critical.
3781
3782 Apply_Type_Conversion_Checks (N);
3783 end Integer_Value;
3784
3785 -------------------
3786 -- Invalid_Value --
3787 -------------------
3788
3789 when Attribute_Invalid_Value =>
3790 Rewrite (N, Get_Simple_Init_Val (Ptyp, N));
3791
3792 ----------
3793 -- Last --
3794 ----------
3795
3796 when Attribute_Last =>
3797
3798 -- If the prefix type is a constrained packed array type which
3799 -- already has a Packed_Array_Impl_Type representation defined, then
3800 -- replace this attribute with a direct reference to 'Last of the
3801 -- appropriate index subtype (since otherwise the back end will try
3802 -- to give us the value of 'Last for this implementation type).
3803
3804 if Is_Constrained_Packed_Array (Ptyp) then
3805 Rewrite (N,
3806 Make_Attribute_Reference (Loc,
3807 Attribute_Name => Name_Last,
3808 Prefix => New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
3809 Analyze_And_Resolve (N, Typ);
3810
3811 -- For access type, apply access check as needed
3812
3813 elsif Is_Access_Type (Ptyp) then
3814 Apply_Access_Check (N);
3815
3816 -- For scalar type, if low bound is a reference to an entity, just
3817 -- replace with a direct reference. Note that we can only have a
3818 -- reference to a constant entity at this stage, anything else would
3819 -- have already been rewritten.
3820
3821 elsif Is_Scalar_Type (Ptyp) then
3822 declare
3823 Hi : constant Node_Id := Type_High_Bound (Ptyp);
3824 begin
3825 if Is_Entity_Name (Hi) then
3826 Rewrite (N, New_Occurrence_Of (Entity (Hi), Loc));
3827 end if;
3828 end;
3829 end if;
3830
3831 --------------
3832 -- Last_Bit --
3833 --------------
3834
3835 -- We compute this if a component clause was present, otherwise we leave
3836 -- the computation up to the back end, since we don't know what layout
3837 -- will be chosen.
3838
3839 when Attribute_Last_Bit => Last_Bit_Attr : declare
3840 CE : constant Entity_Id := Entity (Selector_Name (Pref));
3841
3842 begin
3843 -- In Ada 2005 (or later) if we have the non-default bit order, then
3844 -- we return the original value as given in the component clause
3845 -- (RM 2005 13.5.2(3/2)).
3846
3847 if Present (Component_Clause (CE))
3848 and then Ada_Version >= Ada_2005
3849 and then Reverse_Bit_Order (Scope (CE))
3850 then
3851 Rewrite (N,
3852 Make_Integer_Literal (Loc,
3853 Intval => Expr_Value (Last_Bit (Component_Clause (CE)))));
3854 Analyze_And_Resolve (N, Typ);
3855
3856 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3857 -- rewrite with normalized value if we know it statically.
3858
3859 elsif Known_Static_Component_Bit_Offset (CE)
3860 and then Known_Static_Esize (CE)
3861 then
3862 Rewrite (N,
3863 Make_Integer_Literal (Loc,
3864 Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
3865 + Esize (CE) - 1));
3866 Analyze_And_Resolve (N, Typ);
3867
3868 -- Otherwise leave to back end, just apply universal integer checks
3869
3870 else
3871 Apply_Universal_Integer_Attribute_Checks (N);
3872 end if;
3873 end Last_Bit_Attr;
3874
3875 ------------------
3876 -- Leading_Part --
3877 ------------------
3878
3879 -- Transforms 'Leading_Part into a call to the floating-point attribute
3880 -- function Leading_Part in Fat_xxx (where xxx is the root type)
3881
3882 -- Note: strictly, we should generate special case code to deal with
3883 -- absurdly large positive arguments (greater than Integer'Last), which
3884 -- result in returning the first argument unchanged, but it hardly seems
3885 -- worth the effort. We raise constraint error for absurdly negative
3886 -- arguments which is fine.
3887
3888 when Attribute_Leading_Part =>
3889 Expand_Fpt_Attribute_RI (N);
3890
3891 ------------
3892 -- Length --
3893 ------------
3894
3895 when Attribute_Length => Length : declare
3896 Ityp : Entity_Id;
3897 Xnum : Uint;
3898
3899 begin
3900 -- Processing for packed array types
3901
3902 if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
3903 Ityp := Get_Index_Subtype (N);
3904
3905 -- If the index type, Ityp, is an enumeration type with holes,
3906 -- then we calculate X'Length explicitly using
3907
3908 -- Typ'Max
3909 -- (0, Ityp'Pos (X'Last (N)) -
3910 -- Ityp'Pos (X'First (N)) + 1);
3911
3912 -- Since the bounds in the template are the representation values
3913 -- and the back end would get the wrong value.
3914
3915 if Is_Enumeration_Type (Ityp)
3916 and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
3917 then
3918 if No (Exprs) then
3919 Xnum := Uint_1;
3920 else
3921 Xnum := Expr_Value (First (Expressions (N)));
3922 end if;
3923
3924 Rewrite (N,
3925 Make_Attribute_Reference (Loc,
3926 Prefix => New_Occurrence_Of (Typ, Loc),
3927 Attribute_Name => Name_Max,
3928 Expressions => New_List
3929 (Make_Integer_Literal (Loc, 0),
3930
3931 Make_Op_Add (Loc,
3932 Left_Opnd =>
3933 Make_Op_Subtract (Loc,
3934 Left_Opnd =>
3935 Make_Attribute_Reference (Loc,
3936 Prefix => New_Occurrence_Of (Ityp, Loc),
3937 Attribute_Name => Name_Pos,
3938
3939 Expressions => New_List (
3940 Make_Attribute_Reference (Loc,
3941 Prefix => Duplicate_Subexpr (Pref),
3942 Attribute_Name => Name_Last,
3943 Expressions => New_List (
3944 Make_Integer_Literal (Loc, Xnum))))),
3945
3946 Right_Opnd =>
3947 Make_Attribute_Reference (Loc,
3948 Prefix => New_Occurrence_Of (Ityp, Loc),
3949 Attribute_Name => Name_Pos,
3950
3951 Expressions => New_List (
3952 Make_Attribute_Reference (Loc,
3953 Prefix =>
3954 Duplicate_Subexpr_No_Checks (Pref),
3955 Attribute_Name => Name_First,
3956 Expressions => New_List (
3957 Make_Integer_Literal (Loc, Xnum)))))),
3958
3959 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
3960
3961 Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
3962 return;
3963
3964 -- If the prefix type is a constrained packed array type which
3965 -- already has a Packed_Array_Impl_Type representation defined,
3966 -- then replace this attribute with a reference to 'Range_Length
3967 -- of the appropriate index subtype (since otherwise the
3968 -- back end will try to give us the value of 'Length for
3969 -- this implementation type).s
3970
3971 elsif Is_Constrained (Ptyp) then
3972 Rewrite (N,
3973 Make_Attribute_Reference (Loc,
3974 Attribute_Name => Name_Range_Length,
3975 Prefix => New_Occurrence_Of (Ityp, Loc)));
3976 Analyze_And_Resolve (N, Typ);
3977 end if;
3978
3979 -- Access type case
3980
3981 elsif Is_Access_Type (Ptyp) then
3982 Apply_Access_Check (N);
3983
3984 -- If the designated type is a packed array type, then we convert
3985 -- the reference to:
3986
3987 -- typ'Max (0, 1 +
3988 -- xtyp'Pos (Pref'Last (Expr)) -
3989 -- xtyp'Pos (Pref'First (Expr)));
3990
3991 -- This is a bit complex, but it is the easiest thing to do that
3992 -- works in all cases including enum types with holes xtyp here
3993 -- is the appropriate index type.
3994
3995 declare
3996 Dtyp : constant Entity_Id := Designated_Type (Ptyp);
3997 Xtyp : Entity_Id;
3998
3999 begin
4000 if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
4001 Xtyp := Get_Index_Subtype (N);
4002
4003 Rewrite (N,
4004 Make_Attribute_Reference (Loc,
4005 Prefix => New_Occurrence_Of (Typ, Loc),
4006 Attribute_Name => Name_Max,
4007 Expressions => New_List (
4008 Make_Integer_Literal (Loc, 0),
4009
4010 Make_Op_Add (Loc,
4011 Make_Integer_Literal (Loc, 1),
4012 Make_Op_Subtract (Loc,
4013 Left_Opnd =>
4014 Make_Attribute_Reference (Loc,
4015 Prefix => New_Occurrence_Of (Xtyp, Loc),
4016 Attribute_Name => Name_Pos,
4017 Expressions => New_List (
4018 Make_Attribute_Reference (Loc,
4019 Prefix => Duplicate_Subexpr (Pref),
4020 Attribute_Name => Name_Last,
4021 Expressions =>
4022 New_Copy_List (Exprs)))),
4023
4024 Right_Opnd =>
4025 Make_Attribute_Reference (Loc,
4026 Prefix => New_Occurrence_Of (Xtyp, Loc),
4027 Attribute_Name => Name_Pos,
4028 Expressions => New_List (
4029 Make_Attribute_Reference (Loc,
4030 Prefix =>
4031 Duplicate_Subexpr_No_Checks (Pref),
4032 Attribute_Name => Name_First,
4033 Expressions =>
4034 New_Copy_List (Exprs)))))))));
4035
4036 Analyze_And_Resolve (N, Typ);
4037 end if;
4038 end;
4039
4040 -- Otherwise leave it to the back end
4041
4042 else
4043 Apply_Universal_Integer_Attribute_Checks (N);
4044 end if;
4045 end Length;
4046
4047 -- Attribute Loop_Entry is replaced with a reference to a constant value
4048 -- which captures the prefix at the entry point of the related loop. The
4049 -- loop itself may be transformed into a conditional block.
4050
4051 when Attribute_Loop_Entry =>
4052 Expand_Loop_Entry_Attribute (N);
4053
4054 -------------
4055 -- Machine --
4056 -------------
4057
4058 -- Transforms 'Machine into a call to the floating-point attribute
4059 -- function Machine in Fat_xxx (where xxx is the root type).
4060 -- Expansion is avoided for cases the back end can handle directly.
4061
4062 when Attribute_Machine =>
4063 if not Is_Inline_Floating_Point_Attribute (N) then
4064 Expand_Fpt_Attribute_R (N);
4065 end if;
4066
4067 ----------------------
4068 -- Machine_Rounding --
4069 ----------------------
4070
4071 -- Transforms 'Machine_Rounding into a call to the floating-point
4072 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
4073 -- type). Expansion is avoided for cases the back end can handle
4074 -- directly.
4075
4076 when Attribute_Machine_Rounding =>
4077 if not Is_Inline_Floating_Point_Attribute (N) then
4078 Expand_Fpt_Attribute_R (N);
4079 end if;
4080
4081 ------------------
4082 -- Machine_Size --
4083 ------------------
4084
4085 -- Machine_Size is equivalent to Object_Size, so transform it into
4086 -- Object_Size and that way the back end never sees Machine_Size.
4087
4088 when Attribute_Machine_Size =>
4089 Rewrite (N,
4090 Make_Attribute_Reference (Loc,
4091 Prefix => Prefix (N),
4092 Attribute_Name => Name_Object_Size));
4093
4094 Analyze_And_Resolve (N, Typ);
4095
4096 --------------
4097 -- Mantissa --
4098 --------------
4099
4100 -- The only case that can get this far is the dynamic case of the old
4101 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
4102 -- we expand:
4103
4104 -- typ'Mantissa
4105
4106 -- into
4107
4108 -- ityp (System.Mantissa.Mantissa_Value
4109 -- (Integer'Integer_Value (typ'First),
4110 -- Integer'Integer_Value (typ'Last)));
4111
4112 when Attribute_Mantissa => Mantissa : begin
4113 Rewrite (N,
4114 Convert_To (Typ,
4115 Make_Function_Call (Loc,
4116 Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
4117
4118 Parameter_Associations => New_List (
4119
4120 Make_Attribute_Reference (Loc,
4121 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
4122 Attribute_Name => Name_Integer_Value,
4123 Expressions => New_List (
4124
4125 Make_Attribute_Reference (Loc,
4126 Prefix => New_Occurrence_Of (Ptyp, Loc),
4127 Attribute_Name => Name_First))),
4128
4129 Make_Attribute_Reference (Loc,
4130 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
4131 Attribute_Name => Name_Integer_Value,
4132 Expressions => New_List (
4133
4134 Make_Attribute_Reference (Loc,
4135 Prefix => New_Occurrence_Of (Ptyp, Loc),
4136 Attribute_Name => Name_Last)))))));
4137
4138 Analyze_And_Resolve (N, Typ);
4139 end Mantissa;
4140
4141 ---------
4142 -- Max --
4143 ---------
4144
4145 when Attribute_Max =>
4146 Expand_Min_Max_Attribute (N);
4147
4148 ----------------------------------
4149 -- Max_Size_In_Storage_Elements --
4150 ----------------------------------
4151
4152 when Attribute_Max_Size_In_Storage_Elements => declare
4153 Typ : constant Entity_Id := Etype (N);
4154 Attr : Node_Id;
4155
4156 Conversion_Added : Boolean := False;
4157 -- A flag which tracks whether the original attribute has been
4158 -- wrapped inside a type conversion.
4159
4160 begin
4161 -- If the prefix is X'Class, we transform it into a direct reference
4162 -- to the class-wide type, because the back end must not see a 'Class
4163 -- reference. See also 'Size.
4164
4165 if Is_Entity_Name (Pref)
4166 and then Is_Class_Wide_Type (Entity (Pref))
4167 then
4168 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
4169 return;
4170 end if;
4171
4172 Apply_Universal_Integer_Attribute_Checks (N);
4173
4174 -- The universal integer check may sometimes add a type conversion,
4175 -- retrieve the original attribute reference from the expression.
4176
4177 Attr := N;
4178
4179 if Nkind (Attr) = N_Type_Conversion then
4180 Attr := Expression (Attr);
4181 Conversion_Added := True;
4182 end if;
4183
4184 pragma Assert (Nkind (Attr) = N_Attribute_Reference);
4185
4186 -- Heap-allocated controlled objects contain two extra pointers which
4187 -- are not part of the actual type. Transform the attribute reference
4188 -- into a runtime expression to add the size of the hidden header.
4189
4190 if Needs_Finalization (Ptyp)
4191 and then not Header_Size_Added (Attr)
4192 then
4193 Set_Header_Size_Added (Attr);
4194
4195 -- Generate:
4196 -- P'Max_Size_In_Storage_Elements +
4197 -- Universal_Integer
4198 -- (Header_Size_With_Padding (Ptyp'Alignment))
4199
4200 Rewrite (Attr,
4201 Make_Op_Add (Loc,
4202 Left_Opnd => Relocate_Node (Attr),
4203 Right_Opnd =>
4204 Convert_To (Universal_Integer,
4205 Make_Function_Call (Loc,
4206 Name =>
4207 New_Occurrence_Of
4208 (RTE (RE_Header_Size_With_Padding), Loc),
4209
4210 Parameter_Associations => New_List (
4211 Make_Attribute_Reference (Loc,
4212 Prefix =>
4213 New_Occurrence_Of (Ptyp, Loc),
4214 Attribute_Name => Name_Alignment))))));
4215
4216 -- Add a conversion to the target type
4217
4218 if not Conversion_Added then
4219 Rewrite (Attr,
4220 Make_Type_Conversion (Loc,
4221 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4222 Expression => Relocate_Node (Attr)));
4223 end if;
4224
4225 Analyze (Attr);
4226 return;
4227 end if;
4228 end;
4229
4230 --------------------
4231 -- Mechanism_Code --
4232 --------------------
4233
4234 when Attribute_Mechanism_Code =>
4235
4236 -- We must replace the prefix i the renamed case
4237
4238 if Is_Entity_Name (Pref)
4239 and then Present (Alias (Entity (Pref)))
4240 then
4241 Set_Renamed_Subprogram (Pref, Alias (Entity (Pref)));
4242 end if;
4243
4244 ---------
4245 -- Min --
4246 ---------
4247
4248 when Attribute_Min =>
4249 Expand_Min_Max_Attribute (N);
4250
4251 ---------
4252 -- Mod --
4253 ---------
4254
4255 when Attribute_Mod => Mod_Case : declare
4256 Arg : constant Node_Id := Relocate_Node (First (Exprs));
4257 Hi : constant Node_Id := Type_High_Bound (Etype (Arg));
4258 Modv : constant Uint := Modulus (Btyp);
4259
4260 begin
4261
4262 -- This is not so simple. The issue is what type to use for the
4263 -- computation of the modular value.
4264
4265 -- The easy case is when the modulus value is within the bounds
4266 -- of the signed integer type of the argument. In this case we can
4267 -- just do the computation in that signed integer type, and then
4268 -- do an ordinary conversion to the target type.
4269
4270 if Modv <= Expr_Value (Hi) then
4271 Rewrite (N,
4272 Convert_To (Btyp,
4273 Make_Op_Mod (Loc,
4274 Left_Opnd => Arg,
4275 Right_Opnd => Make_Integer_Literal (Loc, Modv))));
4276
4277 -- Here we know that the modulus is larger than type'Last of the
4278 -- integer type. There are two cases to consider:
4279
4280 -- a) The integer value is non-negative. In this case, it is
4281 -- returned as the result (since it is less than the modulus).
4282
4283 -- b) The integer value is negative. In this case, we know that the
4284 -- result is modulus + value, where the value might be as small as
4285 -- -modulus. The trouble is what type do we use to do the subtract.
4286 -- No type will do, since modulus can be as big as 2**64, and no
4287 -- integer type accommodates this value. Let's do bit of algebra
4288
4289 -- modulus + value
4290 -- = modulus - (-value)
4291 -- = (modulus - 1) - (-value - 1)
4292
4293 -- Now modulus - 1 is certainly in range of the modular type.
4294 -- -value is in the range 1 .. modulus, so -value -1 is in the
4295 -- range 0 .. modulus-1 which is in range of the modular type.
4296 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
4297 -- which we can compute using the integer base type.
4298
4299 -- Once this is done we analyze the if expression without range
4300 -- checks, because we know everything is in range, and we want
4301 -- to prevent spurious warnings on either branch.
4302
4303 else
4304 Rewrite (N,
4305 Make_If_Expression (Loc,
4306 Expressions => New_List (
4307 Make_Op_Ge (Loc,
4308 Left_Opnd => Duplicate_Subexpr (Arg),
4309 Right_Opnd => Make_Integer_Literal (Loc, 0)),
4310
4311 Convert_To (Btyp,
4312 Duplicate_Subexpr_No_Checks (Arg)),
4313
4314 Make_Op_Subtract (Loc,
4315 Left_Opnd =>
4316 Make_Integer_Literal (Loc,
4317 Intval => Modv - 1),
4318 Right_Opnd =>
4319 Convert_To (Btyp,
4320 Make_Op_Minus (Loc,
4321 Right_Opnd =>
4322 Make_Op_Add (Loc,
4323 Left_Opnd => Duplicate_Subexpr_No_Checks (Arg),
4324 Right_Opnd =>
4325 Make_Integer_Literal (Loc,
4326 Intval => 1))))))));
4327
4328 end if;
4329
4330 Analyze_And_Resolve (N, Btyp, Suppress => All_Checks);
4331 end Mod_Case;
4332
4333 -----------
4334 -- Model --
4335 -----------
4336
4337 -- Transforms 'Model into a call to the floating-point attribute
4338 -- function Model in Fat_xxx (where xxx is the root type).
4339 -- Expansion is avoided for cases the back end can handle directly.
4340
4341 when Attribute_Model =>
4342 if not Is_Inline_Floating_Point_Attribute (N) then
4343 Expand_Fpt_Attribute_R (N);
4344 end if;
4345
4346 -----------------
4347 -- Object_Size --
4348 -----------------
4349
4350 -- The processing for Object_Size shares the processing for Size
4351
4352 ---------
4353 -- Old --
4354 ---------
4355
4356 when Attribute_Old => Old : declare
4357 Typ : constant Entity_Id := Etype (N);
4358 CW_Temp : Entity_Id;
4359 CW_Typ : Entity_Id;
4360 Ins_Nod : Node_Id;
4361 Subp : Node_Id;
4362 Temp : Entity_Id;
4363
4364 begin
4365 -- Generating C code we don't need to expand this attribute when
4366 -- we are analyzing the internally built nested postconditions
4367 -- procedure since it will be expanded inline (and later it will
4368 -- be removed by Expand_N_Subprogram_Body). It this expansion is
4369 -- performed in such case then the compiler generates unreferenced
4370 -- extra temporaries.
4371
4372 if Modify_Tree_For_C
4373 and then Chars (Current_Scope) = Name_uPostconditions
4374 then
4375 return;
4376 end if;
4377
4378 -- Climb the parent chain looking for subprogram _Postconditions
4379
4380 Subp := N;
4381 while Present (Subp) loop
4382 exit when Nkind (Subp) = N_Subprogram_Body
4383 and then Chars (Defining_Entity (Subp)) = Name_uPostconditions;
4384
4385 -- If assertions are disabled, no need to create the declaration
4386 -- that preserves the value. The postcondition pragma in which
4387 -- 'Old appears will be checked or disabled according to the
4388 -- current policy in effect.
4389
4390 if Nkind (Subp) = N_Pragma and then not Is_Checked (Subp) then
4391 return;
4392 end if;
4393
4394 Subp := Parent (Subp);
4395 end loop;
4396
4397 -- 'Old can only appear in a postcondition, the generated body of
4398 -- _Postconditions must be in the tree (or inlined if we are
4399 -- generating C code).
4400
4401 pragma Assert
4402 (Present (Subp)
4403 or else (Modify_Tree_For_C and then In_Inlined_Body));
4404
4405 Temp := Make_Temporary (Loc, 'T', Pref);
4406
4407 -- Set the entity kind now in order to mark the temporary as a
4408 -- handler of attribute 'Old's prefix.
4409
4410 Set_Ekind (Temp, E_Constant);
4411 Set_Stores_Attribute_Old_Prefix (Temp);
4412
4413 -- Push the scope of the related subprogram where _Postcondition
4414 -- resides as this ensures that the object will be analyzed in the
4415 -- proper context.
4416
4417 if Present (Subp) then
4418 Push_Scope (Scope (Defining_Entity (Subp)));
4419
4420 -- No need to push the scope when generating C code since the
4421 -- _Postcondition procedure has been inlined.
4422
4423 else pragma Assert (Modify_Tree_For_C);
4424 pragma Assert (In_Inlined_Body);
4425 null;
4426 end if;
4427
4428 -- Locate the insertion place of the internal temporary that saves
4429 -- the 'Old value.
4430
4431 if Present (Subp) then
4432 Ins_Nod := Subp;
4433
4434 -- Generating C, the postcondition procedure has been inlined and the
4435 -- temporary is added before the first declaration of the enclosing
4436 -- subprogram.
4437
4438 else pragma Assert (Modify_Tree_For_C);
4439 Ins_Nod := N;
4440 while Nkind (Ins_Nod) /= N_Subprogram_Body loop
4441 Ins_Nod := Parent (Ins_Nod);
4442 end loop;
4443
4444 Ins_Nod := First (Declarations (Ins_Nod));
4445 end if;
4446
4447 -- Preserve the tag of the prefix by offering a specific view of the
4448 -- class-wide version of the prefix.
4449
4450 if Is_Tagged_Type (Typ) then
4451
4452 -- Generate:
4453 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
4454
4455 CW_Temp := Make_Temporary (Loc, 'T');
4456 CW_Typ := Class_Wide_Type (Typ);
4457
4458 Insert_Before_And_Analyze (Ins_Nod,
4459 Make_Object_Declaration (Loc,
4460 Defining_Identifier => CW_Temp,
4461 Constant_Present => True,
4462 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
4463 Expression =>
4464 Convert_To (CW_Typ, Relocate_Node (Pref))));
4465
4466 -- Generate:
4467 -- Temp : Typ renames Typ (CW_Temp);
4468
4469 Insert_Before_And_Analyze (Ins_Nod,
4470 Make_Object_Renaming_Declaration (Loc,
4471 Defining_Identifier => Temp,
4472 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4473 Name =>
4474 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))));
4475
4476 -- Non-tagged case
4477
4478 else
4479 -- Generate:
4480 -- Temp : constant Typ := Pref;
4481
4482 Insert_Before_And_Analyze (Ins_Nod,
4483 Make_Object_Declaration (Loc,
4484 Defining_Identifier => Temp,
4485 Constant_Present => True,
4486 Object_Definition => New_Occurrence_Of (Typ, Loc),
4487 Expression => Relocate_Node (Pref)));
4488 end if;
4489
4490 if Present (Subp) then
4491 Pop_Scope;
4492 end if;
4493
4494 -- Ensure that the prefix of attribute 'Old is valid. The check must
4495 -- be inserted after the expansion of the attribute has taken place
4496 -- to reflect the new placement of the prefix.
4497
4498 if Validity_Checks_On and then Validity_Check_Operands then
4499 Ensure_Valid (Pref);
4500 end if;
4501
4502 Rewrite (N, New_Occurrence_Of (Temp, Loc));
4503 end Old;
4504
4505 ----------------------
4506 -- Overlaps_Storage --
4507 ----------------------
4508
4509 when Attribute_Overlaps_Storage => Overlaps_Storage : declare
4510 Loc : constant Source_Ptr := Sloc (N);
4511
4512 X : constant Node_Id := Prefix (N);
4513 Y : constant Node_Id := First (Expressions (N));
4514 -- The arguments
4515
4516 X_Addr, Y_Addr : Node_Id;
4517 -- the expressions for their integer addresses
4518
4519 X_Size, Y_Size : Node_Id;
4520 -- the expressions for their sizes
4521
4522 Cond : Node_Id;
4523
4524 begin
4525 -- Attribute expands into:
4526
4527 -- if X'Address < Y'address then
4528 -- (X'address + X'Size - 1) >= Y'address
4529 -- else
4530 -- (Y'address + Y'size - 1) >= X'Address
4531 -- end if;
4532
4533 -- with the proper address operations. We convert addresses to
4534 -- integer addresses to use predefined arithmetic. The size is
4535 -- expressed in storage units. We add copies of X_Addr and Y_Addr
4536 -- to prevent the appearance of the same node in two places in
4537 -- the tree.
4538
4539 X_Addr :=
4540 Unchecked_Convert_To (RTE (RE_Integer_Address),
4541 Make_Attribute_Reference (Loc,
4542 Attribute_Name => Name_Address,
4543 Prefix => New_Copy_Tree (X)));
4544
4545 Y_Addr :=
4546 Unchecked_Convert_To (RTE (RE_Integer_Address),
4547 Make_Attribute_Reference (Loc,
4548 Attribute_Name => Name_Address,
4549 Prefix => New_Copy_Tree (Y)));
4550
4551 X_Size :=
4552 Make_Op_Divide (Loc,
4553 Left_Opnd =>
4554 Make_Attribute_Reference (Loc,
4555 Attribute_Name => Name_Size,
4556 Prefix => New_Copy_Tree (X)),
4557 Right_Opnd =>
4558 Make_Integer_Literal (Loc, System_Storage_Unit));
4559
4560 Y_Size :=
4561 Make_Op_Divide (Loc,
4562 Left_Opnd =>
4563 Make_Attribute_Reference (Loc,
4564 Attribute_Name => Name_Size,
4565 Prefix => New_Copy_Tree (Y)),
4566 Right_Opnd =>
4567 Make_Integer_Literal (Loc, System_Storage_Unit));
4568
4569 Cond :=
4570 Make_Op_Le (Loc,
4571 Left_Opnd => X_Addr,
4572 Right_Opnd => Y_Addr);
4573
4574 Rewrite (N,
4575 Make_If_Expression (Loc, New_List (
4576 Cond,
4577
4578 Make_Op_Ge (Loc,
4579 Left_Opnd =>
4580 Make_Op_Add (Loc,
4581 Left_Opnd => New_Copy_Tree (X_Addr),
4582 Right_Opnd =>
4583 Make_Op_Subtract (Loc,
4584 Left_Opnd => X_Size,
4585 Right_Opnd => Make_Integer_Literal (Loc, 1))),
4586 Right_Opnd => Y_Addr),
4587
4588 Make_Op_Ge (Loc,
4589 Left_Opnd =>
4590 Make_Op_Add (Loc,
4591 Left_Opnd => New_Copy_Tree (Y_Addr),
4592 Right_Opnd =>
4593 Make_Op_Subtract (Loc,
4594 Left_Opnd => Y_Size,
4595 Right_Opnd => Make_Integer_Literal (Loc, 1))),
4596 Right_Opnd => X_Addr))));
4597
4598 Analyze_And_Resolve (N, Standard_Boolean);
4599 end Overlaps_Storage;
4600
4601 ------------
4602 -- Output --
4603 ------------
4604
4605 when Attribute_Output => Output : declare
4606 P_Type : constant Entity_Id := Entity (Pref);
4607 U_Type : constant Entity_Id := Underlying_Type (P_Type);
4608 Pname : Entity_Id;
4609 Decl : Node_Id;
4610 Prag : Node_Id;
4611 Arg3 : Node_Id;
4612 Wfunc : Node_Id;
4613
4614 begin
4615 -- If no underlying type, we have an error that will be diagnosed
4616 -- elsewhere, so here we just completely ignore the expansion.
4617
4618 if No (U_Type) then
4619 return;
4620 end if;
4621
4622 -- Stream operations can appear in user code even if the restriction
4623 -- No_Streams is active (for example, when instantiating a predefined
4624 -- container). In that case rewrite the attribute as a Raise to
4625 -- prevent any run-time use.
4626
4627 if Restriction_Active (No_Streams) then
4628 Rewrite (N,
4629 Make_Raise_Program_Error (Sloc (N),
4630 Reason => PE_Stream_Operation_Not_Allowed));
4631 Set_Etype (N, Standard_Void_Type);
4632 return;
4633 end if;
4634
4635 -- If TSS for Output is present, just call it
4636
4637 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
4638
4639 if Present (Pname) then
4640 null;
4641
4642 else
4643 -- If there is a Stream_Convert pragma, use it, we rewrite
4644
4645 -- sourcetyp'Output (stream, Item)
4646
4647 -- as
4648
4649 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
4650
4651 -- where strmwrite is the given Write function that converts an
4652 -- argument of type sourcetyp or a type acctyp, from which it is
4653 -- derived to type strmtyp. The conversion to acttyp is required
4654 -- for the derived case.
4655
4656 Prag := Get_Stream_Convert_Pragma (P_Type);
4657
4658 if Present (Prag) then
4659 Arg3 :=
4660 Next (Next (First (Pragma_Argument_Associations (Prag))));
4661 Wfunc := Entity (Expression (Arg3));
4662
4663 Rewrite (N,
4664 Make_Attribute_Reference (Loc,
4665 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
4666 Attribute_Name => Name_Output,
4667 Expressions => New_List (
4668 Relocate_Node (First (Exprs)),
4669 Make_Function_Call (Loc,
4670 Name => New_Occurrence_Of (Wfunc, Loc),
4671 Parameter_Associations => New_List (
4672 OK_Convert_To (Etype (First_Formal (Wfunc)),
4673 Relocate_Node (Next (First (Exprs)))))))));
4674
4675 Analyze (N);
4676 return;
4677
4678 -- For elementary types, we call the W_xxx routine directly. Note
4679 -- that the effect of Write and Output is identical for the case
4680 -- of an elementary type (there are no discriminants or bounds).
4681
4682 elsif Is_Elementary_Type (U_Type) then
4683
4684 -- A special case arises if we have a defined _Write routine,
4685 -- since in this case we are required to call this routine.
4686
4687 if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then
4688 Build_Record_Or_Elementary_Output_Procedure
4689 (Loc, U_Type, Decl, Pname);
4690 Insert_Action (N, Decl);
4691
4692 -- For normal cases, we call the W_xxx routine directly
4693
4694 else
4695 Rewrite (N, Build_Elementary_Write_Call (N));
4696 Analyze (N);
4697 return;
4698 end if;
4699
4700 -- Array type case
4701
4702 elsif Is_Array_Type (U_Type) then
4703 Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
4704 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
4705
4706 -- Class-wide case, first output external tag, then dispatch
4707 -- to the appropriate primitive Output function (RM 13.13.2(31)).
4708
4709 elsif Is_Class_Wide_Type (P_Type) then
4710
4711 -- No need to do anything else compiling under restriction
4712 -- No_Dispatching_Calls. During the semantic analysis we
4713 -- already notified such violation.
4714
4715 if Restriction_Active (No_Dispatching_Calls) then
4716 return;
4717 end if;
4718
4719 Tag_Write : declare
4720 Strm : constant Node_Id := First (Exprs);
4721 Item : constant Node_Id := Next (Strm);
4722
4723 begin
4724 -- Ada 2005 (AI-344): Check that the accessibility level
4725 -- of the type of the output object is not deeper than
4726 -- that of the attribute's prefix type.
4727
4728 -- if Get_Access_Level (Item'Tag)
4729 -- /= Get_Access_Level (P_Type'Tag)
4730 -- then
4731 -- raise Tag_Error;
4732 -- end if;
4733
4734 -- String'Output (Strm, External_Tag (Item'Tag));
4735
4736 -- We cannot figure out a practical way to implement this
4737 -- accessibility check on virtual machines, so we omit it.
4738
4739 if Ada_Version >= Ada_2005
4740 and then Tagged_Type_Expansion
4741 then
4742 Insert_Action (N,
4743 Make_Implicit_If_Statement (N,
4744 Condition =>
4745 Make_Op_Ne (Loc,
4746 Left_Opnd =>
4747 Build_Get_Access_Level (Loc,
4748 Make_Attribute_Reference (Loc,
4749 Prefix =>
4750 Relocate_Node (
4751 Duplicate_Subexpr (Item,
4752 Name_Req => True)),
4753 Attribute_Name => Name_Tag)),
4754
4755 Right_Opnd =>
4756 Make_Integer_Literal (Loc,
4757 Type_Access_Level (P_Type))),
4758
4759 Then_Statements =>
4760 New_List (Make_Raise_Statement (Loc,
4761 New_Occurrence_Of (
4762 RTE (RE_Tag_Error), Loc)))));
4763 end if;
4764
4765 Insert_Action (N,
4766 Make_Attribute_Reference (Loc,
4767 Prefix => New_Occurrence_Of (Standard_String, Loc),
4768 Attribute_Name => Name_Output,
4769 Expressions => New_List (
4770 Relocate_Node (Duplicate_Subexpr (Strm)),
4771 Make_Function_Call (Loc,
4772 Name =>
4773 New_Occurrence_Of (RTE (RE_External_Tag), Loc),
4774 Parameter_Associations => New_List (
4775 Make_Attribute_Reference (Loc,
4776 Prefix =>
4777 Relocate_Node
4778 (Duplicate_Subexpr (Item, Name_Req => True)),
4779 Attribute_Name => Name_Tag))))));
4780 end Tag_Write;
4781
4782 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
4783
4784 -- Tagged type case, use the primitive Output function
4785
4786 elsif Is_Tagged_Type (U_Type) then
4787 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
4788
4789 -- All other record type cases, including protected records.
4790 -- The latter only arise for expander generated code for
4791 -- handling shared passive partition access.
4792
4793 else
4794 pragma Assert
4795 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
4796
4797 -- Ada 2005 (AI-216): Program_Error is raised when executing
4798 -- the default implementation of the Output attribute of an
4799 -- unchecked union type if the type lacks default discriminant
4800 -- values.
4801
4802 if Is_Unchecked_Union (Base_Type (U_Type))
4803 and then No (Discriminant_Constraint (U_Type))
4804 then
4805 Insert_Action (N,
4806 Make_Raise_Program_Error (Loc,
4807 Reason => PE_Unchecked_Union_Restriction));
4808
4809 return;
4810 end if;
4811
4812 Build_Record_Or_Elementary_Output_Procedure
4813 (Loc, Base_Type (U_Type), Decl, Pname);
4814 Insert_Action (N, Decl);
4815 end if;
4816 end if;
4817
4818 -- If we fall through, Pname is the name of the procedure to call
4819
4820 Rewrite_Stream_Proc_Call (Pname);
4821 end Output;
4822
4823 ---------
4824 -- Pos --
4825 ---------
4826
4827 -- For enumeration types with a standard representation, Pos is
4828 -- handled by the back end.
4829
4830 -- For enumeration types, with a non-standard representation we generate
4831 -- a call to the _Rep_To_Pos function created when the type was frozen.
4832 -- The call has the form
4833
4834 -- _rep_to_pos (expr, flag)
4835
4836 -- The parameter flag is True if range checks are enabled, causing
4837 -- Program_Error to be raised if the expression has an invalid
4838 -- representation, and False if range checks are suppressed.
4839
4840 -- For integer types, Pos is equivalent to a simple integer
4841 -- conversion and we rewrite it as such
4842
4843 when Attribute_Pos => Pos :
4844 declare
4845 Etyp : Entity_Id := Base_Type (Entity (Pref));
4846
4847 begin
4848 -- Deal with zero/non-zero boolean values
4849
4850 if Is_Boolean_Type (Etyp) then
4851 Adjust_Condition (First (Exprs));
4852 Etyp := Standard_Boolean;
4853 Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
4854 end if;
4855
4856 -- Case of enumeration type
4857
4858 if Is_Enumeration_Type (Etyp) then
4859
4860 -- Non-standard enumeration type (generate call)
4861
4862 if Present (Enum_Pos_To_Rep (Etyp)) then
4863 Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
4864 Rewrite (N,
4865 Convert_To (Typ,
4866 Make_Function_Call (Loc,
4867 Name =>
4868 New_Occurrence_Of (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4869 Parameter_Associations => Exprs)));
4870
4871 Analyze_And_Resolve (N, Typ);
4872
4873 -- Standard enumeration type (do universal integer check)
4874
4875 else
4876 Apply_Universal_Integer_Attribute_Checks (N);
4877 end if;
4878
4879 -- Deal with integer types (replace by conversion)
4880
4881 elsif Is_Integer_Type (Etyp) then
4882 Rewrite (N, Convert_To (Typ, First (Exprs)));
4883 Analyze_And_Resolve (N, Typ);
4884 end if;
4885
4886 end Pos;
4887
4888 --------------
4889 -- Position --
4890 --------------
4891
4892 -- We compute this if a component clause was present, otherwise we leave
4893 -- the computation up to the back end, since we don't know what layout
4894 -- will be chosen.
4895
4896 when Attribute_Position => Position_Attr :
4897 declare
4898 CE : constant Entity_Id := Entity (Selector_Name (Pref));
4899
4900 begin
4901 if Present (Component_Clause (CE)) then
4902
4903 -- In Ada 2005 (or later) if we have the non-default bit order,
4904 -- then we return the original value as given in the component
4905 -- clause (RM 2005 13.5.2(2/2)).
4906
4907 if Ada_Version >= Ada_2005
4908 and then Reverse_Bit_Order (Scope (CE))
4909 then
4910 Rewrite (N,
4911 Make_Integer_Literal (Loc,
4912 Intval => Expr_Value (Position (Component_Clause (CE)))));
4913
4914 -- Otherwise (Ada 83 or 95, or default bit order specified in
4915 -- later Ada version), return the normalized value.
4916
4917 else
4918 Rewrite (N,
4919 Make_Integer_Literal (Loc,
4920 Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
4921 end if;
4922
4923 Analyze_And_Resolve (N, Typ);
4924
4925 -- If back end is doing things, just apply universal integer checks
4926
4927 else
4928 Apply_Universal_Integer_Attribute_Checks (N);
4929 end if;
4930 end Position_Attr;
4931
4932 ----------
4933 -- Pred --
4934 ----------
4935
4936 -- 1. Deal with enumeration types with holes.
4937 -- 2. For floating-point, generate call to attribute function.
4938 -- 3. For other cases, deal with constraint checking.
4939
4940 when Attribute_Pred => Pred :
4941 declare
4942 Etyp : constant Entity_Id := Base_Type (Ptyp);
4943
4944 begin
4945
4946 -- For enumeration types with non-standard representations, we
4947 -- expand typ'Pred (x) into
4948
4949 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
4950
4951 -- If the representation is contiguous, we compute instead
4952 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
4953 -- The conversion function Enum_Pos_To_Rep is defined on the
4954 -- base type, not the subtype, so we have to use the base type
4955 -- explicitly for this and other enumeration attributes.
4956
4957 if Is_Enumeration_Type (Ptyp)
4958 and then Present (Enum_Pos_To_Rep (Etyp))
4959 then
4960 if Has_Contiguous_Rep (Etyp) then
4961 Rewrite (N,
4962 Unchecked_Convert_To (Ptyp,
4963 Make_Op_Add (Loc,
4964 Left_Opnd =>
4965 Make_Integer_Literal (Loc,
4966 Enumeration_Rep (First_Literal (Ptyp))),
4967 Right_Opnd =>
4968 Make_Function_Call (Loc,
4969 Name =>
4970 New_Occurrence_Of
4971 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4972
4973 Parameter_Associations =>
4974 New_List (
4975 Unchecked_Convert_To (Ptyp,
4976 Make_Op_Subtract (Loc,
4977 Left_Opnd =>
4978 Unchecked_Convert_To (Standard_Integer,
4979 Relocate_Node (First (Exprs))),
4980 Right_Opnd =>
4981 Make_Integer_Literal (Loc, 1))),
4982 Rep_To_Pos_Flag (Ptyp, Loc))))));
4983
4984 else
4985 -- Add Boolean parameter True, to request program errror if
4986 -- we have a bad representation on our hands. If checks are
4987 -- suppressed, then add False instead
4988
4989 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
4990 Rewrite (N,
4991 Make_Indexed_Component (Loc,
4992 Prefix =>
4993 New_Occurrence_Of
4994 (Enum_Pos_To_Rep (Etyp), Loc),
4995 Expressions => New_List (
4996 Make_Op_Subtract (Loc,
4997 Left_Opnd =>
4998 Make_Function_Call (Loc,
4999 Name =>
5000 New_Occurrence_Of
5001 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5002 Parameter_Associations => Exprs),
5003 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
5004 end if;
5005
5006 Analyze_And_Resolve (N, Typ);
5007
5008 -- For floating-point, we transform 'Pred into a call to the Pred
5009 -- floating-point attribute function in Fat_xxx (xxx is root type).
5010 -- Note that this function takes care of the overflow case.
5011
5012 elsif Is_Floating_Point_Type (Ptyp) then
5013 Expand_Fpt_Attribute_R (N);
5014 Analyze_And_Resolve (N, Typ);
5015
5016 -- For modular types, nothing to do (no overflow, since wraps)
5017
5018 elsif Is_Modular_Integer_Type (Ptyp) then
5019 null;
5020
5021 -- For other types, if argument is marked as needing a range check or
5022 -- overflow checking is enabled, we must generate a check.
5023
5024 elsif not Overflow_Checks_Suppressed (Ptyp)
5025 or else Do_Range_Check (First (Exprs))
5026 then
5027 Set_Do_Range_Check (First (Exprs), False);
5028 Expand_Pred_Succ_Attribute (N);
5029 end if;
5030 end Pred;
5031
5032 --------------
5033 -- Priority --
5034 --------------
5035
5036 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5037
5038 -- We rewrite X'Priority as the following run-time call:
5039
5040 -- Get_Ceiling (X._Object)
5041
5042 -- Note that although X'Priority is notionally an object, it is quite
5043 -- deliberately not defined as an aliased object in the RM. This means
5044 -- that it works fine to rewrite it as a call, without having to worry
5045 -- about complications that would other arise from X'Priority'Access,
5046 -- which is illegal, because of the lack of aliasing.
5047
5048 when Attribute_Priority =>
5049 declare
5050 Call : Node_Id;
5051 Conctyp : Entity_Id;
5052 Object_Parm : Node_Id;
5053 Subprg : Entity_Id;
5054 RT_Subprg_Name : Node_Id;
5055
5056 begin
5057 -- Look for the enclosing concurrent type
5058
5059 Conctyp := Current_Scope;
5060 while not Is_Concurrent_Type (Conctyp) loop
5061 Conctyp := Scope (Conctyp);
5062 end loop;
5063
5064 pragma Assert (Is_Protected_Type (Conctyp));
5065
5066 -- Generate the actual of the call
5067
5068 Subprg := Current_Scope;
5069 while not Present (Protected_Body_Subprogram (Subprg)) loop
5070 Subprg := Scope (Subprg);
5071 end loop;
5072
5073 -- Use of 'Priority inside protected entries and barriers (in
5074 -- both cases the type of the first formal of their expanded
5075 -- subprogram is Address)
5076
5077 if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) =
5078 RTE (RE_Address)
5079 then
5080 declare
5081 New_Itype : Entity_Id;
5082
5083 begin
5084 -- In the expansion of protected entries the type of the
5085 -- first formal of the Protected_Body_Subprogram is an
5086 -- Address. In order to reference the _object component
5087 -- we generate:
5088
5089 -- type T is access p__ptTV;
5090 -- freeze T []
5091
5092 New_Itype := Create_Itype (E_Access_Type, N);
5093 Set_Etype (New_Itype, New_Itype);
5094 Set_Directly_Designated_Type (New_Itype,
5095 Corresponding_Record_Type (Conctyp));
5096 Freeze_Itype (New_Itype, N);
5097
5098 -- Generate:
5099 -- T!(O)._object'unchecked_access
5100
5101 Object_Parm :=
5102 Make_Attribute_Reference (Loc,
5103 Prefix =>
5104 Make_Selected_Component (Loc,
5105 Prefix =>
5106 Unchecked_Convert_To (New_Itype,
5107 New_Occurrence_Of
5108 (First_Entity
5109 (Protected_Body_Subprogram (Subprg)),
5110 Loc)),
5111 Selector_Name =>
5112 Make_Identifier (Loc, Name_uObject)),
5113 Attribute_Name => Name_Unchecked_Access);
5114 end;
5115
5116 -- Use of 'Priority inside a protected subprogram
5117
5118 else
5119 Object_Parm :=
5120 Make_Attribute_Reference (Loc,
5121 Prefix =>
5122 Make_Selected_Component (Loc,
5123 Prefix => New_Occurrence_Of
5124 (First_Entity
5125 (Protected_Body_Subprogram (Subprg)),
5126 Loc),
5127 Selector_Name => Make_Identifier (Loc, Name_uObject)),
5128 Attribute_Name => Name_Unchecked_Access);
5129 end if;
5130
5131 -- Select the appropriate run-time subprogram
5132
5133 if Number_Entries (Conctyp) = 0 then
5134 RT_Subprg_Name :=
5135 New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc);
5136 else
5137 RT_Subprg_Name :=
5138 New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc);
5139 end if;
5140
5141 Call :=
5142 Make_Function_Call (Loc,
5143 Name => RT_Subprg_Name,
5144 Parameter_Associations => New_List (Object_Parm));
5145
5146 Rewrite (N, Call);
5147
5148 -- Avoid the generation of extra checks on the pointer to the
5149 -- protected object.
5150
5151 Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
5152 end;
5153
5154 ------------------
5155 -- Range_Length --
5156 ------------------
5157
5158 when Attribute_Range_Length => Range_Length : begin
5159
5160 -- The only special processing required is for the case where
5161 -- Range_Length is applied to an enumeration type with holes.
5162 -- In this case we transform
5163
5164 -- X'Range_Length
5165
5166 -- to
5167
5168 -- X'Pos (X'Last) - X'Pos (X'First) + 1
5169
5170 -- So that the result reflects the proper Pos values instead
5171 -- of the underlying representations.
5172
5173 if Is_Enumeration_Type (Ptyp)
5174 and then Has_Non_Standard_Rep (Ptyp)
5175 then
5176 Rewrite (N,
5177 Make_Op_Add (Loc,
5178 Left_Opnd =>
5179 Make_Op_Subtract (Loc,
5180 Left_Opnd =>
5181 Make_Attribute_Reference (Loc,
5182 Attribute_Name => Name_Pos,
5183 Prefix => New_Occurrence_Of (Ptyp, Loc),
5184 Expressions => New_List (
5185 Make_Attribute_Reference (Loc,
5186 Attribute_Name => Name_Last,
5187 Prefix => New_Occurrence_Of (Ptyp, Loc)))),
5188
5189 Right_Opnd =>
5190 Make_Attribute_Reference (Loc,
5191 Attribute_Name => Name_Pos,
5192 Prefix => New_Occurrence_Of (Ptyp, Loc),
5193 Expressions => New_List (
5194 Make_Attribute_Reference (Loc,
5195 Attribute_Name => Name_First,
5196 Prefix => New_Occurrence_Of (Ptyp, Loc))))),
5197
5198 Right_Opnd => Make_Integer_Literal (Loc, 1)));
5199
5200 Analyze_And_Resolve (N, Typ);
5201
5202 -- For all other cases, the attribute is handled by the back end, but
5203 -- we need to deal with the case of the range check on a universal
5204 -- integer.
5205
5206 else
5207 Apply_Universal_Integer_Attribute_Checks (N);
5208 end if;
5209 end Range_Length;
5210
5211 ----------
5212 -- Read --
5213 ----------
5214
5215 when Attribute_Read => Read : declare
5216 P_Type : constant Entity_Id := Entity (Pref);
5217 B_Type : constant Entity_Id := Base_Type (P_Type);
5218 U_Type : constant Entity_Id := Underlying_Type (P_Type);
5219 Pname : Entity_Id;
5220 Decl : Node_Id;
5221 Prag : Node_Id;
5222 Arg2 : Node_Id;
5223 Rfunc : Node_Id;
5224 Lhs : Node_Id;
5225 Rhs : Node_Id;
5226
5227 begin
5228 -- If no underlying type, we have an error that will be diagnosed
5229 -- elsewhere, so here we just completely ignore the expansion.
5230
5231 if No (U_Type) then
5232 return;
5233 end if;
5234
5235 -- Stream operations can appear in user code even if the restriction
5236 -- No_Streams is active (for example, when instantiating a predefined
5237 -- container). In that case rewrite the attribute as a Raise to
5238 -- prevent any run-time use.
5239
5240 if Restriction_Active (No_Streams) then
5241 Rewrite (N,
5242 Make_Raise_Program_Error (Sloc (N),
5243 Reason => PE_Stream_Operation_Not_Allowed));
5244 Set_Etype (N, B_Type);
5245 return;
5246 end if;
5247
5248 -- The simple case, if there is a TSS for Read, just call it
5249
5250 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
5251
5252 if Present (Pname) then
5253 null;
5254
5255 else
5256 -- If there is a Stream_Convert pragma, use it, we rewrite
5257
5258 -- sourcetyp'Read (stream, Item)
5259
5260 -- as
5261
5262 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
5263
5264 -- where strmread is the given Read function that converts an
5265 -- argument of type strmtyp to type sourcetyp or a type from which
5266 -- it is derived. The conversion to sourcetyp is required in the
5267 -- latter case.
5268
5269 -- A special case arises if Item is a type conversion in which
5270 -- case, we have to expand to:
5271
5272 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
5273
5274 -- where Itemx is the expression of the type conversion (i.e.
5275 -- the actual object), and typex is the type of Itemx.
5276
5277 Prag := Get_Stream_Convert_Pragma (P_Type);
5278
5279 if Present (Prag) then
5280 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
5281 Rfunc := Entity (Expression (Arg2));
5282 Lhs := Relocate_Node (Next (First (Exprs)));
5283 Rhs :=
5284 OK_Convert_To (B_Type,
5285 Make_Function_Call (Loc,
5286 Name => New_Occurrence_Of (Rfunc, Loc),
5287 Parameter_Associations => New_List (
5288 Make_Attribute_Reference (Loc,
5289 Prefix =>
5290 New_Occurrence_Of
5291 (Etype (First_Formal (Rfunc)), Loc),
5292 Attribute_Name => Name_Input,
5293 Expressions => New_List (
5294 Relocate_Node (First (Exprs)))))));
5295
5296 if Nkind (Lhs) = N_Type_Conversion then
5297 Lhs := Expression (Lhs);
5298 Rhs := Convert_To (Etype (Lhs), Rhs);
5299 end if;
5300
5301 Rewrite (N,
5302 Make_Assignment_Statement (Loc,
5303 Name => Lhs,
5304 Expression => Rhs));
5305 Set_Assignment_OK (Lhs);
5306 Analyze (N);
5307 return;
5308
5309 -- For elementary types, we call the I_xxx routine using the first
5310 -- parameter and then assign the result into the second parameter.
5311 -- We set Assignment_OK to deal with the conversion case.
5312
5313 elsif Is_Elementary_Type (U_Type) then
5314 declare
5315 Lhs : Node_Id;
5316 Rhs : Node_Id;
5317
5318 begin
5319 Lhs := Relocate_Node (Next (First (Exprs)));
5320 Rhs := Build_Elementary_Input_Call (N);
5321
5322 if Nkind (Lhs) = N_Type_Conversion then
5323 Lhs := Expression (Lhs);
5324 Rhs := Convert_To (Etype (Lhs), Rhs);
5325 end if;
5326
5327 Set_Assignment_OK (Lhs);
5328
5329 Rewrite (N,
5330 Make_Assignment_Statement (Loc,
5331 Name => Lhs,
5332 Expression => Rhs));
5333
5334 Analyze (N);
5335 return;
5336 end;
5337
5338 -- Array type case
5339
5340 elsif Is_Array_Type (U_Type) then
5341 Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
5342 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
5343
5344 -- Tagged type case, use the primitive Read function. Note that
5345 -- this will dispatch in the class-wide case which is what we want
5346
5347 elsif Is_Tagged_Type (U_Type) then
5348 Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
5349
5350 -- All other record type cases, including protected records. The
5351 -- latter only arise for expander generated code for handling
5352 -- shared passive partition access.
5353
5354 else
5355 pragma Assert
5356 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
5357
5358 -- Ada 2005 (AI-216): Program_Error is raised when executing
5359 -- the default implementation of the Read attribute of an
5360 -- Unchecked_Union type.
5361
5362 if Is_Unchecked_Union (Base_Type (U_Type)) then
5363 Insert_Action (N,
5364 Make_Raise_Program_Error (Loc,
5365 Reason => PE_Unchecked_Union_Restriction));
5366 end if;
5367
5368 if Has_Discriminants (U_Type)
5369 and then Present
5370 (Discriminant_Default_Value (First_Discriminant (U_Type)))
5371 then
5372 Build_Mutable_Record_Read_Procedure
5373 (Loc, Full_Base (U_Type), Decl, Pname);
5374 else
5375 Build_Record_Read_Procedure
5376 (Loc, Full_Base (U_Type), Decl, Pname);
5377 end if;
5378
5379 -- Suppress checks, uninitialized or otherwise invalid
5380 -- data does not cause constraint errors to be raised for
5381 -- a complete record read.
5382
5383 Insert_Action (N, Decl, All_Checks);
5384 end if;
5385 end if;
5386
5387 Rewrite_Stream_Proc_Call (Pname);
5388 end Read;
5389
5390 ---------
5391 -- Ref --
5392 ---------
5393
5394 -- Ref is identical to To_Address, see To_Address for processing
5395
5396 ---------------
5397 -- Remainder --
5398 ---------------
5399
5400 -- Transforms 'Remainder into a call to the floating-point attribute
5401 -- function Remainder in Fat_xxx (where xxx is the root type)
5402
5403 when Attribute_Remainder =>
5404 Expand_Fpt_Attribute_RR (N);
5405
5406 ------------
5407 -- Result --
5408 ------------
5409
5410 -- Transform 'Result into reference to _Result formal. At the point
5411 -- where a legal 'Result attribute is expanded, we know that we are in
5412 -- the context of a _Postcondition function with a _Result parameter.
5413
5414 when Attribute_Result =>
5415 Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult));
5416 Analyze_And_Resolve (N, Typ);
5417
5418 -----------
5419 -- Round --
5420 -----------
5421
5422 -- The handling of the Round attribute is quite delicate. The processing
5423 -- in Sem_Attr introduced a conversion to universal real, reflecting the
5424 -- semantics of Round, but we do not want anything to do with universal
5425 -- real at runtime, since this corresponds to using floating-point
5426 -- arithmetic.
5427
5428 -- What we have now is that the Etype of the Round attribute correctly
5429 -- indicates the final result type. The operand of the Round is the
5430 -- conversion to universal real, described above, and the operand of
5431 -- this conversion is the actual operand of Round, which may be the
5432 -- special case of a fixed point multiplication or division (Etype =
5433 -- universal fixed)
5434
5435 -- The exapander will expand first the operand of the conversion, then
5436 -- the conversion, and finally the round attribute itself, since we
5437 -- always work inside out. But we cannot simply process naively in this
5438 -- order. In the semantic world where universal fixed and real really
5439 -- exist and have infinite precision, there is no problem, but in the
5440 -- implementation world, where universal real is a floating-point type,
5441 -- we would get the wrong result.
5442
5443 -- So the approach is as follows. First, when expanding a multiply or
5444 -- divide whose type is universal fixed, we do nothing at all, instead
5445 -- deferring the operation till later.
5446
5447 -- The actual processing is done in Expand_N_Type_Conversion which
5448 -- handles the special case of Round by looking at its parent to see if
5449 -- it is a Round attribute, and if it is, handling the conversion (or
5450 -- its fixed multiply/divide child) in an appropriate manner.
5451
5452 -- This means that by the time we get to expanding the Round attribute
5453 -- itself, the Round is nothing more than a type conversion (and will
5454 -- often be a null type conversion), so we just replace it with the
5455 -- appropriate conversion operation.
5456
5457 when Attribute_Round =>
5458 Rewrite (N,
5459 Convert_To (Etype (N), Relocate_Node (First (Exprs))));
5460 Analyze_And_Resolve (N);
5461
5462 --------------
5463 -- Rounding --
5464 --------------
5465
5466 -- Transforms 'Rounding into a call to the floating-point attribute
5467 -- function Rounding in Fat_xxx (where xxx is the root type)
5468 -- Expansion is avoided for cases the back end can handle directly.
5469
5470 when Attribute_Rounding =>
5471 if not Is_Inline_Floating_Point_Attribute (N) then
5472 Expand_Fpt_Attribute_R (N);
5473 end if;
5474
5475 -------------
5476 -- Scaling --
5477 -------------
5478
5479 -- Transforms 'Scaling into a call to the floating-point attribute
5480 -- function Scaling in Fat_xxx (where xxx is the root type)
5481
5482 when Attribute_Scaling =>
5483 Expand_Fpt_Attribute_RI (N);
5484
5485 -------------------------
5486 -- Simple_Storage_Pool --
5487 -------------------------
5488
5489 when Attribute_Simple_Storage_Pool =>
5490 Rewrite (N,
5491 Make_Type_Conversion (Loc,
5492 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
5493 Expression => New_Occurrence_Of (Entity (N), Loc)));
5494 Analyze_And_Resolve (N, Typ);
5495
5496 ----------
5497 -- Size --
5498 ----------
5499
5500 when Attribute_Size |
5501 Attribute_Object_Size |
5502 Attribute_Value_Size |
5503 Attribute_VADS_Size => Size :
5504
5505 declare
5506 Siz : Uint;
5507 New_Node : Node_Id;
5508
5509 begin
5510 -- Processing for VADS_Size case. Note that this processing removes
5511 -- all traces of VADS_Size from the tree, and completes all required
5512 -- processing for VADS_Size by translating the attribute reference
5513 -- to an appropriate Size or Object_Size reference.
5514
5515 if Id = Attribute_VADS_Size
5516 or else (Use_VADS_Size and then Id = Attribute_Size)
5517 then
5518 -- If the size is specified, then we simply use the specified
5519 -- size. This applies to both types and objects. The size of an
5520 -- object can be specified in the following ways:
5521
5522 -- An explicit size object is given for an object
5523 -- A component size is specified for an indexed component
5524 -- A component clause is specified for a selected component
5525 -- The object is a component of a packed composite object
5526
5527 -- If the size is specified, then VADS_Size of an object
5528
5529 if (Is_Entity_Name (Pref)
5530 and then Present (Size_Clause (Entity (Pref))))
5531 or else
5532 (Nkind (Pref) = N_Component_Clause
5533 and then (Present (Component_Clause
5534 (Entity (Selector_Name (Pref))))
5535 or else Is_Packed (Etype (Prefix (Pref)))))
5536 or else
5537 (Nkind (Pref) = N_Indexed_Component
5538 and then (Component_Size (Etype (Prefix (Pref))) /= 0
5539 or else Is_Packed (Etype (Prefix (Pref)))))
5540 then
5541 Set_Attribute_Name (N, Name_Size);
5542
5543 -- Otherwise if we have an object rather than a type, then the
5544 -- VADS_Size attribute applies to the type of the object, rather
5545 -- than the object itself. This is one of the respects in which
5546 -- VADS_Size differs from Size.
5547
5548 else
5549 if (not Is_Entity_Name (Pref)
5550 or else not Is_Type (Entity (Pref)))
5551 and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp))
5552 then
5553 Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
5554 end if;
5555
5556 -- For a scalar type for which no size was explicitly given,
5557 -- VADS_Size means Object_Size. This is the other respect in
5558 -- which VADS_Size differs from Size.
5559
5560 if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then
5561 Set_Attribute_Name (N, Name_Object_Size);
5562
5563 -- In all other cases, Size and VADS_Size are the sane
5564
5565 else
5566 Set_Attribute_Name (N, Name_Size);
5567 end if;
5568 end if;
5569 end if;
5570
5571 -- If the prefix is X'Class, we transform it into a direct reference
5572 -- to the class-wide type, because the back end must not see a 'Class
5573 -- reference.
5574
5575 if Is_Entity_Name (Pref)
5576 and then Is_Class_Wide_Type (Entity (Pref))
5577 then
5578 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
5579 return;
5580
5581 -- For X'Size applied to an object of a class-wide type, transform
5582 -- X'Size into a call to the primitive operation _Size applied to X.
5583
5584 elsif Is_Class_Wide_Type (Ptyp) then
5585
5586 -- No need to do anything else compiling under restriction
5587 -- No_Dispatching_Calls. During the semantic analysis we
5588 -- already noted this restriction violation.
5589
5590 if Restriction_Active (No_Dispatching_Calls) then
5591 return;
5592 end if;
5593
5594 New_Node :=
5595 Make_Function_Call (Loc,
5596 Name => New_Occurrence_Of
5597 (Find_Prim_Op (Ptyp, Name_uSize), Loc),
5598 Parameter_Associations => New_List (Pref));
5599
5600 if Typ /= Standard_Long_Long_Integer then
5601
5602 -- The context is a specific integer type with which the
5603 -- original attribute was compatible. The function has a
5604 -- specific type as well, so to preserve the compatibility
5605 -- we must convert explicitly.
5606
5607 New_Node := Convert_To (Typ, New_Node);
5608 end if;
5609
5610 Rewrite (N, New_Node);
5611 Analyze_And_Resolve (N, Typ);
5612 return;
5613
5614 -- Case of known RM_Size of a type
5615
5616 elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
5617 and then Is_Entity_Name (Pref)
5618 and then Is_Type (Entity (Pref))
5619 and then Known_Static_RM_Size (Entity (Pref))
5620 then
5621 Siz := RM_Size (Entity (Pref));
5622
5623 -- Case of known Esize of a type
5624
5625 elsif Id = Attribute_Object_Size
5626 and then Is_Entity_Name (Pref)
5627 and then Is_Type (Entity (Pref))
5628 and then Known_Static_Esize (Entity (Pref))
5629 then
5630 Siz := Esize (Entity (Pref));
5631
5632 -- Case of known size of object
5633
5634 elsif Id = Attribute_Size
5635 and then Is_Entity_Name (Pref)
5636 and then Is_Object (Entity (Pref))
5637 and then Known_Esize (Entity (Pref))
5638 and then Known_Static_Esize (Entity (Pref))
5639 then
5640 Siz := Esize (Entity (Pref));
5641
5642 -- For an array component, we can do Size in the front end
5643 -- if the component_size of the array is set.
5644
5645 elsif Nkind (Pref) = N_Indexed_Component then
5646 Siz := Component_Size (Etype (Prefix (Pref)));
5647
5648 -- For a record component, we can do Size in the front end if there
5649 -- is a component clause, or if the record is packed and the
5650 -- component's size is known at compile time.
5651
5652 elsif Nkind (Pref) = N_Selected_Component then
5653 declare
5654 Rec : constant Entity_Id := Etype (Prefix (Pref));
5655 Comp : constant Entity_Id := Entity (Selector_Name (Pref));
5656
5657 begin
5658 if Present (Component_Clause (Comp)) then
5659 Siz := Esize (Comp);
5660
5661 elsif Is_Packed (Rec) then
5662 Siz := RM_Size (Ptyp);
5663
5664 else
5665 Apply_Universal_Integer_Attribute_Checks (N);
5666 return;
5667 end if;
5668 end;
5669
5670 -- All other cases are handled by the back end
5671
5672 else
5673 Apply_Universal_Integer_Attribute_Checks (N);
5674
5675 -- If Size is applied to a formal parameter that is of a packed
5676 -- array subtype, then apply Size to the actual subtype.
5677
5678 if Is_Entity_Name (Pref)
5679 and then Is_Formal (Entity (Pref))
5680 and then Is_Array_Type (Ptyp)
5681 and then Is_Packed (Ptyp)
5682 then
5683 Rewrite (N,
5684 Make_Attribute_Reference (Loc,
5685 Prefix =>
5686 New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
5687 Attribute_Name => Name_Size));
5688 Analyze_And_Resolve (N, Typ);
5689 end if;
5690
5691 -- If Size applies to a dereference of an access to unconstrained
5692 -- packed array, the back end needs to see its unconstrained
5693 -- nominal type, but also a hint to the actual constrained type.
5694
5695 if Nkind (Pref) = N_Explicit_Dereference
5696 and then Is_Array_Type (Ptyp)
5697 and then not Is_Constrained (Ptyp)
5698 and then Is_Packed (Ptyp)
5699 then
5700 Set_Actual_Designated_Subtype (Pref,
5701 Get_Actual_Subtype (Pref));
5702 end if;
5703
5704 return;
5705 end if;
5706
5707 -- Common processing for record and array component case
5708
5709 if Siz /= No_Uint and then Siz /= 0 then
5710 declare
5711 CS : constant Boolean := Comes_From_Source (N);
5712
5713 begin
5714 Rewrite (N, Make_Integer_Literal (Loc, Siz));
5715
5716 -- This integer literal is not a static expression. We do not
5717 -- call Analyze_And_Resolve here, because this would activate
5718 -- the circuit for deciding that a static value was out of
5719 -- range, and we don't want that.
5720
5721 -- So just manually set the type, mark the expression as non-
5722 -- static, and then ensure that the result is checked properly
5723 -- if the attribute comes from source (if it was internally
5724 -- generated, we never need a constraint check).
5725
5726 Set_Etype (N, Typ);
5727 Set_Is_Static_Expression (N, False);
5728
5729 if CS then
5730 Apply_Constraint_Check (N, Typ);
5731 end if;
5732 end;
5733 end if;
5734 end Size;
5735
5736 ------------------
5737 -- Storage_Pool --
5738 ------------------
5739
5740 when Attribute_Storage_Pool =>
5741 Rewrite (N,
5742 Make_Type_Conversion (Loc,
5743 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
5744 Expression => New_Occurrence_Of (Entity (N), Loc)));
5745 Analyze_And_Resolve (N, Typ);
5746
5747 ------------------
5748 -- Storage_Size --
5749 ------------------
5750
5751 when Attribute_Storage_Size => Storage_Size : declare
5752 Alloc_Op : Entity_Id := Empty;
5753
5754 begin
5755
5756 -- Access type case, always go to the root type
5757
5758 -- The case of access types results in a value of zero for the case
5759 -- where no storage size attribute clause has been given. If a
5760 -- storage size has been given, then the attribute is converted
5761 -- to a reference to the variable used to hold this value.
5762
5763 if Is_Access_Type (Ptyp) then
5764 if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
5765 Rewrite (N,
5766 Make_Attribute_Reference (Loc,
5767 Prefix => New_Occurrence_Of (Typ, Loc),
5768 Attribute_Name => Name_Max,
5769 Expressions => New_List (
5770 Make_Integer_Literal (Loc, 0),
5771 Convert_To (Typ,
5772 New_Occurrence_Of
5773 (Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
5774
5775 elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
5776
5777 -- If the access type is associated with a simple storage pool
5778 -- object, then attempt to locate the optional Storage_Size
5779 -- function of the simple storage pool type. If not found,
5780 -- then the result will default to zero.
5781
5782 if Present (Get_Rep_Pragma (Root_Type (Ptyp),
5783 Name_Simple_Storage_Pool_Type))
5784 then
5785 declare
5786 Pool_Type : constant Entity_Id :=
5787 Base_Type (Etype (Entity (N)));
5788
5789 begin
5790 Alloc_Op := Get_Name_Entity_Id (Name_Storage_Size);
5791 while Present (Alloc_Op) loop
5792 if Scope (Alloc_Op) = Scope (Pool_Type)
5793 and then Present (First_Formal (Alloc_Op))
5794 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
5795 then
5796 exit;
5797 end if;
5798
5799 Alloc_Op := Homonym (Alloc_Op);
5800 end loop;
5801 end;
5802
5803 -- In the normal Storage_Pool case, retrieve the primitive
5804 -- function associated with the pool type.
5805
5806 else
5807 Alloc_Op :=
5808 Find_Prim_Op
5809 (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
5810 Attribute_Name (N));
5811 end if;
5812
5813 -- If Storage_Size wasn't found (can only occur in the simple
5814 -- storage pool case), then simply use zero for the result.
5815
5816 if not Present (Alloc_Op) then
5817 Rewrite (N, Make_Integer_Literal (Loc, 0));
5818
5819 -- Otherwise, rewrite the allocator as a call to pool type's
5820 -- Storage_Size function.
5821
5822 else
5823 Rewrite (N,
5824 OK_Convert_To (Typ,
5825 Make_Function_Call (Loc,
5826 Name =>
5827 New_Occurrence_Of (Alloc_Op, Loc),
5828
5829 Parameter_Associations => New_List (
5830 New_Occurrence_Of
5831 (Associated_Storage_Pool
5832 (Root_Type (Ptyp)), Loc)))));
5833 end if;
5834
5835 else
5836 Rewrite (N, Make_Integer_Literal (Loc, 0));
5837 end if;
5838
5839 Analyze_And_Resolve (N, Typ);
5840
5841 -- For tasks, we retrieve the size directly from the TCB. The
5842 -- size may depend on a discriminant of the type, and therefore
5843 -- can be a per-object expression, so type-level information is
5844 -- not sufficient in general. There are four cases to consider:
5845
5846 -- a) If the attribute appears within a task body, the designated
5847 -- TCB is obtained by a call to Self.
5848
5849 -- b) If the prefix of the attribute is the name of a task object,
5850 -- the designated TCB is the one stored in the corresponding record.
5851
5852 -- c) If the prefix is a task type, the size is obtained from the
5853 -- size variable created for each task type
5854
5855 -- d) If no Storage_Size was specified for the type, there is no
5856 -- size variable, and the value is a system-specific default.
5857
5858 else
5859 if In_Open_Scopes (Ptyp) then
5860
5861 -- Storage_Size (Self)
5862
5863 Rewrite (N,
5864 Convert_To (Typ,
5865 Make_Function_Call (Loc,
5866 Name =>
5867 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
5868 Parameter_Associations =>
5869 New_List (
5870 Make_Function_Call (Loc,
5871 Name =>
5872 New_Occurrence_Of (RTE (RE_Self), Loc))))));
5873
5874 elsif not Is_Entity_Name (Pref)
5875 or else not Is_Type (Entity (Pref))
5876 then
5877 -- Storage_Size (Rec (Obj).Size)
5878
5879 Rewrite (N,
5880 Convert_To (Typ,
5881 Make_Function_Call (Loc,
5882 Name =>
5883 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
5884 Parameter_Associations =>
5885 New_List (
5886 Make_Selected_Component (Loc,
5887 Prefix =>
5888 Unchecked_Convert_To (
5889 Corresponding_Record_Type (Ptyp),
5890 New_Copy_Tree (Pref)),
5891 Selector_Name =>
5892 Make_Identifier (Loc, Name_uTask_Id))))));
5893
5894 elsif Present (Storage_Size_Variable (Ptyp)) then
5895
5896 -- Static Storage_Size pragma given for type: retrieve value
5897 -- from its allocated storage variable.
5898
5899 Rewrite (N,
5900 Convert_To (Typ,
5901 Make_Function_Call (Loc,
5902 Name => New_Occurrence_Of (
5903 RTE (RE_Adjust_Storage_Size), Loc),
5904 Parameter_Associations =>
5905 New_List (
5906 New_Occurrence_Of (
5907 Storage_Size_Variable (Ptyp), Loc)))));
5908 else
5909 -- Get system default
5910
5911 Rewrite (N,
5912 Convert_To (Typ,
5913 Make_Function_Call (Loc,
5914 Name =>
5915 New_Occurrence_Of (
5916 RTE (RE_Default_Stack_Size), Loc))));
5917 end if;
5918
5919 Analyze_And_Resolve (N, Typ);
5920 end if;
5921 end Storage_Size;
5922
5923 -----------------
5924 -- Stream_Size --
5925 -----------------
5926
5927 when Attribute_Stream_Size =>
5928 Rewrite (N,
5929 Make_Integer_Literal (Loc, Intval => Get_Stream_Size (Ptyp)));
5930 Analyze_And_Resolve (N, Typ);
5931
5932 ----------
5933 -- Succ --
5934 ----------
5935
5936 -- 1. Deal with enumeration types with holes.
5937 -- 2. For floating-point, generate call to attribute function.
5938 -- 3. For other cases, deal with constraint checking.
5939
5940 when Attribute_Succ => Succ : declare
5941 Etyp : constant Entity_Id := Base_Type (Ptyp);
5942
5943 begin
5944
5945 -- For enumeration types with non-standard representations, we
5946 -- expand typ'Succ (x) into
5947
5948 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
5949
5950 -- If the representation is contiguous, we compute instead
5951 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
5952
5953 if Is_Enumeration_Type (Ptyp)
5954 and then Present (Enum_Pos_To_Rep (Etyp))
5955 then
5956 if Has_Contiguous_Rep (Etyp) then
5957 Rewrite (N,
5958 Unchecked_Convert_To (Ptyp,
5959 Make_Op_Add (Loc,
5960 Left_Opnd =>
5961 Make_Integer_Literal (Loc,
5962 Enumeration_Rep (First_Literal (Ptyp))),
5963 Right_Opnd =>
5964 Make_Function_Call (Loc,
5965 Name =>
5966 New_Occurrence_Of
5967 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5968
5969 Parameter_Associations =>
5970 New_List (
5971 Unchecked_Convert_To (Ptyp,
5972 Make_Op_Add (Loc,
5973 Left_Opnd =>
5974 Unchecked_Convert_To (Standard_Integer,
5975 Relocate_Node (First (Exprs))),
5976 Right_Opnd =>
5977 Make_Integer_Literal (Loc, 1))),
5978 Rep_To_Pos_Flag (Ptyp, Loc))))));
5979 else
5980 -- Add Boolean parameter True, to request program errror if
5981 -- we have a bad representation on our hands. Add False if
5982 -- checks are suppressed.
5983
5984 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
5985 Rewrite (N,
5986 Make_Indexed_Component (Loc,
5987 Prefix =>
5988 New_Occurrence_Of
5989 (Enum_Pos_To_Rep (Etyp), Loc),
5990 Expressions => New_List (
5991 Make_Op_Add (Loc,
5992 Left_Opnd =>
5993 Make_Function_Call (Loc,
5994 Name =>
5995 New_Occurrence_Of
5996 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5997 Parameter_Associations => Exprs),
5998 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
5999 end if;
6000
6001 Analyze_And_Resolve (N, Typ);
6002
6003 -- For floating-point, we transform 'Succ into a call to the Succ
6004 -- floating-point attribute function in Fat_xxx (xxx is root type)
6005
6006 elsif Is_Floating_Point_Type (Ptyp) then
6007 Expand_Fpt_Attribute_R (N);
6008 Analyze_And_Resolve (N, Typ);
6009
6010 -- For modular types, nothing to do (no overflow, since wraps)
6011
6012 elsif Is_Modular_Integer_Type (Ptyp) then
6013 null;
6014
6015 -- For other types, if argument is marked as needing a range check or
6016 -- overflow checking is enabled, we must generate a check.
6017
6018 elsif not Overflow_Checks_Suppressed (Ptyp)
6019 or else Do_Range_Check (First (Exprs))
6020 then
6021 Set_Do_Range_Check (First (Exprs), False);
6022 Expand_Pred_Succ_Attribute (N);
6023 end if;
6024 end Succ;
6025
6026 ---------
6027 -- Tag --
6028 ---------
6029
6030 -- Transforms X'Tag into a direct reference to the tag of X
6031
6032 when Attribute_Tag => Tag : declare
6033 Ttyp : Entity_Id;
6034 Prefix_Is_Type : Boolean;
6035
6036 begin
6037 if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then
6038 Ttyp := Entity (Pref);
6039 Prefix_Is_Type := True;
6040 else
6041 Ttyp := Ptyp;
6042 Prefix_Is_Type := False;
6043 end if;
6044
6045 if Is_Class_Wide_Type (Ttyp) then
6046 Ttyp := Root_Type (Ttyp);
6047 end if;
6048
6049 Ttyp := Underlying_Type (Ttyp);
6050
6051 -- Ada 2005: The type may be a synchronized tagged type, in which
6052 -- case the tag information is stored in the corresponding record.
6053
6054 if Is_Concurrent_Type (Ttyp) then
6055 Ttyp := Corresponding_Record_Type (Ttyp);
6056 end if;
6057
6058 if Prefix_Is_Type then
6059
6060 -- For VMs we leave the type attribute unexpanded because
6061 -- there's not a dispatching table to reference.
6062
6063 if Tagged_Type_Expansion then
6064 Rewrite (N,
6065 Unchecked_Convert_To (RTE (RE_Tag),
6066 New_Occurrence_Of
6067 (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc)));
6068 Analyze_And_Resolve (N, RTE (RE_Tag));
6069 end if;
6070
6071 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
6072 -- references the primary tag of the actual object. If 'Tag is
6073 -- applied to class-wide interface objects we generate code that
6074 -- displaces "this" to reference the base of the object.
6075
6076 elsif Comes_From_Source (N)
6077 and then Is_Class_Wide_Type (Etype (Prefix (N)))
6078 and then Is_Interface (Etype (Prefix (N)))
6079 then
6080 -- Generate:
6081 -- (To_Tag_Ptr (Prefix'Address)).all
6082
6083 -- Note that Prefix'Address is recursively expanded into a call
6084 -- to Base_Address (Obj.Tag)
6085
6086 -- Not needed for VM targets, since all handled by the VM
6087
6088 if Tagged_Type_Expansion then
6089 Rewrite (N,
6090 Make_Explicit_Dereference (Loc,
6091 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6092 Make_Attribute_Reference (Loc,
6093 Prefix => Relocate_Node (Pref),
6094 Attribute_Name => Name_Address))));
6095 Analyze_And_Resolve (N, RTE (RE_Tag));
6096 end if;
6097
6098 else
6099 Rewrite (N,
6100 Make_Selected_Component (Loc,
6101 Prefix => Relocate_Node (Pref),
6102 Selector_Name =>
6103 New_Occurrence_Of (First_Tag_Component (Ttyp), Loc)));
6104 Analyze_And_Resolve (N, RTE (RE_Tag));
6105 end if;
6106 end Tag;
6107
6108 ----------------
6109 -- Terminated --
6110 ----------------
6111
6112 -- Transforms 'Terminated attribute into a call to Terminated function
6113
6114 when Attribute_Terminated => Terminated :
6115 begin
6116 -- The prefix of Terminated is of a task interface class-wide type.
6117 -- Generate:
6118 -- terminated (Task_Id (Pref._disp_get_task_id));
6119
6120 if Ada_Version >= Ada_2005
6121 and then Ekind (Ptyp) = E_Class_Wide_Type
6122 and then Is_Interface (Ptyp)
6123 and then Is_Task_Interface (Ptyp)
6124 then
6125 Rewrite (N,
6126 Make_Function_Call (Loc,
6127 Name =>
6128 New_Occurrence_Of (RTE (RE_Terminated), Loc),
6129 Parameter_Associations => New_List (
6130 Make_Unchecked_Type_Conversion (Loc,
6131 Subtype_Mark =>
6132 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
6133 Expression =>
6134 Make_Selected_Component (Loc,
6135 Prefix =>
6136 New_Copy_Tree (Pref),
6137 Selector_Name =>
6138 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
6139
6140 elsif Restricted_Profile then
6141 Rewrite (N,
6142 Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
6143
6144 else
6145 Rewrite (N,
6146 Build_Call_With_Task (Pref, RTE (RE_Terminated)));
6147 end if;
6148
6149 Analyze_And_Resolve (N, Standard_Boolean);
6150 end Terminated;
6151
6152 ----------------
6153 -- To_Address --
6154 ----------------
6155
6156 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
6157 -- unchecked conversion from (integral) type of X to type address.
6158
6159 when Attribute_To_Address | Attribute_Ref =>
6160 Rewrite (N,
6161 Unchecked_Convert_To (RTE (RE_Address),
6162 Relocate_Node (First (Exprs))));
6163 Analyze_And_Resolve (N, RTE (RE_Address));
6164
6165 ------------
6166 -- To_Any --
6167 ------------
6168
6169 when Attribute_To_Any => To_Any : declare
6170 P_Type : constant Entity_Id := Etype (Pref);
6171 Decls : constant List_Id := New_List;
6172 begin
6173 Rewrite (N,
6174 Build_To_Any_Call
6175 (Loc,
6176 Convert_To (P_Type,
6177 Relocate_Node (First (Exprs))), Decls));
6178 Insert_Actions (N, Decls);
6179 Analyze_And_Resolve (N, RTE (RE_Any));
6180 end To_Any;
6181
6182 ----------------
6183 -- Truncation --
6184 ----------------
6185
6186 -- Transforms 'Truncation into a call to the floating-point attribute
6187 -- function Truncation in Fat_xxx (where xxx is the root type).
6188 -- Expansion is avoided for cases the back end can handle directly.
6189
6190 when Attribute_Truncation =>
6191 if not Is_Inline_Floating_Point_Attribute (N) then
6192 Expand_Fpt_Attribute_R (N);
6193 end if;
6194
6195 --------------
6196 -- TypeCode --
6197 --------------
6198
6199 when Attribute_TypeCode => TypeCode : declare
6200 P_Type : constant Entity_Id := Etype (Pref);
6201 Decls : constant List_Id := New_List;
6202 begin
6203 Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls));
6204 Insert_Actions (N, Decls);
6205 Analyze_And_Resolve (N, RTE (RE_TypeCode));
6206 end TypeCode;
6207
6208 -----------------------
6209 -- Unbiased_Rounding --
6210 -----------------------
6211
6212 -- Transforms 'Unbiased_Rounding into a call to the floating-point
6213 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
6214 -- root type). Expansion is avoided for cases the back end can handle
6215 -- directly.
6216
6217 when Attribute_Unbiased_Rounding =>
6218 if not Is_Inline_Floating_Point_Attribute (N) then
6219 Expand_Fpt_Attribute_R (N);
6220 end if;
6221
6222 ------------
6223 -- Update --
6224 ------------
6225
6226 when Attribute_Update =>
6227 Expand_Update_Attribute (N);
6228
6229 ---------------
6230 -- VADS_Size --
6231 ---------------
6232
6233 -- The processing for VADS_Size is shared with Size
6234
6235 ---------
6236 -- Val --
6237 ---------
6238
6239 -- For enumeration types with a standard representation, and for all
6240 -- other types, Val is handled by the back end. For enumeration types
6241 -- with a non-standard representation we use the _Pos_To_Rep array that
6242 -- was created when the type was frozen.
6243
6244 when Attribute_Val => Val : declare
6245 Etyp : constant Entity_Id := Base_Type (Entity (Pref));
6246
6247 begin
6248 if Is_Enumeration_Type (Etyp)
6249 and then Present (Enum_Pos_To_Rep (Etyp))
6250 then
6251 if Has_Contiguous_Rep (Etyp) then
6252 declare
6253 Rep_Node : constant Node_Id :=
6254 Unchecked_Convert_To (Etyp,
6255 Make_Op_Add (Loc,
6256 Left_Opnd =>
6257 Make_Integer_Literal (Loc,
6258 Enumeration_Rep (First_Literal (Etyp))),
6259 Right_Opnd =>
6260 (Convert_To (Standard_Integer,
6261 Relocate_Node (First (Exprs))))));
6262
6263 begin
6264 Rewrite (N,
6265 Unchecked_Convert_To (Etyp,
6266 Make_Op_Add (Loc,
6267 Left_Opnd =>
6268 Make_Integer_Literal (Loc,
6269 Enumeration_Rep (First_Literal (Etyp))),
6270 Right_Opnd =>
6271 Make_Function_Call (Loc,
6272 Name =>
6273 New_Occurrence_Of
6274 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
6275 Parameter_Associations => New_List (
6276 Rep_Node,
6277 Rep_To_Pos_Flag (Etyp, Loc))))));
6278 end;
6279
6280 else
6281 Rewrite (N,
6282 Make_Indexed_Component (Loc,
6283 Prefix => New_Occurrence_Of (Enum_Pos_To_Rep (Etyp), Loc),
6284 Expressions => New_List (
6285 Convert_To (Standard_Integer,
6286 Relocate_Node (First (Exprs))))));
6287 end if;
6288
6289 Analyze_And_Resolve (N, Typ);
6290
6291 -- If the argument is marked as requiring a range check then generate
6292 -- it here.
6293
6294 elsif Do_Range_Check (First (Exprs)) then
6295 Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
6296 end if;
6297 end Val;
6298
6299 -----------
6300 -- Valid --
6301 -----------
6302
6303 -- The code for valid is dependent on the particular types involved.
6304 -- See separate sections below for the generated code in each case.
6305
6306 when Attribute_Valid => Valid : declare
6307 Btyp : Entity_Id := Base_Type (Ptyp);
6308 Tst : Node_Id;
6309
6310 Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
6311 -- Save the validity checking mode. We always turn off validity
6312 -- checking during process of 'Valid since this is one place
6313 -- where we do not want the implicit validity checks to intefere
6314 -- with the explicit validity check that the programmer is doing.
6315
6316 function Make_Range_Test return Node_Id;
6317 -- Build the code for a range test of the form
6318 -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
6319
6320 ---------------------
6321 -- Make_Range_Test --
6322 ---------------------
6323
6324 function Make_Range_Test return Node_Id is
6325 Temp : constant Node_Id := Duplicate_Subexpr (Pref);
6326
6327 begin
6328 -- The value whose validity is being checked has been captured in
6329 -- an object declaration. We certainly don't want this object to
6330 -- appear valid because the declaration initializes it.
6331
6332 if Is_Entity_Name (Temp) then
6333 Set_Is_Known_Valid (Entity (Temp), False);
6334 end if;
6335
6336 return
6337 Make_In (Loc,
6338 Left_Opnd =>
6339 Unchecked_Convert_To (Btyp, Temp),
6340 Right_Opnd =>
6341 Make_Range (Loc,
6342 Low_Bound =>
6343 Unchecked_Convert_To (Btyp,
6344 Make_Attribute_Reference (Loc,
6345 Prefix => New_Occurrence_Of (Ptyp, Loc),
6346 Attribute_Name => Name_First)),
6347 High_Bound =>
6348 Unchecked_Convert_To (Btyp,
6349 Make_Attribute_Reference (Loc,
6350 Prefix => New_Occurrence_Of (Ptyp, Loc),
6351 Attribute_Name => Name_Last))));
6352 end Make_Range_Test;
6353
6354 -- Start of processing for Attribute_Valid
6355
6356 begin
6357 -- Do not expand sourced code 'Valid reference in CodePeer mode,
6358 -- will be handled by the back-end directly.
6359
6360 if CodePeer_Mode and then Comes_From_Source (N) then
6361 return;
6362 end if;
6363
6364 -- Turn off validity checks. We do not want any implicit validity
6365 -- checks to intefere with the explicit check from the attribute
6366
6367 Validity_Checks_On := False;
6368
6369 -- Retrieve the base type. Handle the case where the base type is a
6370 -- private enumeration type.
6371
6372 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
6373 Btyp := Full_View (Btyp);
6374 end if;
6375
6376 -- Floating-point case. This case is handled by the Valid attribute
6377 -- code in the floating-point attribute run-time library.
6378
6379 if Is_Floating_Point_Type (Ptyp) then
6380 Float_Valid : declare
6381 Pkg : RE_Id;
6382 Ftp : Entity_Id;
6383
6384 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id;
6385 -- Return entity for Pkg.Nam
6386
6387 --------------------
6388 -- Get_Fat_Entity --
6389 --------------------
6390
6391 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id is
6392 Exp_Name : constant Node_Id :=
6393 Make_Selected_Component (Loc,
6394 Prefix => New_Occurrence_Of (RTE (Pkg), Loc),
6395 Selector_Name => Make_Identifier (Loc, Nam));
6396 begin
6397 Find_Selected_Component (Exp_Name);
6398 return Entity (Exp_Name);
6399 end Get_Fat_Entity;
6400
6401 -- Start of processing for Float_Valid
6402
6403 begin
6404 -- The C and AAMP back-ends handle Valid for fpt types
6405
6406 if Generate_C_Code or else Float_Rep (Btyp) = AAMP then
6407 Analyze_And_Resolve (Pref, Ptyp);
6408 Set_Etype (N, Standard_Boolean);
6409 Set_Analyzed (N);
6410
6411 else
6412 Find_Fat_Info (Ptyp, Ftp, Pkg);
6413
6414 -- If the prefix is a reverse SSO component, or is possibly
6415 -- unaligned, first create a temporary copy that is in
6416 -- native SSO, and properly aligned. Make it Volatile to
6417 -- prevent folding in the back-end. Note that we use an
6418 -- intermediate constrained string type to initialize the
6419 -- temporary, as the value at hand might be invalid, and in
6420 -- that case it cannot be copied using a floating point
6421 -- register.
6422
6423 if In_Reverse_Storage_Order_Object (Pref)
6424 or else Is_Possibly_Unaligned_Object (Pref)
6425 then
6426 declare
6427 Temp : constant Entity_Id :=
6428 Make_Temporary (Loc, 'F');
6429
6430 Fat_S : constant Entity_Id :=
6431 Get_Fat_Entity (Name_S);
6432 -- Constrained string subtype of appropriate size
6433
6434 Fat_P : constant Entity_Id :=
6435 Get_Fat_Entity (Name_P);
6436 -- Access to Fat_S
6437
6438 Decl : constant Node_Id :=
6439 Make_Object_Declaration (Loc,
6440 Defining_Identifier => Temp,
6441 Aliased_Present => True,
6442 Object_Definition =>
6443 New_Occurrence_Of (Ptyp, Loc));
6444
6445 begin
6446 Set_Aspect_Specifications (Decl, New_List (
6447 Make_Aspect_Specification (Loc,
6448 Identifier =>
6449 Make_Identifier (Loc, Name_Volatile))));
6450
6451 Insert_Actions (N,
6452 New_List (
6453 Decl,
6454
6455 Make_Assignment_Statement (Loc,
6456 Name =>
6457 Make_Explicit_Dereference (Loc,
6458 Prefix =>
6459 Unchecked_Convert_To (Fat_P,
6460 Make_Attribute_Reference (Loc,
6461 Prefix =>
6462 New_Occurrence_Of (Temp, Loc),
6463 Attribute_Name =>
6464 Name_Unrestricted_Access))),
6465 Expression =>
6466 Unchecked_Convert_To (Fat_S,
6467 Relocate_Node (Pref)))),
6468
6469 Suppress => All_Checks);
6470
6471 Rewrite (Pref, New_Occurrence_Of (Temp, Loc));
6472 end;
6473 end if;
6474
6475 -- We now have an object of the proper endianness and
6476 -- alignment, and can construct a Valid attribute.
6477
6478 -- We make sure the prefix of this valid attribute is
6479 -- marked as not coming from source, to avoid losing
6480 -- warnings from 'Valid looking like a possible update.
6481
6482 Set_Comes_From_Source (Pref, False);
6483
6484 Expand_Fpt_Attribute
6485 (N, Pkg, Name_Valid,
6486 New_List (
6487 Make_Attribute_Reference (Loc,
6488 Prefix => Unchecked_Convert_To (Ftp, Pref),
6489 Attribute_Name => Name_Unrestricted_Access)));
6490 end if;
6491
6492 -- One more task, we still need a range check. Required
6493 -- only if we have a constraint, since the Valid routine
6494 -- catches infinities properly (infinities are never valid).
6495
6496 -- The way we do the range check is simply to create the
6497 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
6498
6499 if not Subtypes_Statically_Match (Ptyp, Btyp) then
6500 Rewrite (N,
6501 Make_And_Then (Loc,
6502 Left_Opnd => Relocate_Node (N),
6503 Right_Opnd =>
6504 Make_In (Loc,
6505 Left_Opnd => Convert_To (Btyp, Pref),
6506 Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
6507 end if;
6508 end Float_Valid;
6509
6510 -- Enumeration type with holes
6511
6512 -- For enumeration types with holes, the Pos value constructed by
6513 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
6514 -- second argument of False returns minus one for an invalid value,
6515 -- and the non-negative pos value for a valid value, so the
6516 -- expansion of X'Valid is simply:
6517
6518 -- type(X)'Pos (X) >= 0
6519
6520 -- We can't quite generate it that way because of the requirement
6521 -- for the non-standard second argument of False in the resulting
6522 -- rep_to_pos call, so we have to explicitly create:
6523
6524 -- _rep_to_pos (X, False) >= 0
6525
6526 -- If we have an enumeration subtype, we also check that the
6527 -- value is in range:
6528
6529 -- _rep_to_pos (X, False) >= 0
6530 -- and then
6531 -- (X >= type(X)'First and then type(X)'Last <= X)
6532
6533 elsif Is_Enumeration_Type (Ptyp)
6534 and then Present (Enum_Pos_To_Rep (Btyp))
6535 then
6536 Tst :=
6537 Make_Op_Ge (Loc,
6538 Left_Opnd =>
6539 Make_Function_Call (Loc,
6540 Name =>
6541 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
6542 Parameter_Associations => New_List (
6543 Pref,
6544 New_Occurrence_Of (Standard_False, Loc))),
6545 Right_Opnd => Make_Integer_Literal (Loc, 0));
6546
6547 if Ptyp /= Btyp
6548 and then
6549 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
6550 or else
6551 Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
6552 then
6553 -- The call to Make_Range_Test will create declarations
6554 -- that need a proper insertion point, but Pref is now
6555 -- attached to a node with no ancestor. Attach to tree
6556 -- even if it is to be rewritten below.
6557
6558 Set_Parent (Tst, Parent (N));
6559
6560 Tst :=
6561 Make_And_Then (Loc,
6562 Left_Opnd => Make_Range_Test,
6563 Right_Opnd => Tst);
6564 end if;
6565
6566 Rewrite (N, Tst);
6567
6568 -- Fortran convention booleans
6569
6570 -- For the very special case of Fortran convention booleans, the
6571 -- value is always valid, since it is an integer with the semantics
6572 -- that non-zero is true, and any value is permissible.
6573
6574 elsif Is_Boolean_Type (Ptyp)
6575 and then Convention (Ptyp) = Convention_Fortran
6576 then
6577 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6578
6579 -- For biased representations, we will be doing an unchecked
6580 -- conversion without unbiasing the result. That means that the range
6581 -- test has to take this into account, and the proper form of the
6582 -- test is:
6583
6584 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
6585
6586 elsif Has_Biased_Representation (Ptyp) then
6587 Btyp := RTE (RE_Unsigned_32);
6588 Rewrite (N,
6589 Make_Op_Lt (Loc,
6590 Left_Opnd =>
6591 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
6592 Right_Opnd =>
6593 Unchecked_Convert_To (Btyp,
6594 Make_Attribute_Reference (Loc,
6595 Prefix => New_Occurrence_Of (Ptyp, Loc),
6596 Attribute_Name => Name_Range_Length))));
6597
6598 -- For all other scalar types, what we want logically is a
6599 -- range test:
6600
6601 -- X in type(X)'First .. type(X)'Last
6602
6603 -- But that's precisely what won't work because of possible
6604 -- unwanted optimization (and indeed the basic motivation for
6605 -- the Valid attribute is exactly that this test does not work).
6606 -- What will work is:
6607
6608 -- Btyp!(X) >= Btyp!(type(X)'First)
6609 -- and then
6610 -- Btyp!(X) <= Btyp!(type(X)'Last)
6611
6612 -- where Btyp is an integer type large enough to cover the full
6613 -- range of possible stored values (i.e. it is chosen on the basis
6614 -- of the size of the type, not the range of the values). We write
6615 -- this as two tests, rather than a range check, so that static
6616 -- evaluation will easily remove either or both of the checks if
6617 -- they can be -statically determined to be true (this happens
6618 -- when the type of X is static and the range extends to the full
6619 -- range of stored values).
6620
6621 -- Unsigned types. Note: it is safe to consider only whether the
6622 -- subtype is unsigned, since we will in that case be doing all
6623 -- unsigned comparisons based on the subtype range. Since we use the
6624 -- actual subtype object size, this is appropriate.
6625
6626 -- For example, if we have
6627
6628 -- subtype x is integer range 1 .. 200;
6629 -- for x'Object_Size use 8;
6630
6631 -- Now the base type is signed, but objects of this type are bits
6632 -- unsigned, and doing an unsigned test of the range 1 to 200 is
6633 -- correct, even though a value greater than 127 looks signed to a
6634 -- signed comparison.
6635
6636 elsif Is_Unsigned_Type (Ptyp) then
6637 if Esize (Ptyp) <= 32 then
6638 Btyp := RTE (RE_Unsigned_32);
6639 else
6640 Btyp := RTE (RE_Unsigned_64);
6641 end if;
6642
6643 Rewrite (N, Make_Range_Test);
6644
6645 -- Signed types
6646
6647 else
6648 if Esize (Ptyp) <= Esize (Standard_Integer) then
6649 Btyp := Standard_Integer;
6650 else
6651 Btyp := Universal_Integer;
6652 end if;
6653
6654 Rewrite (N, Make_Range_Test);
6655 end if;
6656
6657 -- If a predicate is present, then we do the predicate test, even if
6658 -- within the predicate function (infinite recursion is warned about
6659 -- in Sem_Attr in that case).
6660
6661 declare
6662 Pred_Func : constant Entity_Id := Predicate_Function (Ptyp);
6663
6664 begin
6665 if Present (Pred_Func) then
6666 Rewrite (N,
6667 Make_And_Then (Loc,
6668 Left_Opnd => Relocate_Node (N),
6669 Right_Opnd => Make_Predicate_Call (Ptyp, Pref)));
6670 end if;
6671 end;
6672
6673 Analyze_And_Resolve (N, Standard_Boolean);
6674 Validity_Checks_On := Save_Validity_Checks_On;
6675 end Valid;
6676
6677 -------------------
6678 -- Valid_Scalars --
6679 -------------------
6680
6681 when Attribute_Valid_Scalars => Valid_Scalars : declare
6682 Ftyp : Entity_Id;
6683
6684 begin
6685 if Present (Underlying_Type (Ptyp)) then
6686 Ftyp := Underlying_Type (Ptyp);
6687 else
6688 Ftyp := Ptyp;
6689 end if;
6690
6691 -- Replace by True if no scalar parts
6692
6693 if not Scalar_Part_Present (Ftyp) then
6694 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6695
6696 -- For scalar types, Valid_Scalars is the same as Valid
6697
6698 elsif Is_Scalar_Type (Ftyp) then
6699 Rewrite (N,
6700 Make_Attribute_Reference (Loc,
6701 Attribute_Name => Name_Valid,
6702 Prefix => Pref));
6703
6704 -- For array types, we construct a function that determines if there
6705 -- are any non-valid scalar subcomponents, and call the function.
6706 -- We only do this for arrays whose component type needs checking
6707
6708 elsif Is_Array_Type (Ftyp)
6709 and then Scalar_Part_Present (Component_Type (Ftyp))
6710 then
6711 Rewrite (N,
6712 Make_Function_Call (Loc,
6713 Name =>
6714 New_Occurrence_Of (Build_Array_VS_Func (Ftyp, N), Loc),
6715 Parameter_Associations => New_List (Pref)));
6716
6717 -- For record types, we construct a function that determines if there
6718 -- are any non-valid scalar subcomponents, and call the function.
6719
6720 elsif Is_Record_Type (Ftyp)
6721 and then Nkind (Type_Definition (Declaration_Node (Ftyp))) =
6722 N_Record_Definition
6723 then
6724 Rewrite (N,
6725 Make_Function_Call (Loc,
6726 Name =>
6727 New_Occurrence_Of (Build_Record_VS_Func (Ftyp, N), Loc),
6728 Parameter_Associations => New_List (Pref)));
6729
6730 -- Other record types or types with discriminants
6731
6732 elsif Is_Record_Type (Ftyp) or else Has_Discriminants (Ptyp) then
6733
6734 -- Build expression with list of equality tests
6735
6736 declare
6737 C : Entity_Id;
6738 X : Node_Id;
6739 A : Name_Id;
6740
6741 begin
6742 X := New_Occurrence_Of (Standard_True, Loc);
6743 C := First_Component_Or_Discriminant (Ptyp);
6744 while Present (C) loop
6745 if not Scalar_Part_Present (Etype (C)) then
6746 goto Continue;
6747 elsif Is_Scalar_Type (Etype (C)) then
6748 A := Name_Valid;
6749 else
6750 A := Name_Valid_Scalars;
6751 end if;
6752
6753 X :=
6754 Make_And_Then (Loc,
6755 Left_Opnd => X,
6756 Right_Opnd =>
6757 Make_Attribute_Reference (Loc,
6758 Attribute_Name => A,
6759 Prefix =>
6760 Make_Selected_Component (Loc,
6761 Prefix =>
6762 Duplicate_Subexpr (Pref, Name_Req => True),
6763 Selector_Name =>
6764 New_Occurrence_Of (C, Loc))));
6765 <<Continue>>
6766 Next_Component_Or_Discriminant (C);
6767 end loop;
6768
6769 Rewrite (N, X);
6770 end;
6771
6772 -- For all other types, result is True
6773
6774 else
6775 Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc));
6776 end if;
6777
6778 -- Result is always boolean, but never static
6779
6780 Analyze_And_Resolve (N, Standard_Boolean);
6781 Set_Is_Static_Expression (N, False);
6782 end Valid_Scalars;
6783
6784 -----------
6785 -- Value --
6786 -----------
6787
6788 -- Value attribute is handled in separate unit Exp_Imgv
6789
6790 when Attribute_Value =>
6791 Exp_Imgv.Expand_Value_Attribute (N);
6792
6793 -----------------
6794 -- Value_Size --
6795 -----------------
6796
6797 -- The processing for Value_Size shares the processing for Size
6798
6799 -------------
6800 -- Version --
6801 -------------
6802
6803 -- The processing for Version shares the processing for Body_Version
6804
6805 ----------------
6806 -- Wide_Image --
6807 ----------------
6808
6809 -- Wide_Image attribute is handled in separate unit Exp_Imgv
6810
6811 when Attribute_Wide_Image =>
6812 Exp_Imgv.Expand_Wide_Image_Attribute (N);
6813
6814 ---------------------
6815 -- Wide_Wide_Image --
6816 ---------------------
6817
6818 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
6819
6820 when Attribute_Wide_Wide_Image =>
6821 Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N);
6822
6823 ----------------
6824 -- Wide_Value --
6825 ----------------
6826
6827 -- We expand typ'Wide_Value (X) into
6828
6829 -- typ'Value
6830 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
6831
6832 -- Wide_String_To_String is a runtime function that converts its wide
6833 -- string argument to String, converting any non-translatable characters
6834 -- into appropriate escape sequences. This preserves the required
6835 -- semantics of Wide_Value in all cases, and results in a very simple
6836 -- implementation approach.
6837
6838 -- Note: for this approach to be fully standard compliant for the cases
6839 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
6840 -- method must cover the entire character range (e.g. UTF-8). But that
6841 -- is a reasonable requirement when dealing with encoded character
6842 -- sequences. Presumably if one of the restrictive encoding mechanisms
6843 -- is in use such as Shift-JIS, then characters that cannot be
6844 -- represented using this encoding will not appear in any case.
6845
6846 when Attribute_Wide_Value => Wide_Value :
6847 begin
6848 Rewrite (N,
6849 Make_Attribute_Reference (Loc,
6850 Prefix => Pref,
6851 Attribute_Name => Name_Value,
6852
6853 Expressions => New_List (
6854 Make_Function_Call (Loc,
6855 Name =>
6856 New_Occurrence_Of (RTE (RE_Wide_String_To_String), Loc),
6857
6858 Parameter_Associations => New_List (
6859 Relocate_Node (First (Exprs)),
6860 Make_Integer_Literal (Loc,
6861 Intval => Int (Wide_Character_Encoding_Method)))))));
6862
6863 Analyze_And_Resolve (N, Typ);
6864 end Wide_Value;
6865
6866 ---------------------
6867 -- Wide_Wide_Value --
6868 ---------------------
6869
6870 -- We expand typ'Wide_Value_Value (X) into
6871
6872 -- typ'Value
6873 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
6874
6875 -- Wide_Wide_String_To_String is a runtime function that converts its
6876 -- wide string argument to String, converting any non-translatable
6877 -- characters into appropriate escape sequences. This preserves the
6878 -- required semantics of Wide_Wide_Value in all cases, and results in a
6879 -- very simple implementation approach.
6880
6881 -- It's not quite right where typ = Wide_Wide_Character, because the
6882 -- encoding method may not cover the whole character type ???
6883
6884 when Attribute_Wide_Wide_Value => Wide_Wide_Value :
6885 begin
6886 Rewrite (N,
6887 Make_Attribute_Reference (Loc,
6888 Prefix => Pref,
6889 Attribute_Name => Name_Value,
6890
6891 Expressions => New_List (
6892 Make_Function_Call (Loc,
6893 Name =>
6894 New_Occurrence_Of
6895 (RTE (RE_Wide_Wide_String_To_String), Loc),
6896
6897 Parameter_Associations => New_List (
6898 Relocate_Node (First (Exprs)),
6899 Make_Integer_Literal (Loc,
6900 Intval => Int (Wide_Character_Encoding_Method)))))));
6901
6902 Analyze_And_Resolve (N, Typ);
6903 end Wide_Wide_Value;
6904
6905 ---------------------
6906 -- Wide_Wide_Width --
6907 ---------------------
6908
6909 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
6910
6911 when Attribute_Wide_Wide_Width =>
6912 Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide);
6913
6914 ----------------
6915 -- Wide_Width --
6916 ----------------
6917
6918 -- Wide_Width attribute is handled in separate unit Exp_Imgv
6919
6920 when Attribute_Wide_Width =>
6921 Exp_Imgv.Expand_Width_Attribute (N, Wide);
6922
6923 -----------
6924 -- Width --
6925 -----------
6926
6927 -- Width attribute is handled in separate unit Exp_Imgv
6928
6929 when Attribute_Width =>
6930 Exp_Imgv.Expand_Width_Attribute (N, Normal);
6931
6932 -----------
6933 -- Write --
6934 -----------
6935
6936 when Attribute_Write => Write : declare
6937 P_Type : constant Entity_Id := Entity (Pref);
6938 U_Type : constant Entity_Id := Underlying_Type (P_Type);
6939 Pname : Entity_Id;
6940 Decl : Node_Id;
6941 Prag : Node_Id;
6942 Arg3 : Node_Id;
6943 Wfunc : Node_Id;
6944
6945 begin
6946 -- If no underlying type, we have an error that will be diagnosed
6947 -- elsewhere, so here we just completely ignore the expansion.
6948
6949 if No (U_Type) then
6950 return;
6951 end if;
6952
6953 -- Stream operations can appear in user code even if the restriction
6954 -- No_Streams is active (for example, when instantiating a predefined
6955 -- container). In that case rewrite the attribute as a Raise to
6956 -- prevent any run-time use.
6957
6958 if Restriction_Active (No_Streams) then
6959 Rewrite (N,
6960 Make_Raise_Program_Error (Sloc (N),
6961 Reason => PE_Stream_Operation_Not_Allowed));
6962 Set_Etype (N, U_Type);
6963 return;
6964 end if;
6965
6966 -- The simple case, if there is a TSS for Write, just call it
6967
6968 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
6969
6970 if Present (Pname) then
6971 null;
6972
6973 else
6974 -- If there is a Stream_Convert pragma, use it, we rewrite
6975
6976 -- sourcetyp'Output (stream, Item)
6977
6978 -- as
6979
6980 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
6981
6982 -- where strmwrite is the given Write function that converts an
6983 -- argument of type sourcetyp or a type acctyp, from which it is
6984 -- derived to type strmtyp. The conversion to acttyp is required
6985 -- for the derived case.
6986
6987 Prag := Get_Stream_Convert_Pragma (P_Type);
6988
6989 if Present (Prag) then
6990 Arg3 :=
6991 Next (Next (First (Pragma_Argument_Associations (Prag))));
6992 Wfunc := Entity (Expression (Arg3));
6993
6994 Rewrite (N,
6995 Make_Attribute_Reference (Loc,
6996 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
6997 Attribute_Name => Name_Output,
6998 Expressions => New_List (
6999 Relocate_Node (First (Exprs)),
7000 Make_Function_Call (Loc,
7001 Name => New_Occurrence_Of (Wfunc, Loc),
7002 Parameter_Associations => New_List (
7003 OK_Convert_To (Etype (First_Formal (Wfunc)),
7004 Relocate_Node (Next (First (Exprs)))))))));
7005
7006 Analyze (N);
7007 return;
7008
7009 -- For elementary types, we call the W_xxx routine directly
7010
7011 elsif Is_Elementary_Type (U_Type) then
7012 Rewrite (N, Build_Elementary_Write_Call (N));
7013 Analyze (N);
7014 return;
7015
7016 -- Array type case
7017
7018 elsif Is_Array_Type (U_Type) then
7019 Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
7020 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
7021
7022 -- Tagged type case, use the primitive Write function. Note that
7023 -- this will dispatch in the class-wide case which is what we want
7024
7025 elsif Is_Tagged_Type (U_Type) then
7026 Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
7027
7028 -- All other record type cases, including protected records.
7029 -- The latter only arise for expander generated code for
7030 -- handling shared passive partition access.
7031
7032 else
7033 pragma Assert
7034 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
7035
7036 -- Ada 2005 (AI-216): Program_Error is raised when executing
7037 -- the default implementation of the Write attribute of an
7038 -- Unchecked_Union type. However, if the 'Write reference is
7039 -- within the generated Output stream procedure, Write outputs
7040 -- the components, and the default values of the discriminant
7041 -- are streamed by the Output procedure itself.
7042
7043 if Is_Unchecked_Union (Base_Type (U_Type))
7044 and not Is_TSS (Current_Scope, TSS_Stream_Output)
7045 then
7046 Insert_Action (N,
7047 Make_Raise_Program_Error (Loc,
7048 Reason => PE_Unchecked_Union_Restriction));
7049 end if;
7050
7051 if Has_Discriminants (U_Type)
7052 and then Present
7053 (Discriminant_Default_Value (First_Discriminant (U_Type)))
7054 then
7055 Build_Mutable_Record_Write_Procedure
7056 (Loc, Full_Base (U_Type), Decl, Pname);
7057 else
7058 Build_Record_Write_Procedure
7059 (Loc, Full_Base (U_Type), Decl, Pname);
7060 end if;
7061
7062 Insert_Action (N, Decl);
7063 end if;
7064 end if;
7065
7066 -- If we fall through, Pname is the procedure to be called
7067
7068 Rewrite_Stream_Proc_Call (Pname);
7069 end Write;
7070
7071 -- Component_Size is handled by the back end, unless the component size
7072 -- is known at compile time, which is always true in the packed array
7073 -- case. It is important that the packed array case is handled in the
7074 -- front end (see Eval_Attribute) since the back end would otherwise get
7075 -- confused by the equivalent packed array type.
7076
7077 when Attribute_Component_Size =>
7078 null;
7079
7080 -- The following attributes are handled by the back end (except that
7081 -- static cases have already been evaluated during semantic processing,
7082 -- but in any case the back end should not count on this).
7083
7084 -- The back end also handles the non-class-wide cases of Size
7085
7086 when Attribute_Bit_Order |
7087 Attribute_Code_Address |
7088 Attribute_Definite |
7089 Attribute_Deref |
7090 Attribute_Null_Parameter |
7091 Attribute_Passed_By_Reference |
7092 Attribute_Pool_Address |
7093 Attribute_Scalar_Storage_Order =>
7094 null;
7095
7096 -- The following attributes are also handled by the back end, but return
7097 -- a universal integer result, so may need a conversion for checking
7098 -- that the result is in range.
7099
7100 when Attribute_Aft |
7101 Attribute_Max_Alignment_For_Allocation =>
7102 Apply_Universal_Integer_Attribute_Checks (N);
7103
7104 -- The following attributes should not appear at this stage, since they
7105 -- have already been handled by the analyzer (and properly rewritten
7106 -- with corresponding values or entities to represent the right values)
7107
7108 when Attribute_Abort_Signal |
7109 Attribute_Address_Size |
7110 Attribute_Atomic_Always_Lock_Free |
7111 Attribute_Base |
7112 Attribute_Class |
7113 Attribute_Compiler_Version |
7114 Attribute_Default_Bit_Order |
7115 Attribute_Default_Scalar_Storage_Order |
7116 Attribute_Delta |
7117 Attribute_Denorm |
7118 Attribute_Digits |
7119 Attribute_Emax |
7120 Attribute_Enabled |
7121 Attribute_Epsilon |
7122 Attribute_Fast_Math |
7123 Attribute_First_Valid |
7124 Attribute_Has_Access_Values |
7125 Attribute_Has_Discriminants |
7126 Attribute_Has_Tagged_Values |
7127 Attribute_Large |
7128 Attribute_Last_Valid |
7129 Attribute_Library_Level |
7130 Attribute_Lock_Free |
7131 Attribute_Machine_Emax |
7132 Attribute_Machine_Emin |
7133 Attribute_Machine_Mantissa |
7134 Attribute_Machine_Overflows |
7135 Attribute_Machine_Radix |
7136 Attribute_Machine_Rounds |
7137 Attribute_Maximum_Alignment |
7138 Attribute_Model_Emin |
7139 Attribute_Model_Epsilon |
7140 Attribute_Model_Mantissa |
7141 Attribute_Model_Small |
7142 Attribute_Modulus |
7143 Attribute_Partition_ID |
7144 Attribute_Range |
7145 Attribute_Restriction_Set |
7146 Attribute_Safe_Emax |
7147 Attribute_Safe_First |
7148 Attribute_Safe_Large |
7149 Attribute_Safe_Last |
7150 Attribute_Safe_Small |
7151 Attribute_Scale |
7152 Attribute_Signed_Zeros |
7153 Attribute_Small |
7154 Attribute_Storage_Unit |
7155 Attribute_Stub_Type |
7156 Attribute_System_Allocator_Alignment |
7157 Attribute_Target_Name |
7158 Attribute_Type_Class |
7159 Attribute_Type_Key |
7160 Attribute_Unconstrained_Array |
7161 Attribute_Universal_Literal_String |
7162 Attribute_Wchar_T_Size |
7163 Attribute_Word_Size =>
7164 raise Program_Error;
7165
7166 -- The Asm_Input and Asm_Output attributes are not expanded at this
7167 -- stage, but will be eliminated in the expansion of the Asm call, see
7168 -- Exp_Intr for details. So the back end will never see these either.
7169
7170 when Attribute_Asm_Input |
7171 Attribute_Asm_Output =>
7172 null;
7173 end case;
7174
7175 -- Note: as mentioned earlier, individual sections of the above case
7176 -- statement assume there is no code after the case statement, and are
7177 -- legitimately allowed to execute return statements if they have nothing
7178 -- more to do, so DO NOT add code at this point.
7179
7180 exception
7181 when RE_Not_Available =>
7182 return;
7183 end Expand_N_Attribute_Reference;
7184
7185 --------------------------------
7186 -- Expand_Pred_Succ_Attribute --
7187 --------------------------------
7188
7189 -- For typ'Pred (exp), we generate the check
7190
7191 -- [constraint_error when exp = typ'Base'First]
7192
7193 -- Similarly, for typ'Succ (exp), we generate the check
7194
7195 -- [constraint_error when exp = typ'Base'Last]
7196
7197 -- These checks are not generated for modular types, since the proper
7198 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
7199 -- We also suppress these checks if we are the right side of an assignment
7200 -- statement or the expression of an object declaration, where the flag
7201 -- Suppress_Assignment_Checks is set for the assignment/declaration.
7202
7203 procedure Expand_Pred_Succ_Attribute (N : Node_Id) is
7204 Loc : constant Source_Ptr := Sloc (N);
7205 P : constant Node_Id := Parent (N);
7206 Cnam : Name_Id;
7207
7208 begin
7209 if Attribute_Name (N) = Name_Pred then
7210 Cnam := Name_First;
7211 else
7212 Cnam := Name_Last;
7213 end if;
7214
7215 if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration)
7216 or else not Suppress_Assignment_Checks (P)
7217 then
7218 Insert_Action (N,
7219 Make_Raise_Constraint_Error (Loc,
7220 Condition =>
7221 Make_Op_Eq (Loc,
7222 Left_Opnd =>
7223 Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
7224 Right_Opnd =>
7225 Make_Attribute_Reference (Loc,
7226 Prefix =>
7227 New_Occurrence_Of (Base_Type (Etype (Prefix (N))), Loc),
7228 Attribute_Name => Cnam)),
7229 Reason => CE_Overflow_Check_Failed));
7230 end if;
7231 end Expand_Pred_Succ_Attribute;
7232
7233 -----------------------------
7234 -- Expand_Update_Attribute --
7235 -----------------------------
7236
7237 procedure Expand_Update_Attribute (N : Node_Id) is
7238 procedure Process_Component_Or_Element_Update
7239 (Temp : Entity_Id;
7240 Comp : Node_Id;
7241 Expr : Node_Id;
7242 Typ : Entity_Id);
7243 -- Generate the statements necessary to update a single component or an
7244 -- element of the prefix. The code is inserted before the attribute N.
7245 -- Temp denotes the entity of the anonymous object created to reflect
7246 -- the changes in values. Comp is the component/index expression to be
7247 -- updated. Expr is an expression yielding the new value of Comp. Typ
7248 -- is the type of the prefix of attribute Update.
7249
7250 procedure Process_Range_Update
7251 (Temp : Entity_Id;
7252 Comp : Node_Id;
7253 Expr : Node_Id;
7254 Typ : Entity_Id);
7255 -- Generate the statements necessary to update a slice of the prefix.
7256 -- The code is inserted before the attribute N. Temp denotes the entity
7257 -- of the anonymous object created to reflect the changes in values.
7258 -- Comp is range of the slice to be updated. Expr is an expression
7259 -- yielding the new value of Comp. Typ is the type of the prefix of
7260 -- attribute Update.
7261
7262 -----------------------------------------
7263 -- Process_Component_Or_Element_Update --
7264 -----------------------------------------
7265
7266 procedure Process_Component_Or_Element_Update
7267 (Temp : Entity_Id;
7268 Comp : Node_Id;
7269 Expr : Node_Id;
7270 Typ : Entity_Id)
7271 is
7272 Loc : constant Source_Ptr := Sloc (Comp);
7273 Exprs : List_Id;
7274 LHS : Node_Id;
7275
7276 begin
7277 -- An array element may be modified by the following relations
7278 -- depending on the number of dimensions:
7279
7280 -- 1 => Expr -- one dimensional update
7281 -- (1, ..., N) => Expr -- multi dimensional update
7282
7283 -- The above forms are converted in assignment statements where the
7284 -- left hand side is an indexed component:
7285
7286 -- Temp (1) := Expr; -- one dimensional update
7287 -- Temp (1, ..., N) := Expr; -- multi dimensional update
7288
7289 if Is_Array_Type (Typ) then
7290
7291 -- The index expressions of a multi dimensional array update
7292 -- appear as an aggregate.
7293
7294 if Nkind (Comp) = N_Aggregate then
7295 Exprs := New_Copy_List_Tree (Expressions (Comp));
7296 else
7297 Exprs := New_List (Relocate_Node (Comp));
7298 end if;
7299
7300 LHS :=
7301 Make_Indexed_Component (Loc,
7302 Prefix => New_Occurrence_Of (Temp, Loc),
7303 Expressions => Exprs);
7304
7305 -- A record component update appears in the following form:
7306
7307 -- Comp => Expr
7308
7309 -- The above relation is transformed into an assignment statement
7310 -- where the left hand side is a selected component:
7311
7312 -- Temp.Comp := Expr;
7313
7314 else pragma Assert (Is_Record_Type (Typ));
7315 LHS :=
7316 Make_Selected_Component (Loc,
7317 Prefix => New_Occurrence_Of (Temp, Loc),
7318 Selector_Name => Relocate_Node (Comp));
7319 end if;
7320
7321 Insert_Action (N,
7322 Make_Assignment_Statement (Loc,
7323 Name => LHS,
7324 Expression => Relocate_Node (Expr)));
7325 end Process_Component_Or_Element_Update;
7326
7327 --------------------------
7328 -- Process_Range_Update --
7329 --------------------------
7330
7331 procedure Process_Range_Update
7332 (Temp : Entity_Id;
7333 Comp : Node_Id;
7334 Expr : Node_Id;
7335 Typ : Entity_Id)
7336 is
7337 Index_Typ : constant Entity_Id := Etype (First_Index (Typ));
7338 Loc : constant Source_Ptr := Sloc (Comp);
7339 Index : Entity_Id;
7340
7341 begin
7342 -- A range update appears as
7343
7344 -- (Low .. High => Expr)
7345
7346 -- The above construct is transformed into a loop that iterates over
7347 -- the given range and modifies the corresponding array values to the
7348 -- value of Expr:
7349
7350 -- for Index in Low .. High loop
7351 -- Temp (<Index_Typ> (Index)) := Expr;
7352 -- end loop;
7353
7354 Index := Make_Temporary (Loc, 'I');
7355
7356 Insert_Action (N,
7357 Make_Loop_Statement (Loc,
7358 Iteration_Scheme =>
7359 Make_Iteration_Scheme (Loc,
7360 Loop_Parameter_Specification =>
7361 Make_Loop_Parameter_Specification (Loc,
7362 Defining_Identifier => Index,
7363 Discrete_Subtype_Definition => Relocate_Node (Comp))),
7364
7365 Statements => New_List (
7366 Make_Assignment_Statement (Loc,
7367 Name =>
7368 Make_Indexed_Component (Loc,
7369 Prefix => New_Occurrence_Of (Temp, Loc),
7370 Expressions => New_List (
7371 Convert_To (Index_Typ,
7372 New_Occurrence_Of (Index, Loc)))),
7373 Expression => Relocate_Node (Expr))),
7374
7375 End_Label => Empty));
7376 end Process_Range_Update;
7377
7378 -- Local variables
7379
7380 Aggr : constant Node_Id := First (Expressions (N));
7381 Loc : constant Source_Ptr := Sloc (N);
7382 Pref : constant Node_Id := Prefix (N);
7383 Typ : constant Entity_Id := Etype (Pref);
7384 Assoc : Node_Id;
7385 Comp : Node_Id;
7386 CW_Temp : Entity_Id;
7387 CW_Typ : Entity_Id;
7388 Expr : Node_Id;
7389 Temp : Entity_Id;
7390
7391 -- Start of processing for Expand_Update_Attribute
7392
7393 begin
7394 -- Create the anonymous object to store the value of the prefix and
7395 -- capture subsequent changes in value.
7396
7397 Temp := Make_Temporary (Loc, 'T', Pref);
7398
7399 -- Preserve the tag of the prefix by offering a specific view of the
7400 -- class-wide version of the prefix.
7401
7402 if Is_Tagged_Type (Typ) then
7403
7404 -- Generate:
7405 -- CW_Temp : Typ'Class := Typ'Class (Pref);
7406
7407 CW_Temp := Make_Temporary (Loc, 'T');
7408 CW_Typ := Class_Wide_Type (Typ);
7409
7410 Insert_Action (N,
7411 Make_Object_Declaration (Loc,
7412 Defining_Identifier => CW_Temp,
7413 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
7414 Expression =>
7415 Convert_To (CW_Typ, Relocate_Node (Pref))));
7416
7417 -- Generate:
7418 -- Temp : Typ renames Typ (CW_Temp);
7419
7420 Insert_Action (N,
7421 Make_Object_Renaming_Declaration (Loc,
7422 Defining_Identifier => Temp,
7423 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
7424 Name =>
7425 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))));
7426
7427 -- Non-tagged case
7428
7429 else
7430 -- Generate:
7431 -- Temp : Typ := Pref;
7432
7433 Insert_Action (N,
7434 Make_Object_Declaration (Loc,
7435 Defining_Identifier => Temp,
7436 Object_Definition => New_Occurrence_Of (Typ, Loc),
7437 Expression => Relocate_Node (Pref)));
7438 end if;
7439
7440 -- Process the update aggregate
7441
7442 Assoc := First (Component_Associations (Aggr));
7443 while Present (Assoc) loop
7444 Comp := First (Choices (Assoc));
7445 Expr := Expression (Assoc);
7446 while Present (Comp) loop
7447 if Nkind (Comp) = N_Range then
7448 Process_Range_Update (Temp, Comp, Expr, Typ);
7449 else
7450 Process_Component_Or_Element_Update (Temp, Comp, Expr, Typ);
7451 end if;
7452
7453 Next (Comp);
7454 end loop;
7455
7456 Next (Assoc);
7457 end loop;
7458
7459 -- The attribute is replaced by a reference to the anonymous object
7460
7461 Rewrite (N, New_Occurrence_Of (Temp, Loc));
7462 Analyze (N);
7463 end Expand_Update_Attribute;
7464
7465 -------------------
7466 -- Find_Fat_Info --
7467 -------------------
7468
7469 procedure Find_Fat_Info
7470 (T : Entity_Id;
7471 Fat_Type : out Entity_Id;
7472 Fat_Pkg : out RE_Id)
7473 is
7474 Rtyp : constant Entity_Id := Root_Type (T);
7475
7476 begin
7477 -- All we do is use the root type (historically this dealt with
7478 -- VAX-float .. to be cleaned up further later ???)
7479
7480 Fat_Type := Rtyp;
7481
7482 if Fat_Type = Standard_Short_Float then
7483 Fat_Pkg := RE_Attr_Short_Float;
7484
7485 elsif Fat_Type = Standard_Float then
7486 Fat_Pkg := RE_Attr_Float;
7487
7488 elsif Fat_Type = Standard_Long_Float then
7489 Fat_Pkg := RE_Attr_Long_Float;
7490
7491 elsif Fat_Type = Standard_Long_Long_Float then
7492 Fat_Pkg := RE_Attr_Long_Long_Float;
7493
7494 -- Universal real (which is its own root type) is treated as being
7495 -- equivalent to Standard.Long_Long_Float, since it is defined to
7496 -- have the same precision as the longest Float type.
7497
7498 elsif Fat_Type = Universal_Real then
7499 Fat_Type := Standard_Long_Long_Float;
7500 Fat_Pkg := RE_Attr_Long_Long_Float;
7501
7502 else
7503 raise Program_Error;
7504 end if;
7505 end Find_Fat_Info;
7506
7507 ----------------------------
7508 -- Find_Stream_Subprogram --
7509 ----------------------------
7510
7511 function Find_Stream_Subprogram
7512 (Typ : Entity_Id;
7513 Nam : TSS_Name_Type) return Entity_Id
7514 is
7515 Base_Typ : constant Entity_Id := Base_Type (Typ);
7516 Ent : constant Entity_Id := TSS (Typ, Nam);
7517
7518 function Is_Available (Entity : RE_Id) return Boolean;
7519 pragma Inline (Is_Available);
7520 -- Function to check whether the specified run-time call is available
7521 -- in the run time used. In the case of a configurable run time, it
7522 -- is normal that some subprograms are not there.
7523 --
7524 -- I don't understand this routine at all, why is this not just a
7525 -- call to RTE_Available? And if for some reason we need a different
7526 -- routine with different semantics, why is not in Rtsfind ???
7527
7528 ------------------
7529 -- Is_Available --
7530 ------------------
7531
7532 function Is_Available (Entity : RE_Id) return Boolean is
7533 begin
7534 -- Assume that the unit will always be available when using a
7535 -- "normal" (not configurable) run time.
7536
7537 return not Configurable_Run_Time_Mode or else RTE_Available (Entity);
7538 end Is_Available;
7539
7540 -- Start of processing for Find_Stream_Subprogram
7541
7542 begin
7543 if Present (Ent) then
7544 return Ent;
7545 end if;
7546
7547 -- Stream attributes for strings are expanded into library calls. The
7548 -- following checks are disabled when the run-time is not available or
7549 -- when compiling predefined types due to bootstrap issues. As a result,
7550 -- the compiler will generate in-place stream routines for string types
7551 -- that appear in GNAT's library, but will generate calls via rtsfind
7552 -- to library routines for user code.
7553
7554 -- Note: In the case of using a configurable run time, it is very likely
7555 -- that stream routines for string types are not present (they require
7556 -- file system support). In this case, the specific stream routines for
7557 -- strings are not used, relying on the regular stream mechanism
7558 -- instead. That is why we include the test Is_Available when dealing
7559 -- with these cases.
7560
7561 if not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) then
7562 -- Storage_Array as defined in package System.Storage_Elements
7563
7564 if Is_RTE (Base_Typ, RE_Storage_Array) then
7565
7566 -- Case of No_Stream_Optimizations restriction active
7567
7568 if Restriction_Active (No_Stream_Optimizations) then
7569 if Nam = TSS_Stream_Input
7570 and then Is_Available (RE_Storage_Array_Input)
7571 then
7572 return RTE (RE_Storage_Array_Input);
7573
7574 elsif Nam = TSS_Stream_Output
7575 and then Is_Available (RE_Storage_Array_Output)
7576 then
7577 return RTE (RE_Storage_Array_Output);
7578
7579 elsif Nam = TSS_Stream_Read
7580 and then Is_Available (RE_Storage_Array_Read)
7581 then
7582 return RTE (RE_Storage_Array_Read);
7583
7584 elsif Nam = TSS_Stream_Write
7585 and then Is_Available (RE_Storage_Array_Write)
7586 then
7587 return RTE (RE_Storage_Array_Write);
7588
7589 elsif Nam /= TSS_Stream_Input and then
7590 Nam /= TSS_Stream_Output and then
7591 Nam /= TSS_Stream_Read and then
7592 Nam /= TSS_Stream_Write
7593 then
7594 raise Program_Error;
7595 end if;
7596
7597 -- Restriction No_Stream_Optimizations is not set, so we can go
7598 -- ahead and optimize using the block IO forms of the routines.
7599
7600 else
7601 if Nam = TSS_Stream_Input
7602 and then Is_Available (RE_Storage_Array_Input_Blk_IO)
7603 then
7604 return RTE (RE_Storage_Array_Input_Blk_IO);
7605
7606 elsif Nam = TSS_Stream_Output
7607 and then Is_Available (RE_Storage_Array_Output_Blk_IO)
7608 then
7609 return RTE (RE_Storage_Array_Output_Blk_IO);
7610
7611 elsif Nam = TSS_Stream_Read
7612 and then Is_Available (RE_Storage_Array_Read_Blk_IO)
7613 then
7614 return RTE (RE_Storage_Array_Read_Blk_IO);
7615
7616 elsif Nam = TSS_Stream_Write
7617 and then Is_Available (RE_Storage_Array_Write_Blk_IO)
7618 then
7619 return RTE (RE_Storage_Array_Write_Blk_IO);
7620
7621 elsif Nam /= TSS_Stream_Input and then
7622 Nam /= TSS_Stream_Output and then
7623 Nam /= TSS_Stream_Read and then
7624 Nam /= TSS_Stream_Write
7625 then
7626 raise Program_Error;
7627 end if;
7628 end if;
7629
7630 -- Stream_Element_Array as defined in package Ada.Streams
7631
7632 elsif Is_RTE (Base_Typ, RE_Stream_Element_Array) then
7633
7634 -- Case of No_Stream_Optimizations restriction active
7635
7636 if Restriction_Active (No_Stream_Optimizations) then
7637 if Nam = TSS_Stream_Input
7638 and then Is_Available (RE_Stream_Element_Array_Input)
7639 then
7640 return RTE (RE_Stream_Element_Array_Input);
7641
7642 elsif Nam = TSS_Stream_Output
7643 and then Is_Available (RE_Stream_Element_Array_Output)
7644 then
7645 return RTE (RE_Stream_Element_Array_Output);
7646
7647 elsif Nam = TSS_Stream_Read
7648 and then Is_Available (RE_Stream_Element_Array_Read)
7649 then
7650 return RTE (RE_Stream_Element_Array_Read);
7651
7652 elsif Nam = TSS_Stream_Write
7653 and then Is_Available (RE_Stream_Element_Array_Write)
7654 then
7655 return RTE (RE_Stream_Element_Array_Write);
7656
7657 elsif Nam /= TSS_Stream_Input and then
7658 Nam /= TSS_Stream_Output and then
7659 Nam /= TSS_Stream_Read and then
7660 Nam /= TSS_Stream_Write
7661 then
7662 raise Program_Error;
7663 end if;
7664
7665 -- Restriction No_Stream_Optimizations is not set, so we can go
7666 -- ahead and optimize using the block IO forms of the routines.
7667
7668 else
7669 if Nam = TSS_Stream_Input
7670 and then Is_Available (RE_Stream_Element_Array_Input_Blk_IO)
7671 then
7672 return RTE (RE_Stream_Element_Array_Input_Blk_IO);
7673
7674 elsif Nam = TSS_Stream_Output
7675 and then Is_Available (RE_Stream_Element_Array_Output_Blk_IO)
7676 then
7677 return RTE (RE_Stream_Element_Array_Output_Blk_IO);
7678
7679 elsif Nam = TSS_Stream_Read
7680 and then Is_Available (RE_Stream_Element_Array_Read_Blk_IO)
7681 then
7682 return RTE (RE_Stream_Element_Array_Read_Blk_IO);
7683
7684 elsif Nam = TSS_Stream_Write
7685 and then Is_Available (RE_Stream_Element_Array_Write_Blk_IO)
7686 then
7687 return RTE (RE_Stream_Element_Array_Write_Blk_IO);
7688
7689 elsif Nam /= TSS_Stream_Input and then
7690 Nam /= TSS_Stream_Output and then
7691 Nam /= TSS_Stream_Read and then
7692 Nam /= TSS_Stream_Write
7693 then
7694 raise Program_Error;
7695 end if;
7696 end if;
7697
7698 -- String as defined in package Ada
7699
7700 elsif Base_Typ = Standard_String then
7701
7702 -- Case of No_Stream_Optimizations restriction active
7703
7704 if Restriction_Active (No_Stream_Optimizations) then
7705 if Nam = TSS_Stream_Input
7706 and then Is_Available (RE_String_Input)
7707 then
7708 return RTE (RE_String_Input);
7709
7710 elsif Nam = TSS_Stream_Output
7711 and then Is_Available (RE_String_Output)
7712 then
7713 return RTE (RE_String_Output);
7714
7715 elsif Nam = TSS_Stream_Read
7716 and then Is_Available (RE_String_Read)
7717 then
7718 return RTE (RE_String_Read);
7719
7720 elsif Nam = TSS_Stream_Write
7721 and then Is_Available (RE_String_Write)
7722 then
7723 return RTE (RE_String_Write);
7724
7725 elsif Nam /= TSS_Stream_Input and then
7726 Nam /= TSS_Stream_Output and then
7727 Nam /= TSS_Stream_Read and then
7728 Nam /= TSS_Stream_Write
7729 then
7730 raise Program_Error;
7731 end if;
7732
7733 -- Restriction No_Stream_Optimizations is not set, so we can go
7734 -- ahead and optimize using the block IO forms of the routines.
7735
7736 else
7737 if Nam = TSS_Stream_Input
7738 and then Is_Available (RE_String_Input_Blk_IO)
7739 then
7740 return RTE (RE_String_Input_Blk_IO);
7741
7742 elsif Nam = TSS_Stream_Output
7743 and then Is_Available (RE_String_Output_Blk_IO)
7744 then
7745 return RTE (RE_String_Output_Blk_IO);
7746
7747 elsif Nam = TSS_Stream_Read
7748 and then Is_Available (RE_String_Read_Blk_IO)
7749 then
7750 return RTE (RE_String_Read_Blk_IO);
7751
7752 elsif Nam = TSS_Stream_Write
7753 and then Is_Available (RE_String_Write_Blk_IO)
7754 then
7755 return RTE (RE_String_Write_Blk_IO);
7756
7757 elsif Nam /= TSS_Stream_Input and then
7758 Nam /= TSS_Stream_Output and then
7759 Nam /= TSS_Stream_Read and then
7760 Nam /= TSS_Stream_Write
7761 then
7762 raise Program_Error;
7763 end if;
7764 end if;
7765
7766 -- Wide_String as defined in package Ada
7767
7768 elsif Base_Typ = Standard_Wide_String then
7769
7770 -- Case of No_Stream_Optimizations restriction active
7771
7772 if Restriction_Active (No_Stream_Optimizations) then
7773 if Nam = TSS_Stream_Input
7774 and then Is_Available (RE_Wide_String_Input)
7775 then
7776 return RTE (RE_Wide_String_Input);
7777
7778 elsif Nam = TSS_Stream_Output
7779 and then Is_Available (RE_Wide_String_Output)
7780 then
7781 return RTE (RE_Wide_String_Output);
7782
7783 elsif Nam = TSS_Stream_Read
7784 and then Is_Available (RE_Wide_String_Read)
7785 then
7786 return RTE (RE_Wide_String_Read);
7787
7788 elsif Nam = TSS_Stream_Write
7789 and then Is_Available (RE_Wide_String_Write)
7790 then
7791 return RTE (RE_Wide_String_Write);
7792
7793 elsif Nam /= TSS_Stream_Input and then
7794 Nam /= TSS_Stream_Output and then
7795 Nam /= TSS_Stream_Read and then
7796 Nam /= TSS_Stream_Write
7797 then
7798 raise Program_Error;
7799 end if;
7800
7801 -- Restriction No_Stream_Optimizations is not set, so we can go
7802 -- ahead and optimize using the block IO forms of the routines.
7803
7804 else
7805 if Nam = TSS_Stream_Input
7806 and then Is_Available (RE_Wide_String_Input_Blk_IO)
7807 then
7808 return RTE (RE_Wide_String_Input_Blk_IO);
7809
7810 elsif Nam = TSS_Stream_Output
7811 and then Is_Available (RE_Wide_String_Output_Blk_IO)
7812 then
7813 return RTE (RE_Wide_String_Output_Blk_IO);
7814
7815 elsif Nam = TSS_Stream_Read
7816 and then Is_Available (RE_Wide_String_Read_Blk_IO)
7817 then
7818 return RTE (RE_Wide_String_Read_Blk_IO);
7819
7820 elsif Nam = TSS_Stream_Write
7821 and then Is_Available (RE_Wide_String_Write_Blk_IO)
7822 then
7823 return RTE (RE_Wide_String_Write_Blk_IO);
7824
7825 elsif Nam /= TSS_Stream_Input and then
7826 Nam /= TSS_Stream_Output and then
7827 Nam /= TSS_Stream_Read and then
7828 Nam /= TSS_Stream_Write
7829 then
7830 raise Program_Error;
7831 end if;
7832 end if;
7833
7834 -- Wide_Wide_String as defined in package Ada
7835
7836 elsif Base_Typ = Standard_Wide_Wide_String then
7837
7838 -- Case of No_Stream_Optimizations restriction active
7839
7840 if Restriction_Active (No_Stream_Optimizations) then
7841 if Nam = TSS_Stream_Input
7842 and then Is_Available (RE_Wide_Wide_String_Input)
7843 then
7844 return RTE (RE_Wide_Wide_String_Input);
7845
7846 elsif Nam = TSS_Stream_Output
7847 and then Is_Available (RE_Wide_Wide_String_Output)
7848 then
7849 return RTE (RE_Wide_Wide_String_Output);
7850
7851 elsif Nam = TSS_Stream_Read
7852 and then Is_Available (RE_Wide_Wide_String_Read)
7853 then
7854 return RTE (RE_Wide_Wide_String_Read);
7855
7856 elsif Nam = TSS_Stream_Write
7857 and then Is_Available (RE_Wide_Wide_String_Write)
7858 then
7859 return RTE (RE_Wide_Wide_String_Write);
7860
7861 elsif Nam /= TSS_Stream_Input and then
7862 Nam /= TSS_Stream_Output and then
7863 Nam /= TSS_Stream_Read and then
7864 Nam /= TSS_Stream_Write
7865 then
7866 raise Program_Error;
7867 end if;
7868
7869 -- Restriction No_Stream_Optimizations is not set, so we can go
7870 -- ahead and optimize using the block IO forms of the routines.
7871
7872 else
7873 if Nam = TSS_Stream_Input
7874 and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO)
7875 then
7876 return RTE (RE_Wide_Wide_String_Input_Blk_IO);
7877
7878 elsif Nam = TSS_Stream_Output
7879 and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO)
7880 then
7881 return RTE (RE_Wide_Wide_String_Output_Blk_IO);
7882
7883 elsif Nam = TSS_Stream_Read
7884 and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO)
7885 then
7886 return RTE (RE_Wide_Wide_String_Read_Blk_IO);
7887
7888 elsif Nam = TSS_Stream_Write
7889 and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO)
7890 then
7891 return RTE (RE_Wide_Wide_String_Write_Blk_IO);
7892
7893 elsif Nam /= TSS_Stream_Input and then
7894 Nam /= TSS_Stream_Output and then
7895 Nam /= TSS_Stream_Read and then
7896 Nam /= TSS_Stream_Write
7897 then
7898 raise Program_Error;
7899 end if;
7900 end if;
7901 end if;
7902 end if;
7903
7904 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
7905 return Find_Prim_Op (Typ, Nam);
7906 else
7907 return Find_Inherited_TSS (Typ, Nam);
7908 end if;
7909 end Find_Stream_Subprogram;
7910
7911 ---------------
7912 -- Full_Base --
7913 ---------------
7914
7915 function Full_Base (T : Entity_Id) return Entity_Id is
7916 BT : Entity_Id;
7917
7918 begin
7919 BT := Base_Type (T);
7920
7921 if Is_Private_Type (BT)
7922 and then Present (Full_View (BT))
7923 then
7924 BT := Full_View (BT);
7925 end if;
7926
7927 return BT;
7928 end Full_Base;
7929
7930 -----------------------
7931 -- Get_Index_Subtype --
7932 -----------------------
7933
7934 function Get_Index_Subtype (N : Node_Id) return Node_Id is
7935 P_Type : Entity_Id := Etype (Prefix (N));
7936 Indx : Node_Id;
7937 J : Int;
7938
7939 begin
7940 if Is_Access_Type (P_Type) then
7941 P_Type := Designated_Type (P_Type);
7942 end if;
7943
7944 if No (Expressions (N)) then
7945 J := 1;
7946 else
7947 J := UI_To_Int (Expr_Value (First (Expressions (N))));
7948 end if;
7949
7950 Indx := First_Index (P_Type);
7951 while J > 1 loop
7952 Next_Index (Indx);
7953 J := J - 1;
7954 end loop;
7955
7956 return Etype (Indx);
7957 end Get_Index_Subtype;
7958
7959 -------------------------------
7960 -- Get_Stream_Convert_Pragma --
7961 -------------------------------
7962
7963 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is
7964 Typ : Entity_Id;
7965 N : Node_Id;
7966
7967 begin
7968 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
7969 -- that a stream convert pragma for a tagged type is not inherited from
7970 -- its parent. Probably what is wrong here is that it is basically
7971 -- incorrect to consider a stream convert pragma to be a representation
7972 -- pragma at all ???
7973
7974 N := First_Rep_Item (Implementation_Base_Type (T));
7975 while Present (N) loop
7976 if Nkind (N) = N_Pragma
7977 and then Pragma_Name (N) = Name_Stream_Convert
7978 then
7979 -- For tagged types this pragma is not inherited, so we
7980 -- must verify that it is defined for the given type and
7981 -- not an ancestor.
7982
7983 Typ :=
7984 Entity (Expression (First (Pragma_Argument_Associations (N))));
7985
7986 if not Is_Tagged_Type (T)
7987 or else T = Typ
7988 or else (Is_Private_Type (Typ) and then T = Full_View (Typ))
7989 then
7990 return N;
7991 end if;
7992 end if;
7993
7994 Next_Rep_Item (N);
7995 end loop;
7996
7997 return Empty;
7998 end Get_Stream_Convert_Pragma;
7999
8000 ---------------------------------
8001 -- Is_Constrained_Packed_Array --
8002 ---------------------------------
8003
8004 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is
8005 Arr : Entity_Id := Typ;
8006
8007 begin
8008 if Is_Access_Type (Arr) then
8009 Arr := Designated_Type (Arr);
8010 end if;
8011
8012 return Is_Array_Type (Arr)
8013 and then Is_Constrained (Arr)
8014 and then Present (Packed_Array_Impl_Type (Arr));
8015 end Is_Constrained_Packed_Array;
8016
8017 ----------------------------------------
8018 -- Is_Inline_Floating_Point_Attribute --
8019 ----------------------------------------
8020
8021 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is
8022 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
8023
8024 function Is_GCC_Target return Boolean;
8025 -- Return True if we are using a GCC target/back-end
8026 -- ??? Note: the implementation is kludgy/fragile
8027
8028 -------------------
8029 -- Is_GCC_Target --
8030 -------------------
8031
8032 function Is_GCC_Target return Boolean is
8033 begin
8034 return not CodePeer_Mode
8035 and then not AAMP_On_Target
8036 and then not Generate_C_Code;
8037 end Is_GCC_Target;
8038
8039 -- Start of processing for Is_Inline_Floating_Point_Attribute
8040
8041 begin
8042 -- Machine and Model can be expanded by the GCC and AAMP back ends only
8043
8044 if Id = Attribute_Machine or else Id = Attribute_Model then
8045 return Is_GCC_Target or else AAMP_On_Target;
8046
8047 -- Remaining cases handled by all back ends are Rounding and Truncation
8048 -- when appearing as the operand of a conversion to some integer type.
8049
8050 elsif Nkind (Parent (N)) /= N_Type_Conversion
8051 or else not Is_Integer_Type (Etype (Parent (N)))
8052 then
8053 return False;
8054 end if;
8055
8056 -- Here we are in the integer conversion context
8057
8058 -- Very probably we should also recognize the cases of Machine_Rounding
8059 -- and unbiased rounding in this conversion context, but the back end is
8060 -- not yet prepared to handle these cases ???
8061
8062 return Id = Attribute_Rounding or else Id = Attribute_Truncation;
8063 end Is_Inline_Floating_Point_Attribute;
8064
8065 end Exp_Attr;