1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, 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))));
586 -- Local Declarations
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;
595 Make_Parameter_Specification (Loc,
596 Defining_Identifier => X,
597 Parameter_Type => New_Occurrence_Of (R_Type, Loc)));
600 Make_VS_If (R_Type, Discriminant_Specifications (Def)));
601 Append_List_To (Stmts, Make_VS_Case (R_Type, Comps));
604 Make_Simple_Return_Statement (Loc,
605 Expression => New_Occurrence_Of (Standard_True, Loc)));
608 Make_Subprogram_Body (Loc,
610 Make_Function_Specification (Loc,
611 Defining_Unit_Name => Func_Id,
612 Parameter_Specifications => Pspecs,
613 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
614 Declarations => New_List,
615 Handled_Statement_Sequence =>
616 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)),
617 Suppress => Discriminant_Check);
619 if not Debug_Generated_Code then
620 Set_Debug_Info_Off (Func_Id);
623 Set_Is_Pure (Func_Id);
625 end Build_Record_VS_Func;
627 ----------------------------------
628 -- Compile_Stream_Body_In_Scope --
629 ----------------------------------
631 procedure Compile_Stream_Body_In_Scope
637 C_Type : constant Entity_Id := Base_Type (Component_Type (Arr));
638 Curr : constant Entity_Id := Current_Scope;
639 Install : Boolean := False;
640 Scop : Entity_Id := Scope (Arr);
644 and then not In_Open_Scopes (Scop)
645 and then Ekind (Scop) = E_Package
650 -- The component type may be private, in which case we install its
651 -- full view to compile the subprogram.
653 Scop := Scope (C_Type);
655 if Is_Private_Type (C_Type)
656 and then Present (Full_View (C_Type))
657 and then not In_Open_Scopes (Scop)
658 and then Ekind (Scop) = E_Package
664 -- If we are within an instance body, then all visibility has been
665 -- established already and there is no need to install the package.
667 if Install and then not In_Instance_Body then
669 Install_Visible_Declarations (Scop);
670 Install_Private_Declarations (Scop);
672 -- The entities in the package are now visible, but the generated
673 -- stream entity must appear in the current scope (usually an
674 -- enclosing stream function) so that itypes all have their proper
683 Insert_Action (N, Decl);
685 Insert_Action (N, Decl, Suppress => All_Checks);
690 -- Remove extra copy of current scope, and package itself
693 End_Package_Scope (Scop);
695 end Compile_Stream_Body_In_Scope;
697 -----------------------------------
698 -- Expand_Access_To_Protected_Op --
699 -----------------------------------
701 procedure Expand_Access_To_Protected_Op
706 -- The value of the attribute_reference is a record containing two
707 -- fields: an access to the protected object, and an access to the
708 -- subprogram itself. The prefix is a selected component.
710 Loc : constant Source_Ptr := Sloc (N);
712 Btyp : constant Entity_Id := Base_Type (Typ);
715 E_T : constant Entity_Id := Equivalent_Type (Btyp);
716 Acc : constant Entity_Id :=
717 Etype (Next_Component (First_Component (E_T)));
721 -- Start of processing for Expand_Access_To_Protected_Op
724 -- Within the body of the protected type, the prefix designates a local
725 -- operation, and the object is the first parameter of the corresponding
726 -- protected body of the current enclosing operation.
728 if Is_Entity_Name (Pref) then
729 -- All indirect calls are external calls, so must do locking and
730 -- barrier reevaluation, even if the 'Access occurs within the
731 -- protected body. Hence the call to External_Subprogram, as opposed
732 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means
733 -- that indirect calls from within the same protected body will
734 -- deadlock, as allowed by RM-9.5.1(8,15,17).
736 Sub := New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc);
738 -- Don't traverse the scopes when the attribute occurs within an init
739 -- proc, because we directly use the _init formal of the init proc in
742 Curr := Current_Scope;
743 if not Is_Init_Proc (Curr) then
744 pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
746 while Scope (Curr) /= Scope (Entity (Pref)) loop
747 Curr := Scope (Curr);
751 -- In case of protected entries the first formal of its Protected_
752 -- Body_Subprogram is the address of the object.
754 if Ekind (Curr) = E_Entry then
758 (Protected_Body_Subprogram (Curr)), Loc);
760 -- If the current scope is an init proc, then use the address of the
761 -- _init formal as the object reference.
763 elsif Is_Init_Proc (Curr) then
765 Make_Attribute_Reference (Loc,
766 Prefix => New_Occurrence_Of (First_Formal (Curr), Loc),
767 Attribute_Name => Name_Address);
769 -- In case of protected subprograms the first formal of its
770 -- Protected_Body_Subprogram is the object and we get its address.
774 Make_Attribute_Reference (Loc,
778 (Protected_Body_Subprogram (Curr)), Loc),
779 Attribute_Name => Name_Address);
782 -- Case where the prefix is not an entity name. Find the
783 -- version of the protected operation to be called from
784 -- outside the protected object.
790 (Entity (Selector_Name (Pref))), Loc);
793 Make_Attribute_Reference (Loc,
794 Prefix => Relocate_Node (Prefix (Pref)),
795 Attribute_Name => Name_Address);
799 Make_Attribute_Reference (Loc,
801 Attribute_Name => Name_Access);
803 -- We set the type of the access reference to the already generated
804 -- access_to_subprogram type, and declare the reference analyzed, to
805 -- prevent further expansion when the enclosing aggregate is analyzed.
807 Set_Etype (Sub_Ref, Acc);
808 Set_Analyzed (Sub_Ref);
812 Expressions => New_List (Obj_Ref, Sub_Ref));
814 -- Sub_Ref has been marked as analyzed, but we still need to make sure
815 -- Sub is correctly frozen.
817 Freeze_Before (N, Entity (Sub));
820 Analyze_And_Resolve (N, E_T);
822 -- For subsequent analysis, the node must retain its type. The backend
823 -- will replace it with the equivalent type where needed.
826 end Expand_Access_To_Protected_Op;
828 --------------------------
829 -- Expand_Fpt_Attribute --
830 --------------------------
832 procedure Expand_Fpt_Attribute
838 Loc : constant Source_Ptr := Sloc (N);
839 Typ : constant Entity_Id := Etype (N);
843 -- The function name is the selected component Attr_xxx.yyy where
844 -- Attr_xxx is the package name, and yyy is the argument Nam.
846 -- Note: it would be more usual to have separate RE entries for each
847 -- of the entities in the Fat packages, but first they have identical
848 -- names (so we would have to have lots of renaming declarations to
849 -- meet the normal RE rule of separate names for all runtime entities),
850 -- and second there would be an awful lot of them.
853 Make_Selected_Component (Loc,
854 Prefix => New_Occurrence_Of (RTE (Pkg), Loc),
855 Selector_Name => Make_Identifier (Loc, Nam));
857 -- The generated call is given the provided set of parameters, and then
858 -- wrapped in a conversion which converts the result to the target type
859 -- We use the base type as the target because a range check may be
863 Unchecked_Convert_To (Base_Type (Etype (N)),
864 Make_Function_Call (Loc,
866 Parameter_Associations => Args)));
868 Analyze_And_Resolve (N, Typ);
869 end Expand_Fpt_Attribute;
871 ----------------------------
872 -- Expand_Fpt_Attribute_R --
873 ----------------------------
875 -- The single argument is converted to its root type to call the
876 -- appropriate runtime function, with the actual call being built
877 -- by Expand_Fpt_Attribute
879 procedure Expand_Fpt_Attribute_R (N : Node_Id) is
880 E1 : constant Node_Id := First (Expressions (N));
884 Find_Fat_Info (Etype (E1), Ftp, Pkg);
886 (N, Pkg, Attribute_Name (N),
887 New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1))));
888 end Expand_Fpt_Attribute_R;
890 -----------------------------
891 -- Expand_Fpt_Attribute_RI --
892 -----------------------------
894 -- The first argument is converted to its root type and the second
895 -- argument is converted to standard long long integer to call the
896 -- appropriate runtime function, with the actual call being built
897 -- by Expand_Fpt_Attribute
899 procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
900 E1 : constant Node_Id := First (Expressions (N));
903 E2 : constant Node_Id := Next (E1);
905 Find_Fat_Info (Etype (E1), Ftp, Pkg);
907 (N, Pkg, Attribute_Name (N),
909 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
910 Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
911 end Expand_Fpt_Attribute_RI;
913 -----------------------------
914 -- Expand_Fpt_Attribute_RR --
915 -----------------------------
917 -- The two arguments are converted to their root types to call the
918 -- appropriate runtime function, with the actual call being built
919 -- by Expand_Fpt_Attribute
921 procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
922 E1 : constant Node_Id := First (Expressions (N));
923 E2 : constant Node_Id := Next (E1);
928 Find_Fat_Info (Etype (E1), Ftp, Pkg);
930 (N, Pkg, Attribute_Name (N),
932 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
933 Unchecked_Convert_To (Ftp, Relocate_Node (E2))));
934 end Expand_Fpt_Attribute_RR;
936 ---------------------------------
937 -- Expand_Loop_Entry_Attribute --
938 ---------------------------------
940 procedure Expand_Loop_Entry_Attribute (N : Node_Id) is
941 procedure Build_Conditional_Block
945 If_Stmt : out Node_Id;
946 Blk_Stmt : out Node_Id);
947 -- Create a block Blk_Stmt with an empty declarative list and a single
948 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
949 -- condition Cond. If_Stmt is Empty when there is no condition provided.
951 function Is_Array_Iteration (N : Node_Id) return Boolean;
952 -- Determine whether loop statement N denotes an Ada 2012 iteration over
955 -----------------------------
956 -- Build_Conditional_Block --
957 -----------------------------
959 procedure Build_Conditional_Block
963 If_Stmt : out Node_Id;
964 Blk_Stmt : out Node_Id)
967 -- Do not reanalyze the original loop statement because it is simply
970 Set_Analyzed (Loop_Stmt);
973 Make_Block_Statement (Loc,
974 Declarations => New_List,
975 Handled_Statement_Sequence =>
976 Make_Handled_Sequence_Of_Statements (Loc,
977 Statements => New_List (Loop_Stmt)));
979 if Present (Cond) then
981 Make_If_Statement (Loc,
983 Then_Statements => New_List (Blk_Stmt));
987 end Build_Conditional_Block;
989 ------------------------
990 -- Is_Array_Iteration --
991 ------------------------
993 function Is_Array_Iteration (N : Node_Id) return Boolean is
994 Stmt : constant Node_Id := Original_Node (N);
998 if Nkind (Stmt) = N_Loop_Statement
999 and then Present (Iteration_Scheme (Stmt))
1000 and then Present (Iterator_Specification (Iteration_Scheme (Stmt)))
1002 Iter := Iterator_Specification (Iteration_Scheme (Stmt));
1005 Of_Present (Iter) and then Is_Array_Type (Etype (Name (Iter)));
1009 end Is_Array_Iteration;
1013 Exprs : constant List_Id := Expressions (N);
1014 Pref : constant Node_Id := Prefix (N);
1015 Typ : constant Entity_Id := Etype (Pref);
1018 CW_Temp : Entity_Id;
1021 Installed : Boolean;
1023 Loop_Id : Entity_Id;
1024 Loop_Stmt : Node_Id;
1027 Temp_Decl : Node_Id;
1028 Temp_Id : Entity_Id;
1030 -- Start of processing for Expand_Loop_Entry_Attribute
1033 -- Step 1: Find the related loop
1035 -- The loop label variant of attribute 'Loop_Entry already has all the
1036 -- information in its expression.
1038 if Present (Exprs) then
1039 Loop_Id := Entity (First (Exprs));
1040 Loop_Stmt := Label_Construct (Parent (Loop_Id));
1042 -- Climb the parent chain to find the nearest enclosing loop. Skip all
1043 -- internally generated loops for quantified expressions and for
1044 -- element iterators over multidimensional arrays: pragma applies to
1049 while Present (Loop_Stmt) loop
1050 if Nkind (Loop_Stmt) = N_Loop_Statement
1051 and then Comes_From_Source (Loop_Stmt)
1056 Loop_Stmt := Parent (Loop_Stmt);
1059 Loop_Id := Entity (Identifier (Loop_Stmt));
1062 Loc := Sloc (Loop_Stmt);
1064 -- Step 2: Transform the loop
1066 -- The loop has already been transformed during the expansion of a prior
1067 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
1069 if Has_Loop_Entry_Attributes (Loop_Id) then
1071 -- When the related loop name appears as the argument of attribute
1072 -- Loop_Entry, the corresponding label construct is the generated
1073 -- block statement. This is because the expander reuses the label.
1075 if Nkind (Loop_Stmt) = N_Block_Statement then
1076 Decls := Declarations (Loop_Stmt);
1078 -- In all other cases, the loop must appear in the handled sequence
1079 -- of statements of the generated block.
1083 (Nkind (Parent (Loop_Stmt)) = N_Handled_Sequence_Of_Statements
1085 Nkind (Parent (Parent (Loop_Stmt))) = N_Block_Statement);
1087 Decls := Declarations (Parent (Parent (Loop_Stmt)));
1092 -- Transform the loop into a conditional block
1095 Set_Has_Loop_Entry_Attributes (Loop_Id);
1096 Scheme := Iteration_Scheme (Loop_Stmt);
1098 -- Infinite loops are transformed into:
1101 -- Temp1 : constant <type of Pref1> := <Pref1>;
1103 -- TempN : constant <type of PrefN> := <PrefN>;
1106 -- <original source statements with attribute rewrites>
1111 Build_Conditional_Block (Loc,
1113 Loop_Stmt => Relocate_Node (Loop_Stmt),
1119 -- While loops are transformed into:
1121 -- function Fnn return Boolean is
1123 -- <condition actions>
1124 -- return <condition>;
1129 -- Temp1 : constant <type of Pref1> := <Pref1>;
1131 -- TempN : constant <type of PrefN> := <PrefN>;
1134 -- <original source statements with attribute rewrites>
1135 -- exit when not Fnn;
1140 -- Note that loops over iterators and containers are already
1141 -- converted into while loops.
1143 elsif Present (Condition (Scheme)) then
1145 Func_Decl : Node_Id;
1146 Func_Id : Entity_Id;
1150 -- Wrap the condition of the while loop in a Boolean function.
1151 -- This avoids the duplication of the same code which may lead
1152 -- to gigi issues with respect to multiple declaration of the
1153 -- same entity in the presence of side effects or checks. Note
1154 -- that the condition actions must also be relocated to the
1155 -- wrapping function.
1158 -- <condition actions>
1159 -- return <condition>;
1161 if Present (Condition_Actions (Scheme)) then
1162 Stmts := Condition_Actions (Scheme);
1168 Make_Simple_Return_Statement (Loc,
1169 Expression => Relocate_Node (Condition (Scheme))));
1172 -- function Fnn return Boolean is
1177 Func_Id := Make_Temporary (Loc, 'F');
1179 Make_Subprogram_Body (Loc,
1181 Make_Function_Specification (Loc,
1182 Defining_Unit_Name => Func_Id,
1183 Result_Definition =>
1184 New_Occurrence_Of (Standard_Boolean, Loc)),
1185 Declarations => Empty_List,
1186 Handled_Statement_Sequence =>
1187 Make_Handled_Sequence_Of_Statements (Loc,
1188 Statements => Stmts));
1190 -- The function is inserted before the related loop. Make sure
1191 -- to analyze it in the context of the loop's enclosing scope.
1193 Push_Scope (Scope (Loop_Id));
1194 Insert_Action (Loop_Stmt, Func_Decl);
1197 -- Transform the original while loop into an infinite loop
1198 -- where the last statement checks the negated condition. This
1199 -- placement ensures that the condition will not be evaluated
1200 -- twice on the first iteration.
1202 Set_Iteration_Scheme (Loop_Stmt, Empty);
1206 -- exit when not Fnn;
1208 Append_To (Statements (Loop_Stmt),
1209 Make_Exit_Statement (Loc,
1213 Make_Function_Call (Loc,
1214 Name => New_Occurrence_Of (Func_Id, Loc)))));
1216 Build_Conditional_Block (Loc,
1218 Make_Function_Call (Loc,
1219 Name => New_Occurrence_Of (Func_Id, Loc)),
1220 Loop_Stmt => Relocate_Node (Loop_Stmt),
1225 -- Ada 2012 iteration over an array is transformed into:
1227 -- if <Array_Nam>'Length (1) > 0
1228 -- and then <Array_Nam>'Length (N) > 0
1231 -- Temp1 : constant <type of Pref1> := <Pref1>;
1233 -- TempN : constant <type of PrefN> := <PrefN>;
1235 -- for X in ... loop -- multiple loops depending on dims
1236 -- <original source statements with attribute rewrites>
1241 elsif Is_Array_Iteration (Loop_Stmt) then
1243 Array_Nam : constant Entity_Id :=
1244 Entity (Name (Iterator_Specification
1245 (Iteration_Scheme (Original_Node (Loop_Stmt)))));
1246 Num_Dims : constant Pos :=
1247 Number_Dimensions (Etype (Array_Nam));
1248 Cond : Node_Id := Empty;
1252 -- Generate a check which determines whether all dimensions of
1253 -- the array are non-null.
1255 for Dim in 1 .. Num_Dims loop
1259 Make_Attribute_Reference (Loc,
1260 Prefix => New_Occurrence_Of (Array_Nam, Loc),
1261 Attribute_Name => Name_Length,
1262 Expressions => New_List (
1263 Make_Integer_Literal (Loc, Dim))),
1265 Make_Integer_Literal (Loc, 0));
1273 Right_Opnd => Check);
1277 Build_Conditional_Block (Loc,
1279 Loop_Stmt => Relocate_Node (Loop_Stmt),
1284 -- For loops are transformed into:
1286 -- if <Low> <= <High> then
1288 -- Temp1 : constant <type of Pref1> := <Pref1>;
1290 -- TempN : constant <type of PrefN> := <PrefN>;
1292 -- for <Def_Id> in <Low> .. <High> loop
1293 -- <original source statements with attribute rewrites>
1298 elsif Present (Loop_Parameter_Specification (Scheme)) then
1300 Loop_Spec : constant Node_Id :=
1301 Loop_Parameter_Specification (Scheme);
1306 Subt_Def := Discrete_Subtype_Definition (Loop_Spec);
1308 -- When the loop iterates over a subtype indication with a
1309 -- range, use the low and high bounds of the subtype itself.
1311 if Nkind (Subt_Def) = N_Subtype_Indication then
1312 Subt_Def := Scalar_Range (Etype (Subt_Def));
1315 pragma Assert (Nkind (Subt_Def) = N_Range);
1322 Left_Opnd => New_Copy_Tree (Low_Bound (Subt_Def)),
1323 Right_Opnd => New_Copy_Tree (High_Bound (Subt_Def)));
1325 Build_Conditional_Block (Loc,
1327 Loop_Stmt => Relocate_Node (Loop_Stmt),
1333 Decls := Declarations (Blk);
1336 -- Step 3: Create a constant to capture the value of the prefix at the
1337 -- entry point into the loop.
1339 Temp_Id := Make_Temporary (Loc, 'P');
1341 -- Preserve the tag of the prefix by offering a specific view of the
1342 -- class-wide version of the prefix.
1344 if Is_Tagged_Type (Typ) then
1347 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
1349 CW_Temp := Make_Temporary (Loc, 'T');
1350 CW_Typ := Class_Wide_Type (Typ);
1353 Make_Object_Declaration (Loc,
1354 Defining_Identifier => CW_Temp,
1355 Constant_Present => True,
1356 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
1358 Convert_To (CW_Typ, Relocate_Node (Pref)));
1359 Append_To (Decls, CW_Decl);
1362 -- Temp : Typ renames Typ (CW_Temp);
1365 Make_Object_Renaming_Declaration (Loc,
1366 Defining_Identifier => Temp_Id,
1367 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
1369 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)));
1370 Append_To (Decls, Temp_Decl);
1378 -- Temp : constant Typ := Pref;
1381 Make_Object_Declaration (Loc,
1382 Defining_Identifier => Temp_Id,
1383 Constant_Present => True,
1384 Object_Definition => New_Occurrence_Of (Typ, Loc),
1385 Expression => Relocate_Node (Pref));
1386 Append_To (Decls, Temp_Decl);
1389 -- Step 4: Analyze all bits
1391 Installed := Current_Scope = Scope (Loop_Id);
1393 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1394 -- associated loop, ensure the proper visibility for analysis.
1396 if not Installed then
1397 Push_Scope (Scope (Loop_Id));
1400 -- The analysis of the conditional block takes care of the constant
1403 if Present (Result) then
1404 Rewrite (Loop_Stmt, Result);
1405 Analyze (Loop_Stmt);
1407 -- The conditional block was analyzed when a previous 'Loop_Entry was
1408 -- expanded. There is no point in reanalyzing the block, simply analyze
1409 -- the declaration of the constant.
1412 if Present (CW_Decl) then
1416 Analyze (Temp_Decl);
1419 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
1422 if not Installed then
1425 end Expand_Loop_Entry_Attribute;
1427 ------------------------------
1428 -- Expand_Min_Max_Attribute --
1429 ------------------------------
1431 procedure Expand_Min_Max_Attribute (N : Node_Id) is
1433 -- Min and Max are handled by the back end (except that static cases
1434 -- have already been evaluated during semantic processing, although the
1435 -- back end should not count on this). The one bit of special processing
1436 -- required in the normal case is that these two attributes typically
1437 -- generate conditionals in the code, so check the relevant restriction.
1439 Check_Restriction (No_Implicit_Conditionals, N);
1441 -- In Modify_Tree_For_C mode, we rewrite as an if expression
1443 if Modify_Tree_For_C then
1445 Loc : constant Source_Ptr := Sloc (N);
1446 Typ : constant Entity_Id := Etype (N);
1447 Expr : constant Node_Id := First (Expressions (N));
1448 Left : constant Node_Id := Relocate_Node (Expr);
1449 Right : constant Node_Id := Relocate_Node (Next (Expr));
1451 function Make_Compare (Left, Right : Node_Id) return Node_Id;
1452 -- Returns Left >= Right for Max, Left <= Right for Min
1458 function Make_Compare (Left, Right : Node_Id) return Node_Id is
1460 if Attribute_Name (N) = Name_Max then
1464 Right_Opnd => Right);
1469 Right_Opnd => Right);
1473 -- Start of processing for Min_Max
1476 -- If both Left and Right are side effect free, then we can just
1477 -- use Duplicate_Expr to duplicate the references and return
1479 -- (if Left >=|<= Right then Left else Right)
1481 if Side_Effect_Free (Left) and then Side_Effect_Free (Right) then
1483 Make_If_Expression (Loc,
1484 Expressions => New_List (
1485 Make_Compare (Left, Right),
1486 Duplicate_Subexpr_No_Checks (Left),
1487 Duplicate_Subexpr_No_Checks (Right))));
1489 -- Otherwise we generate declarations to capture the values.
1491 -- The translation is
1494 -- T1 : constant typ := Left;
1495 -- T2 : constant typ := Right;
1497 -- (if T1 >=|<= T2 then T1 else T2)
1502 T1 : constant Entity_Id := Make_Temporary (Loc, 'T', Left);
1503 T2 : constant Entity_Id := Make_Temporary (Loc, 'T', Right);
1507 Make_Expression_With_Actions (Loc,
1508 Actions => New_List (
1509 Make_Object_Declaration (Loc,
1510 Defining_Identifier => T1,
1511 Constant_Present => True,
1512 Object_Definition =>
1513 New_Occurrence_Of (Etype (Left), Loc),
1514 Expression => Relocate_Node (Left)),
1516 Make_Object_Declaration (Loc,
1517 Defining_Identifier => T2,
1518 Constant_Present => True,
1519 Object_Definition =>
1520 New_Occurrence_Of (Etype (Right), Loc),
1521 Expression => Relocate_Node (Right))),
1524 Make_If_Expression (Loc,
1525 Expressions => New_List (
1527 (New_Occurrence_Of (T1, Loc),
1528 New_Occurrence_Of (T2, Loc)),
1529 New_Occurrence_Of (T1, Loc),
1530 New_Occurrence_Of (T2, Loc)))));
1534 Analyze_And_Resolve (N, Typ);
1537 end Expand_Min_Max_Attribute;
1539 ----------------------------------
1540 -- Expand_N_Attribute_Reference --
1541 ----------------------------------
1543 procedure Expand_N_Attribute_Reference (N : Node_Id) is
1544 Loc : constant Source_Ptr := Sloc (N);
1545 Typ : constant Entity_Id := Etype (N);
1546 Btyp : constant Entity_Id := Base_Type (Typ);
1547 Pref : constant Node_Id := Prefix (N);
1548 Ptyp : constant Entity_Id := Etype (Pref);
1549 Exprs : constant List_Id := Expressions (N);
1550 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
1552 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
1553 -- Rewrites a stream attribute for Read, Write or Output with the
1554 -- procedure call. Pname is the entity for the procedure to call.
1556 ------------------------------
1557 -- Rewrite_Stream_Proc_Call --
1558 ------------------------------
1560 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
1561 Item : constant Node_Id := Next (First (Exprs));
1562 Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
1563 Formal_Typ : constant Entity_Id := Etype (Formal);
1564 Is_Written : constant Boolean := (Ekind (Formal) /= E_In_Parameter);
1567 -- The expansion depends on Item, the second actual, which is
1568 -- the object being streamed in or out.
1570 -- If the item is a component of a packed array type, and
1571 -- a conversion is needed on exit, we introduce a temporary to
1572 -- hold the value, because otherwise the packed reference will
1573 -- not be properly expanded.
1575 if Nkind (Item) = N_Indexed_Component
1576 and then Is_Packed (Base_Type (Etype (Prefix (Item))))
1577 and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
1581 Temp : constant Entity_Id := Make_Temporary (Loc, 'V');
1587 Make_Object_Declaration (Loc,
1588 Defining_Identifier => Temp,
1589 Object_Definition =>
1590 New_Occurrence_Of (Formal_Typ, Loc));
1591 Set_Etype (Temp, Formal_Typ);
1594 Make_Assignment_Statement (Loc,
1595 Name => New_Copy_Tree (Item),
1597 Unchecked_Convert_To
1598 (Etype (Item), New_Occurrence_Of (Temp, Loc)));
1600 Rewrite (Item, New_Occurrence_Of (Temp, Loc));
1604 Make_Procedure_Call_Statement (Loc,
1605 Name => New_Occurrence_Of (Pname, Loc),
1606 Parameter_Associations => Exprs),
1609 Rewrite (N, Make_Null_Statement (Loc));
1614 -- For the class-wide dispatching cases, and for cases in which
1615 -- the base type of the second argument matches the base type of
1616 -- the corresponding formal parameter (that is to say the stream
1617 -- operation is not inherited), we are all set, and can use the
1618 -- argument unchanged.
1620 -- For all other cases we do an unchecked conversion of the second
1621 -- parameter to the type of the formal of the procedure we are
1622 -- calling. This deals with the private type cases, and with going
1623 -- to the root type as required in elementary type case.
1625 if not Is_Class_Wide_Type (Entity (Pref))
1626 and then not Is_Class_Wide_Type (Etype (Item))
1627 and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
1630 Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
1632 -- For untagged derived types set Assignment_OK, to prevent
1633 -- copies from being created when the unchecked conversion
1634 -- is expanded (which would happen in Remove_Side_Effects
1635 -- if Expand_N_Unchecked_Conversion were allowed to call
1636 -- Force_Evaluation). The copy could violate Ada semantics in
1637 -- cases such as an actual that is an out parameter. Note that
1638 -- this approach is also used in exp_ch7 for calls to controlled
1639 -- type operations to prevent problems with actuals wrapped in
1640 -- unchecked conversions.
1642 if Is_Untagged_Derivation (Etype (Expression (Item))) then
1643 Set_Assignment_OK (Item);
1647 -- The stream operation to call may be a renaming created by an
1648 -- attribute definition clause, and may not be frozen yet. Ensure
1649 -- that it has the necessary extra formals.
1651 if not Is_Frozen (Pname) then
1652 Create_Extra_Formals (Pname);
1655 -- And now rewrite the call
1658 Make_Procedure_Call_Statement (Loc,
1659 Name => New_Occurrence_Of (Pname, Loc),
1660 Parameter_Associations => Exprs));
1663 end Rewrite_Stream_Proc_Call;
1665 -- Start of processing for Expand_N_Attribute_Reference
1668 -- Do required validity checking, if enabled. Do not apply check to
1669 -- output parameters of an Asm instruction, since the value of this
1670 -- is not set till after the attribute has been elaborated, and do
1671 -- not apply the check to the arguments of a 'Read or 'Input attribute
1672 -- reference since the scalar argument is an OUT scalar.
1674 if Validity_Checks_On and then Validity_Check_Operands
1675 and then Id /= Attribute_Asm_Output
1676 and then Id /= Attribute_Read
1677 and then Id /= Attribute_Input
1682 Expr := First (Expressions (N));
1683 while Present (Expr) loop
1684 Ensure_Valid (Expr);
1690 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
1691 -- place function, then a temporary return object needs to be created
1692 -- and access to it must be passed to the function. Currently we limit
1693 -- such functions to those with inherently limited result subtypes, but
1694 -- eventually we plan to expand the functions that are treated as
1695 -- build-in-place to include other composite result types.
1697 if Ada_Version >= Ada_2005
1698 and then Is_Build_In_Place_Function_Call (Pref)
1700 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
1703 -- If prefix is a protected type name, this is a reference to the
1704 -- current instance of the type. For a component definition, nothing
1705 -- to do (expansion will occur in the init proc). In other contexts,
1706 -- rewrite into reference to current instance.
1708 if Is_Protected_Self_Reference (Pref)
1710 (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint,
1711 N_Discriminant_Association)
1712 and then Nkind (Parent (Parent (Parent (Parent (N))))) =
1713 N_Component_Definition)
1715 -- No action needed for these attributes since the current instance
1716 -- will be rewritten to be the name of the _object parameter
1717 -- associated with the enclosing protected subprogram (see below).
1719 and then Id /= Attribute_Access
1720 and then Id /= Attribute_Unchecked_Access
1721 and then Id /= Attribute_Unrestricted_Access
1723 Rewrite (Pref, Concurrent_Ref (Pref));
1727 -- Remaining processing depends on specific attribute
1729 -- Note: individual sections of the following case statement are
1730 -- allowed to assume there is no code after the case statement, and
1731 -- are legitimately allowed to execute return statements if they have
1732 -- nothing more to do.
1736 -- Attributes related to Ada 2012 iterators
1738 when Attribute_Constant_Indexing |
1739 Attribute_Default_Iterator |
1740 Attribute_Implicit_Dereference |
1741 Attribute_Iterable |
1742 Attribute_Iterator_Element |
1743 Attribute_Variable_Indexing =>
1746 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
1747 -- were already rejected by the parser. Thus they shouldn't appear here.
1749 when Internal_Attribute_Id =>
1750 raise Program_Error;
1756 when Attribute_Access |
1757 Attribute_Unchecked_Access |
1758 Attribute_Unrestricted_Access =>
1760 Access_Cases : declare
1761 Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
1762 Btyp_DDT : Entity_Id;
1764 function Enclosing_Object (N : Node_Id) return Node_Id;
1765 -- If N denotes a compound name (selected component, indexed
1766 -- component, or slice), returns the name of the outermost such
1767 -- enclosing object. Otherwise returns N. If the object is a
1768 -- renaming, then the renamed object is returned.
1770 ----------------------
1771 -- Enclosing_Object --
1772 ----------------------
1774 function Enclosing_Object (N : Node_Id) return Node_Id is
1779 while Nkind_In (Obj_Name, N_Selected_Component,
1780 N_Indexed_Component,
1783 Obj_Name := Prefix (Obj_Name);
1786 return Get_Referenced_Object (Obj_Name);
1787 end Enclosing_Object;
1789 -- Local declarations
1791 Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
1793 -- Start of processing for Access_Cases
1796 Btyp_DDT := Designated_Type (Btyp);
1798 -- Handle designated types that come from the limited view
1800 if From_Limited_With (Btyp_DDT)
1801 and then Has_Non_Limited_View (Btyp_DDT)
1803 Btyp_DDT := Non_Limited_View (Btyp_DDT);
1806 -- In order to improve the text of error messages, the designated
1807 -- type of access-to-subprogram itypes is set by the semantics as
1808 -- the associated subprogram entity (see sem_attr). Now we replace
1809 -- such node with the proper E_Subprogram_Type itype.
1811 if Id = Attribute_Unrestricted_Access
1812 and then Is_Subprogram (Directly_Designated_Type (Typ))
1814 -- The following conditions ensure that this special management
1815 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
1816 -- At this stage other cases in which the designated type is
1817 -- still a subprogram (instead of an E_Subprogram_Type) are
1818 -- wrong because the semantics must have overridden the type of
1819 -- the node with the type imposed by the context.
1821 if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
1822 and then Etype (Parent (N)) = RTE (RE_Prim_Ptr)
1824 Set_Etype (N, RTE (RE_Prim_Ptr));
1828 Subp : constant Entity_Id :=
1829 Directly_Designated_Type (Typ);
1831 Extra : Entity_Id := Empty;
1832 New_Formal : Entity_Id;
1833 Old_Formal : Entity_Id := First_Formal (Subp);
1834 Subp_Typ : Entity_Id;
1837 Subp_Typ := Create_Itype (E_Subprogram_Type, N);
1838 Set_Etype (Subp_Typ, Etype (Subp));
1839 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
1841 if Present (Old_Formal) then
1842 New_Formal := New_Copy (Old_Formal);
1843 Set_First_Entity (Subp_Typ, New_Formal);
1846 Set_Scope (New_Formal, Subp_Typ);
1847 Etyp := Etype (New_Formal);
1849 -- Handle itypes. There is no need to duplicate
1850 -- here the itypes associated with record types
1851 -- (i.e the implicit full view of private types).
1854 and then Ekind (Base_Type (Etyp)) /= E_Record_Type
1856 Extra := New_Copy (Etyp);
1857 Set_Parent (Extra, New_Formal);
1858 Set_Etype (New_Formal, Extra);
1859 Set_Scope (Extra, Subp_Typ);
1862 Extra := New_Formal;
1863 Next_Formal (Old_Formal);
1864 exit when No (Old_Formal);
1866 Set_Next_Entity (New_Formal,
1867 New_Copy (Old_Formal));
1868 Next_Entity (New_Formal);
1871 Set_Next_Entity (New_Formal, Empty);
1872 Set_Last_Entity (Subp_Typ, Extra);
1875 -- Now that the explicit formals have been duplicated,
1876 -- any extra formals needed by the subprogram must be
1879 if Present (Extra) then
1880 Set_Extra_Formal (Extra, Empty);
1883 Create_Extra_Formals (Subp_Typ);
1884 Set_Directly_Designated_Type (Typ, Subp_Typ);
1889 if Is_Access_Protected_Subprogram_Type (Btyp) then
1890 Expand_Access_To_Protected_Op (N, Pref, Typ);
1892 -- If prefix is a type name, this is a reference to the current
1893 -- instance of the type, within its initialization procedure.
1895 elsif Is_Entity_Name (Pref)
1896 and then Is_Type (Entity (Pref))
1903 -- If the current instance name denotes a task type, then
1904 -- the access attribute is rewritten to be the name of the
1905 -- "_task" parameter associated with the task type's task
1906 -- procedure. An unchecked conversion is applied to ensure
1907 -- a type match in cases of expander-generated calls (e.g.
1910 if Is_Task_Type (Entity (Pref)) then
1912 First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
1913 while Present (Formal) loop
1914 exit when Chars (Formal) = Name_uTask;
1915 Next_Entity (Formal);
1918 pragma Assert (Present (Formal));
1921 Unchecked_Convert_To (Typ,
1922 New_Occurrence_Of (Formal, Loc)));
1925 elsif Is_Protected_Type (Entity (Pref)) then
1927 -- No action needed for current instance located in a
1928 -- component definition (expansion will occur in the
1931 if Is_Protected_Type (Current_Scope) then
1934 -- If the current instance reference is located in a
1935 -- protected subprogram or entry then rewrite the access
1936 -- attribute to be the name of the "_object" parameter.
1937 -- An unchecked conversion is applied to ensure a type
1938 -- match in cases of expander-generated calls (e.g. init
1941 -- The code may be nested in a block, so find enclosing
1942 -- scope that is a protected operation.
1949 Subp := Current_Scope;
1950 while Ekind_In (Subp, E_Loop, E_Block) loop
1951 Subp := Scope (Subp);
1956 (Protected_Body_Subprogram (Subp));
1958 -- For a protected subprogram the _Object parameter
1959 -- is the protected record, so we create an access
1960 -- to it. The _Object parameter of an entry is an
1963 if Ekind (Subp) = E_Entry then
1965 Unchecked_Convert_To (Typ,
1966 New_Occurrence_Of (Formal, Loc)));
1971 Unchecked_Convert_To (Typ,
1972 Make_Attribute_Reference (Loc,
1973 Attribute_Name => Name_Unrestricted_Access,
1975 New_Occurrence_Of (Formal, Loc))));
1976 Analyze_And_Resolve (N);
1981 -- The expression must appear in a default expression,
1982 -- (which in the initialization procedure is the right-hand
1983 -- side of an assignment), and not in a discriminant
1988 while Present (Par) loop
1989 exit when Nkind (Par) = N_Assignment_Statement;
1991 if Nkind (Par) = N_Component_Declaration then
1995 Par := Parent (Par);
1998 if Present (Par) then
2000 Make_Attribute_Reference (Loc,
2001 Prefix => Make_Identifier (Loc, Name_uInit),
2002 Attribute_Name => Attribute_Name (N)));
2004 Analyze_And_Resolve (N, Typ);
2009 -- If the prefix of an Access attribute is a dereference of an
2010 -- access parameter (or a renaming of such a dereference, or a
2011 -- subcomponent of such a dereference) and the context is a
2012 -- general access type (including the type of an object or
2013 -- component with an access_definition, but not the anonymous
2014 -- type of an access parameter or access discriminant), then
2015 -- apply an accessibility check to the access parameter. We used
2016 -- to rewrite the access parameter as a type conversion, but that
2017 -- could only be done if the immediate prefix of the Access
2018 -- attribute was the dereference, and didn't handle cases where
2019 -- the attribute is applied to a subcomponent of the dereference,
2020 -- since there's generally no available, appropriate access type
2021 -- to convert to in that case. The attribute is passed as the
2022 -- point to insert the check, because the access parameter may
2023 -- come from a renaming, possibly in a different scope, and the
2024 -- check must be associated with the attribute itself.
2026 elsif Id = Attribute_Access
2027 and then Nkind (Enc_Object) = N_Explicit_Dereference
2028 and then Is_Entity_Name (Prefix (Enc_Object))
2029 and then (Ekind (Btyp) = E_General_Access_Type
2030 or else Is_Local_Anonymous_Access (Btyp))
2031 and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind
2032 and then Ekind (Etype (Entity (Prefix (Enc_Object))))
2033 = E_Anonymous_Access_Type
2034 and then Present (Extra_Accessibility
2035 (Entity (Prefix (Enc_Object))))
2037 Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N);
2039 -- Ada 2005 (AI-251): If the designated type is an interface we
2040 -- add an implicit conversion to force the displacement of the
2041 -- pointer to reference the secondary dispatch table.
2043 elsif Is_Interface (Btyp_DDT)
2044 and then (Comes_From_Source (N)
2045 or else Comes_From_Source (Ref_Object)
2046 or else (Nkind (Ref_Object) in N_Has_Chars
2047 and then Chars (Ref_Object) = Name_uInit))
2049 if Nkind (Ref_Object) /= N_Explicit_Dereference then
2051 -- No implicit conversion required if types match, or if
2052 -- the prefix is the class_wide_type of the interface. In
2053 -- either case passing an object of the interface type has
2054 -- already set the pointer correctly.
2056 if Btyp_DDT = Etype (Ref_Object)
2057 or else (Is_Class_Wide_Type (Etype (Ref_Object))
2059 Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object))
2064 Rewrite (Prefix (N),
2065 Convert_To (Btyp_DDT,
2066 New_Copy_Tree (Prefix (N))));
2068 Analyze_And_Resolve (Prefix (N), Btyp_DDT);
2071 -- When the object is an explicit dereference, convert the
2072 -- dereference's prefix.
2076 Obj_DDT : constant Entity_Id :=
2078 (Directly_Designated_Type
2079 (Etype (Prefix (Ref_Object))));
2081 -- No implicit conversion required if designated types
2082 -- match, or if we have an unrestricted access.
2084 if Obj_DDT /= Btyp_DDT
2085 and then Id /= Attribute_Unrestricted_Access
2086 and then not (Is_Class_Wide_Type (Obj_DDT)
2087 and then Etype (Obj_DDT) = Btyp_DDT)
2091 New_Copy_Tree (Prefix (Ref_Object))));
2092 Analyze_And_Resolve (N, Typ);
2103 -- Transforms 'Adjacent into a call to the floating-point attribute
2104 -- function Adjacent in Fat_xxx (where xxx is the root type)
2106 when Attribute_Adjacent =>
2107 Expand_Fpt_Attribute_RR (N);
2113 when Attribute_Address => Address : declare
2114 Task_Proc : Entity_Id;
2117 -- If the prefix is a task or a task type, the useful address is that
2118 -- of the procedure for the task body, i.e. the actual program unit.
2119 -- We replace the original entity with that of the procedure.
2121 if Is_Entity_Name (Pref)
2122 and then Is_Task_Type (Entity (Pref))
2124 Task_Proc := Next_Entity (Root_Type (Ptyp));
2126 while Present (Task_Proc) loop
2127 exit when Ekind (Task_Proc) = E_Procedure
2128 and then Etype (First_Formal (Task_Proc)) =
2129 Corresponding_Record_Type (Ptyp);
2130 Next_Entity (Task_Proc);
2133 if Present (Task_Proc) then
2134 Set_Entity (Pref, Task_Proc);
2135 Set_Etype (Pref, Etype (Task_Proc));
2138 -- Similarly, the address of a protected operation is the address
2139 -- of the corresponding protected body, regardless of the protected
2140 -- object from which it is selected.
2142 elsif Nkind (Pref) = N_Selected_Component
2143 and then Is_Subprogram (Entity (Selector_Name (Pref)))
2144 and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref))))
2148 External_Subprogram (Entity (Selector_Name (Pref))), Loc));
2150 elsif Nkind (Pref) = N_Explicit_Dereference
2151 and then Ekind (Ptyp) = E_Subprogram_Type
2152 and then Convention (Ptyp) = Convention_Protected
2154 -- The prefix is be a dereference of an access_to_protected_
2155 -- subprogram. The desired address is the second component of
2156 -- the record that represents the access.
2159 Addr : constant Entity_Id := Etype (N);
2160 Ptr : constant Node_Id := Prefix (Pref);
2161 T : constant Entity_Id :=
2162 Equivalent_Type (Base_Type (Etype (Ptr)));
2166 Unchecked_Convert_To (Addr,
2167 Make_Selected_Component (Loc,
2168 Prefix => Unchecked_Convert_To (T, Ptr),
2169 Selector_Name => New_Occurrence_Of (
2170 Next_Entity (First_Entity (T)), Loc))));
2172 Analyze_And_Resolve (N, Addr);
2175 -- Ada 2005 (AI-251): Class-wide interface objects are always
2176 -- "displaced" to reference the tag associated with the interface
2177 -- type. In order to obtain the real address of such objects we
2178 -- generate a call to a run-time subprogram that returns the base
2179 -- address of the object.
2181 -- This processing is not needed in the VM case, where dispatching
2182 -- issues are taken care of by the virtual machine.
2184 elsif Is_Class_Wide_Type (Ptyp)
2185 and then Is_Interface (Ptyp)
2186 and then Tagged_Type_Expansion
2187 and then not (Nkind (Pref) in N_Has_Entity
2188 and then Is_Subprogram (Entity (Pref)))
2191 Make_Function_Call (Loc,
2192 Name => New_Occurrence_Of (RTE (RE_Base_Address), Loc),
2193 Parameter_Associations => New_List (
2194 Relocate_Node (N))));
2199 -- Deal with packed array reference, other cases are handled by
2202 if Involves_Packed_Array_Reference (Pref) then
2203 Expand_Packed_Address_Reference (N);
2211 when Attribute_Alignment => Alignment : declare
2215 -- For class-wide types, X'Class'Alignment is transformed into a
2216 -- direct reference to the Alignment of the class type, so that the
2217 -- back end does not have to deal with the X'Class'Alignment
2220 if Is_Entity_Name (Pref)
2221 and then Is_Class_Wide_Type (Entity (Pref))
2223 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
2226 -- For x'Alignment applied to an object of a class wide type,
2227 -- transform X'Alignment into a call to the predefined primitive
2228 -- operation _Alignment applied to X.
2230 elsif Is_Class_Wide_Type (Ptyp) then
2232 Make_Attribute_Reference (Loc,
2234 Attribute_Name => Name_Tag);
2236 New_Node := Build_Get_Alignment (Loc, New_Node);
2238 -- Case where the context is a specific integer type with which
2239 -- the original attribute was compatible. The function has a
2240 -- specific type as well, so to preserve the compatibility we
2241 -- must convert explicitly.
2243 if Typ /= Standard_Integer then
2244 New_Node := Convert_To (Typ, New_Node);
2247 Rewrite (N, New_Node);
2248 Analyze_And_Resolve (N, Typ);
2251 -- For all other cases, we just have to deal with the case of
2252 -- the fact that the result can be universal.
2255 Apply_Universal_Integer_Attribute_Checks (N);
2263 -- We compute this if a packed array reference was present, otherwise we
2264 -- leave the computation up to the back end.
2266 when Attribute_Bit =>
2267 if Involves_Packed_Array_Reference (Pref) then
2268 Expand_Packed_Bit_Reference (N);
2270 Apply_Universal_Integer_Attribute_Checks (N);
2277 -- We compute this if a component clause was present, otherwise we leave
2278 -- the computation up to the back end, since we don't know what layout
2281 -- Note that the attribute can apply to a naked record component
2282 -- in generated code (i.e. the prefix is an identifier that
2283 -- references the component or discriminant entity).
2285 when Attribute_Bit_Position => Bit_Position : declare
2289 if Nkind (Pref) = N_Identifier then
2290 CE := Entity (Pref);
2292 CE := Entity (Selector_Name (Pref));
2295 if Known_Static_Component_Bit_Offset (CE) then
2297 Make_Integer_Literal (Loc,
2298 Intval => Component_Bit_Offset (CE)));
2299 Analyze_And_Resolve (N, Typ);
2302 Apply_Universal_Integer_Attribute_Checks (N);
2310 -- A reference to P'Body_Version or P'Version is expanded to
2313 -- pragma Import (C, Vnn, "uuuuT");
2315 -- Get_Version_String (Vnn)
2317 -- where uuuu is the unit name (dots replaced by double underscore)
2318 -- and T is B for the cases of Body_Version, or Version applied to a
2319 -- subprogram acting as its own spec, and S for Version applied to a
2320 -- subprogram spec or package. This sequence of code references the
2321 -- unsigned constant created in the main program by the binder.
2323 -- A special exception occurs for Standard, where the string returned
2324 -- is a copy of the library string in gnatvsn.ads.
2326 when Attribute_Body_Version | Attribute_Version => Version : declare
2327 E : constant Entity_Id := Make_Temporary (Loc, 'V');
2332 -- If not library unit, get to containing library unit
2334 Pent := Entity (Pref);
2335 while Pent /= Standard_Standard
2336 and then Scope (Pent) /= Standard_Standard
2337 and then not Is_Child_Unit (Pent)
2339 Pent := Scope (Pent);
2342 -- Special case Standard and Standard.ASCII
2344 if Pent = Standard_Standard or else Pent = Standard_ASCII then
2346 Make_String_Literal (Loc,
2347 Strval => Verbose_Library_Version));
2352 -- Build required string constant
2354 Get_Name_String (Get_Unit_Name (Pent));
2357 for J in 1 .. Name_Len - 2 loop
2358 if Name_Buffer (J) = '.' then
2359 Store_String_Chars ("__");
2361 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
2365 -- Case of subprogram acting as its own spec, always use body
2367 if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
2368 and then Nkind (Parent (Declaration_Node (Pent))) =
2370 and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
2372 Store_String_Chars ("B");
2374 -- Case of no body present, always use spec
2376 elsif not Unit_Requires_Body (Pent) then
2377 Store_String_Chars ("S");
2379 -- Otherwise use B for Body_Version, S for spec
2381 elsif Id = Attribute_Body_Version then
2382 Store_String_Chars ("B");
2384 Store_String_Chars ("S");
2388 Lib.Version_Referenced (S);
2390 -- Insert the object declaration
2392 Insert_Actions (N, New_List (
2393 Make_Object_Declaration (Loc,
2394 Defining_Identifier => E,
2395 Object_Definition =>
2396 New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
2398 -- Set entity as imported with correct external name
2400 Set_Is_Imported (E);
2401 Set_Interface_Name (E, Make_String_Literal (Loc, S));
2403 -- Set entity as internal to ensure proper Sprint output of its
2404 -- implicit importation.
2406 Set_Is_Internal (E);
2408 -- And now rewrite original reference
2411 Make_Function_Call (Loc,
2412 Name => New_Occurrence_Of (RTE (RE_Get_Version_String), Loc),
2413 Parameter_Associations => New_List (
2414 New_Occurrence_Of (E, Loc))));
2417 Analyze_And_Resolve (N, RTE (RE_Version_String));
2424 -- Transforms 'Ceiling into a call to the floating-point attribute
2425 -- function Ceiling in Fat_xxx (where xxx is the root type)
2427 when Attribute_Ceiling =>
2428 Expand_Fpt_Attribute_R (N);
2434 -- Transforms 'Callable attribute into a call to the Callable function
2436 when Attribute_Callable => Callable :
2438 -- We have an object of a task interface class-wide type as a prefix
2439 -- to Callable. Generate:
2440 -- callable (Task_Id (Pref._disp_get_task_id));
2442 if Ada_Version >= Ada_2005
2443 and then Ekind (Ptyp) = E_Class_Wide_Type
2444 and then Is_Interface (Ptyp)
2445 and then Is_Task_Interface (Ptyp)
2448 Make_Function_Call (Loc,
2450 New_Occurrence_Of (RTE (RE_Callable), Loc),
2451 Parameter_Associations => New_List (
2452 Make_Unchecked_Type_Conversion (Loc,
2454 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
2456 Make_Selected_Component (Loc,
2458 New_Copy_Tree (Pref),
2460 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
2464 Build_Call_With_Task (Pref, RTE (RE_Callable)));
2467 Analyze_And_Resolve (N, Standard_Boolean);
2474 -- Transforms 'Caller attribute into a call to either the
2475 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2477 when Attribute_Caller => Caller : declare
2478 Id_Kind : constant Entity_Id := RTE (RO_AT_Task_Id);
2479 Ent : constant Entity_Id := Entity (Pref);
2480 Conctype : constant Entity_Id := Scope (Ent);
2481 Nest_Depth : Integer := 0;
2488 if Is_Protected_Type (Conctype) then
2489 case Corresponding_Runtime_Package (Conctype) is
2490 when System_Tasking_Protected_Objects_Entries =>
2493 (RTE (RE_Protected_Entry_Caller), Loc);
2495 when System_Tasking_Protected_Objects_Single_Entry =>
2498 (RTE (RE_Protected_Single_Entry_Caller), Loc);
2501 raise Program_Error;
2505 Unchecked_Convert_To (Id_Kind,
2506 Make_Function_Call (Loc,
2508 Parameter_Associations => New_List (
2510 (Find_Protection_Object (Current_Scope), Loc)))));
2515 -- Determine the nesting depth of the E'Caller attribute, that
2516 -- is, how many accept statements are nested within the accept
2517 -- statement for E at the point of E'Caller. The runtime uses
2518 -- this depth to find the specified entry call.
2520 for J in reverse 0 .. Scope_Stack.Last loop
2521 S := Scope_Stack.Table (J).Entity;
2523 -- We should not reach the scope of the entry, as it should
2524 -- already have been checked in Sem_Attr that this attribute
2525 -- reference is within a matching accept statement.
2527 pragma Assert (S /= Conctype);
2532 elsif Is_Entry (S) then
2533 Nest_Depth := Nest_Depth + 1;
2538 Unchecked_Convert_To (Id_Kind,
2539 Make_Function_Call (Loc,
2541 New_Occurrence_Of (RTE (RE_Task_Entry_Caller), Loc),
2542 Parameter_Associations => New_List (
2543 Make_Integer_Literal (Loc,
2544 Intval => Int (Nest_Depth))))));
2547 Analyze_And_Resolve (N, Id_Kind);
2554 -- Transforms 'Compose into a call to the floating-point attribute
2555 -- function Compose in Fat_xxx (where xxx is the root type)
2557 -- Note: we strictly should have special code here to deal with the
2558 -- case of absurdly negative arguments (less than Integer'First)
2559 -- which will return a (signed) zero value, but it hardly seems
2560 -- worth the effort. Absurdly large positive arguments will raise
2561 -- constraint error which is fine.
2563 when Attribute_Compose =>
2564 Expand_Fpt_Attribute_RI (N);
2570 when Attribute_Constrained => Constrained : declare
2571 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
2573 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
2574 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
2575 -- view of an aliased object whose subtype is constrained.
2577 ---------------------------------
2578 -- Is_Constrained_Aliased_View --
2579 ---------------------------------
2581 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
2585 if Is_Entity_Name (Obj) then
2588 if Present (Renamed_Object (E)) then
2589 return Is_Constrained_Aliased_View (Renamed_Object (E));
2591 return Is_Aliased (E) and then Is_Constrained (Etype (E));
2595 return Is_Aliased_View (Obj)
2597 (Is_Constrained (Etype (Obj))
2599 (Nkind (Obj) = N_Explicit_Dereference
2601 not Object_Type_Has_Constrained_Partial_View
2602 (Typ => Base_Type (Etype (Obj)),
2603 Scop => Current_Scope)));
2605 end Is_Constrained_Aliased_View;
2607 -- Start of processing for Constrained
2610 -- Reference to a parameter where the value is passed as an extra
2611 -- actual, corresponding to the extra formal referenced by the
2612 -- Extra_Constrained field of the corresponding formal. If this
2613 -- is an entry in-parameter, it is replaced by a constant renaming
2614 -- for which Extra_Constrained is never created.
2616 if Present (Formal_Ent)
2617 and then Ekind (Formal_Ent) /= E_Constant
2618 and then Present (Extra_Constrained (Formal_Ent))
2622 (Extra_Constrained (Formal_Ent), Sloc (N)));
2624 -- For variables with a Extra_Constrained field, we use the
2625 -- corresponding entity.
2627 elsif Nkind (Pref) = N_Identifier
2628 and then Ekind (Entity (Pref)) = E_Variable
2629 and then Present (Extra_Constrained (Entity (Pref)))
2633 (Extra_Constrained (Entity (Pref)), Sloc (N)));
2635 -- For all other entity names, we can tell at compile time
2637 elsif Is_Entity_Name (Pref) then
2639 Ent : constant Entity_Id := Entity (Pref);
2643 -- (RM J.4) obsolescent cases
2645 if Is_Type (Ent) then
2649 if Is_Private_Type (Ent) then
2650 Res := not Has_Discriminants (Ent)
2651 or else Is_Constrained (Ent);
2653 -- It not a private type, must be a generic actual type
2654 -- that corresponded to a private type. We know that this
2655 -- correspondence holds, since otherwise the reference
2656 -- within the generic template would have been illegal.
2659 if Is_Composite_Type (Underlying_Type (Ent)) then
2660 Res := Is_Constrained (Ent);
2666 -- If the prefix is not a variable or is aliased, then
2667 -- definitely true; if it's a formal parameter without an
2668 -- associated extra formal, then treat it as constrained.
2670 -- Ada 2005 (AI-363): An aliased prefix must be known to be
2671 -- constrained in order to set the attribute to True.
2673 elsif not Is_Variable (Pref)
2674 or else Present (Formal_Ent)
2675 or else (Ada_Version < Ada_2005
2676 and then Is_Aliased_View (Pref))
2677 or else (Ada_Version >= Ada_2005
2678 and then Is_Constrained_Aliased_View (Pref))
2682 -- Variable case, look at type to see if it is constrained.
2683 -- Note that the one case where this is not accurate (the
2684 -- procedure formal case), has been handled above.
2686 -- We use the Underlying_Type here (and below) in case the
2687 -- type is private without discriminants, but the full type
2688 -- has discriminants. This case is illegal, but we generate it
2689 -- internally for passing to the Extra_Constrained parameter.
2692 -- In Ada 2012, test for case of a limited tagged type, in
2693 -- which case the attribute is always required to return
2694 -- True. The underlying type is tested, to make sure we also
2695 -- return True for cases where there is an unconstrained
2696 -- object with an untagged limited partial view which has
2697 -- defaulted discriminants (such objects always produce a
2698 -- False in earlier versions of Ada). (Ada 2012: AI05-0214)
2700 Res := Is_Constrained (Underlying_Type (Etype (Ent)))
2702 (Ada_Version >= Ada_2012
2703 and then Is_Tagged_Type (Underlying_Type (Ptyp))
2704 and then Is_Limited_Type (Ptyp));
2707 Rewrite (N, New_Occurrence_Of (Boolean_Literals (Res), Loc));
2710 -- Prefix is not an entity name. These are also cases where we can
2711 -- always tell at compile time by looking at the form and type of the
2712 -- prefix. If an explicit dereference of an object with constrained
2713 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
2714 -- underlying type is a limited tagged type, then Constrained is
2715 -- required to always return True (Ada 2012: AI05-0214).
2721 not Is_Variable (Pref)
2723 (Nkind (Pref) = N_Explicit_Dereference
2725 not Object_Type_Has_Constrained_Partial_View
2726 (Typ => Base_Type (Ptyp),
2727 Scop => Current_Scope))
2728 or else Is_Constrained (Underlying_Type (Ptyp))
2729 or else (Ada_Version >= Ada_2012
2730 and then Is_Tagged_Type (Underlying_Type (Ptyp))
2731 and then Is_Limited_Type (Ptyp))),
2735 Analyze_And_Resolve (N, Standard_Boolean);
2742 -- Transforms 'Copy_Sign into a call to the floating-point attribute
2743 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
2745 when Attribute_Copy_Sign =>
2746 Expand_Fpt_Attribute_RR (N);
2752 -- Transforms 'Count attribute into a call to the Count function
2754 when Attribute_Count => Count : declare
2756 Conctyp : Entity_Id;
2758 Entry_Id : Entity_Id;
2763 -- If the prefix is a member of an entry family, retrieve both
2764 -- entry name and index. For a simple entry there is no index.
2766 if Nkind (Pref) = N_Indexed_Component then
2767 Entnam := Prefix (Pref);
2768 Index := First (Expressions (Pref));
2774 Entry_Id := Entity (Entnam);
2776 -- Find the concurrent type in which this attribute is referenced
2777 -- (there had better be one).
2779 Conctyp := Current_Scope;
2780 while not Is_Concurrent_Type (Conctyp) loop
2781 Conctyp := Scope (Conctyp);
2786 if Is_Protected_Type (Conctyp) then
2787 case Corresponding_Runtime_Package (Conctyp) is
2788 when System_Tasking_Protected_Objects_Entries =>
2789 Name := New_Occurrence_Of (RTE (RE_Protected_Count), Loc);
2792 Make_Function_Call (Loc,
2794 Parameter_Associations => New_List (
2796 (Find_Protection_Object (Current_Scope), Loc),
2797 Entry_Index_Expression
2798 (Loc, Entry_Id, Index, Scope (Entry_Id))));
2800 when System_Tasking_Protected_Objects_Single_Entry =>
2802 New_Occurrence_Of (RTE (RE_Protected_Count_Entry), Loc);
2805 Make_Function_Call (Loc,
2807 Parameter_Associations => New_List (
2809 (Find_Protection_Object (Current_Scope), Loc)));
2812 raise Program_Error;
2819 Make_Function_Call (Loc,
2820 Name => New_Occurrence_Of (RTE (RE_Task_Count), Loc),
2821 Parameter_Associations => New_List (
2822 Entry_Index_Expression (Loc,
2823 Entry_Id, Index, Scope (Entry_Id))));
2826 -- The call returns type Natural but the context is universal integer
2827 -- so any integer type is allowed. The attribute was already resolved
2828 -- so its Etype is the required result type. If the base type of the
2829 -- context type is other than Standard.Integer we put in a conversion
2830 -- to the required type. This can be a normal typed conversion since
2831 -- both input and output types of the conversion are integer types
2833 if Base_Type (Typ) /= Base_Type (Standard_Integer) then
2834 Rewrite (N, Convert_To (Typ, Call));
2839 Analyze_And_Resolve (N, Typ);
2842 ---------------------
2843 -- Descriptor_Size --
2844 ---------------------
2846 when Attribute_Descriptor_Size =>
2848 -- Attribute Descriptor_Size is handled by the back end when applied
2849 -- to an unconstrained array type.
2851 if Is_Array_Type (Ptyp)
2852 and then not Is_Constrained (Ptyp)
2854 Apply_Universal_Integer_Attribute_Checks (N);
2856 -- For any other type, the descriptor size is 0 because there is no
2857 -- actual descriptor, but the result is not formally static.
2860 Rewrite (N, Make_Integer_Literal (Loc, 0));
2862 Set_Is_Static_Expression (N, False);
2869 -- This processing is shared by Elab_Spec
2871 -- What we do is to insert the following declarations
2874 -- pragma Import (C, enn, "name___elabb/s");
2876 -- and then the Elab_Body/Spec attribute is replaced by a reference
2877 -- to this defining identifier.
2879 when Attribute_Elab_Body |
2880 Attribute_Elab_Spec =>
2882 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
2883 -- back-end knows how to handle these attributes directly.
2885 if CodePeer_Mode then
2890 Ent : constant Entity_Id := Make_Temporary (Loc, 'E');
2894 procedure Make_Elab_String (Nod : Node_Id);
2895 -- Given Nod, an identifier, or a selected component, put the
2896 -- image into the current string literal, with double underline
2897 -- between components.
2899 ----------------------
2900 -- Make_Elab_String --
2901 ----------------------
2903 procedure Make_Elab_String (Nod : Node_Id) is
2905 if Nkind (Nod) = N_Selected_Component then
2906 Make_Elab_String (Prefix (Nod));
2907 Store_String_Char ('_');
2908 Store_String_Char ('_');
2909 Get_Name_String (Chars (Selector_Name (Nod)));
2912 pragma Assert (Nkind (Nod) = N_Identifier);
2913 Get_Name_String (Chars (Nod));
2916 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2917 end Make_Elab_String;
2919 -- Start of processing for Elab_Body/Elab_Spec
2922 -- First we need to prepare the string literal for the name of
2923 -- the elaboration routine to be referenced.
2926 Make_Elab_String (Pref);
2927 Store_String_Chars ("___elab");
2928 Lang := Make_Identifier (Loc, Name_C);
2930 if Id = Attribute_Elab_Body then
2931 Store_String_Char ('b');
2933 Store_String_Char ('s');
2938 Insert_Actions (N, New_List (
2939 Make_Subprogram_Declaration (Loc,
2941 Make_Procedure_Specification (Loc,
2942 Defining_Unit_Name => Ent)),
2945 Chars => Name_Import,
2946 Pragma_Argument_Associations => New_List (
2947 Make_Pragma_Argument_Association (Loc, Expression => Lang),
2949 Make_Pragma_Argument_Association (Loc,
2950 Expression => Make_Identifier (Loc, Chars (Ent))),
2952 Make_Pragma_Argument_Association (Loc,
2953 Expression => Make_String_Literal (Loc, Str))))));
2955 Set_Entity (N, Ent);
2956 Rewrite (N, New_Occurrence_Of (Ent, Loc));
2959 --------------------
2960 -- Elab_Subp_Body --
2961 --------------------
2963 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
2964 -- this attribute directly, and if we are not in CodePeer mode it is
2965 -- entirely ignored ???
2967 when Attribute_Elab_Subp_Body =>
2974 -- Elaborated is always True for preelaborated units, predefined units,
2975 -- pure units and units which have Elaborate_Body pragmas. These units
2976 -- have no elaboration entity.
2978 -- Note: The Elaborated attribute is never passed to the back end
2980 when Attribute_Elaborated => Elaborated : declare
2981 Ent : constant Entity_Id := Entity (Pref);
2984 if Present (Elaboration_Entity (Ent)) then
2988 New_Occurrence_Of (Elaboration_Entity (Ent), Loc),
2990 Make_Integer_Literal (Loc, Uint_0)));
2991 Analyze_And_Resolve (N, Typ);
2993 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
3001 when Attribute_Enum_Rep => Enum_Rep :
3003 -- X'Enum_Rep (Y) expands to
3007 -- This is simply a direct conversion from the enumeration type to
3008 -- the target integer type, which is treated by the back end as a
3009 -- normal integer conversion, treating the enumeration type as an
3010 -- integer, which is exactly what we want. We set Conversion_OK to
3011 -- make sure that the analyzer does not complain about what otherwise
3012 -- might be an illegal conversion.
3014 if Is_Non_Empty_List (Exprs) then
3016 OK_Convert_To (Typ, Relocate_Node (First (Exprs))));
3018 -- X'Enum_Rep where X is an enumeration literal is replaced by
3019 -- the literal value.
3021 elsif Ekind (Entity (Pref)) = E_Enumeration_Literal then
3023 Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref))));
3025 -- If this is a renaming of a literal, recover the representation
3026 -- of the original. If it renames an expression there is nothing
3029 elsif Ekind (Entity (Pref)) = E_Constant
3030 and then Present (Renamed_Object (Entity (Pref)))
3031 and then Is_Entity_Name (Renamed_Object (Entity (Pref)))
3032 and then Ekind (Entity (Renamed_Object (Entity (Pref)))) =
3033 E_Enumeration_Literal
3036 Make_Integer_Literal (Loc,
3037 Enumeration_Rep (Entity (Renamed_Object (Entity (Pref))))));
3039 -- X'Enum_Rep where X is an object does a direct unchecked conversion
3040 -- of the object value, as described for the type case above.
3044 OK_Convert_To (Typ, Relocate_Node (Pref)));
3048 Analyze_And_Resolve (N, Typ);
3055 when Attribute_Enum_Val => Enum_Val : declare
3057 Btyp : constant Entity_Id := Base_Type (Ptyp);
3060 -- X'Enum_Val (Y) expands to
3062 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
3065 Expr := Unchecked_Convert_To (Ptyp, First (Exprs));
3068 Make_Raise_Constraint_Error (Loc,
3072 Make_Function_Call (Loc,
3074 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
3075 Parameter_Associations => New_List (
3076 Relocate_Node (Duplicate_Subexpr (Expr)),
3077 New_Occurrence_Of (Standard_False, Loc))),
3079 Right_Opnd => Make_Integer_Literal (Loc, -1)),
3080 Reason => CE_Range_Check_Failed));
3083 Analyze_And_Resolve (N, Ptyp);
3090 -- Transforms 'Exponent into a call to the floating-point attribute
3091 -- function Exponent in Fat_xxx (where xxx is the root type)
3093 when Attribute_Exponent =>
3094 Expand_Fpt_Attribute_R (N);
3100 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
3102 when Attribute_External_Tag => External_Tag :
3105 Make_Function_Call (Loc,
3106 Name => New_Occurrence_Of (RTE (RE_External_Tag), Loc),
3107 Parameter_Associations => New_List (
3108 Make_Attribute_Reference (Loc,
3109 Attribute_Name => Name_Tag,
3110 Prefix => Prefix (N)))));
3112 Analyze_And_Resolve (N, Standard_String);
3119 when Attribute_First =>
3121 -- If the prefix type is a constrained packed array type which
3122 -- already has a Packed_Array_Impl_Type representation defined, then
3123 -- replace this attribute with a direct reference to 'First of the
3124 -- appropriate index subtype (since otherwise the back end will try
3125 -- to give us the value of 'First for this implementation type).
3127 if Is_Constrained_Packed_Array (Ptyp) then
3129 Make_Attribute_Reference (Loc,
3130 Attribute_Name => Name_First,
3132 New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
3133 Analyze_And_Resolve (N, Typ);
3135 -- For access type, apply access check as needed
3137 elsif Is_Access_Type (Ptyp) then
3138 Apply_Access_Check (N);
3140 -- For scalar type, if low bound is a reference to an entity, just
3141 -- replace with a direct reference. Note that we can only have a
3142 -- reference to a constant entity at this stage, anything else would
3143 -- have already been rewritten.
3145 elsif Is_Scalar_Type (Ptyp) then
3147 Lo : constant Node_Id := Type_Low_Bound (Ptyp);
3149 if Is_Entity_Name (Lo) then
3150 Rewrite (N, New_Occurrence_Of (Entity (Lo), Loc));
3159 -- Compute this if component clause was present, otherwise we leave the
3160 -- computation to be completed in the back-end, since we don't know what
3161 -- layout will be chosen.
3163 when Attribute_First_Bit => First_Bit_Attr : declare
3164 CE : constant Entity_Id := Entity (Selector_Name (Pref));
3167 -- In Ada 2005 (or later) if we have the non-default bit order, then
3168 -- we return the original value as given in the component clause
3169 -- (RM 2005 13.5.2(3/2)).
3171 if Present (Component_Clause (CE))
3172 and then Ada_Version >= Ada_2005
3173 and then Reverse_Bit_Order (Scope (CE))
3176 Make_Integer_Literal (Loc,
3177 Intval => Expr_Value (First_Bit (Component_Clause (CE)))));
3178 Analyze_And_Resolve (N, Typ);
3180 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3181 -- rewrite with normalized value if we know it statically.
3183 elsif Known_Static_Component_Bit_Offset (CE) then
3185 Make_Integer_Literal (Loc,
3186 Component_Bit_Offset (CE) mod System_Storage_Unit));
3187 Analyze_And_Resolve (N, Typ);
3189 -- Otherwise left to back end, just do universal integer checks
3192 Apply_Universal_Integer_Attribute_Checks (N);
3202 -- fixtype'Fixed_Value (integer-value)
3206 -- fixtype(integer-value)
3208 -- We do all the required analysis of the conversion here, because we do
3209 -- not want this to go through the fixed-point conversion circuits. Note
3210 -- that the back end always treats fixed-point as equivalent to the
3211 -- corresponding integer type anyway.
3213 when Attribute_Fixed_Value => Fixed_Value :
3216 Make_Type_Conversion (Loc,
3217 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
3218 Expression => Relocate_Node (First (Exprs))));
3219 Set_Etype (N, Entity (Pref));
3222 -- Note: it might appear that a properly analyzed unchecked conversion
3223 -- would be just fine here, but that's not the case, since the full
3224 -- range checks performed by the following call are critical.
3226 Apply_Type_Conversion_Checks (N);
3233 -- Transforms 'Floor into a call to the floating-point attribute
3234 -- function Floor in Fat_xxx (where xxx is the root type)
3236 when Attribute_Floor =>
3237 Expand_Fpt_Attribute_R (N);
3243 -- For the fixed-point type Typ:
3249 -- Result_Type (System.Fore (Universal_Real (Type'First)),
3250 -- Universal_Real (Type'Last))
3252 -- Note that we know that the type is a non-static subtype, or Fore
3253 -- would have itself been computed dynamically in Eval_Attribute.
3255 when Attribute_Fore => Fore : begin
3258 Make_Function_Call (Loc,
3259 Name => New_Occurrence_Of (RTE (RE_Fore), Loc),
3261 Parameter_Associations => New_List (
3262 Convert_To (Universal_Real,
3263 Make_Attribute_Reference (Loc,
3264 Prefix => New_Occurrence_Of (Ptyp, Loc),
3265 Attribute_Name => Name_First)),
3267 Convert_To (Universal_Real,
3268 Make_Attribute_Reference (Loc,
3269 Prefix => New_Occurrence_Of (Ptyp, Loc),
3270 Attribute_Name => Name_Last))))));
3272 Analyze_And_Resolve (N, Typ);
3279 -- Transforms 'Fraction into a call to the floating-point attribute
3280 -- function Fraction in Fat_xxx (where xxx is the root type)
3282 when Attribute_Fraction =>
3283 Expand_Fpt_Attribute_R (N);
3289 when Attribute_From_Any => From_Any : declare
3290 P_Type : constant Entity_Id := Etype (Pref);
3291 Decls : constant List_Id := New_List;
3294 Build_From_Any_Call (P_Type,
3295 Relocate_Node (First (Exprs)),
3297 Insert_Actions (N, Decls);
3298 Analyze_And_Resolve (N, P_Type);
3301 ----------------------
3302 -- Has_Same_Storage --
3303 ----------------------
3305 when Attribute_Has_Same_Storage => Has_Same_Storage : declare
3306 Loc : constant Source_Ptr := Sloc (N);
3308 X : constant Node_Id := Prefix (N);
3309 Y : constant Node_Id := First (Expressions (N));
3312 X_Addr, Y_Addr : Node_Id;
3313 -- Rhe expressions for their addresses
3315 X_Size, Y_Size : Node_Id;
3316 -- Rhe expressions for their sizes
3319 -- The attribute is expanded as:
3321 -- (X'address = Y'address)
3322 -- and then (X'Size = Y'Size)
3324 -- If both arguments have the same Etype the second conjunct can be
3328 Make_Attribute_Reference (Loc,
3329 Attribute_Name => Name_Address,
3330 Prefix => New_Copy_Tree (X));
3333 Make_Attribute_Reference (Loc,
3334 Attribute_Name => Name_Address,
3335 Prefix => New_Copy_Tree (Y));
3338 Make_Attribute_Reference (Loc,
3339 Attribute_Name => Name_Size,
3340 Prefix => New_Copy_Tree (X));
3343 Make_Attribute_Reference (Loc,
3344 Attribute_Name => Name_Size,
3345 Prefix => New_Copy_Tree (Y));
3347 if Etype (X) = Etype (Y) then
3350 Left_Opnd => X_Addr,
3351 Right_Opnd => Y_Addr)));
3357 Left_Opnd => X_Addr,
3358 Right_Opnd => Y_Addr),
3361 Left_Opnd => X_Size,
3362 Right_Opnd => Y_Size)));
3365 Analyze_And_Resolve (N, Standard_Boolean);
3366 end Has_Same_Storage;
3372 -- For an exception returns a reference to the exception data:
3373 -- Exception_Id!(Prefix'Reference)
3375 -- For a task it returns a reference to the _task_id component of
3376 -- corresponding record:
3378 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
3380 -- in Ada.Task_Identification
3382 when Attribute_Identity => Identity : declare
3383 Id_Kind : Entity_Id;
3386 if Ptyp = Standard_Exception_Type then
3387 Id_Kind := RTE (RE_Exception_Id);
3389 if Present (Renamed_Object (Entity (Pref))) then
3390 Set_Entity (Pref, Renamed_Object (Entity (Pref)));
3394 Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref)));
3396 Id_Kind := RTE (RO_AT_Task_Id);
3398 -- If the prefix is a task interface, the Task_Id is obtained
3399 -- dynamically through a dispatching call, as for other task
3400 -- attributes applied to interfaces.
3402 if Ada_Version >= Ada_2005
3403 and then Ekind (Ptyp) = E_Class_Wide_Type
3404 and then Is_Interface (Ptyp)
3405 and then Is_Task_Interface (Ptyp)
3408 Unchecked_Convert_To (Id_Kind,
3409 Make_Selected_Component (Loc,
3411 New_Copy_Tree (Pref),
3413 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))));
3417 Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
3421 Analyze_And_Resolve (N, Id_Kind);
3428 -- Image attribute is handled in separate unit Exp_Imgv
3430 when Attribute_Image =>
3431 Exp_Imgv.Expand_Image_Attribute (N);
3437 -- X'Img is expanded to typ'Image (X), where typ is the type of X
3439 when Attribute_Img => Img :
3442 Make_Attribute_Reference (Loc,
3443 Prefix => New_Occurrence_Of (Ptyp, Loc),
3444 Attribute_Name => Name_Image,
3445 Expressions => New_List (Relocate_Node (Pref))));
3447 Analyze_And_Resolve (N, Standard_String);
3454 when Attribute_Input => Input : declare
3455 P_Type : constant Entity_Id := Entity (Pref);
3456 B_Type : constant Entity_Id := Base_Type (P_Type);
3457 U_Type : constant Entity_Id := Underlying_Type (P_Type);
3458 Strm : constant Node_Id := First (Exprs);
3466 Cntrl : Node_Id := Empty;
3467 -- Value for controlling argument in call. Always Empty except in
3468 -- the dispatching (class-wide type) case, where it is a reference
3469 -- to the dummy object initialized to the right internal tag.
3471 procedure Freeze_Stream_Subprogram (F : Entity_Id);
3472 -- The expansion of the attribute reference may generate a call to
3473 -- a user-defined stream subprogram that is frozen by the call. This
3474 -- can lead to access-before-elaboration problem if the reference
3475 -- appears in an object declaration and the subprogram body has not
3476 -- been seen. The freezing of the subprogram requires special code
3477 -- because it appears in an expanded context where expressions do
3478 -- not freeze their constituents.
3480 ------------------------------
3481 -- Freeze_Stream_Subprogram --
3482 ------------------------------
3484 procedure Freeze_Stream_Subprogram (F : Entity_Id) is
3485 Decl : constant Node_Id := Unit_Declaration_Node (F);
3489 -- If this is user-defined subprogram, the corresponding
3490 -- stream function appears as a renaming-as-body, and the
3491 -- user subprogram must be retrieved by tree traversal.
3494 and then Nkind (Decl) = N_Subprogram_Declaration
3495 and then Present (Corresponding_Body (Decl))
3497 Bod := Corresponding_Body (Decl);
3499 if Nkind (Unit_Declaration_Node (Bod)) =
3500 N_Subprogram_Renaming_Declaration
3502 Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod))));
3505 end Freeze_Stream_Subprogram;
3507 -- Start of processing for Input
3510 -- If no underlying type, we have an error that will be diagnosed
3511 -- elsewhere, so here we just completely ignore the expansion.
3517 -- Stream operations can appear in user code even if the restriction
3518 -- No_Streams is active (for example, when instantiating a predefined
3519 -- container). In that case rewrite the attribute as a Raise to
3520 -- prevent any run-time use.
3522 if Restriction_Active (No_Streams) then
3524 Make_Raise_Program_Error (Sloc (N),
3525 Reason => PE_Stream_Operation_Not_Allowed));
3526 Set_Etype (N, B_Type);
3530 -- If there is a TSS for Input, just call it
3532 Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
3534 if Present (Fname) then
3538 -- If there is a Stream_Convert pragma, use it, we rewrite
3540 -- sourcetyp'Input (stream)
3544 -- sourcetyp (streamread (strmtyp'Input (stream)));
3546 -- where streamread is the given Read function that converts an
3547 -- argument of type strmtyp to type sourcetyp or a type from which
3548 -- it is derived (extra conversion required for the derived case).
3550 Prag := Get_Stream_Convert_Pragma (P_Type);
3552 if Present (Prag) then
3553 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
3554 Rfunc := Entity (Expression (Arg2));
3558 Make_Function_Call (Loc,
3559 Name => New_Occurrence_Of (Rfunc, Loc),
3560 Parameter_Associations => New_List (
3561 Make_Attribute_Reference (Loc,
3564 (Etype (First_Formal (Rfunc)), Loc),
3565 Attribute_Name => Name_Input,
3566 Expressions => Exprs)))));
3568 Analyze_And_Resolve (N, B_Type);
3573 elsif Is_Elementary_Type (U_Type) then
3575 -- A special case arises if we have a defined _Read routine,
3576 -- since in this case we are required to call this routine.
3578 if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then
3579 Build_Record_Or_Elementary_Input_Function
3580 (Loc, U_Type, Decl, Fname);
3581 Insert_Action (N, Decl);
3583 -- For normal cases, we call the I_xxx routine directly
3586 Rewrite (N, Build_Elementary_Input_Call (N));
3587 Analyze_And_Resolve (N, P_Type);
3593 elsif Is_Array_Type (U_Type) then
3594 Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
3595 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3597 -- Dispatching case with class-wide type
3599 elsif Is_Class_Wide_Type (P_Type) then
3601 -- No need to do anything else compiling under restriction
3602 -- No_Dispatching_Calls. During the semantic analysis we
3603 -- already notified such violation.
3605 if Restriction_Active (No_Dispatching_Calls) then
3610 Rtyp : constant Entity_Id := Root_Type (P_Type);
3614 -- Read the internal tag (RM 13.13.2(34)) and use it to
3615 -- initialize a dummy tag value:
3617 -- Descendant_Tag (String'Input (Strm), P_Type);
3619 -- This value is used only to provide a controlling
3620 -- argument for the eventual _Input call. Descendant_Tag is
3621 -- called rather than Internal_Tag to ensure that we have a
3622 -- tag for a type that is descended from the prefix type and
3623 -- declared at the same accessibility level (the exception
3624 -- Tag_Error will be raised otherwise). The level check is
3625 -- required for Ada 2005 because tagged types can be
3626 -- extended in nested scopes (AI-344).
3628 -- Note: we used to generate an explicit declaration of a
3629 -- constant Ada.Tags.Tag object, and use an occurrence of
3630 -- this constant in Cntrl, but this caused a secondary stack
3634 Make_Function_Call (Loc,
3636 New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
3637 Parameter_Associations => New_List (
3638 Make_Attribute_Reference (Loc,
3640 New_Occurrence_Of (Standard_String, Loc),
3641 Attribute_Name => Name_Input,
3642 Expressions => New_List (
3643 Relocate_Node (Duplicate_Subexpr (Strm)))),
3644 Make_Attribute_Reference (Loc,
3645 Prefix => New_Occurrence_Of (P_Type, Loc),
3646 Attribute_Name => Name_Tag)));
3647 Set_Etype (Expr, RTE (RE_Tag));
3649 -- Now we need to get the entity for the call, and construct
3650 -- a function call node, where we preset a reference to Dnn
3651 -- as the controlling argument (doing an unchecked convert
3652 -- to the class-wide tagged type to make it look like a real
3655 Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
3656 Cntrl := Unchecked_Convert_To (P_Type, Expr);
3657 Set_Etype (Cntrl, P_Type);
3658 Set_Parent (Cntrl, N);
3661 -- For tagged types, use the primitive Input function
3663 elsif Is_Tagged_Type (U_Type) then
3664 Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
3666 -- All other record type cases, including protected records. The
3667 -- latter only arise for expander generated code for handling
3668 -- shared passive partition access.
3672 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
3674 -- Ada 2005 (AI-216): Program_Error is raised executing default
3675 -- implementation of the Input attribute of an unchecked union
3676 -- type if the type lacks default discriminant values.
3678 if Is_Unchecked_Union (Base_Type (U_Type))
3679 and then No (Discriminant_Constraint (U_Type))
3682 Make_Raise_Program_Error (Loc,
3683 Reason => PE_Unchecked_Union_Restriction));
3688 -- Build the type's Input function, passing the subtype rather
3689 -- than its base type, because checks are needed in the case of
3690 -- constrained discriminants (see Ada 2012 AI05-0192).
3692 Build_Record_Or_Elementary_Input_Function
3693 (Loc, U_Type, Decl, Fname);
3694 Insert_Action (N, Decl);
3696 if Nkind (Parent (N)) = N_Object_Declaration
3697 and then Is_Record_Type (U_Type)
3699 -- The stream function may contain calls to user-defined
3700 -- Read procedures for individual components.
3707 Comp := First_Component (U_Type);
3708 while Present (Comp) loop
3710 Find_Stream_Subprogram
3711 (Etype (Comp), TSS_Stream_Read);
3713 if Present (Func) then
3714 Freeze_Stream_Subprogram (Func);
3717 Next_Component (Comp);
3724 -- If we fall through, Fname is the function to be called. The result
3725 -- is obtained by calling the appropriate function, then converting
3726 -- the result. The conversion does a subtype check.
3729 Make_Function_Call (Loc,
3730 Name => New_Occurrence_Of (Fname, Loc),
3731 Parameter_Associations => New_List (
3732 Relocate_Node (Strm)));
3734 Set_Controlling_Argument (Call, Cntrl);
3735 Rewrite (N, Unchecked_Convert_To (P_Type, Call));
3736 Analyze_And_Resolve (N, P_Type);
3738 if Nkind (Parent (N)) = N_Object_Declaration then
3739 Freeze_Stream_Subprogram (Fname);
3749 -- inttype'Fixed_Value (fixed-value)
3753 -- inttype(integer-value))
3755 -- we do all the required analysis of the conversion here, because we do
3756 -- not want this to go through the fixed-point conversion circuits. Note
3757 -- that the back end always treats fixed-point as equivalent to the
3758 -- corresponding integer type anyway.
3760 when Attribute_Integer_Value => Integer_Value :
3763 Make_Type_Conversion (Loc,
3764 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
3765 Expression => Relocate_Node (First (Exprs))));
3766 Set_Etype (N, Entity (Pref));
3769 -- Note: it might appear that a properly analyzed unchecked conversion
3770 -- would be just fine here, but that's not the case, since the full
3771 -- range checks performed by the following call are critical.
3773 Apply_Type_Conversion_Checks (N);
3780 when Attribute_Invalid_Value =>
3781 Rewrite (N, Get_Simple_Init_Val (Ptyp, N));
3787 when Attribute_Last =>
3789 -- If the prefix type is a constrained packed array type which
3790 -- already has a Packed_Array_Impl_Type representation defined, then
3791 -- replace this attribute with a direct reference to 'Last of the
3792 -- appropriate index subtype (since otherwise the back end will try
3793 -- to give us the value of 'Last for this implementation type).
3795 if Is_Constrained_Packed_Array (Ptyp) then
3797 Make_Attribute_Reference (Loc,
3798 Attribute_Name => Name_Last,
3799 Prefix => New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
3800 Analyze_And_Resolve (N, Typ);
3802 -- For access type, apply access check as needed
3804 elsif Is_Access_Type (Ptyp) then
3805 Apply_Access_Check (N);
3807 -- For scalar type, if low bound is a reference to an entity, just
3808 -- replace with a direct reference. Note that we can only have a
3809 -- reference to a constant entity at this stage, anything else would
3810 -- have already been rewritten.
3812 elsif Is_Scalar_Type (Ptyp) then
3814 Hi : constant Node_Id := Type_High_Bound (Ptyp);
3816 if Is_Entity_Name (Hi) then
3817 Rewrite (N, New_Occurrence_Of (Entity (Hi), Loc));
3826 -- We compute this if a component clause was present, otherwise we leave
3827 -- the computation up to the back end, since we don't know what layout
3830 when Attribute_Last_Bit => Last_Bit_Attr : declare
3831 CE : constant Entity_Id := Entity (Selector_Name (Pref));
3834 -- In Ada 2005 (or later) if we have the non-default bit order, then
3835 -- we return the original value as given in the component clause
3836 -- (RM 2005 13.5.2(3/2)).
3838 if Present (Component_Clause (CE))
3839 and then Ada_Version >= Ada_2005
3840 and then Reverse_Bit_Order (Scope (CE))
3843 Make_Integer_Literal (Loc,
3844 Intval => Expr_Value (Last_Bit (Component_Clause (CE)))));
3845 Analyze_And_Resolve (N, Typ);
3847 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3848 -- rewrite with normalized value if we know it statically.
3850 elsif Known_Static_Component_Bit_Offset (CE)
3851 and then Known_Static_Esize (CE)
3854 Make_Integer_Literal (Loc,
3855 Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
3857 Analyze_And_Resolve (N, Typ);
3859 -- Otherwise leave to back end, just apply universal integer checks
3862 Apply_Universal_Integer_Attribute_Checks (N);
3870 -- Transforms 'Leading_Part into a call to the floating-point attribute
3871 -- function Leading_Part in Fat_xxx (where xxx is the root type)
3873 -- Note: strictly, we should generate special case code to deal with
3874 -- absurdly large positive arguments (greater than Integer'Last), which
3875 -- result in returning the first argument unchanged, but it hardly seems
3876 -- worth the effort. We raise constraint error for absurdly negative
3877 -- arguments which is fine.
3879 when Attribute_Leading_Part =>
3880 Expand_Fpt_Attribute_RI (N);
3886 when Attribute_Length => Length : declare
3891 -- Processing for packed array types
3893 if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
3894 Ityp := Get_Index_Subtype (N);
3896 -- If the index type, Ityp, is an enumeration type with holes,
3897 -- then we calculate X'Length explicitly using
3900 -- (0, Ityp'Pos (X'Last (N)) -
3901 -- Ityp'Pos (X'First (N)) + 1);
3903 -- Since the bounds in the template are the representation values
3904 -- and the back end would get the wrong value.
3906 if Is_Enumeration_Type (Ityp)
3907 and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
3912 Xnum := Expr_Value (First (Expressions (N)));
3916 Make_Attribute_Reference (Loc,
3917 Prefix => New_Occurrence_Of (Typ, Loc),
3918 Attribute_Name => Name_Max,
3919 Expressions => New_List
3920 (Make_Integer_Literal (Loc, 0),
3924 Make_Op_Subtract (Loc,
3926 Make_Attribute_Reference (Loc,
3927 Prefix => New_Occurrence_Of (Ityp, Loc),
3928 Attribute_Name => Name_Pos,
3930 Expressions => New_List (
3931 Make_Attribute_Reference (Loc,
3932 Prefix => Duplicate_Subexpr (Pref),
3933 Attribute_Name => Name_Last,
3934 Expressions => New_List (
3935 Make_Integer_Literal (Loc, Xnum))))),
3938 Make_Attribute_Reference (Loc,
3939 Prefix => New_Occurrence_Of (Ityp, Loc),
3940 Attribute_Name => Name_Pos,
3942 Expressions => New_List (
3943 Make_Attribute_Reference (Loc,
3945 Duplicate_Subexpr_No_Checks (Pref),
3946 Attribute_Name => Name_First,
3947 Expressions => New_List (
3948 Make_Integer_Literal (Loc, Xnum)))))),
3950 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
3952 Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
3955 -- If the prefix type is a constrained packed array type which
3956 -- already has a Packed_Array_Impl_Type representation defined,
3957 -- then replace this attribute with a reference to 'Range_Length
3958 -- of the appropriate index subtype (since otherwise the
3959 -- back end will try to give us the value of 'Length for
3960 -- this implementation type).s
3962 elsif Is_Constrained (Ptyp) then
3964 Make_Attribute_Reference (Loc,
3965 Attribute_Name => Name_Range_Length,
3966 Prefix => New_Occurrence_Of (Ityp, Loc)));
3967 Analyze_And_Resolve (N, Typ);
3972 elsif Is_Access_Type (Ptyp) then
3973 Apply_Access_Check (N);
3975 -- If the designated type is a packed array type, then we convert
3976 -- the reference to:
3979 -- xtyp'Pos (Pref'Last (Expr)) -
3980 -- xtyp'Pos (Pref'First (Expr)));
3982 -- This is a bit complex, but it is the easiest thing to do that
3983 -- works in all cases including enum types with holes xtyp here
3984 -- is the appropriate index type.
3987 Dtyp : constant Entity_Id := Designated_Type (Ptyp);
3991 if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
3992 Xtyp := Get_Index_Subtype (N);
3995 Make_Attribute_Reference (Loc,
3996 Prefix => New_Occurrence_Of (Typ, Loc),
3997 Attribute_Name => Name_Max,
3998 Expressions => New_List (
3999 Make_Integer_Literal (Loc, 0),
4002 Make_Integer_Literal (Loc, 1),
4003 Make_Op_Subtract (Loc,
4005 Make_Attribute_Reference (Loc,
4006 Prefix => New_Occurrence_Of (Xtyp, Loc),
4007 Attribute_Name => Name_Pos,
4008 Expressions => New_List (
4009 Make_Attribute_Reference (Loc,
4010 Prefix => Duplicate_Subexpr (Pref),
4011 Attribute_Name => Name_Last,
4013 New_Copy_List (Exprs)))),
4016 Make_Attribute_Reference (Loc,
4017 Prefix => New_Occurrence_Of (Xtyp, Loc),
4018 Attribute_Name => Name_Pos,
4019 Expressions => New_List (
4020 Make_Attribute_Reference (Loc,
4022 Duplicate_Subexpr_No_Checks (Pref),
4023 Attribute_Name => Name_First,
4025 New_Copy_List (Exprs)))))))));
4027 Analyze_And_Resolve (N, Typ);
4031 -- Otherwise leave it to the back end
4034 Apply_Universal_Integer_Attribute_Checks (N);
4038 -- Attribute Loop_Entry is replaced with a reference to a constant value
4039 -- which captures the prefix at the entry point of the related loop. The
4040 -- loop itself may be transformed into a conditional block.
4042 when Attribute_Loop_Entry =>
4043 Expand_Loop_Entry_Attribute (N);
4049 -- Transforms 'Machine into a call to the floating-point attribute
4050 -- function Machine in Fat_xxx (where xxx is the root type).
4051 -- Expansion is avoided for cases the back end can handle directly.
4053 when Attribute_Machine =>
4054 if not Is_Inline_Floating_Point_Attribute (N) then
4055 Expand_Fpt_Attribute_R (N);
4058 ----------------------
4059 -- Machine_Rounding --
4060 ----------------------
4062 -- Transforms 'Machine_Rounding into a call to the floating-point
4063 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
4064 -- type). Expansion is avoided for cases the back end can handle
4067 when Attribute_Machine_Rounding =>
4068 if not Is_Inline_Floating_Point_Attribute (N) then
4069 Expand_Fpt_Attribute_R (N);
4076 -- Machine_Size is equivalent to Object_Size, so transform it into
4077 -- Object_Size and that way the back end never sees Machine_Size.
4079 when Attribute_Machine_Size =>
4081 Make_Attribute_Reference (Loc,
4082 Prefix => Prefix (N),
4083 Attribute_Name => Name_Object_Size));
4085 Analyze_And_Resolve (N, Typ);
4091 -- The only case that can get this far is the dynamic case of the old
4092 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
4099 -- ityp (System.Mantissa.Mantissa_Value
4100 -- (Integer'Integer_Value (typ'First),
4101 -- Integer'Integer_Value (typ'Last)));
4103 when Attribute_Mantissa => Mantissa : begin
4106 Make_Function_Call (Loc,
4107 Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
4109 Parameter_Associations => New_List (
4111 Make_Attribute_Reference (Loc,
4112 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
4113 Attribute_Name => Name_Integer_Value,
4114 Expressions => New_List (
4116 Make_Attribute_Reference (Loc,
4117 Prefix => New_Occurrence_Of (Ptyp, Loc),
4118 Attribute_Name => Name_First))),
4120 Make_Attribute_Reference (Loc,
4121 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
4122 Attribute_Name => Name_Integer_Value,
4123 Expressions => New_List (
4125 Make_Attribute_Reference (Loc,
4126 Prefix => New_Occurrence_Of (Ptyp, Loc),
4127 Attribute_Name => Name_Last)))))));
4129 Analyze_And_Resolve (N, Typ);
4136 when Attribute_Max =>
4137 Expand_Min_Max_Attribute (N);
4139 ----------------------------------
4140 -- Max_Size_In_Storage_Elements --
4141 ----------------------------------
4143 when Attribute_Max_Size_In_Storage_Elements => declare
4144 Typ : constant Entity_Id := Etype (N);
4147 Conversion_Added : Boolean := False;
4148 -- A flag which tracks whether the original attribute has been
4149 -- wrapped inside a type conversion.
4152 -- If the prefix is X'Class, we transform it into a direct reference
4153 -- to the class-wide type, because the back end must not see a 'Class
4154 -- reference. See also 'Size.
4156 if Is_Entity_Name (Pref)
4157 and then Is_Class_Wide_Type (Entity (Pref))
4159 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
4163 Apply_Universal_Integer_Attribute_Checks (N);
4165 -- The universal integer check may sometimes add a type conversion,
4166 -- retrieve the original attribute reference from the expression.
4170 if Nkind (Attr) = N_Type_Conversion then
4171 Attr := Expression (Attr);
4172 Conversion_Added := True;
4175 pragma Assert (Nkind (Attr) = N_Attribute_Reference);
4177 -- Heap-allocated controlled objects contain two extra pointers which
4178 -- are not part of the actual type. Transform the attribute reference
4179 -- into a runtime expression to add the size of the hidden header.
4181 if Needs_Finalization (Ptyp)
4182 and then not Header_Size_Added (Attr)
4184 Set_Header_Size_Added (Attr);
4187 -- P'Max_Size_In_Storage_Elements +
4188 -- Universal_Integer
4189 -- (Header_Size_With_Padding (Ptyp'Alignment))
4193 Left_Opnd => Relocate_Node (Attr),
4195 Convert_To (Universal_Integer,
4196 Make_Function_Call (Loc,
4199 (RTE (RE_Header_Size_With_Padding), Loc),
4201 Parameter_Associations => New_List (
4202 Make_Attribute_Reference (Loc,
4204 New_Occurrence_Of (Ptyp, Loc),
4205 Attribute_Name => Name_Alignment))))));
4207 -- Add a conversion to the target type
4209 if not Conversion_Added then
4211 Make_Type_Conversion (Loc,
4212 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4213 Expression => Relocate_Node (Attr)));
4221 --------------------
4222 -- Mechanism_Code --
4223 --------------------
4225 when Attribute_Mechanism_Code =>
4227 -- We must replace the prefix i the renamed case
4229 if Is_Entity_Name (Pref)
4230 and then Present (Alias (Entity (Pref)))
4232 Set_Renamed_Subprogram (Pref, Alias (Entity (Pref)));
4239 when Attribute_Min =>
4240 Expand_Min_Max_Attribute (N);
4246 when Attribute_Mod => Mod_Case : declare
4247 Arg : constant Node_Id := Relocate_Node (First (Exprs));
4248 Hi : constant Node_Id := Type_High_Bound (Etype (Arg));
4249 Modv : constant Uint := Modulus (Btyp);
4253 -- This is not so simple. The issue is what type to use for the
4254 -- computation of the modular value.
4256 -- The easy case is when the modulus value is within the bounds
4257 -- of the signed integer type of the argument. In this case we can
4258 -- just do the computation in that signed integer type, and then
4259 -- do an ordinary conversion to the target type.
4261 if Modv <= Expr_Value (Hi) then
4266 Right_Opnd => Make_Integer_Literal (Loc, Modv))));
4268 -- Here we know that the modulus is larger than type'Last of the
4269 -- integer type. There are two cases to consider:
4271 -- a) The integer value is non-negative. In this case, it is
4272 -- returned as the result (since it is less than the modulus).
4274 -- b) The integer value is negative. In this case, we know that the
4275 -- result is modulus + value, where the value might be as small as
4276 -- -modulus. The trouble is what type do we use to do the subtract.
4277 -- No type will do, since modulus can be as big as 2**64, and no
4278 -- integer type accommodates this value. Let's do bit of algebra
4281 -- = modulus - (-value)
4282 -- = (modulus - 1) - (-value - 1)
4284 -- Now modulus - 1 is certainly in range of the modular type.
4285 -- -value is in the range 1 .. modulus, so -value -1 is in the
4286 -- range 0 .. modulus-1 which is in range of the modular type.
4287 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
4288 -- which we can compute using the integer base type.
4290 -- Once this is done we analyze the if expression without range
4291 -- checks, because we know everything is in range, and we want
4292 -- to prevent spurious warnings on either branch.
4296 Make_If_Expression (Loc,
4297 Expressions => New_List (
4299 Left_Opnd => Duplicate_Subexpr (Arg),
4300 Right_Opnd => Make_Integer_Literal (Loc, 0)),
4303 Duplicate_Subexpr_No_Checks (Arg)),
4305 Make_Op_Subtract (Loc,
4307 Make_Integer_Literal (Loc,
4308 Intval => Modv - 1),
4314 Left_Opnd => Duplicate_Subexpr_No_Checks (Arg),
4316 Make_Integer_Literal (Loc,
4317 Intval => 1))))))));
4321 Analyze_And_Resolve (N, Btyp, Suppress => All_Checks);
4328 -- Transforms 'Model into a call to the floating-point attribute
4329 -- function Model in Fat_xxx (where xxx is the root type).
4330 -- Expansion is avoided for cases the back end can handle directly.
4332 when Attribute_Model =>
4333 if not Is_Inline_Floating_Point_Attribute (N) then
4334 Expand_Fpt_Attribute_R (N);
4341 -- The processing for Object_Size shares the processing for Size
4347 when Attribute_Old => Old : declare
4348 Typ : constant Entity_Id := Etype (N);
4349 CW_Temp : Entity_Id;
4355 -- Climb the parent chain looking for subprogram _Postconditions
4358 while Present (Subp) loop
4359 exit when Nkind (Subp) = N_Subprogram_Body
4360 and then Chars (Defining_Entity (Subp)) = Name_uPostconditions;
4362 -- If assertions are disabled, no need to create the declaration
4363 -- that preserves the value. The postcondition pragma in which
4364 -- 'Old appears will be checked or disabled according to the
4365 -- current policy in effect.
4367 if Nkind (Subp) = N_Pragma and then not Is_Checked (Subp) then
4371 Subp := Parent (Subp);
4374 -- 'Old can only appear in a postcondition, the generated body of
4375 -- _Postconditions must be in the tree.
4377 pragma Assert (Present (Subp));
4379 Temp := Make_Temporary (Loc, 'T', Pref);
4381 -- Set the entity kind now in order to mark the temporary as a
4382 -- handler of attribute 'Old's prefix.
4384 Set_Ekind (Temp, E_Constant);
4385 Set_Stores_Attribute_Old_Prefix (Temp);
4387 -- Push the scope of the related subprogram where _Postcondition
4388 -- resides as this ensures that the object will be analyzed in the
4391 Push_Scope (Scope (Defining_Entity (Subp)));
4393 -- Preserve the tag of the prefix by offering a specific view of the
4394 -- class-wide version of the prefix.
4396 if Is_Tagged_Type (Typ) then
4399 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
4401 CW_Temp := Make_Temporary (Loc, 'T');
4402 CW_Typ := Class_Wide_Type (Typ);
4404 Insert_Before_And_Analyze (Subp,
4405 Make_Object_Declaration (Loc,
4406 Defining_Identifier => CW_Temp,
4407 Constant_Present => True,
4408 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
4410 Convert_To (CW_Typ, Relocate_Node (Pref))));
4413 -- Temp : Typ renames Typ (CW_Temp);
4415 Insert_Before_And_Analyze (Subp,
4416 Make_Object_Renaming_Declaration (Loc,
4417 Defining_Identifier => Temp,
4418 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4420 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))));
4426 -- Temp : constant Typ := Pref;
4428 Insert_Before_And_Analyze (Subp,
4429 Make_Object_Declaration (Loc,
4430 Defining_Identifier => Temp,
4431 Constant_Present => True,
4432 Object_Definition => New_Occurrence_Of (Typ, Loc),
4433 Expression => Relocate_Node (Pref)));
4438 -- Ensure that the prefix of attribute 'Old is valid. The check must
4439 -- be inserted after the expansion of the attribute has taken place
4440 -- to reflect the new placement of the prefix.
4442 if Validity_Checks_On and then Validity_Check_Operands then
4443 Ensure_Valid (Pref);
4446 Rewrite (N, New_Occurrence_Of (Temp, Loc));
4449 ----------------------
4450 -- Overlaps_Storage --
4451 ----------------------
4453 when Attribute_Overlaps_Storage => Overlaps_Storage : declare
4454 Loc : constant Source_Ptr := Sloc (N);
4456 X : constant Node_Id := Prefix (N);
4457 Y : constant Node_Id := First (Expressions (N));
4460 X_Addr, Y_Addr : Node_Id;
4461 -- the expressions for their integer addresses
4463 X_Size, Y_Size : Node_Id;
4464 -- the expressions for their sizes
4469 -- Attribute expands into:
4471 -- if X'Address < Y'address then
4472 -- (X'address + X'Size - 1) >= Y'address
4474 -- (Y'address + Y'size - 1) >= X'Address
4477 -- with the proper address operations. We convert addresses to
4478 -- integer addresses to use predefined arithmetic. The size is
4479 -- expressed in storage units.
4482 Unchecked_Convert_To (RTE (RE_Integer_Address),
4483 Make_Attribute_Reference (Loc,
4484 Attribute_Name => Name_Address,
4485 Prefix => New_Copy_Tree (X)));
4488 Unchecked_Convert_To (RTE (RE_Integer_Address),
4489 Make_Attribute_Reference (Loc,
4490 Attribute_Name => Name_Address,
4491 Prefix => New_Copy_Tree (Y)));
4494 Make_Op_Divide (Loc,
4496 Make_Attribute_Reference (Loc,
4497 Attribute_Name => Name_Size,
4498 Prefix => New_Copy_Tree (X)),
4500 Make_Integer_Literal (Loc, System_Storage_Unit));
4503 Make_Op_Divide (Loc,
4505 Make_Attribute_Reference (Loc,
4506 Attribute_Name => Name_Size,
4507 Prefix => New_Copy_Tree (Y)),
4509 Make_Integer_Literal (Loc, System_Storage_Unit));
4513 Left_Opnd => X_Addr,
4514 Right_Opnd => Y_Addr);
4517 Make_If_Expression (Loc,
4524 Left_Opnd => X_Addr,
4526 Make_Op_Subtract (Loc,
4527 Left_Opnd => X_Size,
4528 Right_Opnd => Make_Integer_Literal (Loc, 1))),
4529 Right_Opnd => Y_Addr),
4533 Left_Opnd => Y_Addr,
4535 Make_Op_Subtract (Loc,
4536 Left_Opnd => Y_Size,
4537 Right_Opnd => Make_Integer_Literal (Loc, 1))),
4538 Right_Opnd => X_Addr))));
4540 Analyze_And_Resolve (N, Standard_Boolean);
4541 end Overlaps_Storage;
4547 when Attribute_Output => Output : declare
4548 P_Type : constant Entity_Id := Entity (Pref);
4549 U_Type : constant Entity_Id := Underlying_Type (P_Type);
4557 -- If no underlying type, we have an error that will be diagnosed
4558 -- elsewhere, so here we just completely ignore the expansion.
4564 -- Stream operations can appear in user code even if the restriction
4565 -- No_Streams is active (for example, when instantiating a predefined
4566 -- container). In that case rewrite the attribute as a Raise to
4567 -- prevent any run-time use.
4569 if Restriction_Active (No_Streams) then
4571 Make_Raise_Program_Error (Sloc (N),
4572 Reason => PE_Stream_Operation_Not_Allowed));
4573 Set_Etype (N, Standard_Void_Type);
4577 -- If TSS for Output is present, just call it
4579 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
4581 if Present (Pname) then
4585 -- If there is a Stream_Convert pragma, use it, we rewrite
4587 -- sourcetyp'Output (stream, Item)
4591 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
4593 -- where strmwrite is the given Write function that converts an
4594 -- argument of type sourcetyp or a type acctyp, from which it is
4595 -- derived to type strmtyp. The conversion to acttyp is required
4596 -- for the derived case.
4598 Prag := Get_Stream_Convert_Pragma (P_Type);
4600 if Present (Prag) then
4602 Next (Next (First (Pragma_Argument_Associations (Prag))));
4603 Wfunc := Entity (Expression (Arg3));
4606 Make_Attribute_Reference (Loc,
4607 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
4608 Attribute_Name => Name_Output,
4609 Expressions => New_List (
4610 Relocate_Node (First (Exprs)),
4611 Make_Function_Call (Loc,
4612 Name => New_Occurrence_Of (Wfunc, Loc),
4613 Parameter_Associations => New_List (
4614 OK_Convert_To (Etype (First_Formal (Wfunc)),
4615 Relocate_Node (Next (First (Exprs)))))))));
4620 -- For elementary types, we call the W_xxx routine directly. Note
4621 -- that the effect of Write and Output is identical for the case
4622 -- of an elementary type (there are no discriminants or bounds).
4624 elsif Is_Elementary_Type (U_Type) then
4626 -- A special case arises if we have a defined _Write routine,
4627 -- since in this case we are required to call this routine.
4629 if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then
4630 Build_Record_Or_Elementary_Output_Procedure
4631 (Loc, U_Type, Decl, Pname);
4632 Insert_Action (N, Decl);
4634 -- For normal cases, we call the W_xxx routine directly
4637 Rewrite (N, Build_Elementary_Write_Call (N));
4644 elsif Is_Array_Type (U_Type) then
4645 Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
4646 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
4648 -- Class-wide case, first output external tag, then dispatch
4649 -- to the appropriate primitive Output function (RM 13.13.2(31)).
4651 elsif Is_Class_Wide_Type (P_Type) then
4653 -- No need to do anything else compiling under restriction
4654 -- No_Dispatching_Calls. During the semantic analysis we
4655 -- already notified such violation.
4657 if Restriction_Active (No_Dispatching_Calls) then
4662 Strm : constant Node_Id := First (Exprs);
4663 Item : constant Node_Id := Next (Strm);
4666 -- Ada 2005 (AI-344): Check that the accessibility level
4667 -- of the type of the output object is not deeper than
4668 -- that of the attribute's prefix type.
4670 -- if Get_Access_Level (Item'Tag)
4671 -- /= Get_Access_Level (P_Type'Tag)
4676 -- String'Output (Strm, External_Tag (Item'Tag));
4678 -- We cannot figure out a practical way to implement this
4679 -- accessibility check on virtual machines, so we omit it.
4681 if Ada_Version >= Ada_2005
4682 and then Tagged_Type_Expansion
4685 Make_Implicit_If_Statement (N,
4689 Build_Get_Access_Level (Loc,
4690 Make_Attribute_Reference (Loc,
4693 Duplicate_Subexpr (Item,
4695 Attribute_Name => Name_Tag)),
4698 Make_Integer_Literal (Loc,
4699 Type_Access_Level (P_Type))),
4702 New_List (Make_Raise_Statement (Loc,
4704 RTE (RE_Tag_Error), Loc)))));
4708 Make_Attribute_Reference (Loc,
4709 Prefix => New_Occurrence_Of (Standard_String, Loc),
4710 Attribute_Name => Name_Output,
4711 Expressions => New_List (
4712 Relocate_Node (Duplicate_Subexpr (Strm)),
4713 Make_Function_Call (Loc,
4715 New_Occurrence_Of (RTE (RE_External_Tag), Loc),
4716 Parameter_Associations => New_List (
4717 Make_Attribute_Reference (Loc,
4720 (Duplicate_Subexpr (Item, Name_Req => True)),
4721 Attribute_Name => Name_Tag))))));
4724 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
4726 -- Tagged type case, use the primitive Output function
4728 elsif Is_Tagged_Type (U_Type) then
4729 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
4731 -- All other record type cases, including protected records.
4732 -- The latter only arise for expander generated code for
4733 -- handling shared passive partition access.
4737 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
4739 -- Ada 2005 (AI-216): Program_Error is raised when executing
4740 -- the default implementation of the Output attribute of an
4741 -- unchecked union type if the type lacks default discriminant
4744 if Is_Unchecked_Union (Base_Type (U_Type))
4745 and then No (Discriminant_Constraint (U_Type))
4748 Make_Raise_Program_Error (Loc,
4749 Reason => PE_Unchecked_Union_Restriction));
4754 Build_Record_Or_Elementary_Output_Procedure
4755 (Loc, Base_Type (U_Type), Decl, Pname);
4756 Insert_Action (N, Decl);
4760 -- If we fall through, Pname is the name of the procedure to call
4762 Rewrite_Stream_Proc_Call (Pname);
4769 -- For enumeration types with a standard representation, Pos is
4770 -- handled by the back end.
4772 -- For enumeration types, with a non-standard representation we generate
4773 -- a call to the _Rep_To_Pos function created when the type was frozen.
4774 -- The call has the form
4776 -- _rep_to_pos (expr, flag)
4778 -- The parameter flag is True if range checks are enabled, causing
4779 -- Program_Error to be raised if the expression has an invalid
4780 -- representation, and False if range checks are suppressed.
4782 -- For integer types, Pos is equivalent to a simple integer
4783 -- conversion and we rewrite it as such
4785 when Attribute_Pos => Pos :
4787 Etyp : Entity_Id := Base_Type (Entity (Pref));
4790 -- Deal with zero/non-zero boolean values
4792 if Is_Boolean_Type (Etyp) then
4793 Adjust_Condition (First (Exprs));
4794 Etyp := Standard_Boolean;
4795 Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
4798 -- Case of enumeration type
4800 if Is_Enumeration_Type (Etyp) then
4802 -- Non-standard enumeration type (generate call)
4804 if Present (Enum_Pos_To_Rep (Etyp)) then
4805 Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
4808 Make_Function_Call (Loc,
4810 New_Occurrence_Of (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4811 Parameter_Associations => Exprs)));
4813 Analyze_And_Resolve (N, Typ);
4815 -- Standard enumeration type (do universal integer check)
4818 Apply_Universal_Integer_Attribute_Checks (N);
4821 -- Deal with integer types (replace by conversion)
4823 elsif Is_Integer_Type (Etyp) then
4824 Rewrite (N, Convert_To (Typ, First (Exprs)));
4825 Analyze_And_Resolve (N, Typ);
4834 -- We compute this if a component clause was present, otherwise we leave
4835 -- the computation up to the back end, since we don't know what layout
4838 when Attribute_Position => Position_Attr :
4840 CE : constant Entity_Id := Entity (Selector_Name (Pref));
4843 if Present (Component_Clause (CE)) then
4845 -- In Ada 2005 (or later) if we have the non-default bit order,
4846 -- then we return the original value as given in the component
4847 -- clause (RM 2005 13.5.2(2/2)).
4849 if Ada_Version >= Ada_2005
4850 and then Reverse_Bit_Order (Scope (CE))
4853 Make_Integer_Literal (Loc,
4854 Intval => Expr_Value (Position (Component_Clause (CE)))));
4856 -- Otherwise (Ada 83 or 95, or default bit order specified in
4857 -- later Ada version), return the normalized value.
4861 Make_Integer_Literal (Loc,
4862 Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
4865 Analyze_And_Resolve (N, Typ);
4867 -- If back end is doing things, just apply universal integer checks
4870 Apply_Universal_Integer_Attribute_Checks (N);
4878 -- 1. Deal with enumeration types with holes.
4879 -- 2. For floating-point, generate call to attribute function.
4880 -- 3. For other cases, deal with constraint checking.
4882 when Attribute_Pred => Pred :
4884 Etyp : constant Entity_Id := Base_Type (Ptyp);
4888 -- For enumeration types with non-standard representations, we
4889 -- expand typ'Pred (x) into
4891 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
4893 -- If the representation is contiguous, we compute instead
4894 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
4895 -- The conversion function Enum_Pos_To_Rep is defined on the
4896 -- base type, not the subtype, so we have to use the base type
4897 -- explicitly for this and other enumeration attributes.
4899 if Is_Enumeration_Type (Ptyp)
4900 and then Present (Enum_Pos_To_Rep (Etyp))
4902 if Has_Contiguous_Rep (Etyp) then
4904 Unchecked_Convert_To (Ptyp,
4907 Make_Integer_Literal (Loc,
4908 Enumeration_Rep (First_Literal (Ptyp))),
4910 Make_Function_Call (Loc,
4913 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4915 Parameter_Associations =>
4917 Unchecked_Convert_To (Ptyp,
4918 Make_Op_Subtract (Loc,
4920 Unchecked_Convert_To (Standard_Integer,
4921 Relocate_Node (First (Exprs))),
4923 Make_Integer_Literal (Loc, 1))),
4924 Rep_To_Pos_Flag (Ptyp, Loc))))));
4927 -- Add Boolean parameter True, to request program errror if
4928 -- we have a bad representation on our hands. If checks are
4929 -- suppressed, then add False instead
4931 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
4933 Make_Indexed_Component (Loc,
4936 (Enum_Pos_To_Rep (Etyp), Loc),
4937 Expressions => New_List (
4938 Make_Op_Subtract (Loc,
4940 Make_Function_Call (Loc,
4943 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4944 Parameter_Associations => Exprs),
4945 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
4948 Analyze_And_Resolve (N, Typ);
4950 -- For floating-point, we transform 'Pred into a call to the Pred
4951 -- floating-point attribute function in Fat_xxx (xxx is root type).
4952 -- Note that this function takes care of the overflow case.
4954 elsif Is_Floating_Point_Type (Ptyp) then
4955 Expand_Fpt_Attribute_R (N);
4956 Analyze_And_Resolve (N, Typ);
4958 -- For modular types, nothing to do (no overflow, since wraps)
4960 elsif Is_Modular_Integer_Type (Ptyp) then
4963 -- For other types, if argument is marked as needing a range check or
4964 -- overflow checking is enabled, we must generate a check.
4966 elsif not Overflow_Checks_Suppressed (Ptyp)
4967 or else Do_Range_Check (First (Exprs))
4969 Set_Do_Range_Check (First (Exprs), False);
4970 Expand_Pred_Succ_Attribute (N);
4978 -- Ada 2005 (AI-327): Dynamic ceiling priorities
4980 -- We rewrite X'Priority as the following run-time call:
4982 -- Get_Ceiling (X._Object)
4984 -- Note that although X'Priority is notionally an object, it is quite
4985 -- deliberately not defined as an aliased object in the RM. This means
4986 -- that it works fine to rewrite it as a call, without having to worry
4987 -- about complications that would other arise from X'Priority'Access,
4988 -- which is illegal, because of the lack of aliasing.
4990 when Attribute_Priority =>
4993 Conctyp : Entity_Id;
4994 Object_Parm : Node_Id;
4996 RT_Subprg_Name : Node_Id;
4999 -- Look for the enclosing concurrent type
5001 Conctyp := Current_Scope;
5002 while not Is_Concurrent_Type (Conctyp) loop
5003 Conctyp := Scope (Conctyp);
5006 pragma Assert (Is_Protected_Type (Conctyp));
5008 -- Generate the actual of the call
5010 Subprg := Current_Scope;
5011 while not Present (Protected_Body_Subprogram (Subprg)) loop
5012 Subprg := Scope (Subprg);
5015 -- Use of 'Priority inside protected entries and barriers (in
5016 -- both cases the type of the first formal of their expanded
5017 -- subprogram is Address)
5019 if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) =
5023 New_Itype : Entity_Id;
5026 -- In the expansion of protected entries the type of the
5027 -- first formal of the Protected_Body_Subprogram is an
5028 -- Address. In order to reference the _object component
5031 -- type T is access p__ptTV;
5034 New_Itype := Create_Itype (E_Access_Type, N);
5035 Set_Etype (New_Itype, New_Itype);
5036 Set_Directly_Designated_Type (New_Itype,
5037 Corresponding_Record_Type (Conctyp));
5038 Freeze_Itype (New_Itype, N);
5041 -- T!(O)._object'unchecked_access
5044 Make_Attribute_Reference (Loc,
5046 Make_Selected_Component (Loc,
5048 Unchecked_Convert_To (New_Itype,
5051 (Protected_Body_Subprogram (Subprg)),
5054 Make_Identifier (Loc, Name_uObject)),
5055 Attribute_Name => Name_Unchecked_Access);
5058 -- Use of 'Priority inside a protected subprogram
5062 Make_Attribute_Reference (Loc,
5064 Make_Selected_Component (Loc,
5065 Prefix => New_Occurrence_Of
5067 (Protected_Body_Subprogram (Subprg)),
5069 Selector_Name => Make_Identifier (Loc, Name_uObject)),
5070 Attribute_Name => Name_Unchecked_Access);
5073 -- Select the appropriate run-time subprogram
5075 if Number_Entries (Conctyp) = 0 then
5077 New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc);
5080 New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc);
5084 Make_Function_Call (Loc,
5085 Name => RT_Subprg_Name,
5086 Parameter_Associations => New_List (Object_Parm));
5090 -- Avoid the generation of extra checks on the pointer to the
5091 -- protected object.
5093 Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
5100 when Attribute_Range_Length => Range_Length : begin
5102 -- The only special processing required is for the case where
5103 -- Range_Length is applied to an enumeration type with holes.
5104 -- In this case we transform
5110 -- X'Pos (X'Last) - X'Pos (X'First) + 1
5112 -- So that the result reflects the proper Pos values instead
5113 -- of the underlying representations.
5115 if Is_Enumeration_Type (Ptyp)
5116 and then Has_Non_Standard_Rep (Ptyp)
5121 Make_Op_Subtract (Loc,
5123 Make_Attribute_Reference (Loc,
5124 Attribute_Name => Name_Pos,
5125 Prefix => New_Occurrence_Of (Ptyp, Loc),
5126 Expressions => New_List (
5127 Make_Attribute_Reference (Loc,
5128 Attribute_Name => Name_Last,
5129 Prefix => New_Occurrence_Of (Ptyp, Loc)))),
5132 Make_Attribute_Reference (Loc,
5133 Attribute_Name => Name_Pos,
5134 Prefix => New_Occurrence_Of (Ptyp, Loc),
5135 Expressions => New_List (
5136 Make_Attribute_Reference (Loc,
5137 Attribute_Name => Name_First,
5138 Prefix => New_Occurrence_Of (Ptyp, Loc))))),
5140 Right_Opnd => Make_Integer_Literal (Loc, 1)));
5142 Analyze_And_Resolve (N, Typ);
5144 -- For all other cases, the attribute is handled by the back end, but
5145 -- we need to deal with the case of the range check on a universal
5149 Apply_Universal_Integer_Attribute_Checks (N);
5157 when Attribute_Read => Read : declare
5158 P_Type : constant Entity_Id := Entity (Pref);
5159 B_Type : constant Entity_Id := Base_Type (P_Type);
5160 U_Type : constant Entity_Id := Underlying_Type (P_Type);
5170 -- If no underlying type, we have an error that will be diagnosed
5171 -- elsewhere, so here we just completely ignore the expansion.
5177 -- Stream operations can appear in user code even if the restriction
5178 -- No_Streams is active (for example, when instantiating a predefined
5179 -- container). In that case rewrite the attribute as a Raise to
5180 -- prevent any run-time use.
5182 if Restriction_Active (No_Streams) then
5184 Make_Raise_Program_Error (Sloc (N),
5185 Reason => PE_Stream_Operation_Not_Allowed));
5186 Set_Etype (N, B_Type);
5190 -- The simple case, if there is a TSS for Read, just call it
5192 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
5194 if Present (Pname) then
5198 -- If there is a Stream_Convert pragma, use it, we rewrite
5200 -- sourcetyp'Read (stream, Item)
5204 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
5206 -- where strmread is the given Read function that converts an
5207 -- argument of type strmtyp to type sourcetyp or a type from which
5208 -- it is derived. The conversion to sourcetyp is required in the
5211 -- A special case arises if Item is a type conversion in which
5212 -- case, we have to expand to:
5214 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
5216 -- where Itemx is the expression of the type conversion (i.e.
5217 -- the actual object), and typex is the type of Itemx.
5219 Prag := Get_Stream_Convert_Pragma (P_Type);
5221 if Present (Prag) then
5222 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
5223 Rfunc := Entity (Expression (Arg2));
5224 Lhs := Relocate_Node (Next (First (Exprs)));
5226 OK_Convert_To (B_Type,
5227 Make_Function_Call (Loc,
5228 Name => New_Occurrence_Of (Rfunc, Loc),
5229 Parameter_Associations => New_List (
5230 Make_Attribute_Reference (Loc,
5233 (Etype (First_Formal (Rfunc)), Loc),
5234 Attribute_Name => Name_Input,
5235 Expressions => New_List (
5236 Relocate_Node (First (Exprs)))))));
5238 if Nkind (Lhs) = N_Type_Conversion then
5239 Lhs := Expression (Lhs);
5240 Rhs := Convert_To (Etype (Lhs), Rhs);
5244 Make_Assignment_Statement (Loc,
5246 Expression => Rhs));
5247 Set_Assignment_OK (Lhs);
5251 -- For elementary types, we call the I_xxx routine using the first
5252 -- parameter and then assign the result into the second parameter.
5253 -- We set Assignment_OK to deal with the conversion case.
5255 elsif Is_Elementary_Type (U_Type) then
5261 Lhs := Relocate_Node (Next (First (Exprs)));
5262 Rhs := Build_Elementary_Input_Call (N);
5264 if Nkind (Lhs) = N_Type_Conversion then
5265 Lhs := Expression (Lhs);
5266 Rhs := Convert_To (Etype (Lhs), Rhs);
5269 Set_Assignment_OK (Lhs);
5272 Make_Assignment_Statement (Loc,
5274 Expression => Rhs));
5282 elsif Is_Array_Type (U_Type) then
5283 Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
5284 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
5286 -- Tagged type case, use the primitive Read function. Note that
5287 -- this will dispatch in the class-wide case which is what we want
5289 elsif Is_Tagged_Type (U_Type) then
5290 Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
5292 -- All other record type cases, including protected records. The
5293 -- latter only arise for expander generated code for handling
5294 -- shared passive partition access.
5298 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
5300 -- Ada 2005 (AI-216): Program_Error is raised when executing
5301 -- the default implementation of the Read attribute of an
5302 -- Unchecked_Union type.
5304 if Is_Unchecked_Union (Base_Type (U_Type)) then
5306 Make_Raise_Program_Error (Loc,
5307 Reason => PE_Unchecked_Union_Restriction));
5310 if Has_Discriminants (U_Type)
5312 (Discriminant_Default_Value (First_Discriminant (U_Type)))
5314 Build_Mutable_Record_Read_Procedure
5315 (Loc, Full_Base (U_Type), Decl, Pname);
5317 Build_Record_Read_Procedure
5318 (Loc, Full_Base (U_Type), Decl, Pname);
5321 -- Suppress checks, uninitialized or otherwise invalid
5322 -- data does not cause constraint errors to be raised for
5323 -- a complete record read.
5325 Insert_Action (N, Decl, All_Checks);
5329 Rewrite_Stream_Proc_Call (Pname);
5336 -- Ref is identical to To_Address, see To_Address for processing
5342 -- Transforms 'Remainder into a call to the floating-point attribute
5343 -- function Remainder in Fat_xxx (where xxx is the root type)
5345 when Attribute_Remainder =>
5346 Expand_Fpt_Attribute_RR (N);
5352 -- Transform 'Result into reference to _Result formal. At the point
5353 -- where a legal 'Result attribute is expanded, we know that we are in
5354 -- the context of a _Postcondition function with a _Result parameter.
5356 when Attribute_Result =>
5357 Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult));
5358 Analyze_And_Resolve (N, Typ);
5364 -- The handling of the Round attribute is quite delicate. The processing
5365 -- in Sem_Attr introduced a conversion to universal real, reflecting the
5366 -- semantics of Round, but we do not want anything to do with universal
5367 -- real at runtime, since this corresponds to using floating-point
5370 -- What we have now is that the Etype of the Round attribute correctly
5371 -- indicates the final result type. The operand of the Round is the
5372 -- conversion to universal real, described above, and the operand of
5373 -- this conversion is the actual operand of Round, which may be the
5374 -- special case of a fixed point multiplication or division (Etype =
5377 -- The exapander will expand first the operand of the conversion, then
5378 -- the conversion, and finally the round attribute itself, since we
5379 -- always work inside out. But we cannot simply process naively in this
5380 -- order. In the semantic world where universal fixed and real really
5381 -- exist and have infinite precision, there is no problem, but in the
5382 -- implementation world, where universal real is a floating-point type,
5383 -- we would get the wrong result.
5385 -- So the approach is as follows. First, when expanding a multiply or
5386 -- divide whose type is universal fixed, we do nothing at all, instead
5387 -- deferring the operation till later.
5389 -- The actual processing is done in Expand_N_Type_Conversion which
5390 -- handles the special case of Round by looking at its parent to see if
5391 -- it is a Round attribute, and if it is, handling the conversion (or
5392 -- its fixed multiply/divide child) in an appropriate manner.
5394 -- This means that by the time we get to expanding the Round attribute
5395 -- itself, the Round is nothing more than a type conversion (and will
5396 -- often be a null type conversion), so we just replace it with the
5397 -- appropriate conversion operation.
5399 when Attribute_Round =>
5401 Convert_To (Etype (N), Relocate_Node (First (Exprs))));
5402 Analyze_And_Resolve (N);
5408 -- Transforms 'Rounding into a call to the floating-point attribute
5409 -- function Rounding in Fat_xxx (where xxx is the root type)
5410 -- Expansion is avoided for cases the back end can handle directly.
5412 when Attribute_Rounding =>
5413 if not Is_Inline_Floating_Point_Attribute (N) then
5414 Expand_Fpt_Attribute_R (N);
5421 -- Transforms 'Scaling into a call to the floating-point attribute
5422 -- function Scaling in Fat_xxx (where xxx is the root type)
5424 when Attribute_Scaling =>
5425 Expand_Fpt_Attribute_RI (N);
5427 -------------------------
5428 -- Simple_Storage_Pool --
5429 -------------------------
5431 when Attribute_Simple_Storage_Pool =>
5433 Make_Type_Conversion (Loc,
5434 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
5435 Expression => New_Occurrence_Of (Entity (N), Loc)));
5436 Analyze_And_Resolve (N, Typ);
5442 when Attribute_Size |
5443 Attribute_Object_Size |
5444 Attribute_Value_Size |
5445 Attribute_VADS_Size => Size :
5452 -- Processing for VADS_Size case. Note that this processing removes
5453 -- all traces of VADS_Size from the tree, and completes all required
5454 -- processing for VADS_Size by translating the attribute reference
5455 -- to an appropriate Size or Object_Size reference.
5457 if Id = Attribute_VADS_Size
5458 or else (Use_VADS_Size and then Id = Attribute_Size)
5460 -- If the size is specified, then we simply use the specified
5461 -- size. This applies to both types and objects. The size of an
5462 -- object can be specified in the following ways:
5464 -- An explicit size object is given for an object
5465 -- A component size is specified for an indexed component
5466 -- A component clause is specified for a selected component
5467 -- The object is a component of a packed composite object
5469 -- If the size is specified, then VADS_Size of an object
5471 if (Is_Entity_Name (Pref)
5472 and then Present (Size_Clause (Entity (Pref))))
5474 (Nkind (Pref) = N_Component_Clause
5475 and then (Present (Component_Clause
5476 (Entity (Selector_Name (Pref))))
5477 or else Is_Packed (Etype (Prefix (Pref)))))
5479 (Nkind (Pref) = N_Indexed_Component
5480 and then (Component_Size (Etype (Prefix (Pref))) /= 0
5481 or else Is_Packed (Etype (Prefix (Pref)))))
5483 Set_Attribute_Name (N, Name_Size);
5485 -- Otherwise if we have an object rather than a type, then the
5486 -- VADS_Size attribute applies to the type of the object, rather
5487 -- than the object itself. This is one of the respects in which
5488 -- VADS_Size differs from Size.
5491 if (not Is_Entity_Name (Pref)
5492 or else not Is_Type (Entity (Pref)))
5493 and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp))
5495 Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
5498 -- For a scalar type for which no size was explicitly given,
5499 -- VADS_Size means Object_Size. This is the other respect in
5500 -- which VADS_Size differs from Size.
5502 if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then
5503 Set_Attribute_Name (N, Name_Object_Size);
5505 -- In all other cases, Size and VADS_Size are the sane
5508 Set_Attribute_Name (N, Name_Size);
5513 -- If the prefix is X'Class, we transform it into a direct reference
5514 -- to the class-wide type, because the back end must not see a 'Class
5517 if Is_Entity_Name (Pref)
5518 and then Is_Class_Wide_Type (Entity (Pref))
5520 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
5523 -- For X'Size applied to an object of a class-wide type, transform
5524 -- X'Size into a call to the primitive operation _Size applied to X.
5526 elsif Is_Class_Wide_Type (Ptyp) then
5528 -- No need to do anything else compiling under restriction
5529 -- No_Dispatching_Calls. During the semantic analysis we
5530 -- already noted this restriction violation.
5532 if Restriction_Active (No_Dispatching_Calls) then
5537 Make_Function_Call (Loc,
5538 Name => New_Occurrence_Of
5539 (Find_Prim_Op (Ptyp, Name_uSize), Loc),
5540 Parameter_Associations => New_List (Pref));
5542 if Typ /= Standard_Long_Long_Integer then
5544 -- The context is a specific integer type with which the
5545 -- original attribute was compatible. The function has a
5546 -- specific type as well, so to preserve the compatibility
5547 -- we must convert explicitly.
5549 New_Node := Convert_To (Typ, New_Node);
5552 Rewrite (N, New_Node);
5553 Analyze_And_Resolve (N, Typ);
5556 -- Case of known RM_Size of a type
5558 elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
5559 and then Is_Entity_Name (Pref)
5560 and then Is_Type (Entity (Pref))
5561 and then Known_Static_RM_Size (Entity (Pref))
5563 Siz := RM_Size (Entity (Pref));
5565 -- Case of known Esize of a type
5567 elsif Id = Attribute_Object_Size
5568 and then Is_Entity_Name (Pref)
5569 and then Is_Type (Entity (Pref))
5570 and then Known_Static_Esize (Entity (Pref))
5572 Siz := Esize (Entity (Pref));
5574 -- Case of known size of object
5576 elsif Id = Attribute_Size
5577 and then Is_Entity_Name (Pref)
5578 and then Is_Object (Entity (Pref))
5579 and then Known_Esize (Entity (Pref))
5580 and then Known_Static_Esize (Entity (Pref))
5582 Siz := Esize (Entity (Pref));
5584 -- For an array component, we can do Size in the front end
5585 -- if the component_size of the array is set.
5587 elsif Nkind (Pref) = N_Indexed_Component then
5588 Siz := Component_Size (Etype (Prefix (Pref)));
5590 -- For a record component, we can do Size in the front end if there
5591 -- is a component clause, or if the record is packed and the
5592 -- component's size is known at compile time.
5594 elsif Nkind (Pref) = N_Selected_Component then
5596 Rec : constant Entity_Id := Etype (Prefix (Pref));
5597 Comp : constant Entity_Id := Entity (Selector_Name (Pref));
5600 if Present (Component_Clause (Comp)) then
5601 Siz := Esize (Comp);
5603 elsif Is_Packed (Rec) then
5604 Siz := RM_Size (Ptyp);
5607 Apply_Universal_Integer_Attribute_Checks (N);
5612 -- All other cases are handled by the back end
5615 Apply_Universal_Integer_Attribute_Checks (N);
5617 -- If Size is applied to a formal parameter that is of a packed
5618 -- array subtype, then apply Size to the actual subtype.
5620 if Is_Entity_Name (Pref)
5621 and then Is_Formal (Entity (Pref))
5622 and then Is_Array_Type (Ptyp)
5623 and then Is_Packed (Ptyp)
5626 Make_Attribute_Reference (Loc,
5628 New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
5629 Attribute_Name => Name_Size));
5630 Analyze_And_Resolve (N, Typ);
5633 -- If Size applies to a dereference of an access to unconstrained
5634 -- packed array, the back end needs to see its unconstrained
5635 -- nominal type, but also a hint to the actual constrained type.
5637 if Nkind (Pref) = N_Explicit_Dereference
5638 and then Is_Array_Type (Ptyp)
5639 and then not Is_Constrained (Ptyp)
5640 and then Is_Packed (Ptyp)
5642 Set_Actual_Designated_Subtype (Pref,
5643 Get_Actual_Subtype (Pref));
5649 -- Common processing for record and array component case
5651 if Siz /= No_Uint and then Siz /= 0 then
5653 CS : constant Boolean := Comes_From_Source (N);
5656 Rewrite (N, Make_Integer_Literal (Loc, Siz));
5658 -- This integer literal is not a static expression. We do not
5659 -- call Analyze_And_Resolve here, because this would activate
5660 -- the circuit for deciding that a static value was out of
5661 -- range, and we don't want that.
5663 -- So just manually set the type, mark the expression as non-
5664 -- static, and then ensure that the result is checked properly
5665 -- if the attribute comes from source (if it was internally
5666 -- generated, we never need a constraint check).
5669 Set_Is_Static_Expression (N, False);
5672 Apply_Constraint_Check (N, Typ);
5682 when Attribute_Storage_Pool =>
5684 Make_Type_Conversion (Loc,
5685 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
5686 Expression => New_Occurrence_Of (Entity (N), Loc)));
5687 Analyze_And_Resolve (N, Typ);
5693 when Attribute_Storage_Size => Storage_Size : declare
5694 Alloc_Op : Entity_Id := Empty;
5698 -- Access type case, always go to the root type
5700 -- The case of access types results in a value of zero for the case
5701 -- where no storage size attribute clause has been given. If a
5702 -- storage size has been given, then the attribute is converted
5703 -- to a reference to the variable used to hold this value.
5705 if Is_Access_Type (Ptyp) then
5706 if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
5708 Make_Attribute_Reference (Loc,
5709 Prefix => New_Occurrence_Of (Typ, Loc),
5710 Attribute_Name => Name_Max,
5711 Expressions => New_List (
5712 Make_Integer_Literal (Loc, 0),
5715 (Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
5717 elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
5719 -- If the access type is associated with a simple storage pool
5720 -- object, then attempt to locate the optional Storage_Size
5721 -- function of the simple storage pool type. If not found,
5722 -- then the result will default to zero.
5724 if Present (Get_Rep_Pragma (Root_Type (Ptyp),
5725 Name_Simple_Storage_Pool_Type))
5728 Pool_Type : constant Entity_Id :=
5729 Base_Type (Etype (Entity (N)));
5732 Alloc_Op := Get_Name_Entity_Id (Name_Storage_Size);
5733 while Present (Alloc_Op) loop
5734 if Scope (Alloc_Op) = Scope (Pool_Type)
5735 and then Present (First_Formal (Alloc_Op))
5736 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
5741 Alloc_Op := Homonym (Alloc_Op);
5745 -- In the normal Storage_Pool case, retrieve the primitive
5746 -- function associated with the pool type.
5751 (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
5752 Attribute_Name (N));
5755 -- If Storage_Size wasn't found (can only occur in the simple
5756 -- storage pool case), then simply use zero for the result.
5758 if not Present (Alloc_Op) then
5759 Rewrite (N, Make_Integer_Literal (Loc, 0));
5761 -- Otherwise, rewrite the allocator as a call to pool type's
5762 -- Storage_Size function.
5767 Make_Function_Call (Loc,
5769 New_Occurrence_Of (Alloc_Op, Loc),
5771 Parameter_Associations => New_List (
5773 (Associated_Storage_Pool
5774 (Root_Type (Ptyp)), Loc)))));
5778 Rewrite (N, Make_Integer_Literal (Loc, 0));
5781 Analyze_And_Resolve (N, Typ);
5783 -- For tasks, we retrieve the size directly from the TCB. The
5784 -- size may depend on a discriminant of the type, and therefore
5785 -- can be a per-object expression, so type-level information is
5786 -- not sufficient in general. There are four cases to consider:
5788 -- a) If the attribute appears within a task body, the designated
5789 -- TCB is obtained by a call to Self.
5791 -- b) If the prefix of the attribute is the name of a task object,
5792 -- the designated TCB is the one stored in the corresponding record.
5794 -- c) If the prefix is a task type, the size is obtained from the
5795 -- size variable created for each task type
5797 -- d) If no Storage_Size was specified for the type, there is no
5798 -- size variable, and the value is a system-specific default.
5801 if In_Open_Scopes (Ptyp) then
5803 -- Storage_Size (Self)
5807 Make_Function_Call (Loc,
5809 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
5810 Parameter_Associations =>
5812 Make_Function_Call (Loc,
5814 New_Occurrence_Of (RTE (RE_Self), Loc))))));
5816 elsif not Is_Entity_Name (Pref)
5817 or else not Is_Type (Entity (Pref))
5819 -- Storage_Size (Rec (Obj).Size)
5823 Make_Function_Call (Loc,
5825 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
5826 Parameter_Associations =>
5828 Make_Selected_Component (Loc,
5830 Unchecked_Convert_To (
5831 Corresponding_Record_Type (Ptyp),
5832 New_Copy_Tree (Pref)),
5834 Make_Identifier (Loc, Name_uTask_Id))))));
5836 elsif Present (Storage_Size_Variable (Ptyp)) then
5838 -- Static Storage_Size pragma given for type: retrieve value
5839 -- from its allocated storage variable.
5843 Make_Function_Call (Loc,
5844 Name => New_Occurrence_Of (
5845 RTE (RE_Adjust_Storage_Size), Loc),
5846 Parameter_Associations =>
5849 Storage_Size_Variable (Ptyp), Loc)))));
5851 -- Get system default
5855 Make_Function_Call (Loc,
5858 RTE (RE_Default_Stack_Size), Loc))));
5861 Analyze_And_Resolve (N, Typ);
5869 when Attribute_Stream_Size =>
5871 Make_Integer_Literal (Loc, Intval => Get_Stream_Size (Ptyp)));
5872 Analyze_And_Resolve (N, Typ);
5878 -- 1. Deal with enumeration types with holes.
5879 -- 2. For floating-point, generate call to attribute function.
5880 -- 3. For other cases, deal with constraint checking.
5882 when Attribute_Succ => Succ : declare
5883 Etyp : constant Entity_Id := Base_Type (Ptyp);
5887 -- For enumeration types with non-standard representations, we
5888 -- expand typ'Succ (x) into
5890 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
5892 -- If the representation is contiguous, we compute instead
5893 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
5895 if Is_Enumeration_Type (Ptyp)
5896 and then Present (Enum_Pos_To_Rep (Etyp))
5898 if Has_Contiguous_Rep (Etyp) then
5900 Unchecked_Convert_To (Ptyp,
5903 Make_Integer_Literal (Loc,
5904 Enumeration_Rep (First_Literal (Ptyp))),
5906 Make_Function_Call (Loc,
5909 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5911 Parameter_Associations =>
5913 Unchecked_Convert_To (Ptyp,
5916 Unchecked_Convert_To (Standard_Integer,
5917 Relocate_Node (First (Exprs))),
5919 Make_Integer_Literal (Loc, 1))),
5920 Rep_To_Pos_Flag (Ptyp, Loc))))));
5922 -- Add Boolean parameter True, to request program errror if
5923 -- we have a bad representation on our hands. Add False if
5924 -- checks are suppressed.
5926 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
5928 Make_Indexed_Component (Loc,
5931 (Enum_Pos_To_Rep (Etyp), Loc),
5932 Expressions => New_List (
5935 Make_Function_Call (Loc,
5938 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5939 Parameter_Associations => Exprs),
5940 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
5943 Analyze_And_Resolve (N, Typ);
5945 -- For floating-point, we transform 'Succ into a call to the Succ
5946 -- floating-point attribute function in Fat_xxx (xxx is root type)
5948 elsif Is_Floating_Point_Type (Ptyp) then
5949 Expand_Fpt_Attribute_R (N);
5950 Analyze_And_Resolve (N, Typ);
5952 -- For modular types, nothing to do (no overflow, since wraps)
5954 elsif Is_Modular_Integer_Type (Ptyp) then
5957 -- For other types, if argument is marked as needing a range check or
5958 -- overflow checking is enabled, we must generate a check.
5960 elsif not Overflow_Checks_Suppressed (Ptyp)
5961 or else Do_Range_Check (First (Exprs))
5963 Set_Do_Range_Check (First (Exprs), False);
5964 Expand_Pred_Succ_Attribute (N);
5972 -- Transforms X'Tag into a direct reference to the tag of X
5974 when Attribute_Tag => Tag : declare
5976 Prefix_Is_Type : Boolean;
5979 if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then
5980 Ttyp := Entity (Pref);
5981 Prefix_Is_Type := True;
5984 Prefix_Is_Type := False;
5987 if Is_Class_Wide_Type (Ttyp) then
5988 Ttyp := Root_Type (Ttyp);
5991 Ttyp := Underlying_Type (Ttyp);
5993 -- Ada 2005: The type may be a synchronized tagged type, in which
5994 -- case the tag information is stored in the corresponding record.
5996 if Is_Concurrent_Type (Ttyp) then
5997 Ttyp := Corresponding_Record_Type (Ttyp);
6000 if Prefix_Is_Type then
6002 -- For VMs we leave the type attribute unexpanded because
6003 -- there's not a dispatching table to reference.
6005 if Tagged_Type_Expansion then
6007 Unchecked_Convert_To (RTE (RE_Tag),
6009 (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc)));
6010 Analyze_And_Resolve (N, RTE (RE_Tag));
6013 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
6014 -- references the primary tag of the actual object. If 'Tag is
6015 -- applied to class-wide interface objects we generate code that
6016 -- displaces "this" to reference the base of the object.
6018 elsif Comes_From_Source (N)
6019 and then Is_Class_Wide_Type (Etype (Prefix (N)))
6020 and then Is_Interface (Etype (Prefix (N)))
6023 -- (To_Tag_Ptr (Prefix'Address)).all
6025 -- Note that Prefix'Address is recursively expanded into a call
6026 -- to Base_Address (Obj.Tag)
6028 -- Not needed for VM targets, since all handled by the VM
6030 if Tagged_Type_Expansion then
6032 Make_Explicit_Dereference (Loc,
6033 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6034 Make_Attribute_Reference (Loc,
6035 Prefix => Relocate_Node (Pref),
6036 Attribute_Name => Name_Address))));
6037 Analyze_And_Resolve (N, RTE (RE_Tag));
6042 Make_Selected_Component (Loc,
6043 Prefix => Relocate_Node (Pref),
6045 New_Occurrence_Of (First_Tag_Component (Ttyp), Loc)));
6046 Analyze_And_Resolve (N, RTE (RE_Tag));
6054 -- Transforms 'Terminated attribute into a call to Terminated function
6056 when Attribute_Terminated => Terminated :
6058 -- The prefix of Terminated is of a task interface class-wide type.
6060 -- terminated (Task_Id (Pref._disp_get_task_id));
6062 if Ada_Version >= Ada_2005
6063 and then Ekind (Ptyp) = E_Class_Wide_Type
6064 and then Is_Interface (Ptyp)
6065 and then Is_Task_Interface (Ptyp)
6068 Make_Function_Call (Loc,
6070 New_Occurrence_Of (RTE (RE_Terminated), Loc),
6071 Parameter_Associations => New_List (
6072 Make_Unchecked_Type_Conversion (Loc,
6074 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
6076 Make_Selected_Component (Loc,
6078 New_Copy_Tree (Pref),
6080 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
6082 elsif Restricted_Profile then
6084 Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
6088 Build_Call_With_Task (Pref, RTE (RE_Terminated)));
6091 Analyze_And_Resolve (N, Standard_Boolean);
6098 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
6099 -- unchecked conversion from (integral) type of X to type address.
6101 when Attribute_To_Address | Attribute_Ref =>
6103 Unchecked_Convert_To (RTE (RE_Address),
6104 Relocate_Node (First (Exprs))));
6105 Analyze_And_Resolve (N, RTE (RE_Address));
6111 when Attribute_To_Any => To_Any : declare
6112 P_Type : constant Entity_Id := Etype (Pref);
6113 Decls : constant List_Id := New_List;
6119 Relocate_Node (First (Exprs))), Decls));
6120 Insert_Actions (N, Decls);
6121 Analyze_And_Resolve (N, RTE (RE_Any));
6128 -- Transforms 'Truncation into a call to the floating-point attribute
6129 -- function Truncation in Fat_xxx (where xxx is the root type).
6130 -- Expansion is avoided for cases the back end can handle directly.
6132 when Attribute_Truncation =>
6133 if not Is_Inline_Floating_Point_Attribute (N) then
6134 Expand_Fpt_Attribute_R (N);
6141 when Attribute_TypeCode => TypeCode : declare
6142 P_Type : constant Entity_Id := Etype (Pref);
6143 Decls : constant List_Id := New_List;
6145 Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls));
6146 Insert_Actions (N, Decls);
6147 Analyze_And_Resolve (N, RTE (RE_TypeCode));
6150 -----------------------
6151 -- Unbiased_Rounding --
6152 -----------------------
6154 -- Transforms 'Unbiased_Rounding into a call to the floating-point
6155 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
6156 -- root type). Expansion is avoided for cases the back end can handle
6159 when Attribute_Unbiased_Rounding =>
6160 if not Is_Inline_Floating_Point_Attribute (N) then
6161 Expand_Fpt_Attribute_R (N);
6168 when Attribute_Update =>
6169 Expand_Update_Attribute (N);
6175 -- The processing for VADS_Size is shared with Size
6181 -- For enumeration types with a standard representation, and for all
6182 -- other types, Val is handled by the back end. For enumeration types
6183 -- with a non-standard representation we use the _Pos_To_Rep array that
6184 -- was created when the type was frozen.
6186 when Attribute_Val => Val : declare
6187 Etyp : constant Entity_Id := Base_Type (Entity (Pref));
6190 if Is_Enumeration_Type (Etyp)
6191 and then Present (Enum_Pos_To_Rep (Etyp))
6193 if Has_Contiguous_Rep (Etyp) then
6195 Rep_Node : constant Node_Id :=
6196 Unchecked_Convert_To (Etyp,
6199 Make_Integer_Literal (Loc,
6200 Enumeration_Rep (First_Literal (Etyp))),
6202 (Convert_To (Standard_Integer,
6203 Relocate_Node (First (Exprs))))));
6207 Unchecked_Convert_To (Etyp,
6210 Make_Integer_Literal (Loc,
6211 Enumeration_Rep (First_Literal (Etyp))),
6213 Make_Function_Call (Loc,
6216 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
6217 Parameter_Associations => New_List (
6219 Rep_To_Pos_Flag (Etyp, Loc))))));
6224 Make_Indexed_Component (Loc,
6225 Prefix => New_Occurrence_Of (Enum_Pos_To_Rep (Etyp), Loc),
6226 Expressions => New_List (
6227 Convert_To (Standard_Integer,
6228 Relocate_Node (First (Exprs))))));
6231 Analyze_And_Resolve (N, Typ);
6233 -- If the argument is marked as requiring a range check then generate
6236 elsif Do_Range_Check (First (Exprs)) then
6237 Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
6245 -- The code for valid is dependent on the particular types involved.
6246 -- See separate sections below for the generated code in each case.
6248 when Attribute_Valid => Valid : declare
6249 Btyp : Entity_Id := Base_Type (Ptyp);
6252 Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
6253 -- Save the validity checking mode. We always turn off validity
6254 -- checking during process of 'Valid since this is one place
6255 -- where we do not want the implicit validity checks to intefere
6256 -- with the explicit validity check that the programmer is doing.
6258 function Make_Range_Test return Node_Id;
6259 -- Build the code for a range test of the form
6260 -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
6262 ---------------------
6263 -- Make_Range_Test --
6264 ---------------------
6266 function Make_Range_Test return Node_Id is
6267 Temp : constant Node_Id := Duplicate_Subexpr (Pref);
6270 -- The value whose validity is being checked has been captured in
6271 -- an object declaration. We certainly don't want this object to
6272 -- appear valid because the declaration initializes it.
6274 if Is_Entity_Name (Temp) then
6275 Set_Is_Known_Valid (Entity (Temp), False);
6281 Unchecked_Convert_To (Btyp, Temp),
6285 Unchecked_Convert_To (Btyp,
6286 Make_Attribute_Reference (Loc,
6287 Prefix => New_Occurrence_Of (Ptyp, Loc),
6288 Attribute_Name => Name_First)),
6290 Unchecked_Convert_To (Btyp,
6291 Make_Attribute_Reference (Loc,
6292 Prefix => New_Occurrence_Of (Ptyp, Loc),
6293 Attribute_Name => Name_Last))));
6294 end Make_Range_Test;
6296 -- Start of processing for Attribute_Valid
6299 -- Do not expand sourced code 'Valid reference in CodePeer mode,
6300 -- will be handled by the back-end directly.
6302 if CodePeer_Mode and then Comes_From_Source (N) then
6306 -- Turn off validity checks. We do not want any implicit validity
6307 -- checks to intefere with the explicit check from the attribute
6309 Validity_Checks_On := False;
6311 -- Retrieve the base type. Handle the case where the base type is a
6312 -- private enumeration type.
6314 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
6315 Btyp := Full_View (Btyp);
6318 -- Floating-point case. This case is handled by the Valid attribute
6319 -- code in the floating-point attribute run-time library.
6321 if Is_Floating_Point_Type (Ptyp) then
6322 Float_Valid : declare
6326 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id;
6327 -- Return entity for Pkg.Nam
6329 --------------------
6330 -- Get_Fat_Entity --
6331 --------------------
6333 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id is
6334 Exp_Name : constant Node_Id :=
6335 Make_Selected_Component (Loc,
6336 Prefix => New_Occurrence_Of (RTE (Pkg), Loc),
6337 Selector_Name => Make_Identifier (Loc, Nam));
6339 Find_Selected_Component (Exp_Name);
6340 return Entity (Exp_Name);
6343 -- Start of processing for Float_Valid
6346 case Float_Rep (Btyp) is
6348 -- The AAMP back end handles Valid for floating-point types
6351 Analyze_And_Resolve (Pref, Ptyp);
6352 Set_Etype (N, Standard_Boolean);
6356 Find_Fat_Info (Ptyp, Ftp, Pkg);
6358 -- If the prefix is a reverse SSO component, or is
6359 -- possibly unaligned, first create a temporary copy
6360 -- that is in native SSO, and properly aligned. Make it
6361 -- Volatile to prevent folding in the back-end. Note
6362 -- that we use an intermediate constrained string type
6363 -- to initialize the temporary, as the value at hand
6364 -- might be invalid, and in that case it cannot be copied
6365 -- using a floating point register.
6367 if In_Reverse_Storage_Order_Object (Pref)
6369 Is_Possibly_Unaligned_Object (Pref)
6372 Temp : constant Entity_Id :=
6373 Make_Temporary (Loc, 'F');
6375 Fat_S : constant Entity_Id :=
6376 Get_Fat_Entity (Name_S);
6377 -- Constrained string subtype of appropriate size
6379 Fat_P : constant Entity_Id :=
6380 Get_Fat_Entity (Name_P);
6383 Decl : constant Node_Id :=
6384 Make_Object_Declaration (Loc,
6385 Defining_Identifier => Temp,
6386 Aliased_Present => True,
6387 Object_Definition =>
6388 New_Occurrence_Of (Ptyp, Loc));
6391 Set_Aspect_Specifications (Decl, New_List (
6392 Make_Aspect_Specification (Loc,
6394 Make_Identifier (Loc, Name_Volatile))));
6400 Make_Assignment_Statement (Loc,
6402 Make_Explicit_Dereference (Loc,
6404 Unchecked_Convert_To (Fat_P,
6405 Make_Attribute_Reference (Loc,
6407 New_Occurrence_Of (Temp, Loc),
6409 Name_Unrestricted_Access))),
6411 Unchecked_Convert_To (Fat_S,
6412 Relocate_Node (Pref)))),
6414 Suppress => All_Checks);
6416 Rewrite (Pref, New_Occurrence_Of (Temp, Loc));
6420 -- We now have an object of the proper endianness and
6421 -- alignment, and can construct a Valid attribute.
6423 -- We make sure the prefix of this valid attribute is
6424 -- marked as not coming from source, to avoid losing
6425 -- warnings from 'Valid looking like a possible update.
6427 Set_Comes_From_Source (Pref, False);
6429 Expand_Fpt_Attribute
6430 (N, Pkg, Name_Valid,
6432 Make_Attribute_Reference (Loc,
6433 Prefix => Unchecked_Convert_To (Ftp, Pref),
6434 Attribute_Name => Name_Unrestricted_Access)));
6437 -- One more task, we still need a range check. Required
6438 -- only if we have a constraint, since the Valid routine
6439 -- catches infinities properly (infinities are never valid).
6441 -- The way we do the range check is simply to create the
6442 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
6444 if not Subtypes_Statically_Match (Ptyp, Btyp) then
6447 Left_Opnd => Relocate_Node (N),
6450 Left_Opnd => Convert_To (Btyp, Pref),
6451 Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
6455 -- Enumeration type with holes
6457 -- For enumeration types with holes, the Pos value constructed by
6458 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
6459 -- second argument of False returns minus one for an invalid value,
6460 -- and the non-negative pos value for a valid value, so the
6461 -- expansion of X'Valid is simply:
6463 -- type(X)'Pos (X) >= 0
6465 -- We can't quite generate it that way because of the requirement
6466 -- for the non-standard second argument of False in the resulting
6467 -- rep_to_pos call, so we have to explicitly create:
6469 -- _rep_to_pos (X, False) >= 0
6471 -- If we have an enumeration subtype, we also check that the
6472 -- value is in range:
6474 -- _rep_to_pos (X, False) >= 0
6476 -- (X >= type(X)'First and then type(X)'Last <= X)
6478 elsif Is_Enumeration_Type (Ptyp)
6479 and then Present (Enum_Pos_To_Rep (Btyp))
6484 Make_Function_Call (Loc,
6486 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
6487 Parameter_Associations => New_List (
6489 New_Occurrence_Of (Standard_False, Loc))),
6490 Right_Opnd => Make_Integer_Literal (Loc, 0));
6494 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
6496 Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
6498 -- The call to Make_Range_Test will create declarations
6499 -- that need a proper insertion point, but Pref is now
6500 -- attached to a node with no ancestor. Attach to tree
6501 -- even if it is to be rewritten below.
6503 Set_Parent (Tst, Parent (N));
6507 Left_Opnd => Make_Range_Test,
6513 -- Fortran convention booleans
6515 -- For the very special case of Fortran convention booleans, the
6516 -- value is always valid, since it is an integer with the semantics
6517 -- that non-zero is true, and any value is permissible.
6519 elsif Is_Boolean_Type (Ptyp)
6520 and then Convention (Ptyp) = Convention_Fortran
6522 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6524 -- For biased representations, we will be doing an unchecked
6525 -- conversion without unbiasing the result. That means that the range
6526 -- test has to take this into account, and the proper form of the
6529 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
6531 elsif Has_Biased_Representation (Ptyp) then
6532 Btyp := RTE (RE_Unsigned_32);
6536 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
6538 Unchecked_Convert_To (Btyp,
6539 Make_Attribute_Reference (Loc,
6540 Prefix => New_Occurrence_Of (Ptyp, Loc),
6541 Attribute_Name => Name_Range_Length))));
6543 -- For all other scalar types, what we want logically is a
6546 -- X in type(X)'First .. type(X)'Last
6548 -- But that's precisely what won't work because of possible
6549 -- unwanted optimization (and indeed the basic motivation for
6550 -- the Valid attribute is exactly that this test does not work).
6551 -- What will work is:
6553 -- Btyp!(X) >= Btyp!(type(X)'First)
6555 -- Btyp!(X) <= Btyp!(type(X)'Last)
6557 -- where Btyp is an integer type large enough to cover the full
6558 -- range of possible stored values (i.e. it is chosen on the basis
6559 -- of the size of the type, not the range of the values). We write
6560 -- this as two tests, rather than a range check, so that static
6561 -- evaluation will easily remove either or both of the checks if
6562 -- they can be -statically determined to be true (this happens
6563 -- when the type of X is static and the range extends to the full
6564 -- range of stored values).
6566 -- Unsigned types. Note: it is safe to consider only whether the
6567 -- subtype is unsigned, since we will in that case be doing all
6568 -- unsigned comparisons based on the subtype range. Since we use the
6569 -- actual subtype object size, this is appropriate.
6571 -- For example, if we have
6573 -- subtype x is integer range 1 .. 200;
6574 -- for x'Object_Size use 8;
6576 -- Now the base type is signed, but objects of this type are bits
6577 -- unsigned, and doing an unsigned test of the range 1 to 200 is
6578 -- correct, even though a value greater than 127 looks signed to a
6579 -- signed comparison.
6581 elsif Is_Unsigned_Type (Ptyp) then
6582 if Esize (Ptyp) <= 32 then
6583 Btyp := RTE (RE_Unsigned_32);
6585 Btyp := RTE (RE_Unsigned_64);
6588 Rewrite (N, Make_Range_Test);
6593 if Esize (Ptyp) <= Esize (Standard_Integer) then
6594 Btyp := Standard_Integer;
6596 Btyp := Universal_Integer;
6599 Rewrite (N, Make_Range_Test);
6602 -- If a predicate is present, then we do the predicate test, even if
6603 -- within the predicate function (infinite recursion is warned about
6604 -- in Sem_Attr in that case).
6607 Pred_Func : constant Entity_Id := Predicate_Function (Ptyp);
6610 if Present (Pred_Func) then
6613 Left_Opnd => Relocate_Node (N),
6614 Right_Opnd => Make_Predicate_Call (Ptyp, Pref)));
6618 Analyze_And_Resolve (N, Standard_Boolean);
6619 Validity_Checks_On := Save_Validity_Checks_On;
6626 when Attribute_Valid_Scalars => Valid_Scalars : declare
6630 if Present (Underlying_Type (Ptyp)) then
6631 Ftyp := Underlying_Type (Ptyp);
6636 -- Replace by True if no scalar parts
6638 if not Scalar_Part_Present (Ftyp) then
6639 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6641 -- For scalar types, Valid_Scalars is the same as Valid
6643 elsif Is_Scalar_Type (Ftyp) then
6645 Make_Attribute_Reference (Loc,
6646 Attribute_Name => Name_Valid,
6649 -- For array types, we construct a function that determines if there
6650 -- are any non-valid scalar subcomponents, and call the function.
6651 -- We only do this for arrays whose component type needs checking
6653 elsif Is_Array_Type (Ftyp)
6654 and then Scalar_Part_Present (Component_Type (Ftyp))
6657 Make_Function_Call (Loc,
6659 New_Occurrence_Of (Build_Array_VS_Func (Ftyp, N), Loc),
6660 Parameter_Associations => New_List (Pref)));
6662 -- For record types, we construct a function that determines if there
6663 -- are any non-valid scalar subcomponents, and call the function.
6665 elsif Is_Record_Type (Ftyp)
6666 and then Nkind (Type_Definition (Declaration_Node (Ftyp))) =
6670 Make_Function_Call (Loc,
6672 New_Occurrence_Of (Build_Record_VS_Func (Ftyp, N), Loc),
6673 Parameter_Associations => New_List (Pref)));
6675 -- Other record types or types with discriminants
6677 elsif Is_Record_Type (Ftyp) or else Has_Discriminants (Ptyp) then
6679 -- Build expression with list of equality tests
6687 X := New_Occurrence_Of (Standard_True, Loc);
6688 C := First_Component_Or_Discriminant (Ptyp);
6689 while Present (C) loop
6690 if not Scalar_Part_Present (Etype (C)) then
6692 elsif Is_Scalar_Type (Etype (C)) then
6695 A := Name_Valid_Scalars;
6702 Make_Attribute_Reference (Loc,
6703 Attribute_Name => A,
6705 Make_Selected_Component (Loc,
6707 Duplicate_Subexpr (Pref, Name_Req => True),
6709 New_Occurrence_Of (C, Loc))));
6711 Next_Component_Or_Discriminant (C);
6717 -- For all other types, result is True
6720 Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc));
6723 -- Result is always boolean, but never static
6725 Analyze_And_Resolve (N, Standard_Boolean);
6726 Set_Is_Static_Expression (N, False);
6733 -- Value attribute is handled in separate unit Exp_Imgv
6735 when Attribute_Value =>
6736 Exp_Imgv.Expand_Value_Attribute (N);
6742 -- The processing for Value_Size shares the processing for Size
6748 -- The processing for Version shares the processing for Body_Version
6754 -- Wide_Image attribute is handled in separate unit Exp_Imgv
6756 when Attribute_Wide_Image =>
6757 Exp_Imgv.Expand_Wide_Image_Attribute (N);
6759 ---------------------
6760 -- Wide_Wide_Image --
6761 ---------------------
6763 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
6765 when Attribute_Wide_Wide_Image =>
6766 Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N);
6772 -- We expand typ'Wide_Value (X) into
6775 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
6777 -- Wide_String_To_String is a runtime function that converts its wide
6778 -- string argument to String, converting any non-translatable characters
6779 -- into appropriate escape sequences. This preserves the required
6780 -- semantics of Wide_Value in all cases, and results in a very simple
6781 -- implementation approach.
6783 -- Note: for this approach to be fully standard compliant for the cases
6784 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
6785 -- method must cover the entire character range (e.g. UTF-8). But that
6786 -- is a reasonable requirement when dealing with encoded character
6787 -- sequences. Presumably if one of the restrictive encoding mechanisms
6788 -- is in use such as Shift-JIS, then characters that cannot be
6789 -- represented using this encoding will not appear in any case.
6791 when Attribute_Wide_Value => Wide_Value :
6794 Make_Attribute_Reference (Loc,
6796 Attribute_Name => Name_Value,
6798 Expressions => New_List (
6799 Make_Function_Call (Loc,
6801 New_Occurrence_Of (RTE (RE_Wide_String_To_String), Loc),
6803 Parameter_Associations => New_List (
6804 Relocate_Node (First (Exprs)),
6805 Make_Integer_Literal (Loc,
6806 Intval => Int (Wide_Character_Encoding_Method)))))));
6808 Analyze_And_Resolve (N, Typ);
6811 ---------------------
6812 -- Wide_Wide_Value --
6813 ---------------------
6815 -- We expand typ'Wide_Value_Value (X) into
6818 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
6820 -- Wide_Wide_String_To_String is a runtime function that converts its
6821 -- wide string argument to String, converting any non-translatable
6822 -- characters into appropriate escape sequences. This preserves the
6823 -- required semantics of Wide_Wide_Value in all cases, and results in a
6824 -- very simple implementation approach.
6826 -- It's not quite right where typ = Wide_Wide_Character, because the
6827 -- encoding method may not cover the whole character type ???
6829 when Attribute_Wide_Wide_Value => Wide_Wide_Value :
6832 Make_Attribute_Reference (Loc,
6834 Attribute_Name => Name_Value,
6836 Expressions => New_List (
6837 Make_Function_Call (Loc,
6840 (RTE (RE_Wide_Wide_String_To_String), Loc),
6842 Parameter_Associations => New_List (
6843 Relocate_Node (First (Exprs)),
6844 Make_Integer_Literal (Loc,
6845 Intval => Int (Wide_Character_Encoding_Method)))))));
6847 Analyze_And_Resolve (N, Typ);
6848 end Wide_Wide_Value;
6850 ---------------------
6851 -- Wide_Wide_Width --
6852 ---------------------
6854 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
6856 when Attribute_Wide_Wide_Width =>
6857 Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide);
6863 -- Wide_Width attribute is handled in separate unit Exp_Imgv
6865 when Attribute_Wide_Width =>
6866 Exp_Imgv.Expand_Width_Attribute (N, Wide);
6872 -- Width attribute is handled in separate unit Exp_Imgv
6874 when Attribute_Width =>
6875 Exp_Imgv.Expand_Width_Attribute (N, Normal);
6881 when Attribute_Write => Write : declare
6882 P_Type : constant Entity_Id := Entity (Pref);
6883 U_Type : constant Entity_Id := Underlying_Type (P_Type);
6891 -- If no underlying type, we have an error that will be diagnosed
6892 -- elsewhere, so here we just completely ignore the expansion.
6898 -- Stream operations can appear in user code even if the restriction
6899 -- No_Streams is active (for example, when instantiating a predefined
6900 -- container). In that case rewrite the attribute as a Raise to
6901 -- prevent any run-time use.
6903 if Restriction_Active (No_Streams) then
6905 Make_Raise_Program_Error (Sloc (N),
6906 Reason => PE_Stream_Operation_Not_Allowed));
6907 Set_Etype (N, U_Type);
6911 -- The simple case, if there is a TSS for Write, just call it
6913 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
6915 if Present (Pname) then
6919 -- If there is a Stream_Convert pragma, use it, we rewrite
6921 -- sourcetyp'Output (stream, Item)
6925 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
6927 -- where strmwrite is the given Write function that converts an
6928 -- argument of type sourcetyp or a type acctyp, from which it is
6929 -- derived to type strmtyp. The conversion to acttyp is required
6930 -- for the derived case.
6932 Prag := Get_Stream_Convert_Pragma (P_Type);
6934 if Present (Prag) then
6936 Next (Next (First (Pragma_Argument_Associations (Prag))));
6937 Wfunc := Entity (Expression (Arg3));
6940 Make_Attribute_Reference (Loc,
6941 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
6942 Attribute_Name => Name_Output,
6943 Expressions => New_List (
6944 Relocate_Node (First (Exprs)),
6945 Make_Function_Call (Loc,
6946 Name => New_Occurrence_Of (Wfunc, Loc),
6947 Parameter_Associations => New_List (
6948 OK_Convert_To (Etype (First_Formal (Wfunc)),
6949 Relocate_Node (Next (First (Exprs)))))))));
6954 -- For elementary types, we call the W_xxx routine directly
6956 elsif Is_Elementary_Type (U_Type) then
6957 Rewrite (N, Build_Elementary_Write_Call (N));
6963 elsif Is_Array_Type (U_Type) then
6964 Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
6965 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
6967 -- Tagged type case, use the primitive Write function. Note that
6968 -- this will dispatch in the class-wide case which is what we want
6970 elsif Is_Tagged_Type (U_Type) then
6971 Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
6973 -- All other record type cases, including protected records.
6974 -- The latter only arise for expander generated code for
6975 -- handling shared passive partition access.
6979 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
6981 -- Ada 2005 (AI-216): Program_Error is raised when executing
6982 -- the default implementation of the Write attribute of an
6983 -- Unchecked_Union type. However, if the 'Write reference is
6984 -- within the generated Output stream procedure, Write outputs
6985 -- the components, and the default values of the discriminant
6986 -- are streamed by the Output procedure itself.
6988 if Is_Unchecked_Union (Base_Type (U_Type))
6989 and not Is_TSS (Current_Scope, TSS_Stream_Output)
6992 Make_Raise_Program_Error (Loc,
6993 Reason => PE_Unchecked_Union_Restriction));
6996 if Has_Discriminants (U_Type)
6998 (Discriminant_Default_Value (First_Discriminant (U_Type)))
7000 Build_Mutable_Record_Write_Procedure
7001 (Loc, Full_Base (U_Type), Decl, Pname);
7003 Build_Record_Write_Procedure
7004 (Loc, Full_Base (U_Type), Decl, Pname);
7007 Insert_Action (N, Decl);
7011 -- If we fall through, Pname is the procedure to be called
7013 Rewrite_Stream_Proc_Call (Pname);
7016 -- Component_Size is handled by the back end, unless the component size
7017 -- is known at compile time, which is always true in the packed array
7018 -- case. It is important that the packed array case is handled in the
7019 -- front end (see Eval_Attribute) since the back end would otherwise get
7020 -- confused by the equivalent packed array type.
7022 when Attribute_Component_Size =>
7025 -- The following attributes are handled by the back end (except that
7026 -- static cases have already been evaluated during semantic processing,
7027 -- but in any case the back end should not count on this).
7029 -- The back end also handles the non-class-wide cases of Size
7031 when Attribute_Bit_Order |
7032 Attribute_Code_Address |
7033 Attribute_Definite |
7035 Attribute_Null_Parameter |
7036 Attribute_Passed_By_Reference |
7037 Attribute_Pool_Address |
7038 Attribute_Scalar_Storage_Order =>
7041 -- The following attributes are also handled by the back end, but return
7042 -- a universal integer result, so may need a conversion for checking
7043 -- that the result is in range.
7045 when Attribute_Aft |
7046 Attribute_Max_Alignment_For_Allocation =>
7047 Apply_Universal_Integer_Attribute_Checks (N);
7049 -- The following attributes should not appear at this stage, since they
7050 -- have already been handled by the analyzer (and properly rewritten
7051 -- with corresponding values or entities to represent the right values)
7053 when Attribute_Abort_Signal |
7054 Attribute_Address_Size |
7055 Attribute_Atomic_Always_Lock_Free |
7058 Attribute_Compiler_Version |
7059 Attribute_Default_Bit_Order |
7060 Attribute_Default_Scalar_Storage_Order |
7067 Attribute_Fast_Math |
7068 Attribute_First_Valid |
7069 Attribute_Has_Access_Values |
7070 Attribute_Has_Discriminants |
7071 Attribute_Has_Tagged_Values |
7073 Attribute_Last_Valid |
7074 Attribute_Library_Level |
7075 Attribute_Lock_Free |
7076 Attribute_Machine_Emax |
7077 Attribute_Machine_Emin |
7078 Attribute_Machine_Mantissa |
7079 Attribute_Machine_Overflows |
7080 Attribute_Machine_Radix |
7081 Attribute_Machine_Rounds |
7082 Attribute_Maximum_Alignment |
7083 Attribute_Model_Emin |
7084 Attribute_Model_Epsilon |
7085 Attribute_Model_Mantissa |
7086 Attribute_Model_Small |
7088 Attribute_Partition_ID |
7090 Attribute_Restriction_Set |
7091 Attribute_Safe_Emax |
7092 Attribute_Safe_First |
7093 Attribute_Safe_Large |
7094 Attribute_Safe_Last |
7095 Attribute_Safe_Small |
7097 Attribute_Signed_Zeros |
7099 Attribute_Storage_Unit |
7100 Attribute_Stub_Type |
7101 Attribute_System_Allocator_Alignment |
7102 Attribute_Target_Name |
7103 Attribute_Type_Class |
7104 Attribute_Type_Key |
7105 Attribute_Unconstrained_Array |
7106 Attribute_Universal_Literal_String |
7107 Attribute_Wchar_T_Size |
7108 Attribute_Word_Size =>
7109 raise Program_Error;
7111 -- The Asm_Input and Asm_Output attributes are not expanded at this
7112 -- stage, but will be eliminated in the expansion of the Asm call, see
7113 -- Exp_Intr for details. So the back end will never see these either.
7115 when Attribute_Asm_Input |
7116 Attribute_Asm_Output =>
7120 -- Note: as mentioned earlier, individual sections of the above case
7121 -- statement assume there is no code after the case statement, and are
7122 -- legitimately allowed to execute return statements if they have nothing
7123 -- more to do, so DO NOT add code at this point.
7126 when RE_Not_Available =>
7128 end Expand_N_Attribute_Reference;
7130 --------------------------------
7131 -- Expand_Pred_Succ_Attribute --
7132 --------------------------------
7134 -- For typ'Pred (exp), we generate the check
7136 -- [constraint_error when exp = typ'Base'First]
7138 -- Similarly, for typ'Succ (exp), we generate the check
7140 -- [constraint_error when exp = typ'Base'Last]
7142 -- These checks are not generated for modular types, since the proper
7143 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
7144 -- We also suppress these checks if we are the right side of an assignment
7145 -- statement or the expression of an object declaration, where the flag
7146 -- Suppress_Assignment_Checks is set for the assignment/declaration.
7148 procedure Expand_Pred_Succ_Attribute (N : Node_Id) is
7149 Loc : constant Source_Ptr := Sloc (N);
7150 P : constant Node_Id := Parent (N);
7154 if Attribute_Name (N) = Name_Pred then
7160 if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration)
7161 or else not Suppress_Assignment_Checks (P)
7164 Make_Raise_Constraint_Error (Loc,
7168 Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
7170 Make_Attribute_Reference (Loc,
7172 New_Occurrence_Of (Base_Type (Etype (Prefix (N))), Loc),
7173 Attribute_Name => Cnam)),
7174 Reason => CE_Overflow_Check_Failed));
7176 end Expand_Pred_Succ_Attribute;
7178 -----------------------------
7179 -- Expand_Update_Attribute --
7180 -----------------------------
7182 procedure Expand_Update_Attribute (N : Node_Id) is
7183 procedure Process_Component_Or_Element_Update
7188 -- Generate the statements necessary to update a single component or an
7189 -- element of the prefix. The code is inserted before the attribute N.
7190 -- Temp denotes the entity of the anonymous object created to reflect
7191 -- the changes in values. Comp is the component/index expression to be
7192 -- updated. Expr is an expression yielding the new value of Comp. Typ
7193 -- is the type of the prefix of attribute Update.
7195 procedure Process_Range_Update
7200 -- Generate the statements necessary to update a slice of the prefix.
7201 -- The code is inserted before the attribute N. Temp denotes the entity
7202 -- of the anonymous object created to reflect the changes in values.
7203 -- Comp is range of the slice to be updated. Expr is an expression
7204 -- yielding the new value of Comp. Typ is the type of the prefix of
7205 -- attribute Update.
7207 -----------------------------------------
7208 -- Process_Component_Or_Element_Update --
7209 -----------------------------------------
7211 procedure Process_Component_Or_Element_Update
7217 Loc : constant Source_Ptr := Sloc (Comp);
7222 -- An array element may be modified by the following relations
7223 -- depending on the number of dimensions:
7225 -- 1 => Expr -- one dimensional update
7226 -- (1, ..., N) => Expr -- multi dimensional update
7228 -- The above forms are converted in assignment statements where the
7229 -- left hand side is an indexed component:
7231 -- Temp (1) := Expr; -- one dimensional update
7232 -- Temp (1, ..., N) := Expr; -- multi dimensional update
7234 if Is_Array_Type (Typ) then
7236 -- The index expressions of a multi dimensional array update
7237 -- appear as an aggregate.
7239 if Nkind (Comp) = N_Aggregate then
7240 Exprs := New_Copy_List_Tree (Expressions (Comp));
7242 Exprs := New_List (Relocate_Node (Comp));
7246 Make_Indexed_Component (Loc,
7247 Prefix => New_Occurrence_Of (Temp, Loc),
7248 Expressions => Exprs);
7250 -- A record component update appears in the following form:
7254 -- The above relation is transformed into an assignment statement
7255 -- where the left hand side is a selected component:
7257 -- Temp.Comp := Expr;
7259 else pragma Assert (Is_Record_Type (Typ));
7261 Make_Selected_Component (Loc,
7262 Prefix => New_Occurrence_Of (Temp, Loc),
7263 Selector_Name => Relocate_Node (Comp));
7267 Make_Assignment_Statement (Loc,
7269 Expression => Relocate_Node (Expr)));
7270 end Process_Component_Or_Element_Update;
7272 --------------------------
7273 -- Process_Range_Update --
7274 --------------------------
7276 procedure Process_Range_Update
7282 Index_Typ : constant Entity_Id := Etype (First_Index (Typ));
7283 Loc : constant Source_Ptr := Sloc (Comp);
7287 -- A range update appears as
7289 -- (Low .. High => Expr)
7291 -- The above construct is transformed into a loop that iterates over
7292 -- the given range and modifies the corresponding array values to the
7295 -- for Index in Low .. High loop
7296 -- Temp (<Index_Typ> (Index)) := Expr;
7299 Index := Make_Temporary (Loc, 'I');
7302 Make_Loop_Statement (Loc,
7304 Make_Iteration_Scheme (Loc,
7305 Loop_Parameter_Specification =>
7306 Make_Loop_Parameter_Specification (Loc,
7307 Defining_Identifier => Index,
7308 Discrete_Subtype_Definition => Relocate_Node (Comp))),
7310 Statements => New_List (
7311 Make_Assignment_Statement (Loc,
7313 Make_Indexed_Component (Loc,
7314 Prefix => New_Occurrence_Of (Temp, Loc),
7315 Expressions => New_List (
7316 Convert_To (Index_Typ,
7317 New_Occurrence_Of (Index, Loc)))),
7318 Expression => Relocate_Node (Expr))),
7320 End_Label => Empty));
7321 end Process_Range_Update;
7325 Aggr : constant Node_Id := First (Expressions (N));
7326 Loc : constant Source_Ptr := Sloc (N);
7327 Pref : constant Node_Id := Prefix (N);
7328 Typ : constant Entity_Id := Etype (Pref);
7331 CW_Temp : Entity_Id;
7336 -- Start of processing for Expand_Update_Attribute
7339 -- Create the anonymous object to store the value of the prefix and
7340 -- capture subsequent changes in value.
7342 Temp := Make_Temporary (Loc, 'T', Pref);
7344 -- Preserve the tag of the prefix by offering a specific view of the
7345 -- class-wide version of the prefix.
7347 if Is_Tagged_Type (Typ) then
7350 -- CW_Temp : Typ'Class := Typ'Class (Pref);
7352 CW_Temp := Make_Temporary (Loc, 'T');
7353 CW_Typ := Class_Wide_Type (Typ);
7356 Make_Object_Declaration (Loc,
7357 Defining_Identifier => CW_Temp,
7358 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
7360 Convert_To (CW_Typ, Relocate_Node (Pref))));
7363 -- Temp : Typ renames Typ (CW_Temp);
7366 Make_Object_Renaming_Declaration (Loc,
7367 Defining_Identifier => Temp,
7368 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
7370 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))));
7376 -- Temp : Typ := Pref;
7379 Make_Object_Declaration (Loc,
7380 Defining_Identifier => Temp,
7381 Object_Definition => New_Occurrence_Of (Typ, Loc),
7382 Expression => Relocate_Node (Pref)));
7385 -- Process the update aggregate
7387 Assoc := First (Component_Associations (Aggr));
7388 while Present (Assoc) loop
7389 Comp := First (Choices (Assoc));
7390 Expr := Expression (Assoc);
7391 while Present (Comp) loop
7392 if Nkind (Comp) = N_Range then
7393 Process_Range_Update (Temp, Comp, Expr, Typ);
7395 Process_Component_Or_Element_Update (Temp, Comp, Expr, Typ);
7404 -- The attribute is replaced by a reference to the anonymous object
7406 Rewrite (N, New_Occurrence_Of (Temp, Loc));
7408 end Expand_Update_Attribute;
7414 procedure Find_Fat_Info
7416 Fat_Type : out Entity_Id;
7417 Fat_Pkg : out RE_Id)
7419 Rtyp : constant Entity_Id := Root_Type (T);
7422 -- All we do is use the root type (historically this dealt with
7423 -- VAX-float .. to be cleaned up further later ???)
7427 if Fat_Type = Standard_Short_Float then
7428 Fat_Pkg := RE_Attr_Short_Float;
7430 elsif Fat_Type = Standard_Float then
7431 Fat_Pkg := RE_Attr_Float;
7433 elsif Fat_Type = Standard_Long_Float then
7434 Fat_Pkg := RE_Attr_Long_Float;
7436 elsif Fat_Type = Standard_Long_Long_Float then
7437 Fat_Pkg := RE_Attr_Long_Long_Float;
7439 -- Universal real (which is its own root type) is treated as being
7440 -- equivalent to Standard.Long_Long_Float, since it is defined to
7441 -- have the same precision as the longest Float type.
7443 elsif Fat_Type = Universal_Real then
7444 Fat_Type := Standard_Long_Long_Float;
7445 Fat_Pkg := RE_Attr_Long_Long_Float;
7448 raise Program_Error;
7452 ----------------------------
7453 -- Find_Stream_Subprogram --
7454 ----------------------------
7456 function Find_Stream_Subprogram
7458 Nam : TSS_Name_Type) return Entity_Id
7460 Base_Typ : constant Entity_Id := Base_Type (Typ);
7461 Ent : constant Entity_Id := TSS (Typ, Nam);
7463 function Is_Available (Entity : RE_Id) return Boolean;
7464 pragma Inline (Is_Available);
7465 -- Function to check whether the specified run-time call is available
7466 -- in the run time used. In the case of a configurable run time, it
7467 -- is normal that some subprograms are not there.
7469 -- I don't understand this routine at all, why is this not just a
7470 -- call to RTE_Available? And if for some reason we need a different
7471 -- routine with different semantics, why is not in Rtsfind ???
7477 function Is_Available (Entity : RE_Id) return Boolean is
7479 -- Assume that the unit will always be available when using a
7480 -- "normal" (not configurable) run time.
7482 return not Configurable_Run_Time_Mode or else RTE_Available (Entity);
7485 -- Start of processing for Find_Stream_Subprogram
7488 if Present (Ent) then
7492 -- Stream attributes for strings are expanded into library calls. The
7493 -- following checks are disabled when the run-time is not available or
7494 -- when compiling predefined types due to bootstrap issues. As a result,
7495 -- the compiler will generate in-place stream routines for string types
7496 -- that appear in GNAT's library, but will generate calls via rtsfind
7497 -- to library routines for user code.
7499 -- This is disabled for AAMP, to avoid creating dependences on files not
7500 -- supported in the AAMP library (such as s-fileio.adb).
7502 -- Note: In the case of using a configurable run time, it is very likely
7503 -- that stream routines for string types are not present (they require
7504 -- file system support). In this case, the specific stream routines for
7505 -- strings are not used, relying on the regular stream mechanism
7506 -- instead. That is why we include the test Is_Available when dealing
7507 -- with these cases.
7509 if not AAMP_On_Target
7511 not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
7513 -- Storage_Array as defined in package System.Storage_Elements
7515 if Is_RTE (Base_Typ, RE_Storage_Array) then
7517 -- Case of No_Stream_Optimizations restriction active
7519 if Restriction_Active (No_Stream_Optimizations) then
7520 if Nam = TSS_Stream_Input
7521 and then Is_Available (RE_Storage_Array_Input)
7523 return RTE (RE_Storage_Array_Input);
7525 elsif Nam = TSS_Stream_Output
7526 and then Is_Available (RE_Storage_Array_Output)
7528 return RTE (RE_Storage_Array_Output);
7530 elsif Nam = TSS_Stream_Read
7531 and then Is_Available (RE_Storage_Array_Read)
7533 return RTE (RE_Storage_Array_Read);
7535 elsif Nam = TSS_Stream_Write
7536 and then Is_Available (RE_Storage_Array_Write)
7538 return RTE (RE_Storage_Array_Write);
7540 elsif Nam /= TSS_Stream_Input and then
7541 Nam /= TSS_Stream_Output and then
7542 Nam /= TSS_Stream_Read and then
7543 Nam /= TSS_Stream_Write
7545 raise Program_Error;
7548 -- Restriction No_Stream_Optimizations is not set, so we can go
7549 -- ahead and optimize using the block IO forms of the routines.
7552 if Nam = TSS_Stream_Input
7553 and then Is_Available (RE_Storage_Array_Input_Blk_IO)
7555 return RTE (RE_Storage_Array_Input_Blk_IO);
7557 elsif Nam = TSS_Stream_Output
7558 and then Is_Available (RE_Storage_Array_Output_Blk_IO)
7560 return RTE (RE_Storage_Array_Output_Blk_IO);
7562 elsif Nam = TSS_Stream_Read
7563 and then Is_Available (RE_Storage_Array_Read_Blk_IO)
7565 return RTE (RE_Storage_Array_Read_Blk_IO);
7567 elsif Nam = TSS_Stream_Write
7568 and then Is_Available (RE_Storage_Array_Write_Blk_IO)
7570 return RTE (RE_Storage_Array_Write_Blk_IO);
7572 elsif Nam /= TSS_Stream_Input and then
7573 Nam /= TSS_Stream_Output and then
7574 Nam /= TSS_Stream_Read and then
7575 Nam /= TSS_Stream_Write
7577 raise Program_Error;
7581 -- Stream_Element_Array as defined in package Ada.Streams
7583 elsif Is_RTE (Base_Typ, RE_Stream_Element_Array) then
7585 -- Case of No_Stream_Optimizations restriction active
7587 if Restriction_Active (No_Stream_Optimizations) then
7588 if Nam = TSS_Stream_Input
7589 and then Is_Available (RE_Stream_Element_Array_Input)
7591 return RTE (RE_Stream_Element_Array_Input);
7593 elsif Nam = TSS_Stream_Output
7594 and then Is_Available (RE_Stream_Element_Array_Output)
7596 return RTE (RE_Stream_Element_Array_Output);
7598 elsif Nam = TSS_Stream_Read
7599 and then Is_Available (RE_Stream_Element_Array_Read)
7601 return RTE (RE_Stream_Element_Array_Read);
7603 elsif Nam = TSS_Stream_Write
7604 and then Is_Available (RE_Stream_Element_Array_Write)
7606 return RTE (RE_Stream_Element_Array_Write);
7608 elsif Nam /= TSS_Stream_Input and then
7609 Nam /= TSS_Stream_Output and then
7610 Nam /= TSS_Stream_Read and then
7611 Nam /= TSS_Stream_Write
7613 raise Program_Error;
7616 -- Restriction No_Stream_Optimizations is not set, so we can go
7617 -- ahead and optimize using the block IO forms of the routines.
7620 if Nam = TSS_Stream_Input
7621 and then Is_Available (RE_Stream_Element_Array_Input_Blk_IO)
7623 return RTE (RE_Stream_Element_Array_Input_Blk_IO);
7625 elsif Nam = TSS_Stream_Output
7626 and then Is_Available (RE_Stream_Element_Array_Output_Blk_IO)
7628 return RTE (RE_Stream_Element_Array_Output_Blk_IO);
7630 elsif Nam = TSS_Stream_Read
7631 and then Is_Available (RE_Stream_Element_Array_Read_Blk_IO)
7633 return RTE (RE_Stream_Element_Array_Read_Blk_IO);
7635 elsif Nam = TSS_Stream_Write
7636 and then Is_Available (RE_Stream_Element_Array_Write_Blk_IO)
7638 return RTE (RE_Stream_Element_Array_Write_Blk_IO);
7640 elsif Nam /= TSS_Stream_Input and then
7641 Nam /= TSS_Stream_Output and then
7642 Nam /= TSS_Stream_Read and then
7643 Nam /= TSS_Stream_Write
7645 raise Program_Error;
7649 -- String as defined in package Ada
7651 elsif Base_Typ = Standard_String then
7653 -- Case of No_Stream_Optimizations restriction active
7655 if Restriction_Active (No_Stream_Optimizations) then
7656 if Nam = TSS_Stream_Input
7657 and then Is_Available (RE_String_Input)
7659 return RTE (RE_String_Input);
7661 elsif Nam = TSS_Stream_Output
7662 and then Is_Available (RE_String_Output)
7664 return RTE (RE_String_Output);
7666 elsif Nam = TSS_Stream_Read
7667 and then Is_Available (RE_String_Read)
7669 return RTE (RE_String_Read);
7671 elsif Nam = TSS_Stream_Write
7672 and then Is_Available (RE_String_Write)
7674 return RTE (RE_String_Write);
7676 elsif Nam /= TSS_Stream_Input and then
7677 Nam /= TSS_Stream_Output and then
7678 Nam /= TSS_Stream_Read and then
7679 Nam /= TSS_Stream_Write
7681 raise Program_Error;
7684 -- Restriction No_Stream_Optimizations is not set, so we can go
7685 -- ahead and optimize using the block IO forms of the routines.
7688 if Nam = TSS_Stream_Input
7689 and then Is_Available (RE_String_Input_Blk_IO)
7691 return RTE (RE_String_Input_Blk_IO);
7693 elsif Nam = TSS_Stream_Output
7694 and then Is_Available (RE_String_Output_Blk_IO)
7696 return RTE (RE_String_Output_Blk_IO);
7698 elsif Nam = TSS_Stream_Read
7699 and then Is_Available (RE_String_Read_Blk_IO)
7701 return RTE (RE_String_Read_Blk_IO);
7703 elsif Nam = TSS_Stream_Write
7704 and then Is_Available (RE_String_Write_Blk_IO)
7706 return RTE (RE_String_Write_Blk_IO);
7708 elsif Nam /= TSS_Stream_Input and then
7709 Nam /= TSS_Stream_Output and then
7710 Nam /= TSS_Stream_Read and then
7711 Nam /= TSS_Stream_Write
7713 raise Program_Error;
7717 -- Wide_String as defined in package Ada
7719 elsif Base_Typ = Standard_Wide_String then
7721 -- Case of No_Stream_Optimizations restriction active
7723 if Restriction_Active (No_Stream_Optimizations) then
7724 if Nam = TSS_Stream_Input
7725 and then Is_Available (RE_Wide_String_Input)
7727 return RTE (RE_Wide_String_Input);
7729 elsif Nam = TSS_Stream_Output
7730 and then Is_Available (RE_Wide_String_Output)
7732 return RTE (RE_Wide_String_Output);
7734 elsif Nam = TSS_Stream_Read
7735 and then Is_Available (RE_Wide_String_Read)
7737 return RTE (RE_Wide_String_Read);
7739 elsif Nam = TSS_Stream_Write
7740 and then Is_Available (RE_Wide_String_Write)
7742 return RTE (RE_Wide_String_Write);
7744 elsif Nam /= TSS_Stream_Input and then
7745 Nam /= TSS_Stream_Output and then
7746 Nam /= TSS_Stream_Read and then
7747 Nam /= TSS_Stream_Write
7749 raise Program_Error;
7752 -- Restriction No_Stream_Optimizations is not set, so we can go
7753 -- ahead and optimize using the block IO forms of the routines.
7756 if Nam = TSS_Stream_Input
7757 and then Is_Available (RE_Wide_String_Input_Blk_IO)
7759 return RTE (RE_Wide_String_Input_Blk_IO);
7761 elsif Nam = TSS_Stream_Output
7762 and then Is_Available (RE_Wide_String_Output_Blk_IO)
7764 return RTE (RE_Wide_String_Output_Blk_IO);
7766 elsif Nam = TSS_Stream_Read
7767 and then Is_Available (RE_Wide_String_Read_Blk_IO)
7769 return RTE (RE_Wide_String_Read_Blk_IO);
7771 elsif Nam = TSS_Stream_Write
7772 and then Is_Available (RE_Wide_String_Write_Blk_IO)
7774 return RTE (RE_Wide_String_Write_Blk_IO);
7776 elsif Nam /= TSS_Stream_Input and then
7777 Nam /= TSS_Stream_Output and then
7778 Nam /= TSS_Stream_Read and then
7779 Nam /= TSS_Stream_Write
7781 raise Program_Error;
7785 -- Wide_Wide_String as defined in package Ada
7787 elsif Base_Typ = Standard_Wide_Wide_String then
7789 -- Case of No_Stream_Optimizations restriction active
7791 if Restriction_Active (No_Stream_Optimizations) then
7792 if Nam = TSS_Stream_Input
7793 and then Is_Available (RE_Wide_Wide_String_Input)
7795 return RTE (RE_Wide_Wide_String_Input);
7797 elsif Nam = TSS_Stream_Output
7798 and then Is_Available (RE_Wide_Wide_String_Output)
7800 return RTE (RE_Wide_Wide_String_Output);
7802 elsif Nam = TSS_Stream_Read
7803 and then Is_Available (RE_Wide_Wide_String_Read)
7805 return RTE (RE_Wide_Wide_String_Read);
7807 elsif Nam = TSS_Stream_Write
7808 and then Is_Available (RE_Wide_Wide_String_Write)
7810 return RTE (RE_Wide_Wide_String_Write);
7812 elsif Nam /= TSS_Stream_Input and then
7813 Nam /= TSS_Stream_Output and then
7814 Nam /= TSS_Stream_Read and then
7815 Nam /= TSS_Stream_Write
7817 raise Program_Error;
7820 -- Restriction No_Stream_Optimizations is not set, so we can go
7821 -- ahead and optimize using the block IO forms of the routines.
7824 if Nam = TSS_Stream_Input
7825 and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO)
7827 return RTE (RE_Wide_Wide_String_Input_Blk_IO);
7829 elsif Nam = TSS_Stream_Output
7830 and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO)
7832 return RTE (RE_Wide_Wide_String_Output_Blk_IO);
7834 elsif Nam = TSS_Stream_Read
7835 and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO)
7837 return RTE (RE_Wide_Wide_String_Read_Blk_IO);
7839 elsif Nam = TSS_Stream_Write
7840 and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO)
7842 return RTE (RE_Wide_Wide_String_Write_Blk_IO);
7844 elsif Nam /= TSS_Stream_Input and then
7845 Nam /= TSS_Stream_Output and then
7846 Nam /= TSS_Stream_Read and then
7847 Nam /= TSS_Stream_Write
7849 raise Program_Error;
7855 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
7856 return Find_Prim_Op (Typ, Nam);
7858 return Find_Inherited_TSS (Typ, Nam);
7860 end Find_Stream_Subprogram;
7866 function Full_Base (T : Entity_Id) return Entity_Id is
7870 BT := Base_Type (T);
7872 if Is_Private_Type (BT)
7873 and then Present (Full_View (BT))
7875 BT := Full_View (BT);
7881 -----------------------
7882 -- Get_Index_Subtype --
7883 -----------------------
7885 function Get_Index_Subtype (N : Node_Id) return Node_Id is
7886 P_Type : Entity_Id := Etype (Prefix (N));
7891 if Is_Access_Type (P_Type) then
7892 P_Type := Designated_Type (P_Type);
7895 if No (Expressions (N)) then
7898 J := UI_To_Int (Expr_Value (First (Expressions (N))));
7901 Indx := First_Index (P_Type);
7907 return Etype (Indx);
7908 end Get_Index_Subtype;
7910 -------------------------------
7911 -- Get_Stream_Convert_Pragma --
7912 -------------------------------
7914 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is
7919 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
7920 -- that a stream convert pragma for a tagged type is not inherited from
7921 -- its parent. Probably what is wrong here is that it is basically
7922 -- incorrect to consider a stream convert pragma to be a representation
7923 -- pragma at all ???
7925 N := First_Rep_Item (Implementation_Base_Type (T));
7926 while Present (N) loop
7927 if Nkind (N) = N_Pragma
7928 and then Pragma_Name (N) = Name_Stream_Convert
7930 -- For tagged types this pragma is not inherited, so we
7931 -- must verify that it is defined for the given type and
7935 Entity (Expression (First (Pragma_Argument_Associations (N))));
7937 if not Is_Tagged_Type (T)
7939 or else (Is_Private_Type (Typ) and then T = Full_View (Typ))
7949 end Get_Stream_Convert_Pragma;
7951 ---------------------------------
7952 -- Is_Constrained_Packed_Array --
7953 ---------------------------------
7955 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is
7956 Arr : Entity_Id := Typ;
7959 if Is_Access_Type (Arr) then
7960 Arr := Designated_Type (Arr);
7963 return Is_Array_Type (Arr)
7964 and then Is_Constrained (Arr)
7965 and then Present (Packed_Array_Impl_Type (Arr));
7966 end Is_Constrained_Packed_Array;
7968 ----------------------------------------
7969 -- Is_Inline_Floating_Point_Attribute --
7970 ----------------------------------------
7972 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is
7973 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
7975 function Is_GCC_Target return Boolean;
7976 -- Return True if we are using a GCC target/back-end
7977 -- ??? Note: the implementation is kludgy/fragile
7983 function Is_GCC_Target return Boolean is
7985 return not CodePeer_Mode and then not AAMP_On_Target;
7988 -- Start of processing for Exp_Attr
7991 -- Machine and Model can be expanded by the GCC backend only
7993 if Id = Attribute_Machine or else Id = Attribute_Model then
7994 return Is_GCC_Target;
7996 -- Remaining cases handled by all back ends are Rounding and Truncation
7997 -- when appearing as the operand of a conversion to some integer type.
7999 elsif Nkind (Parent (N)) /= N_Type_Conversion
8000 or else not Is_Integer_Type (Etype (Parent (N)))
8005 -- Here we are in the integer conversion context
8007 -- Very probably we should also recognize the cases of Machine_Rounding
8008 -- and unbiased rounding in this conversion context, but the back end is
8009 -- not yet prepared to handle these cases ???
8011 return Id = Attribute_Rounding or else Id = Attribute_Truncation;
8012 end Is_Inline_Floating_Point_Attribute;