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