1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
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 Fname; use Fname;
43 with Freeze; use Freeze;
44 with Gnatvsn; use Gnatvsn;
45 with Itypes; use Itypes;
47 with Namet; use Namet;
48 with Nmake; use Nmake;
49 with Nlists; use Nlists;
51 with Restrict; use Restrict;
52 with Rident; use Rident;
53 with Rtsfind; use Rtsfind;
55 with Sem_Aux; use Sem_Aux;
56 with Sem_Ch6; use Sem_Ch6;
57 with Sem_Ch7; use Sem_Ch7;
58 with Sem_Ch8; use Sem_Ch8;
59 with Sem_Eval; use Sem_Eval;
60 with Sem_Res; use Sem_Res;
61 with Sem_Util; use Sem_Util;
62 with Sinfo; use Sinfo;
63 with Snames; use Snames;
64 with Stand; use Stand;
65 with Stringt; use Stringt;
66 with Targparm; use Targparm;
67 with Tbuild; use Tbuild;
68 with Ttypes; use Ttypes;
69 with Uintp; use Uintp;
70 with Uname; use Uname;
71 with Validsw; use Validsw;
73 package body Exp_Attr is
75 -----------------------
76 -- Local Subprograms --
77 -----------------------
79 function Build_Array_VS_Func
81 Nod : Node_Id) return Entity_Id;
82 -- Build function to test Valid_Scalars for array type A_Type. Nod is the
83 -- Valid_Scalars attribute node, used to insert the function body, and the
84 -- value returned is the entity of the constructed function body. We do not
85 -- bother to generate a separate spec for this subprogram.
87 function Build_Record_VS_Func
89 Nod : Node_Id) return Entity_Id;
90 -- Build function to test Valid_Scalars for record type A_Type. Nod is the
91 -- Valid_Scalars attribute node, used to insert the function body, and the
92 -- value returned is the entity of the constructed function body. We do not
93 -- bother to generate a separate spec for this subprogram.
95 procedure Compile_Stream_Body_In_Scope
100 -- The body for a stream subprogram may be generated outside of the scope
101 -- of the type. If the type is fully private, it may depend on the full
102 -- view of other types (e.g. indexes) that are currently private as well.
103 -- We install the declarations of the package in which the type is declared
104 -- before compiling the body in what is its proper environment. The Check
105 -- parameter indicates if checks are to be suppressed for the stream body.
106 -- We suppress checks for array/record reads, since the rule is that these
107 -- are like assignments, out of range values due to uninitialized storage,
108 -- or other invalid values do NOT cause a Constraint_Error to be raised.
109 -- If we are within an instance body all visibility has been established
110 -- already and there is no need to install the package.
112 -- This mechanism is now extended to the component types of the array type,
113 -- when the component type is not in scope and is private, to handle
114 -- properly the case when the full view has defaulted discriminants.
116 -- This special processing is ultimately caused by the fact that the
117 -- compiler lacks a well-defined phase when full views are visible
118 -- everywhere. Having such a separate pass would remove much of the
119 -- special-case code that shuffles partial and full views in the middle
120 -- of semantic analysis and expansion.
122 procedure Expand_Access_To_Protected_Op
126 -- An attribute reference to a protected subprogram is transformed into
127 -- a pair of pointers: one to the object, and one to the operations.
128 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
130 procedure Expand_Fpt_Attribute
135 -- This procedure expands a call to a floating-point attribute function.
136 -- N is the attribute reference node, and Args is a list of arguments to
137 -- be passed to the function call. Pkg identifies the package containing
138 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
139 -- have already been converted to the floating-point type for which Pkg was
140 -- instantiated. The Nam argument is the relevant attribute processing
141 -- routine to be called. This is the same as the attribute name, except in
142 -- the Unaligned_Valid case.
144 procedure Expand_Fpt_Attribute_R (N : Node_Id);
145 -- This procedure expands a call to a floating-point attribute function
146 -- that takes a single floating-point argument. The function to be called
147 -- is always the same as the attribute name.
149 procedure Expand_Fpt_Attribute_RI (N : Node_Id);
150 -- This procedure expands a call to a floating-point attribute function
151 -- that takes one floating-point argument and one integer argument. The
152 -- function to be called is always the same as the attribute name.
154 procedure Expand_Fpt_Attribute_RR (N : Node_Id);
155 -- This procedure expands a call to a floating-point attribute function
156 -- that takes two floating-point arguments. The function to be called
157 -- is always the same as the attribute name.
159 procedure Expand_Loop_Entry_Attribute (N : Node_Id);
160 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
161 -- loop may be converted into a conditional block. See body for details.
163 procedure Expand_Min_Max_Attribute (N : Node_Id);
164 -- Handle the expansion of attributes 'Max and 'Min, including expanding
165 -- then out if we are in Modify_Tree_For_C mode.
167 procedure Expand_Pred_Succ_Attribute (N : Node_Id);
168 -- Handles expansion of Pred or Succ attributes for case of non-real
169 -- operand with overflow checking required.
171 procedure Expand_Update_Attribute (N : Node_Id);
172 -- Handle the expansion of attribute Update
174 function Get_Index_Subtype (N : Node_Id) return Entity_Id;
175 -- Used for Last, Last, and Length, when the prefix is an array type.
176 -- Obtains the corresponding index subtype.
178 procedure Find_Fat_Info
180 Fat_Type : out Entity_Id;
181 Fat_Pkg : out RE_Id);
182 -- Given a floating-point type T, identifies the package containing the
183 -- attributes for this type (returned in Fat_Pkg), and the corresponding
184 -- type for which this package was instantiated from Fat_Gen. Error if T
185 -- is not a floating-point type.
187 function Find_Stream_Subprogram
189 Nam : TSS_Name_Type) return Entity_Id;
190 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
191 -- types, the corresponding primitive operation is looked up, else the
192 -- appropriate TSS from the type itself, or from its closest ancestor
193 -- defining it, is returned. In both cases, inheritance of representation
194 -- aspects is thus taken into account.
196 function Full_Base (T : Entity_Id) return Entity_Id;
197 -- The stream functions need to examine the underlying representation of
198 -- composite types. In some cases T may be non-private but its base type
199 -- is, in which case the function returns the corresponding full view.
201 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id;
202 -- Given a type, find a corresponding stream convert pragma that applies to
203 -- the implementation base type of this type (Typ). If found, return the
204 -- pragma node, otherwise return Empty if no pragma is found.
206 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
207 -- Utility for array attributes, returns true on packed constrained
208 -- arrays, and on access to same.
210 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean;
211 -- Returns true iff the given node refers to an attribute call that
212 -- can be expanded directly by the back end and does not need front end
213 -- expansion. Typically used for rounding and truncation attributes that
214 -- appear directly inside a conversion to integer.
216 -------------------------
217 -- Build_Array_VS_Func --
218 -------------------------
220 function Build_Array_VS_Func
222 Nod : Node_Id) return Entity_Id
224 Loc : constant Source_Ptr := Sloc (Nod);
225 Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
226 Comp_Type : constant Entity_Id := Component_Type (A_Type);
227 Body_Stmts : List_Id;
228 Index_List : List_Id;
231 function Test_Component return List_Id;
232 -- Create one statement to test validity of one component designated by
233 -- a full set of indexes. Returns statement list containing test.
235 function Test_One_Dimension (N : Int) return List_Id;
236 -- Create loop to test one dimension of the array. The single statement
237 -- in the loop body tests the inner dimensions if any, or else the
238 -- single component. Note that this procedure is called recursively,
239 -- with N being the dimension to be initialized. A call with N greater
240 -- than the number of dimensions simply generates the component test,
241 -- terminating the recursion. Returns statement list containing tests.
247 function Test_Component return List_Id is
253 Make_Indexed_Component (Loc,
254 Prefix => Make_Identifier (Loc, Name_uA),
255 Expressions => Index_List);
257 if Is_Scalar_Type (Comp_Type) then
260 Anam := Name_Valid_Scalars;
264 Make_If_Statement (Loc,
268 Make_Attribute_Reference (Loc,
269 Attribute_Name => Anam,
271 Then_Statements => New_List (
272 Make_Simple_Return_Statement (Loc,
273 Expression => New_Occurrence_Of (Standard_False, Loc)))));
276 ------------------------
277 -- Test_One_Dimension --
278 ------------------------
280 function Test_One_Dimension (N : Int) return List_Id is
284 -- If all dimensions dealt with, we simply test the component
286 if N > Number_Dimensions (A_Type) then
287 return Test_Component;
289 -- Here we generate the required loop
293 Make_Defining_Identifier (Loc, New_External_Name ('J', N));
295 Append (New_Occurrence_Of (Index, Loc), Index_List);
298 Make_Implicit_Loop_Statement (Nod,
301 Make_Iteration_Scheme (Loc,
302 Loop_Parameter_Specification =>
303 Make_Loop_Parameter_Specification (Loc,
304 Defining_Identifier => Index,
305 Discrete_Subtype_Definition =>
306 Make_Attribute_Reference (Loc,
307 Prefix => Make_Identifier (Loc, Name_uA),
308 Attribute_Name => Name_Range,
309 Expressions => New_List (
310 Make_Integer_Literal (Loc, N))))),
311 Statements => Test_One_Dimension (N + 1)),
312 Make_Simple_Return_Statement (Loc,
313 Expression => New_Occurrence_Of (Standard_True, Loc)));
315 end Test_One_Dimension;
317 -- Start of processing for Build_Array_VS_Func
320 Index_List := New_List;
321 Body_Stmts := Test_One_Dimension (1);
323 -- Parameter is always (A : A_Typ)
325 Formals := New_List (
326 Make_Parameter_Specification (Loc,
327 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uA),
329 Out_Present => False,
330 Parameter_Type => New_Occurrence_Of (A_Type, Loc)));
334 Set_Ekind (Func_Id, E_Function);
335 Set_Is_Internal (Func_Id);
338 Make_Subprogram_Body (Loc,
340 Make_Function_Specification (Loc,
341 Defining_Unit_Name => Func_Id,
342 Parameter_Specifications => Formals,
344 New_Occurrence_Of (Standard_Boolean, Loc)),
345 Declarations => New_List,
346 Handled_Statement_Sequence =>
347 Make_Handled_Sequence_Of_Statements (Loc,
348 Statements => Body_Stmts)));
350 if not Debug_Generated_Code then
351 Set_Debug_Info_Off (Func_Id);
354 Set_Is_Pure (Func_Id);
356 end Build_Array_VS_Func;
358 --------------------------
359 -- Build_Record_VS_Func --
360 --------------------------
364 -- function _Valid_Scalars (X : T) return Boolean is
366 -- -- Check discriminants
368 -- if not X.D1'Valid_Scalars or else
369 -- not X.D2'Valid_Scalars or else
375 -- -- Check components
377 -- if not X.C1'Valid_Scalars or else
378 -- not X.C2'Valid_Scalars or else
384 -- -- Check variant part
388 -- if not X.C2'Valid_Scalars or else
389 -- not X.C3'Valid_Scalars or else
396 -- if not X.Cn'Valid_Scalars or else
404 -- end _Valid_Scalars;
406 function Build_Record_VS_Func
408 Nod : Node_Id) return Entity_Id
410 Loc : constant Source_Ptr := Sloc (R_Type);
411 Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
412 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
414 function Make_VS_Case
417 Discrs : Elist_Id := New_Elmt_List) return List_Id;
418 -- Building block for variant valid scalars. Given a Component_List node
419 -- CL, it generates an 'if' followed by a 'case' statement that compares
420 -- all components of local temporaries named X and Y (that are declared
421 -- as formals at some upper level). E provides the Sloc to be used for
422 -- the generated code.
426 L : List_Id) return Node_Id;
427 -- Building block for variant validate scalars. Given the list, L, of
428 -- components (or discriminants) L, it generates a return statement that
429 -- compares all components of local temporaries named X and Y (that are
430 -- declared as formals at some upper level). E provides the Sloc to be
431 -- used for the generated code.
437 -- <Make_VS_If on shared components>
440 -- when V1 => <Make_VS_Case> on subcomponents
442 -- when Vn => <Make_VS_Case> on subcomponents
445 function Make_VS_Case
448 Discrs : Elist_Id := New_Elmt_List) return List_Id
450 Loc : constant Source_Ptr := Sloc (E);
451 Result : constant List_Id := New_List;
456 Append_To (Result, Make_VS_If (E, Component_Items (CL)));
458 if No (Variant_Part (CL)) then
462 Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
468 Alt_List := New_List;
469 while Present (Variant) loop
471 Make_Case_Statement_Alternative (Loc,
472 Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
474 Make_VS_Case (E, Component_List (Variant), Discrs)));
475 Next_Non_Pragma (Variant);
479 Make_Case_Statement (Loc,
481 Make_Selected_Component (Loc,
482 Prefix => Make_Identifier (Loc, Name_X),
483 Selector_Name => New_Copy (Name (Variant_Part (CL)))),
484 Alternatives => Alt_List));
496 -- not X.C1'Valid_Scalars
498 -- not X.C2'Valid_Scalars
504 -- or a null statement if the list L is empty
508 L : List_Id) return Node_Id
510 Loc : constant Source_Ptr := Sloc (E);
513 Field_Name : Name_Id;
518 return Make_Null_Statement (Loc);
523 C := First_Non_Pragma (L);
524 while Present (C) loop
525 Def_Id := Defining_Identifier (C);
526 Field_Name := Chars (Def_Id);
528 -- The tags need not be checked since they will always be valid
530 -- Note also that in the following, we use Make_Identifier for
531 -- the component names. Use of New_Occurrence_Of to identify
532 -- the components would be incorrect because wrong entities for
533 -- discriminants could be picked up in the private type case.
535 -- Don't bother with abstract parent in interface case
537 if Field_Name = Name_uParent
538 and then Is_Interface (Etype (Def_Id))
542 -- Don't bother with tag, always valid, and not scalar anyway
544 elsif Field_Name = Name_uTag then
547 -- Don't bother with component with no scalar components
549 elsif not Scalar_Part_Present (Etype (Def_Id)) then
552 -- Normal case, generate Valid_Scalars attribute reference
555 Evolve_Or_Else (Cond,
558 Make_Attribute_Reference (Loc,
560 Make_Selected_Component (Loc,
562 Make_Identifier (Loc, Name_X),
564 Make_Identifier (Loc, Field_Name)),
565 Attribute_Name => Name_Valid_Scalars)));
572 return Make_Null_Statement (Loc);
576 Make_Implicit_If_Statement (E,
578 Then_Statements => New_List (
579 Make_Simple_Return_Statement (Loc,
581 New_Occurrence_Of (Standard_False, Loc))));
588 Def : constant Node_Id := Parent (R_Type);
589 Comps : constant Node_Id := Component_List (Type_Definition (Def));
590 Stmts : constant List_Id := New_List;
591 Pspecs : constant List_Id := New_List;
593 -- Start of processing for Build_Record_VS_Func
597 Make_Parameter_Specification (Loc,
598 Defining_Identifier => X,
599 Parameter_Type => New_Occurrence_Of (R_Type, Loc)));
602 Make_VS_If (R_Type, Discriminant_Specifications (Def)));
603 Append_List_To (Stmts, Make_VS_Case (R_Type, Comps));
606 Make_Simple_Return_Statement (Loc,
607 Expression => New_Occurrence_Of (Standard_True, Loc)));
610 Make_Subprogram_Body (Loc,
612 Make_Function_Specification (Loc,
613 Defining_Unit_Name => Func_Id,
614 Parameter_Specifications => Pspecs,
615 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
616 Declarations => New_List,
617 Handled_Statement_Sequence =>
618 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)),
619 Suppress => Discriminant_Check);
621 if not Debug_Generated_Code then
622 Set_Debug_Info_Off (Func_Id);
625 Set_Is_Pure (Func_Id);
627 end Build_Record_VS_Func;
629 ----------------------------------
630 -- Compile_Stream_Body_In_Scope --
631 ----------------------------------
633 procedure Compile_Stream_Body_In_Scope
639 C_Type : constant Entity_Id := Base_Type (Component_Type (Arr));
640 Curr : constant Entity_Id := Current_Scope;
641 Install : Boolean := False;
642 Scop : Entity_Id := Scope (Arr);
646 and then not In_Open_Scopes (Scop)
647 and then Ekind (Scop) = E_Package
652 -- The component type may be private, in which case we install its
653 -- full view to compile the subprogram.
655 -- The component type may be private, in which case we install its
656 -- full view to compile the subprogram. We do not do this if the
657 -- type has a Stream_Convert pragma, which indicates that there are
658 -- special stream-processing operations for that type (for example
659 -- Unbounded_String and its wide varieties).
661 Scop := Scope (C_Type);
663 if Is_Private_Type (C_Type)
664 and then Present (Full_View (C_Type))
665 and then not In_Open_Scopes (Scop)
666 and then Ekind (Scop) = E_Package
667 and then No (Get_Stream_Convert_Pragma (C_Type))
673 -- If we are within an instance body, then all visibility has been
674 -- established already and there is no need to install the package.
676 if Install and then not In_Instance_Body then
678 Install_Visible_Declarations (Scop);
679 Install_Private_Declarations (Scop);
681 -- The entities in the package are now visible, but the generated
682 -- stream entity must appear in the current scope (usually an
683 -- enclosing stream function) so that itypes all have their proper
692 Insert_Action (N, Decl);
694 Insert_Action (N, Decl, Suppress => All_Checks);
699 -- Remove extra copy of current scope, and package itself
702 End_Package_Scope (Scop);
704 end Compile_Stream_Body_In_Scope;
706 -----------------------------------
707 -- Expand_Access_To_Protected_Op --
708 -----------------------------------
710 procedure Expand_Access_To_Protected_Op
715 -- The value of the attribute_reference is a record containing two
716 -- fields: an access to the protected object, and an access to the
717 -- subprogram itself. The prefix is a selected component.
719 Loc : constant Source_Ptr := Sloc (N);
721 Btyp : constant Entity_Id := Base_Type (Typ);
724 E_T : constant Entity_Id := Equivalent_Type (Btyp);
725 Acc : constant Entity_Id :=
726 Etype (Next_Component (First_Component (E_T)));
730 -- Start of processing for Expand_Access_To_Protected_Op
733 -- Within the body of the protected type, the prefix designates a local
734 -- operation, and the object is the first parameter of the corresponding
735 -- protected body of the current enclosing operation.
737 if Is_Entity_Name (Pref) then
738 -- All indirect calls are external calls, so must do locking and
739 -- barrier reevaluation, even if the 'Access occurs within the
740 -- protected body. Hence the call to External_Subprogram, as opposed
741 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means
742 -- that indirect calls from within the same protected body will
743 -- deadlock, as allowed by RM-9.5.1(8,15,17).
745 Sub := New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc);
747 -- Don't traverse the scopes when the attribute occurs within an init
748 -- proc, because we directly use the _init formal of the init proc in
751 Curr := Current_Scope;
752 if not Is_Init_Proc (Curr) then
753 pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
755 while Scope (Curr) /= Scope (Entity (Pref)) loop
756 Curr := Scope (Curr);
760 -- In case of protected entries the first formal of its Protected_
761 -- Body_Subprogram is the address of the object.
763 if Ekind (Curr) = E_Entry then
767 (Protected_Body_Subprogram (Curr)), Loc);
769 -- If the current scope is an init proc, then use the address of the
770 -- _init formal as the object reference.
772 elsif Is_Init_Proc (Curr) then
774 Make_Attribute_Reference (Loc,
775 Prefix => New_Occurrence_Of (First_Formal (Curr), Loc),
776 Attribute_Name => Name_Address);
778 -- In case of protected subprograms the first formal of its
779 -- Protected_Body_Subprogram is the object and we get its address.
783 Make_Attribute_Reference (Loc,
787 (Protected_Body_Subprogram (Curr)), Loc),
788 Attribute_Name => Name_Address);
791 -- Case where the prefix is not an entity name. Find the
792 -- version of the protected operation to be called from
793 -- outside the protected object.
799 (Entity (Selector_Name (Pref))), Loc);
802 Make_Attribute_Reference (Loc,
803 Prefix => Relocate_Node (Prefix (Pref)),
804 Attribute_Name => Name_Address);
808 Make_Attribute_Reference (Loc,
810 Attribute_Name => Name_Access);
812 -- We set the type of the access reference to the already generated
813 -- access_to_subprogram type, and declare the reference analyzed, to
814 -- prevent further expansion when the enclosing aggregate is analyzed.
816 Set_Etype (Sub_Ref, Acc);
817 Set_Analyzed (Sub_Ref);
821 Expressions => New_List (Obj_Ref, Sub_Ref));
823 -- Sub_Ref has been marked as analyzed, but we still need to make sure
824 -- Sub is correctly frozen.
826 Freeze_Before (N, Entity (Sub));
829 Analyze_And_Resolve (N, E_T);
831 -- For subsequent analysis, the node must retain its type. The backend
832 -- will replace it with the equivalent type where needed.
835 end Expand_Access_To_Protected_Op;
837 --------------------------
838 -- Expand_Fpt_Attribute --
839 --------------------------
841 procedure Expand_Fpt_Attribute
847 Loc : constant Source_Ptr := Sloc (N);
848 Typ : constant Entity_Id := Etype (N);
852 -- The function name is the selected component Attr_xxx.yyy where
853 -- Attr_xxx is the package name, and yyy is the argument Nam.
855 -- Note: it would be more usual to have separate RE entries for each
856 -- of the entities in the Fat packages, but first they have identical
857 -- names (so we would have to have lots of renaming declarations to
858 -- meet the normal RE rule of separate names for all runtime entities),
859 -- and second there would be an awful lot of them.
862 Make_Selected_Component (Loc,
863 Prefix => New_Occurrence_Of (RTE (Pkg), Loc),
864 Selector_Name => Make_Identifier (Loc, Nam));
866 -- The generated call is given the provided set of parameters, and then
867 -- wrapped in a conversion which converts the result to the target type
868 -- We use the base type as the target because a range check may be
872 Unchecked_Convert_To (Base_Type (Etype (N)),
873 Make_Function_Call (Loc,
875 Parameter_Associations => Args)));
877 Analyze_And_Resolve (N, Typ);
878 end Expand_Fpt_Attribute;
880 ----------------------------
881 -- Expand_Fpt_Attribute_R --
882 ----------------------------
884 -- The single argument is converted to its root type to call the
885 -- appropriate runtime function, with the actual call being built
886 -- by Expand_Fpt_Attribute
888 procedure Expand_Fpt_Attribute_R (N : Node_Id) is
889 E1 : constant Node_Id := First (Expressions (N));
893 Find_Fat_Info (Etype (E1), Ftp, Pkg);
895 (N, Pkg, Attribute_Name (N),
896 New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1))));
897 end Expand_Fpt_Attribute_R;
899 -----------------------------
900 -- Expand_Fpt_Attribute_RI --
901 -----------------------------
903 -- The first argument is converted to its root type and the second
904 -- argument is converted to standard long long integer to call the
905 -- appropriate runtime function, with the actual call being built
906 -- by Expand_Fpt_Attribute
908 procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
909 E1 : constant Node_Id := First (Expressions (N));
912 E2 : constant Node_Id := Next (E1);
914 Find_Fat_Info (Etype (E1), Ftp, Pkg);
916 (N, Pkg, Attribute_Name (N),
918 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
919 Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
920 end Expand_Fpt_Attribute_RI;
922 -----------------------------
923 -- Expand_Fpt_Attribute_RR --
924 -----------------------------
926 -- The two arguments are converted to their root types to call the
927 -- appropriate runtime function, with the actual call being built
928 -- by Expand_Fpt_Attribute
930 procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
931 E1 : constant Node_Id := First (Expressions (N));
932 E2 : constant Node_Id := Next (E1);
937 Find_Fat_Info (Etype (E1), Ftp, Pkg);
939 (N, Pkg, Attribute_Name (N),
941 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
942 Unchecked_Convert_To (Ftp, Relocate_Node (E2))));
943 end Expand_Fpt_Attribute_RR;
945 ---------------------------------
946 -- Expand_Loop_Entry_Attribute --
947 ---------------------------------
949 procedure Expand_Loop_Entry_Attribute (N : Node_Id) is
950 procedure Build_Conditional_Block
954 If_Stmt : out Node_Id;
955 Blk_Stmt : out Node_Id);
956 -- Create a block Blk_Stmt with an empty declarative list and a single
957 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
958 -- condition Cond. If_Stmt is Empty when there is no condition provided.
960 function Is_Array_Iteration (N : Node_Id) return Boolean;
961 -- Determine whether loop statement N denotes an Ada 2012 iteration over
964 -----------------------------
965 -- Build_Conditional_Block --
966 -----------------------------
968 procedure Build_Conditional_Block
972 If_Stmt : out Node_Id;
973 Blk_Stmt : out Node_Id)
976 -- Do not reanalyze the original loop statement because it is simply
979 Set_Analyzed (Loop_Stmt);
982 Make_Block_Statement (Loc,
983 Declarations => New_List,
984 Handled_Statement_Sequence =>
985 Make_Handled_Sequence_Of_Statements (Loc,
986 Statements => New_List (Loop_Stmt)));
988 if Present (Cond) then
990 Make_If_Statement (Loc,
992 Then_Statements => New_List (Blk_Stmt));
996 end Build_Conditional_Block;
998 ------------------------
999 -- Is_Array_Iteration --
1000 ------------------------
1002 function Is_Array_Iteration (N : Node_Id) return Boolean is
1003 Stmt : constant Node_Id := Original_Node (N);
1007 if Nkind (Stmt) = N_Loop_Statement
1008 and then Present (Iteration_Scheme (Stmt))
1009 and then Present (Iterator_Specification (Iteration_Scheme (Stmt)))
1011 Iter := Iterator_Specification (Iteration_Scheme (Stmt));
1014 Of_Present (Iter) and then Is_Array_Type (Etype (Name (Iter)));
1018 end Is_Array_Iteration;
1022 Exprs : constant List_Id := Expressions (N);
1023 Pref : constant Node_Id := Prefix (N);
1024 Typ : constant Entity_Id := Etype (Pref);
1027 CW_Temp : Entity_Id;
1030 Installed : Boolean;
1032 Loop_Id : Entity_Id;
1033 Loop_Stmt : Node_Id;
1036 Temp_Decl : Node_Id;
1037 Temp_Id : Entity_Id;
1039 -- Start of processing for Expand_Loop_Entry_Attribute
1042 -- Step 1: Find the related loop
1044 -- The loop label variant of attribute 'Loop_Entry already has all the
1045 -- information in its expression.
1047 if Present (Exprs) then
1048 Loop_Id := Entity (First (Exprs));
1049 Loop_Stmt := Label_Construct (Parent (Loop_Id));
1051 -- Climb the parent chain to find the nearest enclosing loop. Skip all
1052 -- internally generated loops for quantified expressions and for
1053 -- element iterators over multidimensional arrays: pragma applies to
1058 while Present (Loop_Stmt) loop
1059 if Nkind (Loop_Stmt) = N_Loop_Statement
1060 and then Comes_From_Source (Loop_Stmt)
1065 Loop_Stmt := Parent (Loop_Stmt);
1068 Loop_Id := Entity (Identifier (Loop_Stmt));
1071 Loc := Sloc (Loop_Stmt);
1073 -- Step 2: Transform the loop
1075 -- The loop has already been transformed during the expansion of a prior
1076 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
1078 if Has_Loop_Entry_Attributes (Loop_Id) then
1080 -- When the related loop name appears as the argument of attribute
1081 -- Loop_Entry, the corresponding label construct is the generated
1082 -- block statement. This is because the expander reuses the label.
1084 if Nkind (Loop_Stmt) = N_Block_Statement then
1085 Decls := Declarations (Loop_Stmt);
1087 -- In all other cases, the loop must appear in the handled sequence
1088 -- of statements of the generated block.
1092 (Nkind (Parent (Loop_Stmt)) = N_Handled_Sequence_Of_Statements
1094 Nkind (Parent (Parent (Loop_Stmt))) = N_Block_Statement);
1096 Decls := Declarations (Parent (Parent (Loop_Stmt)));
1101 -- Transform the loop into a conditional block
1104 Set_Has_Loop_Entry_Attributes (Loop_Id);
1105 Scheme := Iteration_Scheme (Loop_Stmt);
1107 -- Infinite loops are transformed into:
1110 -- Temp1 : constant <type of Pref1> := <Pref1>;
1112 -- TempN : constant <type of PrefN> := <PrefN>;
1115 -- <original source statements with attribute rewrites>
1120 Build_Conditional_Block (Loc,
1122 Loop_Stmt => Relocate_Node (Loop_Stmt),
1128 -- While loops are transformed into:
1130 -- function Fnn return Boolean is
1132 -- <condition actions>
1133 -- return <condition>;
1138 -- Temp1 : constant <type of Pref1> := <Pref1>;
1140 -- TempN : constant <type of PrefN> := <PrefN>;
1143 -- <original source statements with attribute rewrites>
1144 -- exit when not Fnn;
1149 -- Note that loops over iterators and containers are already
1150 -- converted into while loops.
1152 elsif Present (Condition (Scheme)) then
1154 Func_Decl : Node_Id;
1155 Func_Id : Entity_Id;
1159 -- Wrap the condition of the while loop in a Boolean function.
1160 -- This avoids the duplication of the same code which may lead
1161 -- to gigi issues with respect to multiple declaration of the
1162 -- same entity in the presence of side effects or checks. Note
1163 -- that the condition actions must also be relocated to the
1164 -- wrapping function.
1167 -- <condition actions>
1168 -- return <condition>;
1170 if Present (Condition_Actions (Scheme)) then
1171 Stmts := Condition_Actions (Scheme);
1177 Make_Simple_Return_Statement (Loc,
1178 Expression => Relocate_Node (Condition (Scheme))));
1181 -- function Fnn return Boolean is
1186 Func_Id := Make_Temporary (Loc, 'F');
1188 Make_Subprogram_Body (Loc,
1190 Make_Function_Specification (Loc,
1191 Defining_Unit_Name => Func_Id,
1192 Result_Definition =>
1193 New_Occurrence_Of (Standard_Boolean, Loc)),
1194 Declarations => Empty_List,
1195 Handled_Statement_Sequence =>
1196 Make_Handled_Sequence_Of_Statements (Loc,
1197 Statements => Stmts));
1199 -- The function is inserted before the related loop. Make sure
1200 -- to analyze it in the context of the loop's enclosing scope.
1202 Push_Scope (Scope (Loop_Id));
1203 Insert_Action (Loop_Stmt, Func_Decl);
1206 -- Transform the original while loop into an infinite loop
1207 -- where the last statement checks the negated condition. This
1208 -- placement ensures that the condition will not be evaluated
1209 -- twice on the first iteration.
1211 Set_Iteration_Scheme (Loop_Stmt, Empty);
1215 -- exit when not Fnn;
1217 Append_To (Statements (Loop_Stmt),
1218 Make_Exit_Statement (Loc,
1222 Make_Function_Call (Loc,
1223 Name => New_Occurrence_Of (Func_Id, Loc)))));
1225 Build_Conditional_Block (Loc,
1227 Make_Function_Call (Loc,
1228 Name => New_Occurrence_Of (Func_Id, Loc)),
1229 Loop_Stmt => Relocate_Node (Loop_Stmt),
1234 -- Ada 2012 iteration over an array is transformed into:
1236 -- if <Array_Nam>'Length (1) > 0
1237 -- and then <Array_Nam>'Length (N) > 0
1240 -- Temp1 : constant <type of Pref1> := <Pref1>;
1242 -- TempN : constant <type of PrefN> := <PrefN>;
1244 -- for X in ... loop -- multiple loops depending on dims
1245 -- <original source statements with attribute rewrites>
1250 elsif Is_Array_Iteration (Loop_Stmt) then
1252 Array_Nam : constant Entity_Id :=
1253 Entity (Name (Iterator_Specification
1254 (Iteration_Scheme (Original_Node (Loop_Stmt)))));
1255 Num_Dims : constant Pos :=
1256 Number_Dimensions (Etype (Array_Nam));
1257 Cond : Node_Id := Empty;
1261 -- Generate a check which determines whether all dimensions of
1262 -- the array are non-null.
1264 for Dim in 1 .. Num_Dims loop
1268 Make_Attribute_Reference (Loc,
1269 Prefix => New_Occurrence_Of (Array_Nam, Loc),
1270 Attribute_Name => Name_Length,
1271 Expressions => New_List (
1272 Make_Integer_Literal (Loc, Dim))),
1274 Make_Integer_Literal (Loc, 0));
1282 Right_Opnd => Check);
1286 Build_Conditional_Block (Loc,
1288 Loop_Stmt => Relocate_Node (Loop_Stmt),
1293 -- For loops are transformed into:
1295 -- if <Low> <= <High> then
1297 -- Temp1 : constant <type of Pref1> := <Pref1>;
1299 -- TempN : constant <type of PrefN> := <PrefN>;
1301 -- for <Def_Id> in <Low> .. <High> loop
1302 -- <original source statements with attribute rewrites>
1307 elsif Present (Loop_Parameter_Specification (Scheme)) then
1309 Loop_Spec : constant Node_Id :=
1310 Loop_Parameter_Specification (Scheme);
1315 Subt_Def := Discrete_Subtype_Definition (Loop_Spec);
1317 -- When the loop iterates over a subtype indication with a
1318 -- range, use the low and high bounds of the subtype itself.
1320 if Nkind (Subt_Def) = N_Subtype_Indication then
1321 Subt_Def := Scalar_Range (Etype (Subt_Def));
1324 pragma Assert (Nkind (Subt_Def) = N_Range);
1331 Left_Opnd => New_Copy_Tree (Low_Bound (Subt_Def)),
1332 Right_Opnd => New_Copy_Tree (High_Bound (Subt_Def)));
1334 Build_Conditional_Block (Loc,
1336 Loop_Stmt => Relocate_Node (Loop_Stmt),
1342 Decls := Declarations (Blk);
1345 -- Step 3: Create a constant to capture the value of the prefix at the
1346 -- entry point into the loop.
1348 Temp_Id := Make_Temporary (Loc, 'P');
1350 -- Preserve the tag of the prefix by offering a specific view of the
1351 -- class-wide version of the prefix.
1353 if Is_Tagged_Type (Typ) then
1356 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
1358 CW_Temp := Make_Temporary (Loc, 'T');
1359 CW_Typ := Class_Wide_Type (Typ);
1362 Make_Object_Declaration (Loc,
1363 Defining_Identifier => CW_Temp,
1364 Constant_Present => True,
1365 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
1367 Convert_To (CW_Typ, Relocate_Node (Pref)));
1368 Append_To (Decls, CW_Decl);
1371 -- Temp : Typ renames Typ (CW_Temp);
1374 Make_Object_Renaming_Declaration (Loc,
1375 Defining_Identifier => Temp_Id,
1376 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
1378 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)));
1379 Append_To (Decls, Temp_Decl);
1387 -- Temp : constant Typ := Pref;
1390 Make_Object_Declaration (Loc,
1391 Defining_Identifier => Temp_Id,
1392 Constant_Present => True,
1393 Object_Definition => New_Occurrence_Of (Typ, Loc),
1394 Expression => Relocate_Node (Pref));
1395 Append_To (Decls, Temp_Decl);
1398 -- Step 4: Analyze all bits
1400 Installed := Current_Scope = Scope (Loop_Id);
1402 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1403 -- associated loop, ensure the proper visibility for analysis.
1405 if not Installed then
1406 Push_Scope (Scope (Loop_Id));
1409 -- The analysis of the conditional block takes care of the constant
1412 if Present (Result) then
1413 Rewrite (Loop_Stmt, Result);
1414 Analyze (Loop_Stmt);
1416 -- The conditional block was analyzed when a previous 'Loop_Entry was
1417 -- expanded. There is no point in reanalyzing the block, simply analyze
1418 -- the declaration of the constant.
1421 if Present (CW_Decl) then
1425 Analyze (Temp_Decl);
1428 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
1431 if not Installed then
1434 end Expand_Loop_Entry_Attribute;
1436 ------------------------------
1437 -- Expand_Min_Max_Attribute --
1438 ------------------------------
1440 procedure Expand_Min_Max_Attribute (N : Node_Id) is
1442 -- Min and Max are handled by the back end (except that static cases
1443 -- have already been evaluated during semantic processing, although the
1444 -- back end should not count on this). The one bit of special processing
1445 -- required in the normal case is that these two attributes typically
1446 -- generate conditionals in the code, so check the relevant restriction.
1448 Check_Restriction (No_Implicit_Conditionals, N);
1450 -- In Modify_Tree_For_C mode, we rewrite as an if expression
1452 if Modify_Tree_For_C then
1454 Loc : constant Source_Ptr := Sloc (N);
1455 Typ : constant Entity_Id := Etype (N);
1456 Expr : constant Node_Id := First (Expressions (N));
1457 Left : constant Node_Id := Relocate_Node (Expr);
1458 Right : constant Node_Id := Relocate_Node (Next (Expr));
1460 function Make_Compare (Left, Right : Node_Id) return Node_Id;
1461 -- Returns Left >= Right for Max, Left <= Right for Min
1467 function Make_Compare (Left, Right : Node_Id) return Node_Id is
1469 if Attribute_Name (N) = Name_Max then
1473 Right_Opnd => Right);
1478 Right_Opnd => Right);
1482 -- Start of processing for Min_Max
1485 -- If both Left and Right are side effect free, then we can just
1486 -- use Duplicate_Expr to duplicate the references and return
1488 -- (if Left >=|<= Right then Left else Right)
1490 if Side_Effect_Free (Left) and then Side_Effect_Free (Right) then
1492 Make_If_Expression (Loc,
1493 Expressions => New_List (
1494 Make_Compare (Left, Right),
1495 Duplicate_Subexpr_No_Checks (Left),
1496 Duplicate_Subexpr_No_Checks (Right))));
1498 -- Otherwise we generate declarations to capture the values.
1500 -- The translation is
1503 -- T1 : constant typ := Left;
1504 -- T2 : constant typ := Right;
1506 -- (if T1 >=|<= T2 then T1 else T2)
1511 T1 : constant Entity_Id := Make_Temporary (Loc, 'T', Left);
1512 T2 : constant Entity_Id := Make_Temporary (Loc, 'T', Right);
1516 Make_Expression_With_Actions (Loc,
1517 Actions => New_List (
1518 Make_Object_Declaration (Loc,
1519 Defining_Identifier => T1,
1520 Constant_Present => True,
1521 Object_Definition =>
1522 New_Occurrence_Of (Etype (Left), Loc),
1523 Expression => Relocate_Node (Left)),
1525 Make_Object_Declaration (Loc,
1526 Defining_Identifier => T2,
1527 Constant_Present => True,
1528 Object_Definition =>
1529 New_Occurrence_Of (Etype (Right), Loc),
1530 Expression => Relocate_Node (Right))),
1533 Make_If_Expression (Loc,
1534 Expressions => New_List (
1536 (New_Occurrence_Of (T1, Loc),
1537 New_Occurrence_Of (T2, Loc)),
1538 New_Occurrence_Of (T1, Loc),
1539 New_Occurrence_Of (T2, Loc)))));
1543 Analyze_And_Resolve (N, Typ);
1546 end Expand_Min_Max_Attribute;
1548 ----------------------------------
1549 -- Expand_N_Attribute_Reference --
1550 ----------------------------------
1552 procedure Expand_N_Attribute_Reference (N : Node_Id) is
1553 Loc : constant Source_Ptr := Sloc (N);
1554 Typ : constant Entity_Id := Etype (N);
1555 Btyp : constant Entity_Id := Base_Type (Typ);
1556 Pref : constant Node_Id := Prefix (N);
1557 Ptyp : constant Entity_Id := Etype (Pref);
1558 Exprs : constant List_Id := Expressions (N);
1559 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
1561 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
1562 -- Rewrites a stream attribute for Read, Write or Output with the
1563 -- procedure call. Pname is the entity for the procedure to call.
1565 ------------------------------
1566 -- Rewrite_Stream_Proc_Call --
1567 ------------------------------
1569 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
1570 Item : constant Node_Id := Next (First (Exprs));
1571 Item_Typ : constant Entity_Id := Etype (Item);
1572 Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
1573 Formal_Typ : constant Entity_Id := Etype (Formal);
1574 Is_Written : constant Boolean := Ekind (Formal) /= E_In_Parameter;
1577 -- The expansion depends on Item, the second actual, which is
1578 -- the object being streamed in or out.
1580 -- If the item is a component of a packed array type, and
1581 -- a conversion is needed on exit, we introduce a temporary to
1582 -- hold the value, because otherwise the packed reference will
1583 -- not be properly expanded.
1585 if Nkind (Item) = N_Indexed_Component
1586 and then Is_Packed (Base_Type (Etype (Prefix (Item))))
1587 and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
1591 Temp : constant Entity_Id := Make_Temporary (Loc, 'V');
1597 Make_Object_Declaration (Loc,
1598 Defining_Identifier => Temp,
1599 Object_Definition => New_Occurrence_Of (Formal_Typ, Loc));
1600 Set_Etype (Temp, Formal_Typ);
1603 Make_Assignment_Statement (Loc,
1604 Name => New_Copy_Tree (Item),
1606 Unchecked_Convert_To
1607 (Item_Typ, New_Occurrence_Of (Temp, Loc)));
1609 Rewrite (Item, New_Occurrence_Of (Temp, Loc));
1613 Make_Procedure_Call_Statement (Loc,
1614 Name => New_Occurrence_Of (Pname, Loc),
1615 Parameter_Associations => Exprs),
1618 Rewrite (N, Make_Null_Statement (Loc));
1623 -- For the class-wide dispatching cases, and for cases in which
1624 -- the base type of the second argument matches the base type of
1625 -- the corresponding formal parameter (that is to say the stream
1626 -- operation is not inherited), we are all set, and can use the
1627 -- argument unchanged.
1629 if not Is_Class_Wide_Type (Entity (Pref))
1630 and then not Is_Class_Wide_Type (Etype (Item))
1631 and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
1633 -- Perform a view conversion when either the argument or the
1634 -- formal parameter are of a private type.
1636 if Is_Private_Type (Formal_Typ)
1637 or else Is_Private_Type (Item_Typ)
1640 Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
1642 -- Otherwise perform a regular type conversion to ensure that all
1643 -- relevant checks are installed.
1646 Rewrite (Item, Convert_To (Formal_Typ, Relocate_Node (Item)));
1649 -- For untagged derived types set Assignment_OK, to prevent
1650 -- copies from being created when the unchecked conversion
1651 -- is expanded (which would happen in Remove_Side_Effects
1652 -- if Expand_N_Unchecked_Conversion were allowed to call
1653 -- Force_Evaluation). The copy could violate Ada semantics in
1654 -- cases such as an actual that is an out parameter. Note that
1655 -- this approach is also used in exp_ch7 for calls to controlled
1656 -- type operations to prevent problems with actuals wrapped in
1657 -- unchecked conversions.
1659 if Is_Untagged_Derivation (Etype (Expression (Item))) then
1660 Set_Assignment_OK (Item);
1664 -- The stream operation to call may be a renaming created by an
1665 -- attribute definition clause, and may not be frozen yet. Ensure
1666 -- that it has the necessary extra formals.
1668 if not Is_Frozen (Pname) then
1669 Create_Extra_Formals (Pname);
1672 -- And now rewrite the call
1675 Make_Procedure_Call_Statement (Loc,
1676 Name => New_Occurrence_Of (Pname, Loc),
1677 Parameter_Associations => Exprs));
1680 end Rewrite_Stream_Proc_Call;
1682 -- Start of processing for Expand_N_Attribute_Reference
1685 -- Do required validity checking, if enabled. Do not apply check to
1686 -- output parameters of an Asm instruction, since the value of this
1687 -- is not set till after the attribute has been elaborated, and do
1688 -- not apply the check to the arguments of a 'Read or 'Input attribute
1689 -- reference since the scalar argument is an OUT scalar.
1691 if Validity_Checks_On and then Validity_Check_Operands
1692 and then Id /= Attribute_Asm_Output
1693 and then Id /= Attribute_Read
1694 and then Id /= Attribute_Input
1699 Expr := First (Expressions (N));
1700 while Present (Expr) loop
1701 Ensure_Valid (Expr);
1707 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
1708 -- place function, then a temporary return object needs to be created
1709 -- and access to it must be passed to the function. Currently we limit
1710 -- such functions to those with inherently limited result subtypes, but
1711 -- eventually we plan to expand the functions that are treated as
1712 -- build-in-place to include other composite result types.
1714 if Ada_Version >= Ada_2005
1715 and then Is_Build_In_Place_Function_Call (Pref)
1717 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
1720 -- If prefix is a protected type name, this is a reference to the
1721 -- current instance of the type. For a component definition, nothing
1722 -- to do (expansion will occur in the init proc). In other contexts,
1723 -- rewrite into reference to current instance.
1725 if Is_Protected_Self_Reference (Pref)
1727 (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint,
1728 N_Discriminant_Association)
1729 and then Nkind (Parent (Parent (Parent (Parent (N))))) =
1730 N_Component_Definition)
1732 -- No action needed for these attributes since the current instance
1733 -- will be rewritten to be the name of the _object parameter
1734 -- associated with the enclosing protected subprogram (see below).
1736 and then Id /= Attribute_Access
1737 and then Id /= Attribute_Unchecked_Access
1738 and then Id /= Attribute_Unrestricted_Access
1740 Rewrite (Pref, Concurrent_Ref (Pref));
1744 -- Remaining processing depends on specific attribute
1746 -- Note: individual sections of the following case statement are
1747 -- allowed to assume there is no code after the case statement, and
1748 -- are legitimately allowed to execute return statements if they have
1749 -- nothing more to do.
1753 -- Attributes related to Ada 2012 iterators
1755 when Attribute_Constant_Indexing |
1756 Attribute_Default_Iterator |
1757 Attribute_Implicit_Dereference |
1758 Attribute_Iterable |
1759 Attribute_Iterator_Element |
1760 Attribute_Variable_Indexing =>
1763 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
1764 -- were already rejected by the parser. Thus they shouldn't appear here.
1766 when Internal_Attribute_Id =>
1767 raise Program_Error;
1773 when Attribute_Access |
1774 Attribute_Unchecked_Access |
1775 Attribute_Unrestricted_Access =>
1777 Access_Cases : declare
1778 Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
1779 Btyp_DDT : Entity_Id;
1781 function Enclosing_Object (N : Node_Id) return Node_Id;
1782 -- If N denotes a compound name (selected component, indexed
1783 -- component, or slice), returns the name of the outermost such
1784 -- enclosing object. Otherwise returns N. If the object is a
1785 -- renaming, then the renamed object is returned.
1787 ----------------------
1788 -- Enclosing_Object --
1789 ----------------------
1791 function Enclosing_Object (N : Node_Id) return Node_Id is
1796 while Nkind_In (Obj_Name, N_Selected_Component,
1797 N_Indexed_Component,
1800 Obj_Name := Prefix (Obj_Name);
1803 return Get_Referenced_Object (Obj_Name);
1804 end Enclosing_Object;
1806 -- Local declarations
1808 Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
1810 -- Start of processing for Access_Cases
1813 Btyp_DDT := Designated_Type (Btyp);
1815 -- Handle designated types that come from the limited view
1817 if From_Limited_With (Btyp_DDT)
1818 and then Has_Non_Limited_View (Btyp_DDT)
1820 Btyp_DDT := Non_Limited_View (Btyp_DDT);
1823 -- In order to improve the text of error messages, the designated
1824 -- type of access-to-subprogram itypes is set by the semantics as
1825 -- the associated subprogram entity (see sem_attr). Now we replace
1826 -- such node with the proper E_Subprogram_Type itype.
1828 if Id = Attribute_Unrestricted_Access
1829 and then Is_Subprogram (Directly_Designated_Type (Typ))
1831 -- The following conditions ensure that this special management
1832 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
1833 -- At this stage other cases in which the designated type is
1834 -- still a subprogram (instead of an E_Subprogram_Type) are
1835 -- wrong because the semantics must have overridden the type of
1836 -- the node with the type imposed by the context.
1838 if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
1839 and then Etype (Parent (N)) = RTE (RE_Prim_Ptr)
1841 Set_Etype (N, RTE (RE_Prim_Ptr));
1845 Subp : constant Entity_Id :=
1846 Directly_Designated_Type (Typ);
1848 Extra : Entity_Id := Empty;
1849 New_Formal : Entity_Id;
1850 Old_Formal : Entity_Id := First_Formal (Subp);
1851 Subp_Typ : Entity_Id;
1854 Subp_Typ := Create_Itype (E_Subprogram_Type, N);
1855 Set_Etype (Subp_Typ, Etype (Subp));
1856 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
1858 if Present (Old_Formal) then
1859 New_Formal := New_Copy (Old_Formal);
1860 Set_First_Entity (Subp_Typ, New_Formal);
1863 Set_Scope (New_Formal, Subp_Typ);
1864 Etyp := Etype (New_Formal);
1866 -- Handle itypes. There is no need to duplicate
1867 -- here the itypes associated with record types
1868 -- (i.e the implicit full view of private types).
1871 and then Ekind (Base_Type (Etyp)) /= E_Record_Type
1873 Extra := New_Copy (Etyp);
1874 Set_Parent (Extra, New_Formal);
1875 Set_Etype (New_Formal, Extra);
1876 Set_Scope (Extra, Subp_Typ);
1879 Extra := New_Formal;
1880 Next_Formal (Old_Formal);
1881 exit when No (Old_Formal);
1883 Set_Next_Entity (New_Formal,
1884 New_Copy (Old_Formal));
1885 Next_Entity (New_Formal);
1888 Set_Next_Entity (New_Formal, Empty);
1889 Set_Last_Entity (Subp_Typ, Extra);
1892 -- Now that the explicit formals have been duplicated,
1893 -- any extra formals needed by the subprogram must be
1896 if Present (Extra) then
1897 Set_Extra_Formal (Extra, Empty);
1900 Create_Extra_Formals (Subp_Typ);
1901 Set_Directly_Designated_Type (Typ, Subp_Typ);
1906 if Is_Access_Protected_Subprogram_Type (Btyp) then
1907 Expand_Access_To_Protected_Op (N, Pref, Typ);
1909 -- If prefix is a type name, this is a reference to the current
1910 -- instance of the type, within its initialization procedure.
1912 elsif Is_Entity_Name (Pref)
1913 and then Is_Type (Entity (Pref))
1920 -- If the current instance name denotes a task type, then
1921 -- the access attribute is rewritten to be the name of the
1922 -- "_task" parameter associated with the task type's task
1923 -- procedure. An unchecked conversion is applied to ensure
1924 -- a type match in cases of expander-generated calls (e.g.
1927 if Is_Task_Type (Entity (Pref)) then
1929 First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
1930 while Present (Formal) loop
1931 exit when Chars (Formal) = Name_uTask;
1932 Next_Entity (Formal);
1935 pragma Assert (Present (Formal));
1938 Unchecked_Convert_To (Typ,
1939 New_Occurrence_Of (Formal, Loc)));
1942 elsif Is_Protected_Type (Entity (Pref)) then
1944 -- No action needed for current instance located in a
1945 -- component definition (expansion will occur in the
1948 if Is_Protected_Type (Current_Scope) then
1951 -- If the current instance reference is located in a
1952 -- protected subprogram or entry then rewrite the access
1953 -- attribute to be the name of the "_object" parameter.
1954 -- An unchecked conversion is applied to ensure a type
1955 -- match in cases of expander-generated calls (e.g. init
1958 -- The code may be nested in a block, so find enclosing
1959 -- scope that is a protected operation.
1966 Subp := Current_Scope;
1967 while Ekind_In (Subp, E_Loop, E_Block) loop
1968 Subp := Scope (Subp);
1973 (Protected_Body_Subprogram (Subp));
1975 -- For a protected subprogram the _Object parameter
1976 -- is the protected record, so we create an access
1977 -- to it. The _Object parameter of an entry is an
1980 if Ekind (Subp) = E_Entry then
1982 Unchecked_Convert_To (Typ,
1983 New_Occurrence_Of (Formal, Loc)));
1988 Unchecked_Convert_To (Typ,
1989 Make_Attribute_Reference (Loc,
1990 Attribute_Name => Name_Unrestricted_Access,
1992 New_Occurrence_Of (Formal, Loc))));
1993 Analyze_And_Resolve (N);
1998 -- The expression must appear in a default expression,
1999 -- (which in the initialization procedure is the right-hand
2000 -- side of an assignment), and not in a discriminant
2005 while Present (Par) loop
2006 exit when Nkind (Par) = N_Assignment_Statement;
2008 if Nkind (Par) = N_Component_Declaration then
2012 Par := Parent (Par);
2015 if Present (Par) then
2017 Make_Attribute_Reference (Loc,
2018 Prefix => Make_Identifier (Loc, Name_uInit),
2019 Attribute_Name => Attribute_Name (N)));
2021 Analyze_And_Resolve (N, Typ);
2026 -- If the prefix of an Access attribute is a dereference of an
2027 -- access parameter (or a renaming of such a dereference, or a
2028 -- subcomponent of such a dereference) and the context is a
2029 -- general access type (including the type of an object or
2030 -- component with an access_definition, but not the anonymous
2031 -- type of an access parameter or access discriminant), then
2032 -- apply an accessibility check to the access parameter. We used
2033 -- to rewrite the access parameter as a type conversion, but that
2034 -- could only be done if the immediate prefix of the Access
2035 -- attribute was the dereference, and didn't handle cases where
2036 -- the attribute is applied to a subcomponent of the dereference,
2037 -- since there's generally no available, appropriate access type
2038 -- to convert to in that case. The attribute is passed as the
2039 -- point to insert the check, because the access parameter may
2040 -- come from a renaming, possibly in a different scope, and the
2041 -- check must be associated with the attribute itself.
2043 elsif Id = Attribute_Access
2044 and then Nkind (Enc_Object) = N_Explicit_Dereference
2045 and then Is_Entity_Name (Prefix (Enc_Object))
2046 and then (Ekind (Btyp) = E_General_Access_Type
2047 or else Is_Local_Anonymous_Access (Btyp))
2048 and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind
2049 and then Ekind (Etype (Entity (Prefix (Enc_Object))))
2050 = E_Anonymous_Access_Type
2051 and then Present (Extra_Accessibility
2052 (Entity (Prefix (Enc_Object))))
2054 Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N);
2056 -- Ada 2005 (AI-251): If the designated type is an interface we
2057 -- add an implicit conversion to force the displacement of the
2058 -- pointer to reference the secondary dispatch table.
2060 elsif Is_Interface (Btyp_DDT)
2061 and then (Comes_From_Source (N)
2062 or else Comes_From_Source (Ref_Object)
2063 or else (Nkind (Ref_Object) in N_Has_Chars
2064 and then Chars (Ref_Object) = Name_uInit))
2066 if Nkind (Ref_Object) /= N_Explicit_Dereference then
2068 -- No implicit conversion required if types match, or if
2069 -- the prefix is the class_wide_type of the interface. In
2070 -- either case passing an object of the interface type has
2071 -- already set the pointer correctly.
2073 if Btyp_DDT = Etype (Ref_Object)
2074 or else (Is_Class_Wide_Type (Etype (Ref_Object))
2076 Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object))
2081 Rewrite (Prefix (N),
2082 Convert_To (Btyp_DDT,
2083 New_Copy_Tree (Prefix (N))));
2085 Analyze_And_Resolve (Prefix (N), Btyp_DDT);
2088 -- When the object is an explicit dereference, convert the
2089 -- dereference's prefix.
2093 Obj_DDT : constant Entity_Id :=
2095 (Directly_Designated_Type
2096 (Etype (Prefix (Ref_Object))));
2098 -- No implicit conversion required if designated types
2099 -- match, or if we have an unrestricted access.
2101 if Obj_DDT /= Btyp_DDT
2102 and then Id /= Attribute_Unrestricted_Access
2103 and then not (Is_Class_Wide_Type (Obj_DDT)
2104 and then Etype (Obj_DDT) = Btyp_DDT)
2108 New_Copy_Tree (Prefix (Ref_Object))));
2109 Analyze_And_Resolve (N, Typ);
2120 -- Transforms 'Adjacent into a call to the floating-point attribute
2121 -- function Adjacent in Fat_xxx (where xxx is the root type)
2123 when Attribute_Adjacent =>
2124 Expand_Fpt_Attribute_RR (N);
2130 when Attribute_Address => Address : declare
2131 Task_Proc : Entity_Id;
2134 -- If the prefix is a task or a task type, the useful address is that
2135 -- of the procedure for the task body, i.e. the actual program unit.
2136 -- We replace the original entity with that of the procedure.
2138 if Is_Entity_Name (Pref)
2139 and then Is_Task_Type (Entity (Pref))
2141 Task_Proc := Next_Entity (Root_Type (Ptyp));
2143 while Present (Task_Proc) loop
2144 exit when Ekind (Task_Proc) = E_Procedure
2145 and then Etype (First_Formal (Task_Proc)) =
2146 Corresponding_Record_Type (Ptyp);
2147 Next_Entity (Task_Proc);
2150 if Present (Task_Proc) then
2151 Set_Entity (Pref, Task_Proc);
2152 Set_Etype (Pref, Etype (Task_Proc));
2155 -- Similarly, the address of a protected operation is the address
2156 -- of the corresponding protected body, regardless of the protected
2157 -- object from which it is selected.
2159 elsif Nkind (Pref) = N_Selected_Component
2160 and then Is_Subprogram (Entity (Selector_Name (Pref)))
2161 and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref))))
2165 External_Subprogram (Entity (Selector_Name (Pref))), Loc));
2167 elsif Nkind (Pref) = N_Explicit_Dereference
2168 and then Ekind (Ptyp) = E_Subprogram_Type
2169 and then Convention (Ptyp) = Convention_Protected
2171 -- The prefix is be a dereference of an access_to_protected_
2172 -- subprogram. The desired address is the second component of
2173 -- the record that represents the access.
2176 Addr : constant Entity_Id := Etype (N);
2177 Ptr : constant Node_Id := Prefix (Pref);
2178 T : constant Entity_Id :=
2179 Equivalent_Type (Base_Type (Etype (Ptr)));
2183 Unchecked_Convert_To (Addr,
2184 Make_Selected_Component (Loc,
2185 Prefix => Unchecked_Convert_To (T, Ptr),
2186 Selector_Name => New_Occurrence_Of (
2187 Next_Entity (First_Entity (T)), Loc))));
2189 Analyze_And_Resolve (N, Addr);
2192 -- Ada 2005 (AI-251): Class-wide interface objects are always
2193 -- "displaced" to reference the tag associated with the interface
2194 -- type. In order to obtain the real address of such objects we
2195 -- generate a call to a run-time subprogram that returns the base
2196 -- address of the object.
2198 -- This processing is not needed in the VM case, where dispatching
2199 -- issues are taken care of by the virtual machine.
2201 elsif Is_Class_Wide_Type (Ptyp)
2202 and then Is_Interface (Ptyp)
2203 and then Tagged_Type_Expansion
2204 and then not (Nkind (Pref) in N_Has_Entity
2205 and then Is_Subprogram (Entity (Pref)))
2208 Make_Function_Call (Loc,
2209 Name => New_Occurrence_Of (RTE (RE_Base_Address), Loc),
2210 Parameter_Associations => New_List (
2211 Relocate_Node (N))));
2216 -- Deal with packed array reference, other cases are handled by
2219 if Involves_Packed_Array_Reference (Pref) then
2220 Expand_Packed_Address_Reference (N);
2228 when Attribute_Alignment => Alignment : declare
2232 -- For class-wide types, X'Class'Alignment is transformed into a
2233 -- direct reference to the Alignment of the class type, so that the
2234 -- back end does not have to deal with the X'Class'Alignment
2237 if Is_Entity_Name (Pref)
2238 and then Is_Class_Wide_Type (Entity (Pref))
2240 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
2243 -- For x'Alignment applied to an object of a class wide type,
2244 -- transform X'Alignment into a call to the predefined primitive
2245 -- operation _Alignment applied to X.
2247 elsif Is_Class_Wide_Type (Ptyp) then
2249 Make_Attribute_Reference (Loc,
2251 Attribute_Name => Name_Tag);
2253 New_Node := Build_Get_Alignment (Loc, New_Node);
2255 -- Case where the context is a specific integer type with which
2256 -- the original attribute was compatible. The function has a
2257 -- specific type as well, so to preserve the compatibility we
2258 -- must convert explicitly.
2260 if Typ /= Standard_Integer then
2261 New_Node := Convert_To (Typ, New_Node);
2264 Rewrite (N, New_Node);
2265 Analyze_And_Resolve (N, Typ);
2268 -- For all other cases, we just have to deal with the case of
2269 -- the fact that the result can be universal.
2272 Apply_Universal_Integer_Attribute_Checks (N);
2280 -- We compute this if a packed array reference was present, otherwise we
2281 -- leave the computation up to the back end.
2283 when Attribute_Bit =>
2284 if Involves_Packed_Array_Reference (Pref) then
2285 Expand_Packed_Bit_Reference (N);
2287 Apply_Universal_Integer_Attribute_Checks (N);
2294 -- We compute this if a component clause was present, otherwise we leave
2295 -- the computation up to the back end, since we don't know what layout
2298 -- Note that the attribute can apply to a naked record component
2299 -- in generated code (i.e. the prefix is an identifier that
2300 -- references the component or discriminant entity).
2302 when Attribute_Bit_Position => Bit_Position : declare
2306 if Nkind (Pref) = N_Identifier then
2307 CE := Entity (Pref);
2309 CE := Entity (Selector_Name (Pref));
2312 if Known_Static_Component_Bit_Offset (CE) then
2314 Make_Integer_Literal (Loc,
2315 Intval => Component_Bit_Offset (CE)));
2316 Analyze_And_Resolve (N, Typ);
2319 Apply_Universal_Integer_Attribute_Checks (N);
2327 -- A reference to P'Body_Version or P'Version is expanded to
2330 -- pragma Import (C, Vnn, "uuuuT");
2332 -- Get_Version_String (Vnn)
2334 -- where uuuu is the unit name (dots replaced by double underscore)
2335 -- and T is B for the cases of Body_Version, or Version applied to a
2336 -- subprogram acting as its own spec, and S for Version applied to a
2337 -- subprogram spec or package. This sequence of code references the
2338 -- unsigned constant created in the main program by the binder.
2340 -- A special exception occurs for Standard, where the string returned
2341 -- is a copy of the library string in gnatvsn.ads.
2343 when Attribute_Body_Version | Attribute_Version => Version : declare
2344 E : constant Entity_Id := Make_Temporary (Loc, 'V');
2349 -- If not library unit, get to containing library unit
2351 Pent := Entity (Pref);
2352 while Pent /= Standard_Standard
2353 and then Scope (Pent) /= Standard_Standard
2354 and then not Is_Child_Unit (Pent)
2356 Pent := Scope (Pent);
2359 -- Special case Standard and Standard.ASCII
2361 if Pent = Standard_Standard or else Pent = Standard_ASCII then
2363 Make_String_Literal (Loc,
2364 Strval => Verbose_Library_Version));
2369 -- Build required string constant
2371 Get_Name_String (Get_Unit_Name (Pent));
2374 for J in 1 .. Name_Len - 2 loop
2375 if Name_Buffer (J) = '.' then
2376 Store_String_Chars ("__");
2378 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
2382 -- Case of subprogram acting as its own spec, always use body
2384 if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
2385 and then Nkind (Parent (Declaration_Node (Pent))) =
2387 and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
2389 Store_String_Chars ("B");
2391 -- Case of no body present, always use spec
2393 elsif not Unit_Requires_Body (Pent) then
2394 Store_String_Chars ("S");
2396 -- Otherwise use B for Body_Version, S for spec
2398 elsif Id = Attribute_Body_Version then
2399 Store_String_Chars ("B");
2401 Store_String_Chars ("S");
2405 Lib.Version_Referenced (S);
2407 -- Insert the object declaration
2409 Insert_Actions (N, New_List (
2410 Make_Object_Declaration (Loc,
2411 Defining_Identifier => E,
2412 Object_Definition =>
2413 New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
2415 -- Set entity as imported with correct external name
2417 Set_Is_Imported (E);
2418 Set_Interface_Name (E, Make_String_Literal (Loc, S));
2420 -- Set entity as internal to ensure proper Sprint output of its
2421 -- implicit importation.
2423 Set_Is_Internal (E);
2425 -- And now rewrite original reference
2428 Make_Function_Call (Loc,
2429 Name => New_Occurrence_Of (RTE (RE_Get_Version_String), Loc),
2430 Parameter_Associations => New_List (
2431 New_Occurrence_Of (E, Loc))));
2434 Analyze_And_Resolve (N, RTE (RE_Version_String));
2441 -- Transforms 'Ceiling into a call to the floating-point attribute
2442 -- function Ceiling in Fat_xxx (where xxx is the root type)
2444 when Attribute_Ceiling =>
2445 Expand_Fpt_Attribute_R (N);
2451 -- Transforms 'Callable attribute into a call to the Callable function
2453 when Attribute_Callable => Callable :
2455 -- We have an object of a task interface class-wide type as a prefix
2456 -- to Callable. Generate:
2457 -- callable (Task_Id (Pref._disp_get_task_id));
2459 if Ada_Version >= Ada_2005
2460 and then Ekind (Ptyp) = E_Class_Wide_Type
2461 and then Is_Interface (Ptyp)
2462 and then Is_Task_Interface (Ptyp)
2465 Make_Function_Call (Loc,
2467 New_Occurrence_Of (RTE (RE_Callable), Loc),
2468 Parameter_Associations => New_List (
2469 Make_Unchecked_Type_Conversion (Loc,
2471 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
2473 Make_Selected_Component (Loc,
2475 New_Copy_Tree (Pref),
2477 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
2481 Build_Call_With_Task (Pref, RTE (RE_Callable)));
2484 Analyze_And_Resolve (N, Standard_Boolean);
2491 -- Transforms 'Caller attribute into a call to either the
2492 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2494 when Attribute_Caller => Caller : declare
2495 Id_Kind : constant Entity_Id := RTE (RO_AT_Task_Id);
2496 Ent : constant Entity_Id := Entity (Pref);
2497 Conctype : constant Entity_Id := Scope (Ent);
2498 Nest_Depth : Integer := 0;
2505 if Is_Protected_Type (Conctype) then
2506 case Corresponding_Runtime_Package (Conctype) is
2507 when System_Tasking_Protected_Objects_Entries =>
2510 (RTE (RE_Protected_Entry_Caller), Loc);
2512 when System_Tasking_Protected_Objects_Single_Entry =>
2515 (RTE (RE_Protected_Single_Entry_Caller), Loc);
2518 raise Program_Error;
2522 Unchecked_Convert_To (Id_Kind,
2523 Make_Function_Call (Loc,
2525 Parameter_Associations => New_List (
2527 (Find_Protection_Object (Current_Scope), Loc)))));
2532 -- Determine the nesting depth of the E'Caller attribute, that
2533 -- is, how many accept statements are nested within the accept
2534 -- statement for E at the point of E'Caller. The runtime uses
2535 -- this depth to find the specified entry call.
2537 for J in reverse 0 .. Scope_Stack.Last loop
2538 S := Scope_Stack.Table (J).Entity;
2540 -- We should not reach the scope of the entry, as it should
2541 -- already have been checked in Sem_Attr that this attribute
2542 -- reference is within a matching accept statement.
2544 pragma Assert (S /= Conctype);
2549 elsif Is_Entry (S) then
2550 Nest_Depth := Nest_Depth + 1;
2555 Unchecked_Convert_To (Id_Kind,
2556 Make_Function_Call (Loc,
2558 New_Occurrence_Of (RTE (RE_Task_Entry_Caller), Loc),
2559 Parameter_Associations => New_List (
2560 Make_Integer_Literal (Loc,
2561 Intval => Int (Nest_Depth))))));
2564 Analyze_And_Resolve (N, Id_Kind);
2571 -- Transforms 'Compose into a call to the floating-point attribute
2572 -- function Compose in Fat_xxx (where xxx is the root type)
2574 -- Note: we strictly should have special code here to deal with the
2575 -- case of absurdly negative arguments (less than Integer'First)
2576 -- which will return a (signed) zero value, but it hardly seems
2577 -- worth the effort. Absurdly large positive arguments will raise
2578 -- constraint error which is fine.
2580 when Attribute_Compose =>
2581 Expand_Fpt_Attribute_RI (N);
2587 when Attribute_Constrained => Constrained : declare
2588 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
2590 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
2591 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
2592 -- view of an aliased object whose subtype is constrained.
2594 ---------------------------------
2595 -- Is_Constrained_Aliased_View --
2596 ---------------------------------
2598 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
2602 if Is_Entity_Name (Obj) then
2605 if Present (Renamed_Object (E)) then
2606 return Is_Constrained_Aliased_View (Renamed_Object (E));
2608 return Is_Aliased (E) and then Is_Constrained (Etype (E));
2612 return Is_Aliased_View (Obj)
2614 (Is_Constrained (Etype (Obj))
2616 (Nkind (Obj) = N_Explicit_Dereference
2618 not Object_Type_Has_Constrained_Partial_View
2619 (Typ => Base_Type (Etype (Obj)),
2620 Scop => Current_Scope)));
2622 end Is_Constrained_Aliased_View;
2624 -- Start of processing for Constrained
2627 -- Reference to a parameter where the value is passed as an extra
2628 -- actual, corresponding to the extra formal referenced by the
2629 -- Extra_Constrained field of the corresponding formal. If this
2630 -- is an entry in-parameter, it is replaced by a constant renaming
2631 -- for which Extra_Constrained is never created.
2633 if Present (Formal_Ent)
2634 and then Ekind (Formal_Ent) /= E_Constant
2635 and then Present (Extra_Constrained (Formal_Ent))
2639 (Extra_Constrained (Formal_Ent), Sloc (N)));
2641 -- For variables with a Extra_Constrained field, we use the
2642 -- corresponding entity.
2644 elsif Nkind (Pref) = N_Identifier
2645 and then Ekind (Entity (Pref)) = E_Variable
2646 and then Present (Extra_Constrained (Entity (Pref)))
2650 (Extra_Constrained (Entity (Pref)), Sloc (N)));
2652 -- For all other entity names, we can tell at compile time
2654 elsif Is_Entity_Name (Pref) then
2656 Ent : constant Entity_Id := Entity (Pref);
2660 -- (RM J.4) obsolescent cases
2662 if Is_Type (Ent) then
2666 if Is_Private_Type (Ent) then
2667 Res := not Has_Discriminants (Ent)
2668 or else Is_Constrained (Ent);
2670 -- It not a private type, must be a generic actual type
2671 -- that corresponded to a private type. We know that this
2672 -- correspondence holds, since otherwise the reference
2673 -- within the generic template would have been illegal.
2676 if Is_Composite_Type (Underlying_Type (Ent)) then
2677 Res := Is_Constrained (Ent);
2683 -- If the prefix is not a variable or is aliased, then
2684 -- definitely true; if it's a formal parameter without an
2685 -- associated extra formal, then treat it as constrained.
2687 -- Ada 2005 (AI-363): An aliased prefix must be known to be
2688 -- constrained in order to set the attribute to True.
2690 elsif not Is_Variable (Pref)
2691 or else Present (Formal_Ent)
2692 or else (Ada_Version < Ada_2005
2693 and then Is_Aliased_View (Pref))
2694 or else (Ada_Version >= Ada_2005
2695 and then Is_Constrained_Aliased_View (Pref))
2699 -- Variable case, look at type to see if it is constrained.
2700 -- Note that the one case where this is not accurate (the
2701 -- procedure formal case), has been handled above.
2703 -- We use the Underlying_Type here (and below) in case the
2704 -- type is private without discriminants, but the full type
2705 -- has discriminants. This case is illegal, but we generate it
2706 -- internally for passing to the Extra_Constrained parameter.
2709 -- In Ada 2012, test for case of a limited tagged type, in
2710 -- which case the attribute is always required to return
2711 -- True. The underlying type is tested, to make sure we also
2712 -- return True for cases where there is an unconstrained
2713 -- object with an untagged limited partial view which has
2714 -- defaulted discriminants (such objects always produce a
2715 -- False in earlier versions of Ada). (Ada 2012: AI05-0214)
2717 Res := Is_Constrained (Underlying_Type (Etype (Ent)))
2719 (Ada_Version >= Ada_2012
2720 and then Is_Tagged_Type (Underlying_Type (Ptyp))
2721 and then Is_Limited_Type (Ptyp));
2724 Rewrite (N, New_Occurrence_Of (Boolean_Literals (Res), Loc));
2727 -- Prefix is not an entity name. These are also cases where we can
2728 -- always tell at compile time by looking at the form and type of the
2729 -- prefix. If an explicit dereference of an object with constrained
2730 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
2731 -- underlying type is a limited tagged type, then Constrained is
2732 -- required to always return True (Ada 2012: AI05-0214).
2738 not Is_Variable (Pref)
2740 (Nkind (Pref) = N_Explicit_Dereference
2742 not Object_Type_Has_Constrained_Partial_View
2743 (Typ => Base_Type (Ptyp),
2744 Scop => Current_Scope))
2745 or else Is_Constrained (Underlying_Type (Ptyp))
2746 or else (Ada_Version >= Ada_2012
2747 and then Is_Tagged_Type (Underlying_Type (Ptyp))
2748 and then Is_Limited_Type (Ptyp))),
2752 Analyze_And_Resolve (N, Standard_Boolean);
2759 -- Transforms 'Copy_Sign into a call to the floating-point attribute
2760 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
2762 when Attribute_Copy_Sign =>
2763 Expand_Fpt_Attribute_RR (N);
2769 -- Transforms 'Count attribute into a call to the Count function
2771 when Attribute_Count => Count : declare
2773 Conctyp : Entity_Id;
2775 Entry_Id : Entity_Id;
2780 -- If the prefix is a member of an entry family, retrieve both
2781 -- entry name and index. For a simple entry there is no index.
2783 if Nkind (Pref) = N_Indexed_Component then
2784 Entnam := Prefix (Pref);
2785 Index := First (Expressions (Pref));
2791 Entry_Id := Entity (Entnam);
2793 -- Find the concurrent type in which this attribute is referenced
2794 -- (there had better be one).
2796 Conctyp := Current_Scope;
2797 while not Is_Concurrent_Type (Conctyp) loop
2798 Conctyp := Scope (Conctyp);
2803 if Is_Protected_Type (Conctyp) then
2804 case Corresponding_Runtime_Package (Conctyp) is
2805 when System_Tasking_Protected_Objects_Entries =>
2806 Name := New_Occurrence_Of (RTE (RE_Protected_Count), Loc);
2809 Make_Function_Call (Loc,
2811 Parameter_Associations => New_List (
2813 (Find_Protection_Object (Current_Scope), Loc),
2814 Entry_Index_Expression
2815 (Loc, Entry_Id, Index, Scope (Entry_Id))));
2817 when System_Tasking_Protected_Objects_Single_Entry =>
2819 New_Occurrence_Of (RTE (RE_Protected_Count_Entry), Loc);
2822 Make_Function_Call (Loc,
2824 Parameter_Associations => New_List (
2826 (Find_Protection_Object (Current_Scope), Loc)));
2829 raise Program_Error;
2836 Make_Function_Call (Loc,
2837 Name => New_Occurrence_Of (RTE (RE_Task_Count), Loc),
2838 Parameter_Associations => New_List (
2839 Entry_Index_Expression (Loc,
2840 Entry_Id, Index, Scope (Entry_Id))));
2843 -- The call returns type Natural but the context is universal integer
2844 -- so any integer type is allowed. The attribute was already resolved
2845 -- so its Etype is the required result type. If the base type of the
2846 -- context type is other than Standard.Integer we put in a conversion
2847 -- to the required type. This can be a normal typed conversion since
2848 -- both input and output types of the conversion are integer types
2850 if Base_Type (Typ) /= Base_Type (Standard_Integer) then
2851 Rewrite (N, Convert_To (Typ, Call));
2856 Analyze_And_Resolve (N, Typ);
2859 ---------------------
2860 -- Descriptor_Size --
2861 ---------------------
2863 when Attribute_Descriptor_Size =>
2865 -- Attribute Descriptor_Size is handled by the back end when applied
2866 -- to an unconstrained array type.
2868 if Is_Array_Type (Ptyp)
2869 and then not Is_Constrained (Ptyp)
2871 Apply_Universal_Integer_Attribute_Checks (N);
2873 -- For any other type, the descriptor size is 0 because there is no
2874 -- actual descriptor, but the result is not formally static.
2877 Rewrite (N, Make_Integer_Literal (Loc, 0));
2879 Set_Is_Static_Expression (N, False);
2886 -- This processing is shared by Elab_Spec
2888 -- What we do is to insert the following declarations
2891 -- pragma Import (C, enn, "name___elabb/s");
2893 -- and then the Elab_Body/Spec attribute is replaced by a reference
2894 -- to this defining identifier.
2896 when Attribute_Elab_Body |
2897 Attribute_Elab_Spec =>
2899 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
2900 -- back-end knows how to handle these attributes directly.
2902 if CodePeer_Mode then
2907 Ent : constant Entity_Id := Make_Temporary (Loc, 'E');
2911 procedure Make_Elab_String (Nod : Node_Id);
2912 -- Given Nod, an identifier, or a selected component, put the
2913 -- image into the current string literal, with double underline
2914 -- between components.
2916 ----------------------
2917 -- Make_Elab_String --
2918 ----------------------
2920 procedure Make_Elab_String (Nod : Node_Id) is
2922 if Nkind (Nod) = N_Selected_Component then
2923 Make_Elab_String (Prefix (Nod));
2924 Store_String_Char ('_');
2925 Store_String_Char ('_');
2926 Get_Name_String (Chars (Selector_Name (Nod)));
2929 pragma Assert (Nkind (Nod) = N_Identifier);
2930 Get_Name_String (Chars (Nod));
2933 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2934 end Make_Elab_String;
2936 -- Start of processing for Elab_Body/Elab_Spec
2939 -- First we need to prepare the string literal for the name of
2940 -- the elaboration routine to be referenced.
2943 Make_Elab_String (Pref);
2944 Store_String_Chars ("___elab");
2945 Lang := Make_Identifier (Loc, Name_C);
2947 if Id = Attribute_Elab_Body then
2948 Store_String_Char ('b');
2950 Store_String_Char ('s');
2955 Insert_Actions (N, New_List (
2956 Make_Subprogram_Declaration (Loc,
2958 Make_Procedure_Specification (Loc,
2959 Defining_Unit_Name => Ent)),
2962 Chars => Name_Import,
2963 Pragma_Argument_Associations => New_List (
2964 Make_Pragma_Argument_Association (Loc, Expression => Lang),
2966 Make_Pragma_Argument_Association (Loc,
2967 Expression => Make_Identifier (Loc, Chars (Ent))),
2969 Make_Pragma_Argument_Association (Loc,
2970 Expression => Make_String_Literal (Loc, Str))))));
2972 Set_Entity (N, Ent);
2973 Rewrite (N, New_Occurrence_Of (Ent, Loc));
2976 --------------------
2977 -- Elab_Subp_Body --
2978 --------------------
2980 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
2981 -- this attribute directly, and if we are not in CodePeer mode it is
2982 -- entirely ignored ???
2984 when Attribute_Elab_Subp_Body =>
2991 -- Elaborated is always True for preelaborated units, predefined units,
2992 -- pure units and units which have Elaborate_Body pragmas. These units
2993 -- have no elaboration entity.
2995 -- Note: The Elaborated attribute is never passed to the back end
2997 when Attribute_Elaborated => Elaborated : declare
2998 Ent : constant Entity_Id := Entity (Pref);
3001 if Present (Elaboration_Entity (Ent)) then
3005 New_Occurrence_Of (Elaboration_Entity (Ent), Loc),
3007 Make_Integer_Literal (Loc, Uint_0)));
3008 Analyze_And_Resolve (N, Typ);
3010 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
3018 when Attribute_Enum_Rep => Enum_Rep : declare
3022 -- Get the expression, which is X for Enum_Type'Enum_Rep (X) or
3025 if Is_Non_Empty_List (Exprs) then
3026 Expr := First (Exprs);
3031 -- If the expression is an enumeration literal, it is replaced by the
3034 if Nkind (Expr) in N_Has_Entity
3035 and then Ekind (Entity (Expr)) = E_Enumeration_Literal
3038 Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Expr))));
3040 -- If this is a renaming of a literal, recover the representation
3041 -- of the original. If it renames an expression there is nothing to
3044 elsif Nkind (Expr) in N_Has_Entity
3045 and then Ekind (Entity (Expr)) = E_Constant
3046 and then Present (Renamed_Object (Entity (Expr)))
3047 and then Is_Entity_Name (Renamed_Object (Entity (Expr)))
3048 and then Ekind (Entity (Renamed_Object (Entity (Expr)))) =
3049 E_Enumeration_Literal
3052 Make_Integer_Literal (Loc,
3053 Enumeration_Rep (Entity (Renamed_Object (Entity (Expr))))));
3055 -- If not constant-folded above, Enum_Type'Enum_Rep (X) or
3056 -- X'Enum_Rep expands to
3060 -- This is simply a direct conversion from the enumeration type to
3061 -- the target integer type, which is treated by the back end as a
3062 -- normal integer conversion, treating the enumeration type as an
3063 -- integer, which is exactly what we want. We set Conversion_OK to
3064 -- make sure that the analyzer does not complain about what otherwise
3065 -- might be an illegal conversion.
3068 Rewrite (N, OK_Convert_To (Typ, Relocate_Node (Expr)));
3072 Analyze_And_Resolve (N, Typ);
3079 when Attribute_Enum_Val => Enum_Val : declare
3081 Btyp : constant Entity_Id := Base_Type (Ptyp);
3084 -- X'Enum_Val (Y) expands to
3086 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
3089 Expr := Unchecked_Convert_To (Ptyp, First (Exprs));
3092 Make_Raise_Constraint_Error (Loc,
3096 Make_Function_Call (Loc,
3098 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
3099 Parameter_Associations => New_List (
3100 Relocate_Node (Duplicate_Subexpr (Expr)),
3101 New_Occurrence_Of (Standard_False, Loc))),
3103 Right_Opnd => Make_Integer_Literal (Loc, -1)),
3104 Reason => CE_Range_Check_Failed));
3107 Analyze_And_Resolve (N, Ptyp);
3114 -- Transforms 'Exponent into a call to the floating-point attribute
3115 -- function Exponent in Fat_xxx (where xxx is the root type)
3117 when Attribute_Exponent =>
3118 Expand_Fpt_Attribute_R (N);
3124 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
3126 when Attribute_External_Tag => External_Tag :
3129 Make_Function_Call (Loc,
3130 Name => New_Occurrence_Of (RTE (RE_External_Tag), Loc),
3131 Parameter_Associations => New_List (
3132 Make_Attribute_Reference (Loc,
3133 Attribute_Name => Name_Tag,
3134 Prefix => Prefix (N)))));
3136 Analyze_And_Resolve (N, Standard_String);
3139 -----------------------
3140 -- Finalization_Size --
3141 -----------------------
3143 when Attribute_Finalization_Size => Finalization_Size : declare
3144 function Calculate_Header_Size return Node_Id;
3145 -- Generate a runtime call to calculate the size of the hidden header
3146 -- along with any added padding which would precede a heap-allocated
3147 -- object of the prefix type.
3149 ---------------------------
3150 -- Calculate_Header_Size --
3151 ---------------------------
3153 function Calculate_Header_Size return Node_Id is
3156 -- Universal_Integer
3157 -- (Header_Size_With_Padding (Pref'Alignment))
3160 Convert_To (Universal_Integer,
3161 Make_Function_Call (Loc,
3163 New_Occurrence_Of (RTE (RE_Header_Size_With_Padding), Loc),
3165 Parameter_Associations => New_List (
3166 Make_Attribute_Reference (Loc,
3167 Prefix => New_Copy_Tree (Pref),
3168 Attribute_Name => Name_Alignment))));
3169 end Calculate_Header_Size;
3175 -- Start of Finalization_Size
3178 -- An object of a class-wide type first requires a runtime check to
3179 -- determine whether it is actually controlled or not. Depending on
3180 -- the outcome of this check, the Finalization_Size of the object
3181 -- may be zero or some positive value.
3183 -- In this scenario, Pref'Finalization_Size is expanded into
3185 -- Size : Integer := 0;
3187 -- if Needs_Finalization (Pref'Tag) then
3189 -- Universal_Integer
3190 -- (Header_Size_With_Padding (Pref'Alignment));
3193 -- and the attribute reference is replaced with a reference to Size.
3195 if Is_Class_Wide_Type (Ptyp) then
3196 Size := Make_Temporary (Loc, 'S');
3198 Insert_Actions (N, New_List (
3201 -- Size : Integer := 0;
3203 Make_Object_Declaration (Loc,
3204 Defining_Identifier => Size,
3205 Object_Definition =>
3206 New_Occurrence_Of (Standard_Integer, Loc),
3207 Expression => Make_Integer_Literal (Loc, 0)),
3210 -- if Needs_Finalization (Pref'Tag) then
3212 -- Universal_Integer
3213 -- (Header_Size_With_Padding (Pref'Alignment));
3216 Make_If_Statement (Loc,
3218 Make_Function_Call (Loc,
3220 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
3222 Parameter_Associations => New_List (
3223 Make_Attribute_Reference (Loc,
3224 Prefix => New_Copy_Tree (Pref),
3225 Attribute_Name => Name_Tag))),
3227 Then_Statements => New_List (
3228 Make_Assignment_Statement (Loc,
3229 Name => New_Occurrence_Of (Size, Loc),
3230 Expression => Calculate_Header_Size)))));
3232 Rewrite (N, New_Occurrence_Of (Size, Loc));
3234 -- The prefix is known to be controlled at compile time. Calculate
3235 -- Finalization_Size by calling function Header_Size_With_Padding.
3237 elsif Needs_Finalization (Ptyp) then
3238 Rewrite (N, Calculate_Header_Size);
3240 -- The prefix is not an object with controlled parts, so its
3241 -- Finalization_Size is zero.
3244 Rewrite (N, Make_Integer_Literal (Loc, 0));
3248 end Finalization_Size;
3254 when Attribute_First =>
3256 -- If the prefix type is a constrained packed array type which
3257 -- already has a Packed_Array_Impl_Type representation defined, then
3258 -- replace this attribute with a direct reference to 'First of the
3259 -- appropriate index subtype (since otherwise the back end will try
3260 -- to give us the value of 'First for this implementation type).
3262 if Is_Constrained_Packed_Array (Ptyp) then
3264 Make_Attribute_Reference (Loc,
3265 Attribute_Name => Name_First,
3267 New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
3268 Analyze_And_Resolve (N, Typ);
3270 -- For access type, apply access check as needed
3272 elsif Is_Access_Type (Ptyp) then
3273 Apply_Access_Check (N);
3275 -- For scalar type, if low bound is a reference to an entity, just
3276 -- replace with a direct reference. Note that we can only have a
3277 -- reference to a constant entity at this stage, anything else would
3278 -- have already been rewritten.
3280 elsif Is_Scalar_Type (Ptyp) then
3282 Lo : constant Node_Id := Type_Low_Bound (Ptyp);
3284 if Is_Entity_Name (Lo) then
3285 Rewrite (N, New_Occurrence_Of (Entity (Lo), Loc));
3294 -- Compute this if component clause was present, otherwise we leave the
3295 -- computation to be completed in the back-end, since we don't know what
3296 -- layout will be chosen.
3298 when Attribute_First_Bit => First_Bit_Attr : declare
3299 CE : constant Entity_Id := Entity (Selector_Name (Pref));
3302 -- In Ada 2005 (or later) if we have the non-default bit order, then
3303 -- we return the original value as given in the component clause
3304 -- (RM 2005 13.5.2(3/2)).
3306 if Present (Component_Clause (CE))
3307 and then Ada_Version >= Ada_2005
3308 and then Reverse_Bit_Order (Scope (CE))
3311 Make_Integer_Literal (Loc,
3312 Intval => Expr_Value (First_Bit (Component_Clause (CE)))));
3313 Analyze_And_Resolve (N, Typ);
3315 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3316 -- rewrite with normalized value if we know it statically.
3318 elsif Known_Static_Component_Bit_Offset (CE) then
3320 Make_Integer_Literal (Loc,
3321 Component_Bit_Offset (CE) mod System_Storage_Unit));
3322 Analyze_And_Resolve (N, Typ);
3324 -- Otherwise left to back end, just do universal integer checks
3327 Apply_Universal_Integer_Attribute_Checks (N);
3337 -- fixtype'Fixed_Value (integer-value)
3341 -- fixtype(integer-value)
3343 -- We do all the required analysis of the conversion here, because we do
3344 -- not want this to go through the fixed-point conversion circuits. Note
3345 -- that the back end always treats fixed-point as equivalent to the
3346 -- corresponding integer type anyway.
3348 when Attribute_Fixed_Value => Fixed_Value :
3351 Make_Type_Conversion (Loc,
3352 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
3353 Expression => Relocate_Node (First (Exprs))));
3354 Set_Etype (N, Entity (Pref));
3357 -- Note: it might appear that a properly analyzed unchecked conversion
3358 -- would be just fine here, but that's not the case, since the full
3359 -- range checks performed by the following call are critical.
3361 Apply_Type_Conversion_Checks (N);
3368 -- Transforms 'Floor into a call to the floating-point attribute
3369 -- function Floor in Fat_xxx (where xxx is the root type)
3371 when Attribute_Floor =>
3372 Expand_Fpt_Attribute_R (N);
3378 -- For the fixed-point type Typ:
3384 -- Result_Type (System.Fore (Universal_Real (Type'First)),
3385 -- Universal_Real (Type'Last))
3387 -- Note that we know that the type is a non-static subtype, or Fore
3388 -- would have itself been computed dynamically in Eval_Attribute.
3390 when Attribute_Fore => Fore : begin
3393 Make_Function_Call (Loc,
3394 Name => New_Occurrence_Of (RTE (RE_Fore), Loc),
3396 Parameter_Associations => New_List (
3397 Convert_To (Universal_Real,
3398 Make_Attribute_Reference (Loc,
3399 Prefix => New_Occurrence_Of (Ptyp, Loc),
3400 Attribute_Name => Name_First)),
3402 Convert_To (Universal_Real,
3403 Make_Attribute_Reference (Loc,
3404 Prefix => New_Occurrence_Of (Ptyp, Loc),
3405 Attribute_Name => Name_Last))))));
3407 Analyze_And_Resolve (N, Typ);
3414 -- Transforms 'Fraction into a call to the floating-point attribute
3415 -- function Fraction in Fat_xxx (where xxx is the root type)
3417 when Attribute_Fraction =>
3418 Expand_Fpt_Attribute_R (N);
3424 when Attribute_From_Any => From_Any : declare
3425 P_Type : constant Entity_Id := Etype (Pref);
3426 Decls : constant List_Id := New_List;
3429 Build_From_Any_Call (P_Type,
3430 Relocate_Node (First (Exprs)),
3432 Insert_Actions (N, Decls);
3433 Analyze_And_Resolve (N, P_Type);
3436 ----------------------
3437 -- Has_Same_Storage --
3438 ----------------------
3440 when Attribute_Has_Same_Storage => Has_Same_Storage : declare
3441 Loc : constant Source_Ptr := Sloc (N);
3443 X : constant Node_Id := Prefix (N);
3444 Y : constant Node_Id := First (Expressions (N));
3447 X_Addr, Y_Addr : Node_Id;
3448 -- Rhe expressions for their addresses
3450 X_Size, Y_Size : Node_Id;
3451 -- Rhe expressions for their sizes
3454 -- The attribute is expanded as:
3456 -- (X'address = Y'address)
3457 -- and then (X'Size = Y'Size)
3459 -- If both arguments have the same Etype the second conjunct can be
3463 Make_Attribute_Reference (Loc,
3464 Attribute_Name => Name_Address,
3465 Prefix => New_Copy_Tree (X));
3468 Make_Attribute_Reference (Loc,
3469 Attribute_Name => Name_Address,
3470 Prefix => New_Copy_Tree (Y));
3473 Make_Attribute_Reference (Loc,
3474 Attribute_Name => Name_Size,
3475 Prefix => New_Copy_Tree (X));
3478 Make_Attribute_Reference (Loc,
3479 Attribute_Name => Name_Size,
3480 Prefix => New_Copy_Tree (Y));
3482 if Etype (X) = Etype (Y) then
3485 Left_Opnd => X_Addr,
3486 Right_Opnd => Y_Addr)));
3492 Left_Opnd => X_Addr,
3493 Right_Opnd => Y_Addr),
3496 Left_Opnd => X_Size,
3497 Right_Opnd => Y_Size)));
3500 Analyze_And_Resolve (N, Standard_Boolean);
3501 end Has_Same_Storage;
3507 -- For an exception returns a reference to the exception data:
3508 -- Exception_Id!(Prefix'Reference)
3510 -- For a task it returns a reference to the _task_id component of
3511 -- corresponding record:
3513 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
3515 -- in Ada.Task_Identification
3517 when Attribute_Identity => Identity : declare
3518 Id_Kind : Entity_Id;
3521 if Ptyp = Standard_Exception_Type then
3522 Id_Kind := RTE (RE_Exception_Id);
3524 if Present (Renamed_Object (Entity (Pref))) then
3525 Set_Entity (Pref, Renamed_Object (Entity (Pref)));
3529 Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref)));
3531 Id_Kind := RTE (RO_AT_Task_Id);
3533 -- If the prefix is a task interface, the Task_Id is obtained
3534 -- dynamically through a dispatching call, as for other task
3535 -- attributes applied to interfaces.
3537 if Ada_Version >= Ada_2005
3538 and then Ekind (Ptyp) = E_Class_Wide_Type
3539 and then Is_Interface (Ptyp)
3540 and then Is_Task_Interface (Ptyp)
3543 Unchecked_Convert_To (Id_Kind,
3544 Make_Selected_Component (Loc,
3546 New_Copy_Tree (Pref),
3548 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))));
3552 Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
3556 Analyze_And_Resolve (N, Id_Kind);
3563 -- Image attribute is handled in separate unit Exp_Imgv
3565 when Attribute_Image =>
3566 Exp_Imgv.Expand_Image_Attribute (N);
3572 -- X'Img is expanded to typ'Image (X), where typ is the type of X
3574 when Attribute_Img => Img :
3577 Make_Attribute_Reference (Loc,
3578 Prefix => New_Occurrence_Of (Ptyp, Loc),
3579 Attribute_Name => Name_Image,
3580 Expressions => New_List (Relocate_Node (Pref))));
3582 Analyze_And_Resolve (N, Standard_String);
3589 when Attribute_Input => Input : declare
3590 P_Type : constant Entity_Id := Entity (Pref);
3591 B_Type : constant Entity_Id := Base_Type (P_Type);
3592 U_Type : constant Entity_Id := Underlying_Type (P_Type);
3593 Strm : constant Node_Id := First (Exprs);
3601 Cntrl : Node_Id := Empty;
3602 -- Value for controlling argument in call. Always Empty except in
3603 -- the dispatching (class-wide type) case, where it is a reference
3604 -- to the dummy object initialized to the right internal tag.
3606 procedure Freeze_Stream_Subprogram (F : Entity_Id);
3607 -- The expansion of the attribute reference may generate a call to
3608 -- a user-defined stream subprogram that is frozen by the call. This
3609 -- can lead to access-before-elaboration problem if the reference
3610 -- appears in an object declaration and the subprogram body has not
3611 -- been seen. The freezing of the subprogram requires special code
3612 -- because it appears in an expanded context where expressions do
3613 -- not freeze their constituents.
3615 ------------------------------
3616 -- Freeze_Stream_Subprogram --
3617 ------------------------------
3619 procedure Freeze_Stream_Subprogram (F : Entity_Id) is
3620 Decl : constant Node_Id := Unit_Declaration_Node (F);
3624 -- If this is user-defined subprogram, the corresponding
3625 -- stream function appears as a renaming-as-body, and the
3626 -- user subprogram must be retrieved by tree traversal.
3629 and then Nkind (Decl) = N_Subprogram_Declaration
3630 and then Present (Corresponding_Body (Decl))
3632 Bod := Corresponding_Body (Decl);
3634 if Nkind (Unit_Declaration_Node (Bod)) =
3635 N_Subprogram_Renaming_Declaration
3637 Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod))));
3640 end Freeze_Stream_Subprogram;
3642 -- Start of processing for Input
3645 -- If no underlying type, we have an error that will be diagnosed
3646 -- elsewhere, so here we just completely ignore the expansion.
3652 -- Stream operations can appear in user code even if the restriction
3653 -- No_Streams is active (for example, when instantiating a predefined
3654 -- container). In that case rewrite the attribute as a Raise to
3655 -- prevent any run-time use.
3657 if Restriction_Active (No_Streams) then
3659 Make_Raise_Program_Error (Sloc (N),
3660 Reason => PE_Stream_Operation_Not_Allowed));
3661 Set_Etype (N, B_Type);
3665 -- If there is a TSS for Input, just call it
3667 Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
3669 if Present (Fname) then
3673 -- If there is a Stream_Convert pragma, use it, we rewrite
3675 -- sourcetyp'Input (stream)
3679 -- sourcetyp (streamread (strmtyp'Input (stream)));
3681 -- where streamread is the given Read function that converts an
3682 -- argument of type strmtyp to type sourcetyp or a type from which
3683 -- it is derived (extra conversion required for the derived case).
3685 Prag := Get_Stream_Convert_Pragma (P_Type);
3687 if Present (Prag) then
3688 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
3689 Rfunc := Entity (Expression (Arg2));
3693 Make_Function_Call (Loc,
3694 Name => New_Occurrence_Of (Rfunc, Loc),
3695 Parameter_Associations => New_List (
3696 Make_Attribute_Reference (Loc,
3699 (Etype (First_Formal (Rfunc)), Loc),
3700 Attribute_Name => Name_Input,
3701 Expressions => Exprs)))));
3703 Analyze_And_Resolve (N, B_Type);
3708 elsif Is_Elementary_Type (U_Type) then
3710 -- A special case arises if we have a defined _Read routine,
3711 -- since in this case we are required to call this routine.
3713 if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then
3714 Build_Record_Or_Elementary_Input_Function
3715 (Loc, U_Type, Decl, Fname);
3716 Insert_Action (N, Decl);
3718 -- For normal cases, we call the I_xxx routine directly
3721 Rewrite (N, Build_Elementary_Input_Call (N));
3722 Analyze_And_Resolve (N, P_Type);
3728 elsif Is_Array_Type (U_Type) then
3729 Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
3730 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3732 -- Dispatching case with class-wide type
3734 elsif Is_Class_Wide_Type (P_Type) then
3736 -- No need to do anything else compiling under restriction
3737 -- No_Dispatching_Calls. During the semantic analysis we
3738 -- already notified such violation.
3740 if Restriction_Active (No_Dispatching_Calls) then
3745 Rtyp : constant Entity_Id := Root_Type (P_Type);
3749 -- Read the internal tag (RM 13.13.2(34)) and use it to
3750 -- initialize a dummy tag value:
3752 -- Descendant_Tag (String'Input (Strm), P_Type);
3754 -- This value is used only to provide a controlling
3755 -- argument for the eventual _Input call. Descendant_Tag is
3756 -- called rather than Internal_Tag to ensure that we have a
3757 -- tag for a type that is descended from the prefix type and
3758 -- declared at the same accessibility level (the exception
3759 -- Tag_Error will be raised otherwise). The level check is
3760 -- required for Ada 2005 because tagged types can be
3761 -- extended in nested scopes (AI-344).
3763 -- Note: we used to generate an explicit declaration of a
3764 -- constant Ada.Tags.Tag object, and use an occurrence of
3765 -- this constant in Cntrl, but this caused a secondary stack
3769 Make_Function_Call (Loc,
3771 New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
3772 Parameter_Associations => New_List (
3773 Make_Attribute_Reference (Loc,
3775 New_Occurrence_Of (Standard_String, Loc),
3776 Attribute_Name => Name_Input,
3777 Expressions => New_List (
3778 Relocate_Node (Duplicate_Subexpr (Strm)))),
3779 Make_Attribute_Reference (Loc,
3780 Prefix => New_Occurrence_Of (P_Type, Loc),
3781 Attribute_Name => Name_Tag)));
3782 Set_Etype (Expr, RTE (RE_Tag));
3784 -- Now we need to get the entity for the call, and construct
3785 -- a function call node, where we preset a reference to Dnn
3786 -- as the controlling argument (doing an unchecked convert
3787 -- to the class-wide tagged type to make it look like a real
3790 Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
3791 Cntrl := Unchecked_Convert_To (P_Type, Expr);
3792 Set_Etype (Cntrl, P_Type);
3793 Set_Parent (Cntrl, N);
3796 -- For tagged types, use the primitive Input function
3798 elsif Is_Tagged_Type (U_Type) then
3799 Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
3801 -- All other record type cases, including protected records. The
3802 -- latter only arise for expander generated code for handling
3803 -- shared passive partition access.
3807 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
3809 -- Ada 2005 (AI-216): Program_Error is raised executing default
3810 -- implementation of the Input attribute of an unchecked union
3811 -- type if the type lacks default discriminant values.
3813 if Is_Unchecked_Union (Base_Type (U_Type))
3814 and then No (Discriminant_Constraint (U_Type))
3817 Make_Raise_Program_Error (Loc,
3818 Reason => PE_Unchecked_Union_Restriction));
3823 -- Build the type's Input function, passing the subtype rather
3824 -- than its base type, because checks are needed in the case of
3825 -- constrained discriminants (see Ada 2012 AI05-0192).
3827 Build_Record_Or_Elementary_Input_Function
3828 (Loc, U_Type, Decl, Fname);
3829 Insert_Action (N, Decl);
3831 if Nkind (Parent (N)) = N_Object_Declaration
3832 and then Is_Record_Type (U_Type)
3834 -- The stream function may contain calls to user-defined
3835 -- Read procedures for individual components.
3842 Comp := First_Component (U_Type);
3843 while Present (Comp) loop
3845 Find_Stream_Subprogram
3846 (Etype (Comp), TSS_Stream_Read);
3848 if Present (Func) then
3849 Freeze_Stream_Subprogram (Func);
3852 Next_Component (Comp);
3859 -- If we fall through, Fname is the function to be called. The result
3860 -- is obtained by calling the appropriate function, then converting
3861 -- the result. The conversion does a subtype check.
3864 Make_Function_Call (Loc,
3865 Name => New_Occurrence_Of (Fname, Loc),
3866 Parameter_Associations => New_List (
3867 Relocate_Node (Strm)));
3869 Set_Controlling_Argument (Call, Cntrl);
3870 Rewrite (N, Unchecked_Convert_To (P_Type, Call));
3871 Analyze_And_Resolve (N, P_Type);
3873 if Nkind (Parent (N)) = N_Object_Declaration then
3874 Freeze_Stream_Subprogram (Fname);
3884 -- inttype'Fixed_Value (fixed-value)
3888 -- inttype(integer-value))
3890 -- we do all the required analysis of the conversion here, because we do
3891 -- not want this to go through the fixed-point conversion circuits. Note
3892 -- that the back end always treats fixed-point as equivalent to the
3893 -- corresponding integer type anyway.
3895 when Attribute_Integer_Value => Integer_Value :
3898 Make_Type_Conversion (Loc,
3899 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
3900 Expression => Relocate_Node (First (Exprs))));
3901 Set_Etype (N, Entity (Pref));
3904 -- Note: it might appear that a properly analyzed unchecked conversion
3905 -- would be just fine here, but that's not the case, since the full
3906 -- range checks performed by the following call are critical.
3908 Apply_Type_Conversion_Checks (N);
3915 when Attribute_Invalid_Value =>
3916 Rewrite (N, Get_Simple_Init_Val (Ptyp, N));
3922 when Attribute_Last =>
3924 -- If the prefix type is a constrained packed array type which
3925 -- already has a Packed_Array_Impl_Type representation defined, then
3926 -- replace this attribute with a direct reference to 'Last of the
3927 -- appropriate index subtype (since otherwise the back end will try
3928 -- to give us the value of 'Last for this implementation type).
3930 if Is_Constrained_Packed_Array (Ptyp) then
3932 Make_Attribute_Reference (Loc,
3933 Attribute_Name => Name_Last,
3934 Prefix => New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
3935 Analyze_And_Resolve (N, Typ);
3937 -- For access type, apply access check as needed
3939 elsif Is_Access_Type (Ptyp) then
3940 Apply_Access_Check (N);
3942 -- For scalar type, if low bound is a reference to an entity, just
3943 -- replace with a direct reference. Note that we can only have a
3944 -- reference to a constant entity at this stage, anything else would
3945 -- have already been rewritten.
3947 elsif Is_Scalar_Type (Ptyp) then
3949 Hi : constant Node_Id := Type_High_Bound (Ptyp);
3951 if Is_Entity_Name (Hi) then
3952 Rewrite (N, New_Occurrence_Of (Entity (Hi), Loc));
3961 -- We compute this if a component clause was present, otherwise we leave
3962 -- the computation up to the back end, since we don't know what layout
3965 when Attribute_Last_Bit => Last_Bit_Attr : declare
3966 CE : constant Entity_Id := Entity (Selector_Name (Pref));
3969 -- In Ada 2005 (or later) if we have the non-default bit order, then
3970 -- we return the original value as given in the component clause
3971 -- (RM 2005 13.5.2(3/2)).
3973 if Present (Component_Clause (CE))
3974 and then Ada_Version >= Ada_2005
3975 and then Reverse_Bit_Order (Scope (CE))
3978 Make_Integer_Literal (Loc,
3979 Intval => Expr_Value (Last_Bit (Component_Clause (CE)))));
3980 Analyze_And_Resolve (N, Typ);
3982 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3983 -- rewrite with normalized value if we know it statically.
3985 elsif Known_Static_Component_Bit_Offset (CE)
3986 and then Known_Static_Esize (CE)
3989 Make_Integer_Literal (Loc,
3990 Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
3992 Analyze_And_Resolve (N, Typ);
3994 -- Otherwise leave to back end, just apply universal integer checks
3997 Apply_Universal_Integer_Attribute_Checks (N);
4005 -- Transforms 'Leading_Part into a call to the floating-point attribute
4006 -- function Leading_Part in Fat_xxx (where xxx is the root type)
4008 -- Note: strictly, we should generate special case code to deal with
4009 -- absurdly large positive arguments (greater than Integer'Last), which
4010 -- result in returning the first argument unchanged, but it hardly seems
4011 -- worth the effort. We raise constraint error for absurdly negative
4012 -- arguments which is fine.
4014 when Attribute_Leading_Part =>
4015 Expand_Fpt_Attribute_RI (N);
4021 when Attribute_Length => Length : declare
4026 -- Processing for packed array types
4028 if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
4029 Ityp := Get_Index_Subtype (N);
4031 -- If the index type, Ityp, is an enumeration type with holes,
4032 -- then we calculate X'Length explicitly using
4035 -- (0, Ityp'Pos (X'Last (N)) -
4036 -- Ityp'Pos (X'First (N)) + 1);
4038 -- Since the bounds in the template are the representation values
4039 -- and the back end would get the wrong value.
4041 if Is_Enumeration_Type (Ityp)
4042 and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
4047 Xnum := Expr_Value (First (Expressions (N)));
4051 Make_Attribute_Reference (Loc,
4052 Prefix => New_Occurrence_Of (Typ, Loc),
4053 Attribute_Name => Name_Max,
4054 Expressions => New_List
4055 (Make_Integer_Literal (Loc, 0),
4059 Make_Op_Subtract (Loc,
4061 Make_Attribute_Reference (Loc,
4062 Prefix => New_Occurrence_Of (Ityp, Loc),
4063 Attribute_Name => Name_Pos,
4065 Expressions => New_List (
4066 Make_Attribute_Reference (Loc,
4067 Prefix => Duplicate_Subexpr (Pref),
4068 Attribute_Name => Name_Last,
4069 Expressions => New_List (
4070 Make_Integer_Literal (Loc, Xnum))))),
4073 Make_Attribute_Reference (Loc,
4074 Prefix => New_Occurrence_Of (Ityp, Loc),
4075 Attribute_Name => Name_Pos,
4077 Expressions => New_List (
4078 Make_Attribute_Reference (Loc,
4080 Duplicate_Subexpr_No_Checks (Pref),
4081 Attribute_Name => Name_First,
4082 Expressions => New_List (
4083 Make_Integer_Literal (Loc, Xnum)))))),
4085 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
4087 Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
4090 -- If the prefix type is a constrained packed array type which
4091 -- already has a Packed_Array_Impl_Type representation defined,
4092 -- then replace this attribute with a reference to 'Range_Length
4093 -- of the appropriate index subtype (since otherwise the
4094 -- back end will try to give us the value of 'Length for
4095 -- this implementation type).s
4097 elsif Is_Constrained (Ptyp) then
4099 Make_Attribute_Reference (Loc,
4100 Attribute_Name => Name_Range_Length,
4101 Prefix => New_Occurrence_Of (Ityp, Loc)));
4102 Analyze_And_Resolve (N, Typ);
4107 elsif Is_Access_Type (Ptyp) then
4108 Apply_Access_Check (N);
4110 -- If the designated type is a packed array type, then we convert
4111 -- the reference to:
4114 -- xtyp'Pos (Pref'Last (Expr)) -
4115 -- xtyp'Pos (Pref'First (Expr)));
4117 -- This is a bit complex, but it is the easiest thing to do that
4118 -- works in all cases including enum types with holes xtyp here
4119 -- is the appropriate index type.
4122 Dtyp : constant Entity_Id := Designated_Type (Ptyp);
4126 if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
4127 Xtyp := Get_Index_Subtype (N);
4130 Make_Attribute_Reference (Loc,
4131 Prefix => New_Occurrence_Of (Typ, Loc),
4132 Attribute_Name => Name_Max,
4133 Expressions => New_List (
4134 Make_Integer_Literal (Loc, 0),
4137 Make_Integer_Literal (Loc, 1),
4138 Make_Op_Subtract (Loc,
4140 Make_Attribute_Reference (Loc,
4141 Prefix => New_Occurrence_Of (Xtyp, Loc),
4142 Attribute_Name => Name_Pos,
4143 Expressions => New_List (
4144 Make_Attribute_Reference (Loc,
4145 Prefix => Duplicate_Subexpr (Pref),
4146 Attribute_Name => Name_Last,
4148 New_Copy_List (Exprs)))),
4151 Make_Attribute_Reference (Loc,
4152 Prefix => New_Occurrence_Of (Xtyp, Loc),
4153 Attribute_Name => Name_Pos,
4154 Expressions => New_List (
4155 Make_Attribute_Reference (Loc,
4157 Duplicate_Subexpr_No_Checks (Pref),
4158 Attribute_Name => Name_First,
4160 New_Copy_List (Exprs)))))))));
4162 Analyze_And_Resolve (N, Typ);
4166 -- Otherwise leave it to the back end
4169 Apply_Universal_Integer_Attribute_Checks (N);
4173 -- Attribute Loop_Entry is replaced with a reference to a constant value
4174 -- which captures the prefix at the entry point of the related loop. The
4175 -- loop itself may be transformed into a conditional block.
4177 when Attribute_Loop_Entry =>
4178 Expand_Loop_Entry_Attribute (N);
4184 -- Transforms 'Machine into a call to the floating-point attribute
4185 -- function Machine in Fat_xxx (where xxx is the root type).
4186 -- Expansion is avoided for cases the back end can handle directly.
4188 when Attribute_Machine =>
4189 if not Is_Inline_Floating_Point_Attribute (N) then
4190 Expand_Fpt_Attribute_R (N);
4193 ----------------------
4194 -- Machine_Rounding --
4195 ----------------------
4197 -- Transforms 'Machine_Rounding into a call to the floating-point
4198 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
4199 -- type). Expansion is avoided for cases the back end can handle
4202 when Attribute_Machine_Rounding =>
4203 if not Is_Inline_Floating_Point_Attribute (N) then
4204 Expand_Fpt_Attribute_R (N);
4211 -- Machine_Size is equivalent to Object_Size, so transform it into
4212 -- Object_Size and that way the back end never sees Machine_Size.
4214 when Attribute_Machine_Size =>
4216 Make_Attribute_Reference (Loc,
4217 Prefix => Prefix (N),
4218 Attribute_Name => Name_Object_Size));
4220 Analyze_And_Resolve (N, Typ);
4226 -- The only case that can get this far is the dynamic case of the old
4227 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
4234 -- ityp (System.Mantissa.Mantissa_Value
4235 -- (Integer'Integer_Value (typ'First),
4236 -- Integer'Integer_Value (typ'Last)));
4238 when Attribute_Mantissa => Mantissa : begin
4241 Make_Function_Call (Loc,
4242 Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
4244 Parameter_Associations => New_List (
4246 Make_Attribute_Reference (Loc,
4247 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
4248 Attribute_Name => Name_Integer_Value,
4249 Expressions => New_List (
4251 Make_Attribute_Reference (Loc,
4252 Prefix => New_Occurrence_Of (Ptyp, Loc),
4253 Attribute_Name => Name_First))),
4255 Make_Attribute_Reference (Loc,
4256 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
4257 Attribute_Name => Name_Integer_Value,
4258 Expressions => New_List (
4260 Make_Attribute_Reference (Loc,
4261 Prefix => New_Occurrence_Of (Ptyp, Loc),
4262 Attribute_Name => Name_Last)))))));
4264 Analyze_And_Resolve (N, Typ);
4271 when Attribute_Max =>
4272 Expand_Min_Max_Attribute (N);
4274 ----------------------------------
4275 -- Max_Size_In_Storage_Elements --
4276 ----------------------------------
4278 when Attribute_Max_Size_In_Storage_Elements => declare
4279 Typ : constant Entity_Id := Etype (N);
4282 Conversion_Added : Boolean := False;
4283 -- A flag which tracks whether the original attribute has been
4284 -- wrapped inside a type conversion.
4287 -- If the prefix is X'Class, we transform it into a direct reference
4288 -- to the class-wide type, because the back end must not see a 'Class
4289 -- reference. See also 'Size.
4291 if Is_Entity_Name (Pref)
4292 and then Is_Class_Wide_Type (Entity (Pref))
4294 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
4298 Apply_Universal_Integer_Attribute_Checks (N);
4300 -- The universal integer check may sometimes add a type conversion,
4301 -- retrieve the original attribute reference from the expression.
4305 if Nkind (Attr) = N_Type_Conversion then
4306 Attr := Expression (Attr);
4307 Conversion_Added := True;
4310 pragma Assert (Nkind (Attr) = N_Attribute_Reference);
4312 -- Heap-allocated controlled objects contain two extra pointers which
4313 -- are not part of the actual type. Transform the attribute reference
4314 -- into a runtime expression to add the size of the hidden header.
4316 if Needs_Finalization (Ptyp)
4317 and then not Header_Size_Added (Attr)
4319 Set_Header_Size_Added (Attr);
4322 -- P'Max_Size_In_Storage_Elements +
4323 -- Universal_Integer
4324 -- (Header_Size_With_Padding (Ptyp'Alignment))
4328 Left_Opnd => Relocate_Node (Attr),
4330 Convert_To (Universal_Integer,
4331 Make_Function_Call (Loc,
4334 (RTE (RE_Header_Size_With_Padding), Loc),
4336 Parameter_Associations => New_List (
4337 Make_Attribute_Reference (Loc,
4339 New_Occurrence_Of (Ptyp, Loc),
4340 Attribute_Name => Name_Alignment))))));
4342 -- Add a conversion to the target type
4344 if not Conversion_Added then
4346 Make_Type_Conversion (Loc,
4347 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4348 Expression => Relocate_Node (Attr)));
4356 --------------------
4357 -- Mechanism_Code --
4358 --------------------
4360 when Attribute_Mechanism_Code =>
4362 -- We must replace the prefix i the renamed case
4364 if Is_Entity_Name (Pref)
4365 and then Present (Alias (Entity (Pref)))
4367 Set_Renamed_Subprogram (Pref, Alias (Entity (Pref)));
4374 when Attribute_Min =>
4375 Expand_Min_Max_Attribute (N);
4381 when Attribute_Mod => Mod_Case : declare
4382 Arg : constant Node_Id := Relocate_Node (First (Exprs));
4383 Hi : constant Node_Id := Type_High_Bound (Etype (Arg));
4384 Modv : constant Uint := Modulus (Btyp);
4388 -- This is not so simple. The issue is what type to use for the
4389 -- computation of the modular value.
4391 -- The easy case is when the modulus value is within the bounds
4392 -- of the signed integer type of the argument. In this case we can
4393 -- just do the computation in that signed integer type, and then
4394 -- do an ordinary conversion to the target type.
4396 if Modv <= Expr_Value (Hi) then
4401 Right_Opnd => Make_Integer_Literal (Loc, Modv))));
4403 -- Here we know that the modulus is larger than type'Last of the
4404 -- integer type. There are two cases to consider:
4406 -- a) The integer value is non-negative. In this case, it is
4407 -- returned as the result (since it is less than the modulus).
4409 -- b) The integer value is negative. In this case, we know that the
4410 -- result is modulus + value, where the value might be as small as
4411 -- -modulus. The trouble is what type do we use to do the subtract.
4412 -- No type will do, since modulus can be as big as 2**64, and no
4413 -- integer type accommodates this value. Let's do bit of algebra
4416 -- = modulus - (-value)
4417 -- = (modulus - 1) - (-value - 1)
4419 -- Now modulus - 1 is certainly in range of the modular type.
4420 -- -value is in the range 1 .. modulus, so -value -1 is in the
4421 -- range 0 .. modulus-1 which is in range of the modular type.
4422 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
4423 -- which we can compute using the integer base type.
4425 -- Once this is done we analyze the if expression without range
4426 -- checks, because we know everything is in range, and we want
4427 -- to prevent spurious warnings on either branch.
4431 Make_If_Expression (Loc,
4432 Expressions => New_List (
4434 Left_Opnd => Duplicate_Subexpr (Arg),
4435 Right_Opnd => Make_Integer_Literal (Loc, 0)),
4438 Duplicate_Subexpr_No_Checks (Arg)),
4440 Make_Op_Subtract (Loc,
4442 Make_Integer_Literal (Loc,
4443 Intval => Modv - 1),
4449 Left_Opnd => Duplicate_Subexpr_No_Checks (Arg),
4451 Make_Integer_Literal (Loc,
4452 Intval => 1))))))));
4456 Analyze_And_Resolve (N, Btyp, Suppress => All_Checks);
4463 -- Transforms 'Model into a call to the floating-point attribute
4464 -- function Model in Fat_xxx (where xxx is the root type).
4465 -- Expansion is avoided for cases the back end can handle directly.
4467 when Attribute_Model =>
4468 if not Is_Inline_Floating_Point_Attribute (N) then
4469 Expand_Fpt_Attribute_R (N);
4476 -- The processing for Object_Size shares the processing for Size
4482 when Attribute_Old => Old : declare
4483 Typ : constant Entity_Id := Etype (N);
4484 CW_Temp : Entity_Id;
4491 -- Generating C code we don't need to expand this attribute when
4492 -- we are analyzing the internally built nested postconditions
4493 -- procedure since it will be expanded inline (and later it will
4494 -- be removed by Expand_N_Subprogram_Body). It this expansion is
4495 -- performed in such case then the compiler generates unreferenced
4496 -- extra temporaries.
4498 if Modify_Tree_For_C
4499 and then Chars (Current_Scope) = Name_uPostconditions
4504 -- Climb the parent chain looking for subprogram _Postconditions
4507 while Present (Subp) loop
4508 exit when Nkind (Subp) = N_Subprogram_Body
4509 and then Chars (Defining_Entity (Subp)) = Name_uPostconditions;
4511 -- If assertions are disabled, no need to create the declaration
4512 -- that preserves the value. The postcondition pragma in which
4513 -- 'Old appears will be checked or disabled according to the
4514 -- current policy in effect.
4516 if Nkind (Subp) = N_Pragma and then not Is_Checked (Subp) then
4520 Subp := Parent (Subp);
4523 -- 'Old can only appear in a postcondition, the generated body of
4524 -- _Postconditions must be in the tree (or inlined if we are
4525 -- generating C code).
4529 or else (Modify_Tree_For_C and then In_Inlined_Body));
4531 Temp := Make_Temporary (Loc, 'T', Pref);
4533 -- Set the entity kind now in order to mark the temporary as a
4534 -- handler of attribute 'Old's prefix.
4536 Set_Ekind (Temp, E_Constant);
4537 Set_Stores_Attribute_Old_Prefix (Temp);
4539 -- Push the scope of the related subprogram where _Postcondition
4540 -- resides as this ensures that the object will be analyzed in the
4543 if Present (Subp) then
4544 Push_Scope (Scope (Defining_Entity (Subp)));
4546 -- No need to push the scope when generating C code since the
4547 -- _Postcondition procedure has been inlined.
4549 else pragma Assert (Modify_Tree_For_C);
4550 pragma Assert (In_Inlined_Body);
4554 -- Locate the insertion place of the internal temporary that saves
4557 if Present (Subp) then
4560 -- Generating C, the postcondition procedure has been inlined and the
4561 -- temporary is added before the first declaration of the enclosing
4564 else pragma Assert (Modify_Tree_For_C);
4566 while Nkind (Ins_Nod) /= N_Subprogram_Body loop
4567 Ins_Nod := Parent (Ins_Nod);
4570 Ins_Nod := First (Declarations (Ins_Nod));
4573 -- Preserve the tag of the prefix by offering a specific view of the
4574 -- class-wide version of the prefix.
4576 if Is_Tagged_Type (Typ) then
4579 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
4581 CW_Temp := Make_Temporary (Loc, 'T');
4582 CW_Typ := Class_Wide_Type (Typ);
4584 Insert_Before_And_Analyze (Ins_Nod,
4585 Make_Object_Declaration (Loc,
4586 Defining_Identifier => CW_Temp,
4587 Constant_Present => True,
4588 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
4590 Convert_To (CW_Typ, Relocate_Node (Pref))));
4593 -- Temp : Typ renames Typ (CW_Temp);
4595 Insert_Before_And_Analyze (Ins_Nod,
4596 Make_Object_Renaming_Declaration (Loc,
4597 Defining_Identifier => Temp,
4598 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4600 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))));
4606 -- Temp : constant Typ := Pref;
4608 Insert_Before_And_Analyze (Ins_Nod,
4609 Make_Object_Declaration (Loc,
4610 Defining_Identifier => Temp,
4611 Constant_Present => True,
4612 Object_Definition => New_Occurrence_Of (Typ, Loc),
4613 Expression => Relocate_Node (Pref)));
4616 if Present (Subp) then
4620 -- Ensure that the prefix of attribute 'Old is valid. The check must
4621 -- be inserted after the expansion of the attribute has taken place
4622 -- to reflect the new placement of the prefix.
4624 if Validity_Checks_On and then Validity_Check_Operands then
4625 Ensure_Valid (Pref);
4628 Rewrite (N, New_Occurrence_Of (Temp, Loc));
4631 ----------------------
4632 -- Overlaps_Storage --
4633 ----------------------
4635 when Attribute_Overlaps_Storage => Overlaps_Storage : declare
4636 Loc : constant Source_Ptr := Sloc (N);
4638 X : constant Node_Id := Prefix (N);
4639 Y : constant Node_Id := First (Expressions (N));
4642 X_Addr, Y_Addr : Node_Id;
4643 -- the expressions for their integer addresses
4645 X_Size, Y_Size : Node_Id;
4646 -- the expressions for their sizes
4651 -- Attribute expands into:
4653 -- if X'Address < Y'address then
4654 -- (X'address + X'Size - 1) >= Y'address
4656 -- (Y'address + Y'size - 1) >= X'Address
4659 -- with the proper address operations. We convert addresses to
4660 -- integer addresses to use predefined arithmetic. The size is
4661 -- expressed in storage units. We add copies of X_Addr and Y_Addr
4662 -- to prevent the appearance of the same node in two places in
4666 Unchecked_Convert_To (RTE (RE_Integer_Address),
4667 Make_Attribute_Reference (Loc,
4668 Attribute_Name => Name_Address,
4669 Prefix => New_Copy_Tree (X)));
4672 Unchecked_Convert_To (RTE (RE_Integer_Address),
4673 Make_Attribute_Reference (Loc,
4674 Attribute_Name => Name_Address,
4675 Prefix => New_Copy_Tree (Y)));
4678 Make_Op_Divide (Loc,
4680 Make_Attribute_Reference (Loc,
4681 Attribute_Name => Name_Size,
4682 Prefix => New_Copy_Tree (X)),
4684 Make_Integer_Literal (Loc, System_Storage_Unit));
4687 Make_Op_Divide (Loc,
4689 Make_Attribute_Reference (Loc,
4690 Attribute_Name => Name_Size,
4691 Prefix => New_Copy_Tree (Y)),
4693 Make_Integer_Literal (Loc, System_Storage_Unit));
4697 Left_Opnd => X_Addr,
4698 Right_Opnd => Y_Addr);
4701 Make_If_Expression (Loc, New_List (
4707 Left_Opnd => New_Copy_Tree (X_Addr),
4709 Make_Op_Subtract (Loc,
4710 Left_Opnd => X_Size,
4711 Right_Opnd => Make_Integer_Literal (Loc, 1))),
4712 Right_Opnd => Y_Addr),
4717 Left_Opnd => New_Copy_Tree (Y_Addr),
4719 Make_Op_Subtract (Loc,
4720 Left_Opnd => Y_Size,
4721 Right_Opnd => Make_Integer_Literal (Loc, 1))),
4722 Right_Opnd => X_Addr))));
4724 Analyze_And_Resolve (N, Standard_Boolean);
4725 end Overlaps_Storage;
4731 when Attribute_Output => Output : declare
4732 P_Type : constant Entity_Id := Entity (Pref);
4733 U_Type : constant Entity_Id := Underlying_Type (P_Type);
4741 -- If no underlying type, we have an error that will be diagnosed
4742 -- elsewhere, so here we just completely ignore the expansion.
4748 -- Stream operations can appear in user code even if the restriction
4749 -- No_Streams is active (for example, when instantiating a predefined
4750 -- container). In that case rewrite the attribute as a Raise to
4751 -- prevent any run-time use.
4753 if Restriction_Active (No_Streams) then
4755 Make_Raise_Program_Error (Sloc (N),
4756 Reason => PE_Stream_Operation_Not_Allowed));
4757 Set_Etype (N, Standard_Void_Type);
4761 -- If TSS for Output is present, just call it
4763 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
4765 if Present (Pname) then
4769 -- If there is a Stream_Convert pragma, use it, we rewrite
4771 -- sourcetyp'Output (stream, Item)
4775 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
4777 -- where strmwrite is the given Write function that converts an
4778 -- argument of type sourcetyp or a type acctyp, from which it is
4779 -- derived to type strmtyp. The conversion to acttyp is required
4780 -- for the derived case.
4782 Prag := Get_Stream_Convert_Pragma (P_Type);
4784 if Present (Prag) then
4786 Next (Next (First (Pragma_Argument_Associations (Prag))));
4787 Wfunc := Entity (Expression (Arg3));
4790 Make_Attribute_Reference (Loc,
4791 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
4792 Attribute_Name => Name_Output,
4793 Expressions => New_List (
4794 Relocate_Node (First (Exprs)),
4795 Make_Function_Call (Loc,
4796 Name => New_Occurrence_Of (Wfunc, Loc),
4797 Parameter_Associations => New_List (
4798 OK_Convert_To (Etype (First_Formal (Wfunc)),
4799 Relocate_Node (Next (First (Exprs)))))))));
4804 -- For elementary types, we call the W_xxx routine directly. Note
4805 -- that the effect of Write and Output is identical for the case
4806 -- of an elementary type (there are no discriminants or bounds).
4808 elsif Is_Elementary_Type (U_Type) then
4810 -- A special case arises if we have a defined _Write routine,
4811 -- since in this case we are required to call this routine.
4813 if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then
4814 Build_Record_Or_Elementary_Output_Procedure
4815 (Loc, U_Type, Decl, Pname);
4816 Insert_Action (N, Decl);
4818 -- For normal cases, we call the W_xxx routine directly
4821 Rewrite (N, Build_Elementary_Write_Call (N));
4828 elsif Is_Array_Type (U_Type) then
4829 Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
4830 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
4832 -- Class-wide case, first output external tag, then dispatch
4833 -- to the appropriate primitive Output function (RM 13.13.2(31)).
4835 elsif Is_Class_Wide_Type (P_Type) then
4837 -- No need to do anything else compiling under restriction
4838 -- No_Dispatching_Calls. During the semantic analysis we
4839 -- already notified such violation.
4841 if Restriction_Active (No_Dispatching_Calls) then
4846 Strm : constant Node_Id := First (Exprs);
4847 Item : constant Node_Id := Next (Strm);
4850 -- Ada 2005 (AI-344): Check that the accessibility level
4851 -- of the type of the output object is not deeper than
4852 -- that of the attribute's prefix type.
4854 -- if Get_Access_Level (Item'Tag)
4855 -- /= Get_Access_Level (P_Type'Tag)
4860 -- String'Output (Strm, External_Tag (Item'Tag));
4862 -- We cannot figure out a practical way to implement this
4863 -- accessibility check on virtual machines, so we omit it.
4865 if Ada_Version >= Ada_2005
4866 and then Tagged_Type_Expansion
4869 Make_Implicit_If_Statement (N,
4873 Build_Get_Access_Level (Loc,
4874 Make_Attribute_Reference (Loc,
4877 Duplicate_Subexpr (Item,
4879 Attribute_Name => Name_Tag)),
4882 Make_Integer_Literal (Loc,
4883 Type_Access_Level (P_Type))),
4886 New_List (Make_Raise_Statement (Loc,
4888 RTE (RE_Tag_Error), Loc)))));
4892 Make_Attribute_Reference (Loc,
4893 Prefix => New_Occurrence_Of (Standard_String, Loc),
4894 Attribute_Name => Name_Output,
4895 Expressions => New_List (
4896 Relocate_Node (Duplicate_Subexpr (Strm)),
4897 Make_Function_Call (Loc,
4899 New_Occurrence_Of (RTE (RE_External_Tag), Loc),
4900 Parameter_Associations => New_List (
4901 Make_Attribute_Reference (Loc,
4904 (Duplicate_Subexpr (Item, Name_Req => True)),
4905 Attribute_Name => Name_Tag))))));
4908 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
4910 -- Tagged type case, use the primitive Output function
4912 elsif Is_Tagged_Type (U_Type) then
4913 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
4915 -- All other record type cases, including protected records.
4916 -- The latter only arise for expander generated code for
4917 -- handling shared passive partition access.
4921 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
4923 -- Ada 2005 (AI-216): Program_Error is raised when executing
4924 -- the default implementation of the Output attribute of an
4925 -- unchecked union type if the type lacks default discriminant
4928 if Is_Unchecked_Union (Base_Type (U_Type))
4929 and then No (Discriminant_Constraint (U_Type))
4932 Make_Raise_Program_Error (Loc,
4933 Reason => PE_Unchecked_Union_Restriction));
4938 Build_Record_Or_Elementary_Output_Procedure
4939 (Loc, Base_Type (U_Type), Decl, Pname);
4940 Insert_Action (N, Decl);
4944 -- If we fall through, Pname is the name of the procedure to call
4946 Rewrite_Stream_Proc_Call (Pname);
4953 -- For enumeration types with a standard representation, Pos is
4954 -- handled by the back end.
4956 -- For enumeration types, with a non-standard representation we generate
4957 -- a call to the _Rep_To_Pos function created when the type was frozen.
4958 -- The call has the form
4960 -- _rep_to_pos (expr, flag)
4962 -- The parameter flag is True if range checks are enabled, causing
4963 -- Program_Error to be raised if the expression has an invalid
4964 -- representation, and False if range checks are suppressed.
4966 -- For integer types, Pos is equivalent to a simple integer
4967 -- conversion and we rewrite it as such
4969 when Attribute_Pos => Pos :
4971 Etyp : Entity_Id := Base_Type (Entity (Pref));
4974 -- Deal with zero/non-zero boolean values
4976 if Is_Boolean_Type (Etyp) then
4977 Adjust_Condition (First (Exprs));
4978 Etyp := Standard_Boolean;
4979 Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
4982 -- Case of enumeration type
4984 if Is_Enumeration_Type (Etyp) then
4986 -- Non-standard enumeration type (generate call)
4988 if Present (Enum_Pos_To_Rep (Etyp)) then
4989 Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
4992 Make_Function_Call (Loc,
4994 New_Occurrence_Of (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4995 Parameter_Associations => Exprs)));
4997 Analyze_And_Resolve (N, Typ);
4999 -- Standard enumeration type (do universal integer check)
5002 Apply_Universal_Integer_Attribute_Checks (N);
5005 -- Deal with integer types (replace by conversion)
5007 elsif Is_Integer_Type (Etyp) then
5008 Rewrite (N, Convert_To (Typ, First (Exprs)));
5009 Analyze_And_Resolve (N, Typ);
5018 -- We compute this if a component clause was present, otherwise we leave
5019 -- the computation up to the back end, since we don't know what layout
5022 when Attribute_Position => Position_Attr :
5024 CE : constant Entity_Id := Entity (Selector_Name (Pref));
5027 if Present (Component_Clause (CE)) then
5029 -- In Ada 2005 (or later) if we have the non-default bit order,
5030 -- then we return the original value as given in the component
5031 -- clause (RM 2005 13.5.2(2/2)).
5033 if Ada_Version >= Ada_2005
5034 and then Reverse_Bit_Order (Scope (CE))
5037 Make_Integer_Literal (Loc,
5038 Intval => Expr_Value (Position (Component_Clause (CE)))));
5040 -- Otherwise (Ada 83 or 95, or default bit order specified in
5041 -- later Ada version), return the normalized value.
5045 Make_Integer_Literal (Loc,
5046 Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
5049 Analyze_And_Resolve (N, Typ);
5051 -- If back end is doing things, just apply universal integer checks
5054 Apply_Universal_Integer_Attribute_Checks (N);
5062 -- 1. Deal with enumeration types with holes.
5063 -- 2. For floating-point, generate call to attribute function.
5064 -- 3. For other cases, deal with constraint checking.
5066 when Attribute_Pred => Pred :
5068 Etyp : constant Entity_Id := Base_Type (Ptyp);
5072 -- For enumeration types with non-standard representations, we
5073 -- expand typ'Pred (x) into
5075 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
5077 -- If the representation is contiguous, we compute instead
5078 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
5079 -- The conversion function Enum_Pos_To_Rep is defined on the
5080 -- base type, not the subtype, so we have to use the base type
5081 -- explicitly for this and other enumeration attributes.
5083 if Is_Enumeration_Type (Ptyp)
5084 and then Present (Enum_Pos_To_Rep (Etyp))
5086 if Has_Contiguous_Rep (Etyp) then
5088 Unchecked_Convert_To (Ptyp,
5091 Make_Integer_Literal (Loc,
5092 Enumeration_Rep (First_Literal (Ptyp))),
5094 Make_Function_Call (Loc,
5097 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5099 Parameter_Associations =>
5101 Unchecked_Convert_To (Ptyp,
5102 Make_Op_Subtract (Loc,
5104 Unchecked_Convert_To (Standard_Integer,
5105 Relocate_Node (First (Exprs))),
5107 Make_Integer_Literal (Loc, 1))),
5108 Rep_To_Pos_Flag (Ptyp, Loc))))));
5111 -- Add Boolean parameter True, to request program errror if
5112 -- we have a bad representation on our hands. If checks are
5113 -- suppressed, then add False instead
5115 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
5117 Make_Indexed_Component (Loc,
5120 (Enum_Pos_To_Rep (Etyp), Loc),
5121 Expressions => New_List (
5122 Make_Op_Subtract (Loc,
5124 Make_Function_Call (Loc,
5127 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5128 Parameter_Associations => Exprs),
5129 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
5132 Analyze_And_Resolve (N, Typ);
5134 -- For floating-point, we transform 'Pred into a call to the Pred
5135 -- floating-point attribute function in Fat_xxx (xxx is root type).
5136 -- Note that this function takes care of the overflow case.
5138 elsif Is_Floating_Point_Type (Ptyp) then
5139 Expand_Fpt_Attribute_R (N);
5140 Analyze_And_Resolve (N, Typ);
5142 -- For modular types, nothing to do (no overflow, since wraps)
5144 elsif Is_Modular_Integer_Type (Ptyp) then
5147 -- For other types, if argument is marked as needing a range check or
5148 -- overflow checking is enabled, we must generate a check.
5150 elsif not Overflow_Checks_Suppressed (Ptyp)
5151 or else Do_Range_Check (First (Exprs))
5153 Set_Do_Range_Check (First (Exprs), False);
5154 Expand_Pred_Succ_Attribute (N);
5162 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5164 -- We rewrite X'Priority as the following run-time call:
5166 -- Get_Ceiling (X._Object)
5168 -- Note that although X'Priority is notionally an object, it is quite
5169 -- deliberately not defined as an aliased object in the RM. This means
5170 -- that it works fine to rewrite it as a call, without having to worry
5171 -- about complications that would other arise from X'Priority'Access,
5172 -- which is illegal, because of the lack of aliasing.
5174 when Attribute_Priority =>
5177 Conctyp : Entity_Id;
5178 Object_Parm : Node_Id;
5180 RT_Subprg_Name : Node_Id;
5183 -- Look for the enclosing concurrent type
5185 Conctyp := Current_Scope;
5186 while not Is_Concurrent_Type (Conctyp) loop
5187 Conctyp := Scope (Conctyp);
5190 pragma Assert (Is_Protected_Type (Conctyp));
5192 -- Generate the actual of the call
5194 Subprg := Current_Scope;
5195 while not Present (Protected_Body_Subprogram (Subprg)) loop
5196 Subprg := Scope (Subprg);
5199 -- Use of 'Priority inside protected entries and barriers (in
5200 -- both cases the type of the first formal of their expanded
5201 -- subprogram is Address)
5203 if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) =
5207 New_Itype : Entity_Id;
5210 -- In the expansion of protected entries the type of the
5211 -- first formal of the Protected_Body_Subprogram is an
5212 -- Address. In order to reference the _object component
5215 -- type T is access p__ptTV;
5218 New_Itype := Create_Itype (E_Access_Type, N);
5219 Set_Etype (New_Itype, New_Itype);
5220 Set_Directly_Designated_Type (New_Itype,
5221 Corresponding_Record_Type (Conctyp));
5222 Freeze_Itype (New_Itype, N);
5225 -- T!(O)._object'unchecked_access
5228 Make_Attribute_Reference (Loc,
5230 Make_Selected_Component (Loc,
5232 Unchecked_Convert_To (New_Itype,
5235 (Protected_Body_Subprogram (Subprg)),
5238 Make_Identifier (Loc, Name_uObject)),
5239 Attribute_Name => Name_Unchecked_Access);
5242 -- Use of 'Priority inside a protected subprogram
5246 Make_Attribute_Reference (Loc,
5248 Make_Selected_Component (Loc,
5249 Prefix => New_Occurrence_Of
5251 (Protected_Body_Subprogram (Subprg)),
5253 Selector_Name => Make_Identifier (Loc, Name_uObject)),
5254 Attribute_Name => Name_Unchecked_Access);
5257 -- Select the appropriate run-time subprogram
5259 if Number_Entries (Conctyp) = 0 then
5261 New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc);
5264 New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc);
5268 Make_Function_Call (Loc,
5269 Name => RT_Subprg_Name,
5270 Parameter_Associations => New_List (Object_Parm));
5274 -- Avoid the generation of extra checks on the pointer to the
5275 -- protected object.
5277 Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
5284 when Attribute_Range_Length => Range_Length : begin
5286 -- The only special processing required is for the case where
5287 -- Range_Length is applied to an enumeration type with holes.
5288 -- In this case we transform
5294 -- X'Pos (X'Last) - X'Pos (X'First) + 1
5296 -- So that the result reflects the proper Pos values instead
5297 -- of the underlying representations.
5299 if Is_Enumeration_Type (Ptyp)
5300 and then Has_Non_Standard_Rep (Ptyp)
5305 Make_Op_Subtract (Loc,
5307 Make_Attribute_Reference (Loc,
5308 Attribute_Name => Name_Pos,
5309 Prefix => New_Occurrence_Of (Ptyp, Loc),
5310 Expressions => New_List (
5311 Make_Attribute_Reference (Loc,
5312 Attribute_Name => Name_Last,
5313 Prefix => New_Occurrence_Of (Ptyp, Loc)))),
5316 Make_Attribute_Reference (Loc,
5317 Attribute_Name => Name_Pos,
5318 Prefix => New_Occurrence_Of (Ptyp, Loc),
5319 Expressions => New_List (
5320 Make_Attribute_Reference (Loc,
5321 Attribute_Name => Name_First,
5322 Prefix => New_Occurrence_Of (Ptyp, Loc))))),
5324 Right_Opnd => Make_Integer_Literal (Loc, 1)));
5326 Analyze_And_Resolve (N, Typ);
5328 -- For all other cases, the attribute is handled by the back end, but
5329 -- we need to deal with the case of the range check on a universal
5333 Apply_Universal_Integer_Attribute_Checks (N);
5341 when Attribute_Read => Read : declare
5342 P_Type : constant Entity_Id := Entity (Pref);
5343 B_Type : constant Entity_Id := Base_Type (P_Type);
5344 U_Type : constant Entity_Id := Underlying_Type (P_Type);
5354 -- If no underlying type, we have an error that will be diagnosed
5355 -- elsewhere, so here we just completely ignore the expansion.
5361 -- Stream operations can appear in user code even if the restriction
5362 -- No_Streams is active (for example, when instantiating a predefined
5363 -- container). In that case rewrite the attribute as a Raise to
5364 -- prevent any run-time use.
5366 if Restriction_Active (No_Streams) then
5368 Make_Raise_Program_Error (Sloc (N),
5369 Reason => PE_Stream_Operation_Not_Allowed));
5370 Set_Etype (N, B_Type);
5374 -- The simple case, if there is a TSS for Read, just call it
5376 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
5378 if Present (Pname) then
5382 -- If there is a Stream_Convert pragma, use it, we rewrite
5384 -- sourcetyp'Read (stream, Item)
5388 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
5390 -- where strmread is the given Read function that converts an
5391 -- argument of type strmtyp to type sourcetyp or a type from which
5392 -- it is derived. The conversion to sourcetyp is required in the
5395 -- A special case arises if Item is a type conversion in which
5396 -- case, we have to expand to:
5398 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
5400 -- where Itemx is the expression of the type conversion (i.e.
5401 -- the actual object), and typex is the type of Itemx.
5403 Prag := Get_Stream_Convert_Pragma (P_Type);
5405 if Present (Prag) then
5406 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
5407 Rfunc := Entity (Expression (Arg2));
5408 Lhs := Relocate_Node (Next (First (Exprs)));
5410 OK_Convert_To (B_Type,
5411 Make_Function_Call (Loc,
5412 Name => New_Occurrence_Of (Rfunc, Loc),
5413 Parameter_Associations => New_List (
5414 Make_Attribute_Reference (Loc,
5417 (Etype (First_Formal (Rfunc)), Loc),
5418 Attribute_Name => Name_Input,
5419 Expressions => New_List (
5420 Relocate_Node (First (Exprs)))))));
5422 if Nkind (Lhs) = N_Type_Conversion then
5423 Lhs := Expression (Lhs);
5424 Rhs := Convert_To (Etype (Lhs), Rhs);
5428 Make_Assignment_Statement (Loc,
5430 Expression => Rhs));
5431 Set_Assignment_OK (Lhs);
5435 -- For elementary types, we call the I_xxx routine using the first
5436 -- parameter and then assign the result into the second parameter.
5437 -- We set Assignment_OK to deal with the conversion case.
5439 elsif Is_Elementary_Type (U_Type) then
5445 Lhs := Relocate_Node (Next (First (Exprs)));
5446 Rhs := Build_Elementary_Input_Call (N);
5448 if Nkind (Lhs) = N_Type_Conversion then
5449 Lhs := Expression (Lhs);
5450 Rhs := Convert_To (Etype (Lhs), Rhs);
5453 Set_Assignment_OK (Lhs);
5456 Make_Assignment_Statement (Loc,
5458 Expression => Rhs));
5466 elsif Is_Array_Type (U_Type) then
5467 Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
5468 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
5470 -- Tagged type case, use the primitive Read function. Note that
5471 -- this will dispatch in the class-wide case which is what we want
5473 elsif Is_Tagged_Type (U_Type) then
5474 Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
5476 -- All other record type cases, including protected records. The
5477 -- latter only arise for expander generated code for handling
5478 -- shared passive partition access.
5482 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
5484 -- Ada 2005 (AI-216): Program_Error is raised when executing
5485 -- the default implementation of the Read attribute of an
5486 -- Unchecked_Union type.
5488 if Is_Unchecked_Union (Base_Type (U_Type)) then
5490 Make_Raise_Program_Error (Loc,
5491 Reason => PE_Unchecked_Union_Restriction));
5494 if Has_Discriminants (U_Type)
5496 (Discriminant_Default_Value (First_Discriminant (U_Type)))
5498 Build_Mutable_Record_Read_Procedure
5499 (Loc, Full_Base (U_Type), Decl, Pname);
5501 Build_Record_Read_Procedure
5502 (Loc, Full_Base (U_Type), Decl, Pname);
5505 -- Suppress checks, uninitialized or otherwise invalid
5506 -- data does not cause constraint errors to be raised for
5507 -- a complete record read.
5509 Insert_Action (N, Decl, All_Checks);
5513 Rewrite_Stream_Proc_Call (Pname);
5520 -- Ref is identical to To_Address, see To_Address for processing
5526 -- Transforms 'Remainder into a call to the floating-point attribute
5527 -- function Remainder in Fat_xxx (where xxx is the root type)
5529 when Attribute_Remainder =>
5530 Expand_Fpt_Attribute_RR (N);
5536 -- Transform 'Result into reference to _Result formal. At the point
5537 -- where a legal 'Result attribute is expanded, we know that we are in
5538 -- the context of a _Postcondition function with a _Result parameter.
5540 when Attribute_Result =>
5541 Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult));
5542 Analyze_And_Resolve (N, Typ);
5548 -- The handling of the Round attribute is quite delicate. The processing
5549 -- in Sem_Attr introduced a conversion to universal real, reflecting the
5550 -- semantics of Round, but we do not want anything to do with universal
5551 -- real at runtime, since this corresponds to using floating-point
5554 -- What we have now is that the Etype of the Round attribute correctly
5555 -- indicates the final result type. The operand of the Round is the
5556 -- conversion to universal real, described above, and the operand of
5557 -- this conversion is the actual operand of Round, which may be the
5558 -- special case of a fixed point multiplication or division (Etype =
5561 -- The exapander will expand first the operand of the conversion, then
5562 -- the conversion, and finally the round attribute itself, since we
5563 -- always work inside out. But we cannot simply process naively in this
5564 -- order. In the semantic world where universal fixed and real really
5565 -- exist and have infinite precision, there is no problem, but in the
5566 -- implementation world, where universal real is a floating-point type,
5567 -- we would get the wrong result.
5569 -- So the approach is as follows. First, when expanding a multiply or
5570 -- divide whose type is universal fixed, we do nothing at all, instead
5571 -- deferring the operation till later.
5573 -- The actual processing is done in Expand_N_Type_Conversion which
5574 -- handles the special case of Round by looking at its parent to see if
5575 -- it is a Round attribute, and if it is, handling the conversion (or
5576 -- its fixed multiply/divide child) in an appropriate manner.
5578 -- This means that by the time we get to expanding the Round attribute
5579 -- itself, the Round is nothing more than a type conversion (and will
5580 -- often be a null type conversion), so we just replace it with the
5581 -- appropriate conversion operation.
5583 when Attribute_Round =>
5585 Convert_To (Etype (N), Relocate_Node (First (Exprs))));
5586 Analyze_And_Resolve (N);
5592 -- Transforms 'Rounding into a call to the floating-point attribute
5593 -- function Rounding in Fat_xxx (where xxx is the root type)
5594 -- Expansion is avoided for cases the back end can handle directly.
5596 when Attribute_Rounding =>
5597 if not Is_Inline_Floating_Point_Attribute (N) then
5598 Expand_Fpt_Attribute_R (N);
5605 -- Transforms 'Scaling into a call to the floating-point attribute
5606 -- function Scaling in Fat_xxx (where xxx is the root type)
5608 when Attribute_Scaling =>
5609 Expand_Fpt_Attribute_RI (N);
5611 -------------------------
5612 -- Simple_Storage_Pool --
5613 -------------------------
5615 when Attribute_Simple_Storage_Pool =>
5617 Make_Type_Conversion (Loc,
5618 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
5619 Expression => New_Occurrence_Of (Entity (N), Loc)));
5620 Analyze_And_Resolve (N, Typ);
5626 when Attribute_Size |
5627 Attribute_Object_Size |
5628 Attribute_Value_Size |
5629 Attribute_VADS_Size => Size :
5636 -- Processing for VADS_Size case. Note that this processing removes
5637 -- all traces of VADS_Size from the tree, and completes all required
5638 -- processing for VADS_Size by translating the attribute reference
5639 -- to an appropriate Size or Object_Size reference.
5641 if Id = Attribute_VADS_Size
5642 or else (Use_VADS_Size and then Id = Attribute_Size)
5644 -- If the size is specified, then we simply use the specified
5645 -- size. This applies to both types and objects. The size of an
5646 -- object can be specified in the following ways:
5648 -- An explicit size object is given for an object
5649 -- A component size is specified for an indexed component
5650 -- A component clause is specified for a selected component
5651 -- The object is a component of a packed composite object
5653 -- If the size is specified, then VADS_Size of an object
5655 if (Is_Entity_Name (Pref)
5656 and then Present (Size_Clause (Entity (Pref))))
5658 (Nkind (Pref) = N_Component_Clause
5659 and then (Present (Component_Clause
5660 (Entity (Selector_Name (Pref))))
5661 or else Is_Packed (Etype (Prefix (Pref)))))
5663 (Nkind (Pref) = N_Indexed_Component
5664 and then (Component_Size (Etype (Prefix (Pref))) /= 0
5665 or else Is_Packed (Etype (Prefix (Pref)))))
5667 Set_Attribute_Name (N, Name_Size);
5669 -- Otherwise if we have an object rather than a type, then the
5670 -- VADS_Size attribute applies to the type of the object, rather
5671 -- than the object itself. This is one of the respects in which
5672 -- VADS_Size differs from Size.
5675 if (not Is_Entity_Name (Pref)
5676 or else not Is_Type (Entity (Pref)))
5677 and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp))
5679 Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
5682 -- For a scalar type for which no size was explicitly given,
5683 -- VADS_Size means Object_Size. This is the other respect in
5684 -- which VADS_Size differs from Size.
5686 if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then
5687 Set_Attribute_Name (N, Name_Object_Size);
5689 -- In all other cases, Size and VADS_Size are the sane
5692 Set_Attribute_Name (N, Name_Size);
5697 -- If the prefix is X'Class, we transform it into a direct reference
5698 -- to the class-wide type, because the back end must not see a 'Class
5701 if Is_Entity_Name (Pref)
5702 and then Is_Class_Wide_Type (Entity (Pref))
5704 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
5707 -- For X'Size applied to an object of a class-wide type, transform
5708 -- X'Size into a call to the primitive operation _Size applied to X.
5710 elsif Is_Class_Wide_Type (Ptyp) then
5712 -- No need to do anything else compiling under restriction
5713 -- No_Dispatching_Calls. During the semantic analysis we
5714 -- already noted this restriction violation.
5716 if Restriction_Active (No_Dispatching_Calls) then
5721 Make_Function_Call (Loc,
5722 Name => New_Occurrence_Of
5723 (Find_Prim_Op (Ptyp, Name_uSize), Loc),
5724 Parameter_Associations => New_List (Pref));
5726 if Typ /= Standard_Long_Long_Integer then
5728 -- The context is a specific integer type with which the
5729 -- original attribute was compatible. The function has a
5730 -- specific type as well, so to preserve the compatibility
5731 -- we must convert explicitly.
5733 New_Node := Convert_To (Typ, New_Node);
5736 Rewrite (N, New_Node);
5737 Analyze_And_Resolve (N, Typ);
5740 -- Case of known RM_Size of a type
5742 elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
5743 and then Is_Entity_Name (Pref)
5744 and then Is_Type (Entity (Pref))
5745 and then Known_Static_RM_Size (Entity (Pref))
5747 Siz := RM_Size (Entity (Pref));
5749 -- Case of known Esize of a type
5751 elsif Id = Attribute_Object_Size
5752 and then Is_Entity_Name (Pref)
5753 and then Is_Type (Entity (Pref))
5754 and then Known_Static_Esize (Entity (Pref))
5756 Siz := Esize (Entity (Pref));
5758 -- Case of known size of object
5760 elsif Id = Attribute_Size
5761 and then Is_Entity_Name (Pref)
5762 and then Is_Object (Entity (Pref))
5763 and then Known_Esize (Entity (Pref))
5764 and then Known_Static_Esize (Entity (Pref))
5766 Siz := Esize (Entity (Pref));
5768 -- For an array component, we can do Size in the front end
5769 -- if the component_size of the array is set.
5771 elsif Nkind (Pref) = N_Indexed_Component then
5772 Siz := Component_Size (Etype (Prefix (Pref)));
5774 -- For a record component, we can do Size in the front end if there
5775 -- is a component clause, or if the record is packed and the
5776 -- component's size is known at compile time.
5778 elsif Nkind (Pref) = N_Selected_Component then
5780 Rec : constant Entity_Id := Etype (Prefix (Pref));
5781 Comp : constant Entity_Id := Entity (Selector_Name (Pref));
5784 if Present (Component_Clause (Comp)) then
5785 Siz := Esize (Comp);
5787 elsif Is_Packed (Rec) then
5788 Siz := RM_Size (Ptyp);
5791 Apply_Universal_Integer_Attribute_Checks (N);
5796 -- All other cases are handled by the back end
5799 Apply_Universal_Integer_Attribute_Checks (N);
5801 -- If Size is applied to a formal parameter that is of a packed
5802 -- array subtype, then apply Size to the actual subtype.
5804 if Is_Entity_Name (Pref)
5805 and then Is_Formal (Entity (Pref))
5806 and then Is_Array_Type (Ptyp)
5807 and then Is_Packed (Ptyp)
5810 Make_Attribute_Reference (Loc,
5812 New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
5813 Attribute_Name => Name_Size));
5814 Analyze_And_Resolve (N, Typ);
5817 -- If Size applies to a dereference of an access to unconstrained
5818 -- packed array, the back end needs to see its unconstrained
5819 -- nominal type, but also a hint to the actual constrained type.
5821 if Nkind (Pref) = N_Explicit_Dereference
5822 and then Is_Array_Type (Ptyp)
5823 and then not Is_Constrained (Ptyp)
5824 and then Is_Packed (Ptyp)
5826 Set_Actual_Designated_Subtype (Pref,
5827 Get_Actual_Subtype (Pref));
5833 -- Common processing for record and array component case
5835 if Siz /= No_Uint and then Siz /= 0 then
5837 CS : constant Boolean := Comes_From_Source (N);
5840 Rewrite (N, Make_Integer_Literal (Loc, Siz));
5842 -- This integer literal is not a static expression. We do not
5843 -- call Analyze_And_Resolve here, because this would activate
5844 -- the circuit for deciding that a static value was out of
5845 -- range, and we don't want that.
5847 -- So just manually set the type, mark the expression as non-
5848 -- static, and then ensure that the result is checked properly
5849 -- if the attribute comes from source (if it was internally
5850 -- generated, we never need a constraint check).
5853 Set_Is_Static_Expression (N, False);
5856 Apply_Constraint_Check (N, Typ);
5866 when Attribute_Storage_Pool =>
5868 Make_Type_Conversion (Loc,
5869 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
5870 Expression => New_Occurrence_Of (Entity (N), Loc)));
5871 Analyze_And_Resolve (N, Typ);
5877 when Attribute_Storage_Size => Storage_Size : declare
5878 Alloc_Op : Entity_Id := Empty;
5882 -- Access type case, always go to the root type
5884 -- The case of access types results in a value of zero for the case
5885 -- where no storage size attribute clause has been given. If a
5886 -- storage size has been given, then the attribute is converted
5887 -- to a reference to the variable used to hold this value.
5889 if Is_Access_Type (Ptyp) then
5890 if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
5892 Make_Attribute_Reference (Loc,
5893 Prefix => New_Occurrence_Of (Typ, Loc),
5894 Attribute_Name => Name_Max,
5895 Expressions => New_List (
5896 Make_Integer_Literal (Loc, 0),
5899 (Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
5901 elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
5903 -- If the access type is associated with a simple storage pool
5904 -- object, then attempt to locate the optional Storage_Size
5905 -- function of the simple storage pool type. If not found,
5906 -- then the result will default to zero.
5908 if Present (Get_Rep_Pragma (Root_Type (Ptyp),
5909 Name_Simple_Storage_Pool_Type))
5912 Pool_Type : constant Entity_Id :=
5913 Base_Type (Etype (Entity (N)));
5916 Alloc_Op := Get_Name_Entity_Id (Name_Storage_Size);
5917 while Present (Alloc_Op) loop
5918 if Scope (Alloc_Op) = Scope (Pool_Type)
5919 and then Present (First_Formal (Alloc_Op))
5920 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
5925 Alloc_Op := Homonym (Alloc_Op);
5929 -- In the normal Storage_Pool case, retrieve the primitive
5930 -- function associated with the pool type.
5935 (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
5936 Attribute_Name (N));
5939 -- If Storage_Size wasn't found (can only occur in the simple
5940 -- storage pool case), then simply use zero for the result.
5942 if not Present (Alloc_Op) then
5943 Rewrite (N, Make_Integer_Literal (Loc, 0));
5945 -- Otherwise, rewrite the allocator as a call to pool type's
5946 -- Storage_Size function.
5951 Make_Function_Call (Loc,
5953 New_Occurrence_Of (Alloc_Op, Loc),
5955 Parameter_Associations => New_List (
5957 (Associated_Storage_Pool
5958 (Root_Type (Ptyp)), Loc)))));
5962 Rewrite (N, Make_Integer_Literal (Loc, 0));
5965 Analyze_And_Resolve (N, Typ);
5967 -- For tasks, we retrieve the size directly from the TCB. The
5968 -- size may depend on a discriminant of the type, and therefore
5969 -- can be a per-object expression, so type-level information is
5970 -- not sufficient in general. There are four cases to consider:
5972 -- a) If the attribute appears within a task body, the designated
5973 -- TCB is obtained by a call to Self.
5975 -- b) If the prefix of the attribute is the name of a task object,
5976 -- the designated TCB is the one stored in the corresponding record.
5978 -- c) If the prefix is a task type, the size is obtained from the
5979 -- size variable created for each task type
5981 -- d) If no Storage_Size was specified for the type, there is no
5982 -- size variable, and the value is a system-specific default.
5985 if In_Open_Scopes (Ptyp) then
5987 -- Storage_Size (Self)
5991 Make_Function_Call (Loc,
5993 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
5994 Parameter_Associations =>
5996 Make_Function_Call (Loc,
5998 New_Occurrence_Of (RTE (RE_Self), Loc))))));
6000 elsif not Is_Entity_Name (Pref)
6001 or else not Is_Type (Entity (Pref))
6003 -- Storage_Size (Rec (Obj).Size)
6007 Make_Function_Call (Loc,
6009 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
6010 Parameter_Associations =>
6012 Make_Selected_Component (Loc,
6014 Unchecked_Convert_To (
6015 Corresponding_Record_Type (Ptyp),
6016 New_Copy_Tree (Pref)),
6018 Make_Identifier (Loc, Name_uTask_Id))))));
6020 elsif Present (Storage_Size_Variable (Ptyp)) then
6022 -- Static Storage_Size pragma given for type: retrieve value
6023 -- from its allocated storage variable.
6027 Make_Function_Call (Loc,
6028 Name => New_Occurrence_Of (
6029 RTE (RE_Adjust_Storage_Size), Loc),
6030 Parameter_Associations =>
6033 Storage_Size_Variable (Ptyp), Loc)))));
6035 -- Get system default
6039 Make_Function_Call (Loc,
6042 RTE (RE_Default_Stack_Size), Loc))));
6045 Analyze_And_Resolve (N, Typ);
6053 when Attribute_Stream_Size =>
6055 Make_Integer_Literal (Loc, Intval => Get_Stream_Size (Ptyp)));
6056 Analyze_And_Resolve (N, Typ);
6062 -- 1. Deal with enumeration types with holes.
6063 -- 2. For floating-point, generate call to attribute function.
6064 -- 3. For other cases, deal with constraint checking.
6066 when Attribute_Succ => Succ : declare
6067 Etyp : constant Entity_Id := Base_Type (Ptyp);
6071 -- For enumeration types with non-standard representations, we
6072 -- expand typ'Succ (x) into
6074 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
6076 -- If the representation is contiguous, we compute instead
6077 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
6079 if Is_Enumeration_Type (Ptyp)
6080 and then Present (Enum_Pos_To_Rep (Etyp))
6082 if Has_Contiguous_Rep (Etyp) then
6084 Unchecked_Convert_To (Ptyp,
6087 Make_Integer_Literal (Loc,
6088 Enumeration_Rep (First_Literal (Ptyp))),
6090 Make_Function_Call (Loc,
6093 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
6095 Parameter_Associations =>
6097 Unchecked_Convert_To (Ptyp,
6100 Unchecked_Convert_To (Standard_Integer,
6101 Relocate_Node (First (Exprs))),
6103 Make_Integer_Literal (Loc, 1))),
6104 Rep_To_Pos_Flag (Ptyp, Loc))))));
6106 -- Add Boolean parameter True, to request program errror if
6107 -- we have a bad representation on our hands. Add False if
6108 -- checks are suppressed.
6110 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
6112 Make_Indexed_Component (Loc,
6115 (Enum_Pos_To_Rep (Etyp), Loc),
6116 Expressions => New_List (
6119 Make_Function_Call (Loc,
6122 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
6123 Parameter_Associations => Exprs),
6124 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
6127 Analyze_And_Resolve (N, Typ);
6129 -- For floating-point, we transform 'Succ into a call to the Succ
6130 -- floating-point attribute function in Fat_xxx (xxx is root type)
6132 elsif Is_Floating_Point_Type (Ptyp) then
6133 Expand_Fpt_Attribute_R (N);
6134 Analyze_And_Resolve (N, Typ);
6136 -- For modular types, nothing to do (no overflow, since wraps)
6138 elsif Is_Modular_Integer_Type (Ptyp) then
6141 -- For other types, if argument is marked as needing a range check or
6142 -- overflow checking is enabled, we must generate a check.
6144 elsif not Overflow_Checks_Suppressed (Ptyp)
6145 or else Do_Range_Check (First (Exprs))
6147 Set_Do_Range_Check (First (Exprs), False);
6148 Expand_Pred_Succ_Attribute (N);
6156 -- Transforms X'Tag into a direct reference to the tag of X
6158 when Attribute_Tag => Tag : declare
6160 Prefix_Is_Type : Boolean;
6163 if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then
6164 Ttyp := Entity (Pref);
6165 Prefix_Is_Type := True;
6168 Prefix_Is_Type := False;
6171 if Is_Class_Wide_Type (Ttyp) then
6172 Ttyp := Root_Type (Ttyp);
6175 Ttyp := Underlying_Type (Ttyp);
6177 -- Ada 2005: The type may be a synchronized tagged type, in which
6178 -- case the tag information is stored in the corresponding record.
6180 if Is_Concurrent_Type (Ttyp) then
6181 Ttyp := Corresponding_Record_Type (Ttyp);
6184 if Prefix_Is_Type then
6186 -- For VMs we leave the type attribute unexpanded because
6187 -- there's not a dispatching table to reference.
6189 if Tagged_Type_Expansion then
6191 Unchecked_Convert_To (RTE (RE_Tag),
6193 (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc)));
6194 Analyze_And_Resolve (N, RTE (RE_Tag));
6197 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
6198 -- references the primary tag of the actual object. If 'Tag is
6199 -- applied to class-wide interface objects we generate code that
6200 -- displaces "this" to reference the base of the object.
6202 elsif Comes_From_Source (N)
6203 and then Is_Class_Wide_Type (Etype (Prefix (N)))
6204 and then Is_Interface (Etype (Prefix (N)))
6207 -- (To_Tag_Ptr (Prefix'Address)).all
6209 -- Note that Prefix'Address is recursively expanded into a call
6210 -- to Base_Address (Obj.Tag)
6212 -- Not needed for VM targets, since all handled by the VM
6214 if Tagged_Type_Expansion then
6216 Make_Explicit_Dereference (Loc,
6217 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6218 Make_Attribute_Reference (Loc,
6219 Prefix => Relocate_Node (Pref),
6220 Attribute_Name => Name_Address))));
6221 Analyze_And_Resolve (N, RTE (RE_Tag));
6226 Make_Selected_Component (Loc,
6227 Prefix => Relocate_Node (Pref),
6229 New_Occurrence_Of (First_Tag_Component (Ttyp), Loc)));
6230 Analyze_And_Resolve (N, RTE (RE_Tag));
6238 -- Transforms 'Terminated attribute into a call to Terminated function
6240 when Attribute_Terminated => Terminated :
6242 -- The prefix of Terminated is of a task interface class-wide type.
6244 -- terminated (Task_Id (Pref._disp_get_task_id));
6246 if Ada_Version >= Ada_2005
6247 and then Ekind (Ptyp) = E_Class_Wide_Type
6248 and then Is_Interface (Ptyp)
6249 and then Is_Task_Interface (Ptyp)
6252 Make_Function_Call (Loc,
6254 New_Occurrence_Of (RTE (RE_Terminated), Loc),
6255 Parameter_Associations => New_List (
6256 Make_Unchecked_Type_Conversion (Loc,
6258 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
6260 Make_Selected_Component (Loc,
6262 New_Copy_Tree (Pref),
6264 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
6266 elsif Restricted_Profile then
6268 Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
6272 Build_Call_With_Task (Pref, RTE (RE_Terminated)));
6275 Analyze_And_Resolve (N, Standard_Boolean);
6282 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
6283 -- unchecked conversion from (integral) type of X to type address.
6285 when Attribute_To_Address | Attribute_Ref =>
6287 Unchecked_Convert_To (RTE (RE_Address),
6288 Relocate_Node (First (Exprs))));
6289 Analyze_And_Resolve (N, RTE (RE_Address));
6295 when Attribute_To_Any => To_Any : declare
6296 P_Type : constant Entity_Id := Etype (Pref);
6297 Decls : constant List_Id := New_List;
6303 Relocate_Node (First (Exprs))), Decls));
6304 Insert_Actions (N, Decls);
6305 Analyze_And_Resolve (N, RTE (RE_Any));
6312 -- Transforms 'Truncation into a call to the floating-point attribute
6313 -- function Truncation in Fat_xxx (where xxx is the root type).
6314 -- Expansion is avoided for cases the back end can handle directly.
6316 when Attribute_Truncation =>
6317 if not Is_Inline_Floating_Point_Attribute (N) then
6318 Expand_Fpt_Attribute_R (N);
6325 when Attribute_TypeCode => TypeCode : declare
6326 P_Type : constant Entity_Id := Etype (Pref);
6327 Decls : constant List_Id := New_List;
6329 Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls));
6330 Insert_Actions (N, Decls);
6331 Analyze_And_Resolve (N, RTE (RE_TypeCode));
6334 -----------------------
6335 -- Unbiased_Rounding --
6336 -----------------------
6338 -- Transforms 'Unbiased_Rounding into a call to the floating-point
6339 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
6340 -- root type). Expansion is avoided for cases the back end can handle
6343 when Attribute_Unbiased_Rounding =>
6344 if not Is_Inline_Floating_Point_Attribute (N) then
6345 Expand_Fpt_Attribute_R (N);
6352 when Attribute_Update =>
6353 Expand_Update_Attribute (N);
6359 -- The processing for VADS_Size is shared with Size
6365 -- For enumeration types with a standard representation, and for all
6366 -- other types, Val is handled by the back end. For enumeration types
6367 -- with a non-standard representation we use the _Pos_To_Rep array that
6368 -- was created when the type was frozen.
6370 when Attribute_Val => Val : declare
6371 Etyp : constant Entity_Id := Base_Type (Entity (Pref));
6374 if Is_Enumeration_Type (Etyp)
6375 and then Present (Enum_Pos_To_Rep (Etyp))
6377 if Has_Contiguous_Rep (Etyp) then
6379 Rep_Node : constant Node_Id :=
6380 Unchecked_Convert_To (Etyp,
6383 Make_Integer_Literal (Loc,
6384 Enumeration_Rep (First_Literal (Etyp))),
6386 (Convert_To (Standard_Integer,
6387 Relocate_Node (First (Exprs))))));
6391 Unchecked_Convert_To (Etyp,
6394 Make_Integer_Literal (Loc,
6395 Enumeration_Rep (First_Literal (Etyp))),
6397 Make_Function_Call (Loc,
6400 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
6401 Parameter_Associations => New_List (
6403 Rep_To_Pos_Flag (Etyp, Loc))))));
6408 Make_Indexed_Component (Loc,
6409 Prefix => New_Occurrence_Of (Enum_Pos_To_Rep (Etyp), Loc),
6410 Expressions => New_List (
6411 Convert_To (Standard_Integer,
6412 Relocate_Node (First (Exprs))))));
6415 Analyze_And_Resolve (N, Typ);
6417 -- If the argument is marked as requiring a range check then generate
6420 elsif Do_Range_Check (First (Exprs)) then
6421 Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
6429 -- The code for valid is dependent on the particular types involved.
6430 -- See separate sections below for the generated code in each case.
6432 when Attribute_Valid => Valid : declare
6433 Btyp : Entity_Id := Base_Type (Ptyp);
6436 Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
6437 -- Save the validity checking mode. We always turn off validity
6438 -- checking during process of 'Valid since this is one place
6439 -- where we do not want the implicit validity checks to intefere
6440 -- with the explicit validity check that the programmer is doing.
6442 function Make_Range_Test return Node_Id;
6443 -- Build the code for a range test of the form
6444 -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
6446 ---------------------
6447 -- Make_Range_Test --
6448 ---------------------
6450 function Make_Range_Test return Node_Id is
6451 Temp : constant Node_Id := Duplicate_Subexpr (Pref);
6454 -- The value whose validity is being checked has been captured in
6455 -- an object declaration. We certainly don't want this object to
6456 -- appear valid because the declaration initializes it.
6458 if Is_Entity_Name (Temp) then
6459 Set_Is_Known_Valid (Entity (Temp), False);
6465 Unchecked_Convert_To (Btyp, Temp),
6469 Unchecked_Convert_To (Btyp,
6470 Make_Attribute_Reference (Loc,
6471 Prefix => New_Occurrence_Of (Ptyp, Loc),
6472 Attribute_Name => Name_First)),
6474 Unchecked_Convert_To (Btyp,
6475 Make_Attribute_Reference (Loc,
6476 Prefix => New_Occurrence_Of (Ptyp, Loc),
6477 Attribute_Name => Name_Last))));
6478 end Make_Range_Test;
6480 -- Start of processing for Attribute_Valid
6483 -- Do not expand sourced code 'Valid reference in CodePeer mode,
6484 -- will be handled by the back-end directly.
6486 if CodePeer_Mode and then Comes_From_Source (N) then
6490 -- Turn off validity checks. We do not want any implicit validity
6491 -- checks to intefere with the explicit check from the attribute
6493 Validity_Checks_On := False;
6495 -- Retrieve the base type. Handle the case where the base type is a
6496 -- private enumeration type.
6498 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
6499 Btyp := Full_View (Btyp);
6502 -- Floating-point case. This case is handled by the Valid attribute
6503 -- code in the floating-point attribute run-time library.
6505 if Is_Floating_Point_Type (Ptyp) then
6506 Float_Valid : declare
6510 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id;
6511 -- Return entity for Pkg.Nam
6513 --------------------
6514 -- Get_Fat_Entity --
6515 --------------------
6517 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id is
6518 Exp_Name : constant Node_Id :=
6519 Make_Selected_Component (Loc,
6520 Prefix => New_Occurrence_Of (RTE (Pkg), Loc),
6521 Selector_Name => Make_Identifier (Loc, Nam));
6523 Find_Selected_Component (Exp_Name);
6524 return Entity (Exp_Name);
6527 -- Start of processing for Float_Valid
6530 -- The C and AAMP back-ends handle Valid for fpt types
6532 if Generate_C_Code or else Float_Rep (Btyp) = AAMP then
6533 Analyze_And_Resolve (Pref, Ptyp);
6534 Set_Etype (N, Standard_Boolean);
6538 Find_Fat_Info (Ptyp, Ftp, Pkg);
6540 -- If the prefix is a reverse SSO component, or is possibly
6541 -- unaligned, first create a temporary copy that is in
6542 -- native SSO, and properly aligned. Make it Volatile to
6543 -- prevent folding in the back-end. Note that we use an
6544 -- intermediate constrained string type to initialize the
6545 -- temporary, as the value at hand might be invalid, and in
6546 -- that case it cannot be copied using a floating point
6549 if In_Reverse_Storage_Order_Object (Pref)
6550 or else Is_Possibly_Unaligned_Object (Pref)
6553 Temp : constant Entity_Id :=
6554 Make_Temporary (Loc, 'F');
6556 Fat_S : constant Entity_Id :=
6557 Get_Fat_Entity (Name_S);
6558 -- Constrained string subtype of appropriate size
6560 Fat_P : constant Entity_Id :=
6561 Get_Fat_Entity (Name_P);
6564 Decl : constant Node_Id :=
6565 Make_Object_Declaration (Loc,
6566 Defining_Identifier => Temp,
6567 Aliased_Present => True,
6568 Object_Definition =>
6569 New_Occurrence_Of (Ptyp, Loc));
6572 Set_Aspect_Specifications (Decl, New_List (
6573 Make_Aspect_Specification (Loc,
6575 Make_Identifier (Loc, Name_Volatile))));
6581 Make_Assignment_Statement (Loc,
6583 Make_Explicit_Dereference (Loc,
6585 Unchecked_Convert_To (Fat_P,
6586 Make_Attribute_Reference (Loc,
6588 New_Occurrence_Of (Temp, Loc),
6590 Name_Unrestricted_Access))),
6592 Unchecked_Convert_To (Fat_S,
6593 Relocate_Node (Pref)))),
6595 Suppress => All_Checks);
6597 Rewrite (Pref, New_Occurrence_Of (Temp, Loc));
6601 -- We now have an object of the proper endianness and
6602 -- alignment, and can construct a Valid attribute.
6604 -- We make sure the prefix of this valid attribute is
6605 -- marked as not coming from source, to avoid losing
6606 -- warnings from 'Valid looking like a possible update.
6608 Set_Comes_From_Source (Pref, False);
6610 Expand_Fpt_Attribute
6611 (N, Pkg, Name_Valid,
6613 Make_Attribute_Reference (Loc,
6614 Prefix => Unchecked_Convert_To (Ftp, Pref),
6615 Attribute_Name => Name_Unrestricted_Access)));
6618 -- One more task, we still need a range check. Required
6619 -- only if we have a constraint, since the Valid routine
6620 -- catches infinities properly (infinities are never valid).
6622 -- The way we do the range check is simply to create the
6623 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
6625 if not Subtypes_Statically_Match (Ptyp, Btyp) then
6628 Left_Opnd => Relocate_Node (N),
6631 Left_Opnd => Convert_To (Btyp, Pref),
6632 Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
6636 -- Enumeration type with holes
6638 -- For enumeration types with holes, the Pos value constructed by
6639 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
6640 -- second argument of False returns minus one for an invalid value,
6641 -- and the non-negative pos value for a valid value, so the
6642 -- expansion of X'Valid is simply:
6644 -- type(X)'Pos (X) >= 0
6646 -- We can't quite generate it that way because of the requirement
6647 -- for the non-standard second argument of False in the resulting
6648 -- rep_to_pos call, so we have to explicitly create:
6650 -- _rep_to_pos (X, False) >= 0
6652 -- If we have an enumeration subtype, we also check that the
6653 -- value is in range:
6655 -- _rep_to_pos (X, False) >= 0
6657 -- (X >= type(X)'First and then type(X)'Last <= X)
6659 elsif Is_Enumeration_Type (Ptyp)
6660 and then Present (Enum_Pos_To_Rep (Btyp))
6665 Make_Function_Call (Loc,
6667 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
6668 Parameter_Associations => New_List (
6670 New_Occurrence_Of (Standard_False, Loc))),
6671 Right_Opnd => Make_Integer_Literal (Loc, 0));
6675 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
6677 Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
6679 -- The call to Make_Range_Test will create declarations
6680 -- that need a proper insertion point, but Pref is now
6681 -- attached to a node with no ancestor. Attach to tree
6682 -- even if it is to be rewritten below.
6684 Set_Parent (Tst, Parent (N));
6688 Left_Opnd => Make_Range_Test,
6694 -- Fortran convention booleans
6696 -- For the very special case of Fortran convention booleans, the
6697 -- value is always valid, since it is an integer with the semantics
6698 -- that non-zero is true, and any value is permissible.
6700 elsif Is_Boolean_Type (Ptyp)
6701 and then Convention (Ptyp) = Convention_Fortran
6703 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6705 -- For biased representations, we will be doing an unchecked
6706 -- conversion without unbiasing the result. That means that the range
6707 -- test has to take this into account, and the proper form of the
6710 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
6712 elsif Has_Biased_Representation (Ptyp) then
6713 Btyp := RTE (RE_Unsigned_32);
6717 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
6719 Unchecked_Convert_To (Btyp,
6720 Make_Attribute_Reference (Loc,
6721 Prefix => New_Occurrence_Of (Ptyp, Loc),
6722 Attribute_Name => Name_Range_Length))));
6724 -- For all other scalar types, what we want logically is a
6727 -- X in type(X)'First .. type(X)'Last
6729 -- But that's precisely what won't work because of possible
6730 -- unwanted optimization (and indeed the basic motivation for
6731 -- the Valid attribute is exactly that this test does not work).
6732 -- What will work is:
6734 -- Btyp!(X) >= Btyp!(type(X)'First)
6736 -- Btyp!(X) <= Btyp!(type(X)'Last)
6738 -- where Btyp is an integer type large enough to cover the full
6739 -- range of possible stored values (i.e. it is chosen on the basis
6740 -- of the size of the type, not the range of the values). We write
6741 -- this as two tests, rather than a range check, so that static
6742 -- evaluation will easily remove either or both of the checks if
6743 -- they can be -statically determined to be true (this happens
6744 -- when the type of X is static and the range extends to the full
6745 -- range of stored values).
6747 -- Unsigned types. Note: it is safe to consider only whether the
6748 -- subtype is unsigned, since we will in that case be doing all
6749 -- unsigned comparisons based on the subtype range. Since we use the
6750 -- actual subtype object size, this is appropriate.
6752 -- For example, if we have
6754 -- subtype x is integer range 1 .. 200;
6755 -- for x'Object_Size use 8;
6757 -- Now the base type is signed, but objects of this type are bits
6758 -- unsigned, and doing an unsigned test of the range 1 to 200 is
6759 -- correct, even though a value greater than 127 looks signed to a
6760 -- signed comparison.
6762 elsif Is_Unsigned_Type (Ptyp) then
6763 if Esize (Ptyp) <= 32 then
6764 Btyp := RTE (RE_Unsigned_32);
6766 Btyp := RTE (RE_Unsigned_64);
6769 Rewrite (N, Make_Range_Test);
6774 if Esize (Ptyp) <= Esize (Standard_Integer) then
6775 Btyp := Standard_Integer;
6777 Btyp := Universal_Integer;
6780 Rewrite (N, Make_Range_Test);
6783 -- If a predicate is present, then we do the predicate test, even if
6784 -- within the predicate function (infinite recursion is warned about
6785 -- in Sem_Attr in that case).
6788 Pred_Func : constant Entity_Id := Predicate_Function (Ptyp);
6791 if Present (Pred_Func) then
6794 Left_Opnd => Relocate_Node (N),
6795 Right_Opnd => Make_Predicate_Call (Ptyp, Pref)));
6799 Analyze_And_Resolve (N, Standard_Boolean);
6800 Validity_Checks_On := Save_Validity_Checks_On;
6807 when Attribute_Valid_Scalars => Valid_Scalars : declare
6811 if Present (Underlying_Type (Ptyp)) then
6812 Ftyp := Underlying_Type (Ptyp);
6817 -- Replace by True if no scalar parts
6819 if not Scalar_Part_Present (Ftyp) then
6820 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6822 -- For scalar types, Valid_Scalars is the same as Valid
6824 elsif Is_Scalar_Type (Ftyp) then
6826 Make_Attribute_Reference (Loc,
6827 Attribute_Name => Name_Valid,
6830 -- For array types, we construct a function that determines if there
6831 -- are any non-valid scalar subcomponents, and call the function.
6832 -- We only do this for arrays whose component type needs checking
6834 elsif Is_Array_Type (Ftyp)
6835 and then Scalar_Part_Present (Component_Type (Ftyp))
6838 Make_Function_Call (Loc,
6840 New_Occurrence_Of (Build_Array_VS_Func (Ftyp, N), Loc),
6841 Parameter_Associations => New_List (Pref)));
6843 -- For record types, we construct a function that determines if there
6844 -- are any non-valid scalar subcomponents, and call the function.
6846 elsif Is_Record_Type (Ftyp)
6847 and then Nkind (Type_Definition (Declaration_Node (Ftyp))) =
6851 Make_Function_Call (Loc,
6853 New_Occurrence_Of (Build_Record_VS_Func (Ftyp, N), Loc),
6854 Parameter_Associations => New_List (Pref)));
6856 -- Other record types or types with discriminants
6858 elsif Is_Record_Type (Ftyp) or else Has_Discriminants (Ptyp) then
6860 -- Build expression with list of equality tests
6868 X := New_Occurrence_Of (Standard_True, Loc);
6869 C := First_Component_Or_Discriminant (Ptyp);
6870 while Present (C) loop
6871 if not Scalar_Part_Present (Etype (C)) then
6873 elsif Is_Scalar_Type (Etype (C)) then
6876 A := Name_Valid_Scalars;
6883 Make_Attribute_Reference (Loc,
6884 Attribute_Name => A,
6886 Make_Selected_Component (Loc,
6888 Duplicate_Subexpr (Pref, Name_Req => True),
6890 New_Occurrence_Of (C, Loc))));
6892 Next_Component_Or_Discriminant (C);
6898 -- For all other types, result is True
6901 Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc));
6904 -- Result is always boolean, but never static
6906 Analyze_And_Resolve (N, Standard_Boolean);
6907 Set_Is_Static_Expression (N, False);
6914 -- Value attribute is handled in separate unit Exp_Imgv
6916 when Attribute_Value =>
6917 Exp_Imgv.Expand_Value_Attribute (N);
6923 -- The processing for Value_Size shares the processing for Size
6929 -- The processing for Version shares the processing for Body_Version
6935 -- Wide_Image attribute is handled in separate unit Exp_Imgv
6937 when Attribute_Wide_Image =>
6938 Exp_Imgv.Expand_Wide_Image_Attribute (N);
6940 ---------------------
6941 -- Wide_Wide_Image --
6942 ---------------------
6944 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
6946 when Attribute_Wide_Wide_Image =>
6947 Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N);
6953 -- We expand typ'Wide_Value (X) into
6956 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
6958 -- Wide_String_To_String is a runtime function that converts its wide
6959 -- string argument to String, converting any non-translatable characters
6960 -- into appropriate escape sequences. This preserves the required
6961 -- semantics of Wide_Value in all cases, and results in a very simple
6962 -- implementation approach.
6964 -- Note: for this approach to be fully standard compliant for the cases
6965 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
6966 -- method must cover the entire character range (e.g. UTF-8). But that
6967 -- is a reasonable requirement when dealing with encoded character
6968 -- sequences. Presumably if one of the restrictive encoding mechanisms
6969 -- is in use such as Shift-JIS, then characters that cannot be
6970 -- represented using this encoding will not appear in any case.
6972 when Attribute_Wide_Value => Wide_Value :
6975 Make_Attribute_Reference (Loc,
6977 Attribute_Name => Name_Value,
6979 Expressions => New_List (
6980 Make_Function_Call (Loc,
6982 New_Occurrence_Of (RTE (RE_Wide_String_To_String), Loc),
6984 Parameter_Associations => New_List (
6985 Relocate_Node (First (Exprs)),
6986 Make_Integer_Literal (Loc,
6987 Intval => Int (Wide_Character_Encoding_Method)))))));
6989 Analyze_And_Resolve (N, Typ);
6992 ---------------------
6993 -- Wide_Wide_Value --
6994 ---------------------
6996 -- We expand typ'Wide_Value_Value (X) into
6999 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
7001 -- Wide_Wide_String_To_String is a runtime function that converts its
7002 -- wide string argument to String, converting any non-translatable
7003 -- characters into appropriate escape sequences. This preserves the
7004 -- required semantics of Wide_Wide_Value in all cases, and results in a
7005 -- very simple implementation approach.
7007 -- It's not quite right where typ = Wide_Wide_Character, because the
7008 -- encoding method may not cover the whole character type ???
7010 when Attribute_Wide_Wide_Value => Wide_Wide_Value :
7013 Make_Attribute_Reference (Loc,
7015 Attribute_Name => Name_Value,
7017 Expressions => New_List (
7018 Make_Function_Call (Loc,
7021 (RTE (RE_Wide_Wide_String_To_String), Loc),
7023 Parameter_Associations => New_List (
7024 Relocate_Node (First (Exprs)),
7025 Make_Integer_Literal (Loc,
7026 Intval => Int (Wide_Character_Encoding_Method)))))));
7028 Analyze_And_Resolve (N, Typ);
7029 end Wide_Wide_Value;
7031 ---------------------
7032 -- Wide_Wide_Width --
7033 ---------------------
7035 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
7037 when Attribute_Wide_Wide_Width =>
7038 Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide);
7044 -- Wide_Width attribute is handled in separate unit Exp_Imgv
7046 when Attribute_Wide_Width =>
7047 Exp_Imgv.Expand_Width_Attribute (N, Wide);
7053 -- Width attribute is handled in separate unit Exp_Imgv
7055 when Attribute_Width =>
7056 Exp_Imgv.Expand_Width_Attribute (N, Normal);
7062 when Attribute_Write => Write : declare
7063 P_Type : constant Entity_Id := Entity (Pref);
7064 U_Type : constant Entity_Id := Underlying_Type (P_Type);
7072 -- If no underlying type, we have an error that will be diagnosed
7073 -- elsewhere, so here we just completely ignore the expansion.
7079 -- Stream operations can appear in user code even if the restriction
7080 -- No_Streams is active (for example, when instantiating a predefined
7081 -- container). In that case rewrite the attribute as a Raise to
7082 -- prevent any run-time use.
7084 if Restriction_Active (No_Streams) then
7086 Make_Raise_Program_Error (Sloc (N),
7087 Reason => PE_Stream_Operation_Not_Allowed));
7088 Set_Etype (N, U_Type);
7092 -- The simple case, if there is a TSS for Write, just call it
7094 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
7096 if Present (Pname) then
7100 -- If there is a Stream_Convert pragma, use it, we rewrite
7102 -- sourcetyp'Output (stream, Item)
7106 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
7108 -- where strmwrite is the given Write function that converts an
7109 -- argument of type sourcetyp or a type acctyp, from which it is
7110 -- derived to type strmtyp. The conversion to acttyp is required
7111 -- for the derived case.
7113 Prag := Get_Stream_Convert_Pragma (P_Type);
7115 if Present (Prag) then
7117 Next (Next (First (Pragma_Argument_Associations (Prag))));
7118 Wfunc := Entity (Expression (Arg3));
7121 Make_Attribute_Reference (Loc,
7122 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
7123 Attribute_Name => Name_Output,
7124 Expressions => New_List (
7125 Relocate_Node (First (Exprs)),
7126 Make_Function_Call (Loc,
7127 Name => New_Occurrence_Of (Wfunc, Loc),
7128 Parameter_Associations => New_List (
7129 OK_Convert_To (Etype (First_Formal (Wfunc)),
7130 Relocate_Node (Next (First (Exprs)))))))));
7135 -- For elementary types, we call the W_xxx routine directly
7137 elsif Is_Elementary_Type (U_Type) then
7138 Rewrite (N, Build_Elementary_Write_Call (N));
7144 elsif Is_Array_Type (U_Type) then
7145 Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
7146 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
7148 -- Tagged type case, use the primitive Write function. Note that
7149 -- this will dispatch in the class-wide case which is what we want
7151 elsif Is_Tagged_Type (U_Type) then
7152 Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
7154 -- All other record type cases, including protected records.
7155 -- The latter only arise for expander generated code for
7156 -- handling shared passive partition access.
7160 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
7162 -- Ada 2005 (AI-216): Program_Error is raised when executing
7163 -- the default implementation of the Write attribute of an
7164 -- Unchecked_Union type. However, if the 'Write reference is
7165 -- within the generated Output stream procedure, Write outputs
7166 -- the components, and the default values of the discriminant
7167 -- are streamed by the Output procedure itself.
7169 if Is_Unchecked_Union (Base_Type (U_Type))
7170 and not Is_TSS (Current_Scope, TSS_Stream_Output)
7173 Make_Raise_Program_Error (Loc,
7174 Reason => PE_Unchecked_Union_Restriction));
7177 if Has_Discriminants (U_Type)
7179 (Discriminant_Default_Value (First_Discriminant (U_Type)))
7181 Build_Mutable_Record_Write_Procedure
7182 (Loc, Full_Base (U_Type), Decl, Pname);
7184 Build_Record_Write_Procedure
7185 (Loc, Full_Base (U_Type), Decl, Pname);
7188 Insert_Action (N, Decl);
7192 -- If we fall through, Pname is the procedure to be called
7194 Rewrite_Stream_Proc_Call (Pname);
7197 -- Component_Size is handled by the back end, unless the component size
7198 -- is known at compile time, which is always true in the packed array
7199 -- case. It is important that the packed array case is handled in the
7200 -- front end (see Eval_Attribute) since the back end would otherwise get
7201 -- confused by the equivalent packed array type.
7203 when Attribute_Component_Size =>
7206 -- The following attributes are handled by the back end (except that
7207 -- static cases have already been evaluated during semantic processing,
7208 -- but in any case the back end should not count on this).
7210 -- The back end also handles the non-class-wide cases of Size
7212 when Attribute_Bit_Order |
7213 Attribute_Code_Address |
7214 Attribute_Definite |
7216 Attribute_Null_Parameter |
7217 Attribute_Passed_By_Reference |
7218 Attribute_Pool_Address |
7219 Attribute_Scalar_Storage_Order =>
7222 -- The following attributes are also handled by the back end, but return
7223 -- a universal integer result, so may need a conversion for checking
7224 -- that the result is in range.
7226 when Attribute_Aft |
7227 Attribute_Max_Alignment_For_Allocation =>
7228 Apply_Universal_Integer_Attribute_Checks (N);
7230 -- The following attributes should not appear at this stage, since they
7231 -- have already been handled by the analyzer (and properly rewritten
7232 -- with corresponding values or entities to represent the right values)
7234 when Attribute_Abort_Signal |
7235 Attribute_Address_Size |
7236 Attribute_Atomic_Always_Lock_Free |
7239 Attribute_Compiler_Version |
7240 Attribute_Default_Bit_Order |
7241 Attribute_Default_Scalar_Storage_Order |
7248 Attribute_Fast_Math |
7249 Attribute_First_Valid |
7250 Attribute_Has_Access_Values |
7251 Attribute_Has_Discriminants |
7252 Attribute_Has_Tagged_Values |
7254 Attribute_Last_Valid |
7255 Attribute_Library_Level |
7256 Attribute_Lock_Free |
7257 Attribute_Machine_Emax |
7258 Attribute_Machine_Emin |
7259 Attribute_Machine_Mantissa |
7260 Attribute_Machine_Overflows |
7261 Attribute_Machine_Radix |
7262 Attribute_Machine_Rounds |
7263 Attribute_Maximum_Alignment |
7264 Attribute_Model_Emin |
7265 Attribute_Model_Epsilon |
7266 Attribute_Model_Mantissa |
7267 Attribute_Model_Small |
7269 Attribute_Partition_ID |
7271 Attribute_Restriction_Set |
7272 Attribute_Safe_Emax |
7273 Attribute_Safe_First |
7274 Attribute_Safe_Large |
7275 Attribute_Safe_Last |
7276 Attribute_Safe_Small |
7278 Attribute_Signed_Zeros |
7280 Attribute_Storage_Unit |
7281 Attribute_Stub_Type |
7282 Attribute_System_Allocator_Alignment |
7283 Attribute_Target_Name |
7284 Attribute_Type_Class |
7285 Attribute_Type_Key |
7286 Attribute_Unconstrained_Array |
7287 Attribute_Universal_Literal_String |
7288 Attribute_Wchar_T_Size |
7289 Attribute_Word_Size =>
7290 raise Program_Error;
7292 -- The Asm_Input and Asm_Output attributes are not expanded at this
7293 -- stage, but will be eliminated in the expansion of the Asm call, see
7294 -- Exp_Intr for details. So the back end will never see these either.
7296 when Attribute_Asm_Input |
7297 Attribute_Asm_Output =>
7301 -- Note: as mentioned earlier, individual sections of the above case
7302 -- statement assume there is no code after the case statement, and are
7303 -- legitimately allowed to execute return statements if they have nothing
7304 -- more to do, so DO NOT add code at this point.
7307 when RE_Not_Available =>
7309 end Expand_N_Attribute_Reference;
7311 --------------------------------
7312 -- Expand_Pred_Succ_Attribute --
7313 --------------------------------
7315 -- For typ'Pred (exp), we generate the check
7317 -- [constraint_error when exp = typ'Base'First]
7319 -- Similarly, for typ'Succ (exp), we generate the check
7321 -- [constraint_error when exp = typ'Base'Last]
7323 -- These checks are not generated for modular types, since the proper
7324 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
7325 -- We also suppress these checks if we are the right side of an assignment
7326 -- statement or the expression of an object declaration, where the flag
7327 -- Suppress_Assignment_Checks is set for the assignment/declaration.
7329 procedure Expand_Pred_Succ_Attribute (N : Node_Id) is
7330 Loc : constant Source_Ptr := Sloc (N);
7331 P : constant Node_Id := Parent (N);
7335 if Attribute_Name (N) = Name_Pred then
7341 if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration)
7342 or else not Suppress_Assignment_Checks (P)
7345 Make_Raise_Constraint_Error (Loc,
7349 Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
7351 Make_Attribute_Reference (Loc,
7353 New_Occurrence_Of (Base_Type (Etype (Prefix (N))), Loc),
7354 Attribute_Name => Cnam)),
7355 Reason => CE_Overflow_Check_Failed));
7357 end Expand_Pred_Succ_Attribute;
7359 -----------------------------
7360 -- Expand_Update_Attribute --
7361 -----------------------------
7363 procedure Expand_Update_Attribute (N : Node_Id) is
7364 procedure Process_Component_Or_Element_Update
7369 -- Generate the statements necessary to update a single component or an
7370 -- element of the prefix. The code is inserted before the attribute N.
7371 -- Temp denotes the entity of the anonymous object created to reflect
7372 -- the changes in values. Comp is the component/index expression to be
7373 -- updated. Expr is an expression yielding the new value of Comp. Typ
7374 -- is the type of the prefix of attribute Update.
7376 procedure Process_Range_Update
7381 -- Generate the statements necessary to update a slice of the prefix.
7382 -- The code is inserted before the attribute N. Temp denotes the entity
7383 -- of the anonymous object created to reflect the changes in values.
7384 -- Comp is range of the slice to be updated. Expr is an expression
7385 -- yielding the new value of Comp. Typ is the type of the prefix of
7386 -- attribute Update.
7388 -----------------------------------------
7389 -- Process_Component_Or_Element_Update --
7390 -----------------------------------------
7392 procedure Process_Component_Or_Element_Update
7398 Loc : constant Source_Ptr := Sloc (Comp);
7403 -- An array element may be modified by the following relations
7404 -- depending on the number of dimensions:
7406 -- 1 => Expr -- one dimensional update
7407 -- (1, ..., N) => Expr -- multi dimensional update
7409 -- The above forms are converted in assignment statements where the
7410 -- left hand side is an indexed component:
7412 -- Temp (1) := Expr; -- one dimensional update
7413 -- Temp (1, ..., N) := Expr; -- multi dimensional update
7415 if Is_Array_Type (Typ) then
7417 -- The index expressions of a multi dimensional array update
7418 -- appear as an aggregate.
7420 if Nkind (Comp) = N_Aggregate then
7421 Exprs := New_Copy_List_Tree (Expressions (Comp));
7423 Exprs := New_List (Relocate_Node (Comp));
7427 Make_Indexed_Component (Loc,
7428 Prefix => New_Occurrence_Of (Temp, Loc),
7429 Expressions => Exprs);
7431 -- A record component update appears in the following form:
7435 -- The above relation is transformed into an assignment statement
7436 -- where the left hand side is a selected component:
7438 -- Temp.Comp := Expr;
7440 else pragma Assert (Is_Record_Type (Typ));
7442 Make_Selected_Component (Loc,
7443 Prefix => New_Occurrence_Of (Temp, Loc),
7444 Selector_Name => Relocate_Node (Comp));
7448 Make_Assignment_Statement (Loc,
7450 Expression => Relocate_Node (Expr)));
7451 end Process_Component_Or_Element_Update;
7453 --------------------------
7454 -- Process_Range_Update --
7455 --------------------------
7457 procedure Process_Range_Update
7463 Index_Typ : constant Entity_Id := Etype (First_Index (Typ));
7464 Loc : constant Source_Ptr := Sloc (Comp);
7468 -- A range update appears as
7470 -- (Low .. High => Expr)
7472 -- The above construct is transformed into a loop that iterates over
7473 -- the given range and modifies the corresponding array values to the
7476 -- for Index in Low .. High loop
7477 -- Temp (<Index_Typ> (Index)) := Expr;
7480 Index := Make_Temporary (Loc, 'I');
7483 Make_Loop_Statement (Loc,
7485 Make_Iteration_Scheme (Loc,
7486 Loop_Parameter_Specification =>
7487 Make_Loop_Parameter_Specification (Loc,
7488 Defining_Identifier => Index,
7489 Discrete_Subtype_Definition => Relocate_Node (Comp))),
7491 Statements => New_List (
7492 Make_Assignment_Statement (Loc,
7494 Make_Indexed_Component (Loc,
7495 Prefix => New_Occurrence_Of (Temp, Loc),
7496 Expressions => New_List (
7497 Convert_To (Index_Typ,
7498 New_Occurrence_Of (Index, Loc)))),
7499 Expression => Relocate_Node (Expr))),
7501 End_Label => Empty));
7502 end Process_Range_Update;
7506 Aggr : constant Node_Id := First (Expressions (N));
7507 Loc : constant Source_Ptr := Sloc (N);
7508 Pref : constant Node_Id := Prefix (N);
7509 Typ : constant Entity_Id := Etype (Pref);
7512 CW_Temp : Entity_Id;
7517 -- Start of processing for Expand_Update_Attribute
7520 -- Create the anonymous object to store the value of the prefix and
7521 -- capture subsequent changes in value.
7523 Temp := Make_Temporary (Loc, 'T', Pref);
7525 -- Preserve the tag of the prefix by offering a specific view of the
7526 -- class-wide version of the prefix.
7528 if Is_Tagged_Type (Typ) then
7531 -- CW_Temp : Typ'Class := Typ'Class (Pref);
7533 CW_Temp := Make_Temporary (Loc, 'T');
7534 CW_Typ := Class_Wide_Type (Typ);
7537 Make_Object_Declaration (Loc,
7538 Defining_Identifier => CW_Temp,
7539 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
7541 Convert_To (CW_Typ, Relocate_Node (Pref))));
7544 -- Temp : Typ renames Typ (CW_Temp);
7547 Make_Object_Renaming_Declaration (Loc,
7548 Defining_Identifier => Temp,
7549 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
7551 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))));
7557 -- Temp : Typ := Pref;
7560 Make_Object_Declaration (Loc,
7561 Defining_Identifier => Temp,
7562 Object_Definition => New_Occurrence_Of (Typ, Loc),
7563 Expression => Relocate_Node (Pref)));
7566 -- Process the update aggregate
7568 Assoc := First (Component_Associations (Aggr));
7569 while Present (Assoc) loop
7570 Comp := First (Choices (Assoc));
7571 Expr := Expression (Assoc);
7572 while Present (Comp) loop
7573 if Nkind (Comp) = N_Range then
7574 Process_Range_Update (Temp, Comp, Expr, Typ);
7576 Process_Component_Or_Element_Update (Temp, Comp, Expr, Typ);
7585 -- The attribute is replaced by a reference to the anonymous object
7587 Rewrite (N, New_Occurrence_Of (Temp, Loc));
7589 end Expand_Update_Attribute;
7595 procedure Find_Fat_Info
7597 Fat_Type : out Entity_Id;
7598 Fat_Pkg : out RE_Id)
7600 Rtyp : constant Entity_Id := Root_Type (T);
7603 -- All we do is use the root type (historically this dealt with
7604 -- VAX-float .. to be cleaned up further later ???)
7608 if Fat_Type = Standard_Short_Float then
7609 Fat_Pkg := RE_Attr_Short_Float;
7611 elsif Fat_Type = Standard_Float then
7612 Fat_Pkg := RE_Attr_Float;
7614 elsif Fat_Type = Standard_Long_Float then
7615 Fat_Pkg := RE_Attr_Long_Float;
7617 elsif Fat_Type = Standard_Long_Long_Float then
7618 Fat_Pkg := RE_Attr_Long_Long_Float;
7620 -- Universal real (which is its own root type) is treated as being
7621 -- equivalent to Standard.Long_Long_Float, since it is defined to
7622 -- have the same precision as the longest Float type.
7624 elsif Fat_Type = Universal_Real then
7625 Fat_Type := Standard_Long_Long_Float;
7626 Fat_Pkg := RE_Attr_Long_Long_Float;
7629 raise Program_Error;
7633 ----------------------------
7634 -- Find_Stream_Subprogram --
7635 ----------------------------
7637 function Find_Stream_Subprogram
7639 Nam : TSS_Name_Type) return Entity_Id
7641 Base_Typ : constant Entity_Id := Base_Type (Typ);
7642 Ent : constant Entity_Id := TSS (Typ, Nam);
7644 function Is_Available (Entity : RE_Id) return Boolean;
7645 pragma Inline (Is_Available);
7646 -- Function to check whether the specified run-time call is available
7647 -- in the run time used. In the case of a configurable run time, it
7648 -- is normal that some subprograms are not there.
7650 -- I don't understand this routine at all, why is this not just a
7651 -- call to RTE_Available? And if for some reason we need a different
7652 -- routine with different semantics, why is not in Rtsfind ???
7658 function Is_Available (Entity : RE_Id) return Boolean is
7660 -- Assume that the unit will always be available when using a
7661 -- "normal" (not configurable) run time.
7663 return not Configurable_Run_Time_Mode or else RTE_Available (Entity);
7666 -- Start of processing for Find_Stream_Subprogram
7669 if Present (Ent) then
7673 -- Stream attributes for strings are expanded into library calls. The
7674 -- following checks are disabled when the run-time is not available or
7675 -- when compiling predefined types due to bootstrap issues. As a result,
7676 -- the compiler will generate in-place stream routines for string types
7677 -- that appear in GNAT's library, but will generate calls via rtsfind
7678 -- to library routines for user code.
7680 -- Note: In the case of using a configurable run time, it is very likely
7681 -- that stream routines for string types are not present (they require
7682 -- file system support). In this case, the specific stream routines for
7683 -- strings are not used, relying on the regular stream mechanism
7684 -- instead. That is why we include the test Is_Available when dealing
7685 -- with these cases.
7687 if not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) then
7688 -- Storage_Array as defined in package System.Storage_Elements
7690 if Is_RTE (Base_Typ, RE_Storage_Array) then
7692 -- Case of No_Stream_Optimizations restriction active
7694 if Restriction_Active (No_Stream_Optimizations) then
7695 if Nam = TSS_Stream_Input
7696 and then Is_Available (RE_Storage_Array_Input)
7698 return RTE (RE_Storage_Array_Input);
7700 elsif Nam = TSS_Stream_Output
7701 and then Is_Available (RE_Storage_Array_Output)
7703 return RTE (RE_Storage_Array_Output);
7705 elsif Nam = TSS_Stream_Read
7706 and then Is_Available (RE_Storage_Array_Read)
7708 return RTE (RE_Storage_Array_Read);
7710 elsif Nam = TSS_Stream_Write
7711 and then Is_Available (RE_Storage_Array_Write)
7713 return RTE (RE_Storage_Array_Write);
7715 elsif Nam /= TSS_Stream_Input and then
7716 Nam /= TSS_Stream_Output and then
7717 Nam /= TSS_Stream_Read and then
7718 Nam /= TSS_Stream_Write
7720 raise Program_Error;
7723 -- Restriction No_Stream_Optimizations is not set, so we can go
7724 -- ahead and optimize using the block IO forms of the routines.
7727 if Nam = TSS_Stream_Input
7728 and then Is_Available (RE_Storage_Array_Input_Blk_IO)
7730 return RTE (RE_Storage_Array_Input_Blk_IO);
7732 elsif Nam = TSS_Stream_Output
7733 and then Is_Available (RE_Storage_Array_Output_Blk_IO)
7735 return RTE (RE_Storage_Array_Output_Blk_IO);
7737 elsif Nam = TSS_Stream_Read
7738 and then Is_Available (RE_Storage_Array_Read_Blk_IO)
7740 return RTE (RE_Storage_Array_Read_Blk_IO);
7742 elsif Nam = TSS_Stream_Write
7743 and then Is_Available (RE_Storage_Array_Write_Blk_IO)
7745 return RTE (RE_Storage_Array_Write_Blk_IO);
7747 elsif Nam /= TSS_Stream_Input and then
7748 Nam /= TSS_Stream_Output and then
7749 Nam /= TSS_Stream_Read and then
7750 Nam /= TSS_Stream_Write
7752 raise Program_Error;
7756 -- Stream_Element_Array as defined in package Ada.Streams
7758 elsif Is_RTE (Base_Typ, RE_Stream_Element_Array) then
7760 -- Case of No_Stream_Optimizations restriction active
7762 if Restriction_Active (No_Stream_Optimizations) then
7763 if Nam = TSS_Stream_Input
7764 and then Is_Available (RE_Stream_Element_Array_Input)
7766 return RTE (RE_Stream_Element_Array_Input);
7768 elsif Nam = TSS_Stream_Output
7769 and then Is_Available (RE_Stream_Element_Array_Output)
7771 return RTE (RE_Stream_Element_Array_Output);
7773 elsif Nam = TSS_Stream_Read
7774 and then Is_Available (RE_Stream_Element_Array_Read)
7776 return RTE (RE_Stream_Element_Array_Read);
7778 elsif Nam = TSS_Stream_Write
7779 and then Is_Available (RE_Stream_Element_Array_Write)
7781 return RTE (RE_Stream_Element_Array_Write);
7783 elsif Nam /= TSS_Stream_Input and then
7784 Nam /= TSS_Stream_Output and then
7785 Nam /= TSS_Stream_Read and then
7786 Nam /= TSS_Stream_Write
7788 raise Program_Error;
7791 -- Restriction No_Stream_Optimizations is not set, so we can go
7792 -- ahead and optimize using the block IO forms of the routines.
7795 if Nam = TSS_Stream_Input
7796 and then Is_Available (RE_Stream_Element_Array_Input_Blk_IO)
7798 return RTE (RE_Stream_Element_Array_Input_Blk_IO);
7800 elsif Nam = TSS_Stream_Output
7801 and then Is_Available (RE_Stream_Element_Array_Output_Blk_IO)
7803 return RTE (RE_Stream_Element_Array_Output_Blk_IO);
7805 elsif Nam = TSS_Stream_Read
7806 and then Is_Available (RE_Stream_Element_Array_Read_Blk_IO)
7808 return RTE (RE_Stream_Element_Array_Read_Blk_IO);
7810 elsif Nam = TSS_Stream_Write
7811 and then Is_Available (RE_Stream_Element_Array_Write_Blk_IO)
7813 return RTE (RE_Stream_Element_Array_Write_Blk_IO);
7815 elsif Nam /= TSS_Stream_Input and then
7816 Nam /= TSS_Stream_Output and then
7817 Nam /= TSS_Stream_Read and then
7818 Nam /= TSS_Stream_Write
7820 raise Program_Error;
7824 -- String as defined in package Ada
7826 elsif Base_Typ = Standard_String then
7828 -- Case of No_Stream_Optimizations restriction active
7830 if Restriction_Active (No_Stream_Optimizations) then
7831 if Nam = TSS_Stream_Input
7832 and then Is_Available (RE_String_Input)
7834 return RTE (RE_String_Input);
7836 elsif Nam = TSS_Stream_Output
7837 and then Is_Available (RE_String_Output)
7839 return RTE (RE_String_Output);
7841 elsif Nam = TSS_Stream_Read
7842 and then Is_Available (RE_String_Read)
7844 return RTE (RE_String_Read);
7846 elsif Nam = TSS_Stream_Write
7847 and then Is_Available (RE_String_Write)
7849 return RTE (RE_String_Write);
7851 elsif Nam /= TSS_Stream_Input and then
7852 Nam /= TSS_Stream_Output and then
7853 Nam /= TSS_Stream_Read and then
7854 Nam /= TSS_Stream_Write
7856 raise Program_Error;
7859 -- Restriction No_Stream_Optimizations is not set, so we can go
7860 -- ahead and optimize using the block IO forms of the routines.
7863 if Nam = TSS_Stream_Input
7864 and then Is_Available (RE_String_Input_Blk_IO)
7866 return RTE (RE_String_Input_Blk_IO);
7868 elsif Nam = TSS_Stream_Output
7869 and then Is_Available (RE_String_Output_Blk_IO)
7871 return RTE (RE_String_Output_Blk_IO);
7873 elsif Nam = TSS_Stream_Read
7874 and then Is_Available (RE_String_Read_Blk_IO)
7876 return RTE (RE_String_Read_Blk_IO);
7878 elsif Nam = TSS_Stream_Write
7879 and then Is_Available (RE_String_Write_Blk_IO)
7881 return RTE (RE_String_Write_Blk_IO);
7883 elsif Nam /= TSS_Stream_Input and then
7884 Nam /= TSS_Stream_Output and then
7885 Nam /= TSS_Stream_Read and then
7886 Nam /= TSS_Stream_Write
7888 raise Program_Error;
7892 -- Wide_String as defined in package Ada
7894 elsif Base_Typ = Standard_Wide_String then
7896 -- Case of No_Stream_Optimizations restriction active
7898 if Restriction_Active (No_Stream_Optimizations) then
7899 if Nam = TSS_Stream_Input
7900 and then Is_Available (RE_Wide_String_Input)
7902 return RTE (RE_Wide_String_Input);
7904 elsif Nam = TSS_Stream_Output
7905 and then Is_Available (RE_Wide_String_Output)
7907 return RTE (RE_Wide_String_Output);
7909 elsif Nam = TSS_Stream_Read
7910 and then Is_Available (RE_Wide_String_Read)
7912 return RTE (RE_Wide_String_Read);
7914 elsif Nam = TSS_Stream_Write
7915 and then Is_Available (RE_Wide_String_Write)
7917 return RTE (RE_Wide_String_Write);
7919 elsif Nam /= TSS_Stream_Input and then
7920 Nam /= TSS_Stream_Output and then
7921 Nam /= TSS_Stream_Read and then
7922 Nam /= TSS_Stream_Write
7924 raise Program_Error;
7927 -- Restriction No_Stream_Optimizations is not set, so we can go
7928 -- ahead and optimize using the block IO forms of the routines.
7931 if Nam = TSS_Stream_Input
7932 and then Is_Available (RE_Wide_String_Input_Blk_IO)
7934 return RTE (RE_Wide_String_Input_Blk_IO);
7936 elsif Nam = TSS_Stream_Output
7937 and then Is_Available (RE_Wide_String_Output_Blk_IO)
7939 return RTE (RE_Wide_String_Output_Blk_IO);
7941 elsif Nam = TSS_Stream_Read
7942 and then Is_Available (RE_Wide_String_Read_Blk_IO)
7944 return RTE (RE_Wide_String_Read_Blk_IO);
7946 elsif Nam = TSS_Stream_Write
7947 and then Is_Available (RE_Wide_String_Write_Blk_IO)
7949 return RTE (RE_Wide_String_Write_Blk_IO);
7951 elsif Nam /= TSS_Stream_Input and then
7952 Nam /= TSS_Stream_Output and then
7953 Nam /= TSS_Stream_Read and then
7954 Nam /= TSS_Stream_Write
7956 raise Program_Error;
7960 -- Wide_Wide_String as defined in package Ada
7962 elsif Base_Typ = Standard_Wide_Wide_String then
7964 -- Case of No_Stream_Optimizations restriction active
7966 if Restriction_Active (No_Stream_Optimizations) then
7967 if Nam = TSS_Stream_Input
7968 and then Is_Available (RE_Wide_Wide_String_Input)
7970 return RTE (RE_Wide_Wide_String_Input);
7972 elsif Nam = TSS_Stream_Output
7973 and then Is_Available (RE_Wide_Wide_String_Output)
7975 return RTE (RE_Wide_Wide_String_Output);
7977 elsif Nam = TSS_Stream_Read
7978 and then Is_Available (RE_Wide_Wide_String_Read)
7980 return RTE (RE_Wide_Wide_String_Read);
7982 elsif Nam = TSS_Stream_Write
7983 and then Is_Available (RE_Wide_Wide_String_Write)
7985 return RTE (RE_Wide_Wide_String_Write);
7987 elsif Nam /= TSS_Stream_Input and then
7988 Nam /= TSS_Stream_Output and then
7989 Nam /= TSS_Stream_Read and then
7990 Nam /= TSS_Stream_Write
7992 raise Program_Error;
7995 -- Restriction No_Stream_Optimizations is not set, so we can go
7996 -- ahead and optimize using the block IO forms of the routines.
7999 if Nam = TSS_Stream_Input
8000 and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO)
8002 return RTE (RE_Wide_Wide_String_Input_Blk_IO);
8004 elsif Nam = TSS_Stream_Output
8005 and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO)
8007 return RTE (RE_Wide_Wide_String_Output_Blk_IO);
8009 elsif Nam = TSS_Stream_Read
8010 and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO)
8012 return RTE (RE_Wide_Wide_String_Read_Blk_IO);
8014 elsif Nam = TSS_Stream_Write
8015 and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO)
8017 return RTE (RE_Wide_Wide_String_Write_Blk_IO);
8019 elsif Nam /= TSS_Stream_Input and then
8020 Nam /= TSS_Stream_Output and then
8021 Nam /= TSS_Stream_Read and then
8022 Nam /= TSS_Stream_Write
8024 raise Program_Error;
8030 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
8031 return Find_Prim_Op (Typ, Nam);
8033 return Find_Inherited_TSS (Typ, Nam);
8035 end Find_Stream_Subprogram;
8041 function Full_Base (T : Entity_Id) return Entity_Id is
8045 BT := Base_Type (T);
8047 if Is_Private_Type (BT)
8048 and then Present (Full_View (BT))
8050 BT := Full_View (BT);
8056 -----------------------
8057 -- Get_Index_Subtype --
8058 -----------------------
8060 function Get_Index_Subtype (N : Node_Id) return Node_Id is
8061 P_Type : Entity_Id := Etype (Prefix (N));
8066 if Is_Access_Type (P_Type) then
8067 P_Type := Designated_Type (P_Type);
8070 if No (Expressions (N)) then
8073 J := UI_To_Int (Expr_Value (First (Expressions (N))));
8076 Indx := First_Index (P_Type);
8082 return Etype (Indx);
8083 end Get_Index_Subtype;
8085 -------------------------------
8086 -- Get_Stream_Convert_Pragma --
8087 -------------------------------
8089 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is
8094 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
8095 -- that a stream convert pragma for a tagged type is not inherited from
8096 -- its parent. Probably what is wrong here is that it is basically
8097 -- incorrect to consider a stream convert pragma to be a representation
8098 -- pragma at all ???
8100 N := First_Rep_Item (Implementation_Base_Type (T));
8101 while Present (N) loop
8102 if Nkind (N) = N_Pragma
8103 and then Pragma_Name_Mapped (N) = Name_Stream_Convert
8105 -- For tagged types this pragma is not inherited, so we
8106 -- must verify that it is defined for the given type and
8110 Entity (Expression (First (Pragma_Argument_Associations (N))));
8112 if not Is_Tagged_Type (T)
8114 or else (Is_Private_Type (Typ) and then T = Full_View (Typ))
8124 end Get_Stream_Convert_Pragma;
8126 ---------------------------------
8127 -- Is_Constrained_Packed_Array --
8128 ---------------------------------
8130 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is
8131 Arr : Entity_Id := Typ;
8134 if Is_Access_Type (Arr) then
8135 Arr := Designated_Type (Arr);
8138 return Is_Array_Type (Arr)
8139 and then Is_Constrained (Arr)
8140 and then Present (Packed_Array_Impl_Type (Arr));
8141 end Is_Constrained_Packed_Array;
8143 ----------------------------------------
8144 -- Is_Inline_Floating_Point_Attribute --
8145 ----------------------------------------
8147 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is
8148 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
8150 function Is_GCC_Target return Boolean;
8151 -- Return True if we are using a GCC target/back-end
8152 -- ??? Note: the implementation is kludgy/fragile
8158 function Is_GCC_Target return Boolean is
8160 return not CodePeer_Mode
8161 and then not AAMP_On_Target
8162 and then not Generate_C_Code;
8165 -- Start of processing for Is_Inline_Floating_Point_Attribute
8168 -- Machine and Model can be expanded by the GCC and AAMP back ends only
8170 if Id = Attribute_Machine or else Id = Attribute_Model then
8171 return Is_GCC_Target or else AAMP_On_Target;
8173 -- Remaining cases handled by all back ends are Rounding and Truncation
8174 -- when appearing as the operand of a conversion to some integer type.
8176 elsif Nkind (Parent (N)) /= N_Type_Conversion
8177 or else not Is_Integer_Type (Etype (Parent (N)))
8182 -- Here we are in the integer conversion context
8184 -- Very probably we should also recognize the cases of Machine_Rounding
8185 -- and unbiased rounding in this conversion context, but the back end is
8186 -- not yet prepared to handle these cases ???
8188 return Id = Attribute_Rounding or else Id = Attribute_Truncation;
8189 end Is_Inline_Floating_Point_Attribute;
projects / platform / upstream / gcc.git / blob