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 procedure Expand_Access_To_Protected_Op
116 -- An attribute reference to a protected subprogram is transformed into
117 -- a pair of pointers: one to the object, and one to the operations.
118 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
120 procedure Expand_Fpt_Attribute
125 -- This procedure expands a call to a floating-point attribute function.
126 -- N is the attribute reference node, and Args is a list of arguments to
127 -- be passed to the function call. Pkg identifies the package containing
128 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
129 -- have already been converted to the floating-point type for which Pkg was
130 -- instantiated. The Nam argument is the relevant attribute processing
131 -- routine to be called. This is the same as the attribute name, except in
132 -- the Unaligned_Valid case.
134 procedure Expand_Fpt_Attribute_R (N : Node_Id);
135 -- This procedure expands a call to a floating-point attribute function
136 -- that takes a single floating-point argument. The function to be called
137 -- is always the same as the attribute name.
139 procedure Expand_Fpt_Attribute_RI (N : Node_Id);
140 -- This procedure expands a call to a floating-point attribute function
141 -- that takes one floating-point argument and one integer argument. The
142 -- function to be called is always the same as the attribute name.
144 procedure Expand_Fpt_Attribute_RR (N : Node_Id);
145 -- This procedure expands a call to a floating-point attribute function
146 -- that takes two floating-point arguments. The function to be called
147 -- is always the same as the attribute name.
149 procedure Expand_Loop_Entry_Attribute (N : Node_Id);
150 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
151 -- loop may be converted into a conditional block. See body for details.
153 procedure Expand_Min_Max_Attribute (N : Node_Id);
154 -- Handle the expansion of attributes 'Max and 'Min, including expanding
155 -- then out if we are in Modify_Tree_For_C mode.
157 procedure Expand_Pred_Succ_Attribute (N : Node_Id);
158 -- Handles expansion of Pred or Succ attributes for case of non-real
159 -- operand with overflow checking required.
161 procedure Expand_Update_Attribute (N : Node_Id);
162 -- Handle the expansion of attribute Update
164 function Get_Index_Subtype (N : Node_Id) return Entity_Id;
165 -- Used for Last, Last, and Length, when the prefix is an array type.
166 -- Obtains the corresponding index subtype.
168 procedure Find_Fat_Info
170 Fat_Type : out Entity_Id;
171 Fat_Pkg : out RE_Id);
172 -- Given a floating-point type T, identifies the package containing the
173 -- attributes for this type (returned in Fat_Pkg), and the corresponding
174 -- type for which this package was instantiated from Fat_Gen. Error if T
175 -- is not a floating-point type.
177 function Find_Stream_Subprogram
179 Nam : TSS_Name_Type) return Entity_Id;
180 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
181 -- types, the corresponding primitive operation is looked up, else the
182 -- appropriate TSS from the type itself, or from its closest ancestor
183 -- defining it, is returned. In both cases, inheritance of representation
184 -- aspects is thus taken into account.
186 function Full_Base (T : Entity_Id) return Entity_Id;
187 -- The stream functions need to examine the underlying representation of
188 -- composite types. In some cases T may be non-private but its base type
189 -- is, in which case the function returns the corresponding full view.
191 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id;
192 -- Given a type, find a corresponding stream convert pragma that applies to
193 -- the implementation base type of this type (Typ). If found, return the
194 -- pragma node, otherwise return Empty if no pragma is found.
196 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
197 -- Utility for array attributes, returns true on packed constrained
198 -- arrays, and on access to same.
200 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean;
201 -- Returns true iff the given node refers to an attribute call that
202 -- can be expanded directly by the back end and does not need front end
203 -- expansion. Typically used for rounding and truncation attributes that
204 -- appear directly inside a conversion to integer.
206 -------------------------
207 -- Build_Array_VS_Func --
208 -------------------------
210 function Build_Array_VS_Func
212 Nod : Node_Id) return Entity_Id
214 Loc : constant Source_Ptr := Sloc (Nod);
215 Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
216 Comp_Type : constant Entity_Id := Component_Type (A_Type);
217 Body_Stmts : List_Id;
218 Index_List : List_Id;
221 function Test_Component return List_Id;
222 -- Create one statement to test validity of one component designated by
223 -- a full set of indexes. Returns statement list containing test.
225 function Test_One_Dimension (N : Int) return List_Id;
226 -- Create loop to test one dimension of the array. The single statement
227 -- in the loop body tests the inner dimensions if any, or else the
228 -- single component. Note that this procedure is called recursively,
229 -- with N being the dimension to be initialized. A call with N greater
230 -- than the number of dimensions simply generates the component test,
231 -- terminating the recursion. Returns statement list containing tests.
237 function Test_Component return List_Id is
243 Make_Indexed_Component (Loc,
244 Prefix => Make_Identifier (Loc, Name_uA),
245 Expressions => Index_List);
247 if Is_Scalar_Type (Comp_Type) then
250 Anam := Name_Valid_Scalars;
254 Make_If_Statement (Loc,
258 Make_Attribute_Reference (Loc,
259 Attribute_Name => Anam,
261 Then_Statements => New_List (
262 Make_Simple_Return_Statement (Loc,
263 Expression => New_Occurrence_Of (Standard_False, Loc)))));
266 ------------------------
267 -- Test_One_Dimension --
268 ------------------------
270 function Test_One_Dimension (N : Int) return List_Id is
274 -- If all dimensions dealt with, we simply test the component
276 if N > Number_Dimensions (A_Type) then
277 return Test_Component;
279 -- Here we generate the required loop
283 Make_Defining_Identifier (Loc, New_External_Name ('J', N));
285 Append (New_Occurrence_Of (Index, Loc), Index_List);
288 Make_Implicit_Loop_Statement (Nod,
291 Make_Iteration_Scheme (Loc,
292 Loop_Parameter_Specification =>
293 Make_Loop_Parameter_Specification (Loc,
294 Defining_Identifier => Index,
295 Discrete_Subtype_Definition =>
296 Make_Attribute_Reference (Loc,
297 Prefix => Make_Identifier (Loc, Name_uA),
298 Attribute_Name => Name_Range,
299 Expressions => New_List (
300 Make_Integer_Literal (Loc, N))))),
301 Statements => Test_One_Dimension (N + 1)),
302 Make_Simple_Return_Statement (Loc,
303 Expression => New_Occurrence_Of (Standard_True, Loc)));
305 end Test_One_Dimension;
307 -- Start of processing for Build_Array_VS_Func
310 Index_List := New_List;
311 Body_Stmts := Test_One_Dimension (1);
313 -- Parameter is always (A : A_Typ)
315 Formals := New_List (
316 Make_Parameter_Specification (Loc,
317 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uA),
319 Out_Present => False,
320 Parameter_Type => New_Occurrence_Of (A_Type, Loc)));
324 Set_Ekind (Func_Id, E_Function);
325 Set_Is_Internal (Func_Id);
328 Make_Subprogram_Body (Loc,
330 Make_Function_Specification (Loc,
331 Defining_Unit_Name => Func_Id,
332 Parameter_Specifications => Formals,
334 New_Occurrence_Of (Standard_Boolean, Loc)),
335 Declarations => New_List,
336 Handled_Statement_Sequence =>
337 Make_Handled_Sequence_Of_Statements (Loc,
338 Statements => Body_Stmts)));
340 if not Debug_Generated_Code then
341 Set_Debug_Info_Off (Func_Id);
344 Set_Is_Pure (Func_Id);
346 end Build_Array_VS_Func;
348 --------------------------
349 -- Build_Record_VS_Func --
350 --------------------------
354 -- function _Valid_Scalars (X : T) return Boolean is
356 -- -- Check discriminants
358 -- if not X.D1'Valid_Scalars or else
359 -- not X.D2'Valid_Scalars or else
365 -- -- Check components
367 -- if not X.C1'Valid_Scalars or else
368 -- not X.C2'Valid_Scalars or else
374 -- -- Check variant part
378 -- if not X.C2'Valid_Scalars or else
379 -- not X.C3'Valid_Scalars or else
386 -- if not X.Cn'Valid_Scalars or else
394 -- end _Valid_Scalars;
396 function Build_Record_VS_Func
398 Nod : Node_Id) return Entity_Id
400 Loc : constant Source_Ptr := Sloc (R_Type);
401 Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
402 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
404 function Make_VS_Case
407 Discrs : Elist_Id := New_Elmt_List) return List_Id;
408 -- Building block for variant valid scalars. Given a Component_List node
409 -- CL, it generates an 'if' followed by a 'case' statement that compares
410 -- all components of local temporaries named X and Y (that are declared
411 -- as formals at some upper level). E provides the Sloc to be used for
412 -- the generated code.
416 L : List_Id) return Node_Id;
417 -- Building block for variant validate scalars. Given the list, L, of
418 -- components (or discriminants) L, it generates a return statement that
419 -- compares all components of local temporaries named X and Y (that are
420 -- declared as formals at some upper level). E provides the Sloc to be
421 -- used for the generated code.
427 -- <Make_VS_If on shared components>
430 -- when V1 => <Make_VS_Case> on subcomponents
432 -- when Vn => <Make_VS_Case> on subcomponents
435 function Make_VS_Case
438 Discrs : Elist_Id := New_Elmt_List) return List_Id
440 Loc : constant Source_Ptr := Sloc (E);
441 Result : constant List_Id := New_List;
446 Append_To (Result, Make_VS_If (E, Component_Items (CL)));
448 if No (Variant_Part (CL)) then
452 Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
458 Alt_List := New_List;
459 while Present (Variant) loop
461 Make_Case_Statement_Alternative (Loc,
462 Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
464 Make_VS_Case (E, Component_List (Variant), Discrs)));
465 Next_Non_Pragma (Variant);
469 Make_Case_Statement (Loc,
471 Make_Selected_Component (Loc,
472 Prefix => Make_Identifier (Loc, Name_X),
473 Selector_Name => New_Copy (Name (Variant_Part (CL)))),
474 Alternatives => Alt_List));
486 -- not X.C1'Valid_Scalars
488 -- not X.C2'Valid_Scalars
494 -- or a null statement if the list L is empty
498 L : List_Id) return Node_Id
500 Loc : constant Source_Ptr := Sloc (E);
503 Field_Name : Name_Id;
508 return Make_Null_Statement (Loc);
513 C := First_Non_Pragma (L);
514 while Present (C) loop
515 Def_Id := Defining_Identifier (C);
516 Field_Name := Chars (Def_Id);
518 -- The tags need not be checked since they will always be valid
520 -- Note also that in the following, we use Make_Identifier for
521 -- the component names. Use of New_Occurrence_Of to identify
522 -- the components would be incorrect because wrong entities for
523 -- discriminants could be picked up in the private type case.
525 -- Don't bother with abstract parent in interface case
527 if Field_Name = Name_uParent
528 and then Is_Interface (Etype (Def_Id))
532 -- Don't bother with tag, always valid, and not scalar anyway
534 elsif Field_Name = Name_uTag then
537 -- Don't bother with component with no scalar components
539 elsif not Scalar_Part_Present (Etype (Def_Id)) then
542 -- Normal case, generate Valid_Scalars attribute reference
545 Evolve_Or_Else (Cond,
548 Make_Attribute_Reference (Loc,
550 Make_Selected_Component (Loc,
552 Make_Identifier (Loc, Name_X),
554 Make_Identifier (Loc, Field_Name)),
555 Attribute_Name => Name_Valid_Scalars)));
562 return Make_Null_Statement (Loc);
566 Make_Implicit_If_Statement (E,
568 Then_Statements => New_List (
569 Make_Simple_Return_Statement (Loc,
571 New_Occurrence_Of (Standard_False, Loc))));
576 -- Local Declarations
578 Def : constant Node_Id := Parent (R_Type);
579 Comps : constant Node_Id := Component_List (Type_Definition (Def));
580 Stmts : constant List_Id := New_List;
581 Pspecs : constant List_Id := New_List;
585 Make_Parameter_Specification (Loc,
586 Defining_Identifier => X,
587 Parameter_Type => New_Occurrence_Of (R_Type, Loc)));
590 Make_VS_If (R_Type, Discriminant_Specifications (Def)));
591 Append_List_To (Stmts, Make_VS_Case (R_Type, Comps));
594 Make_Simple_Return_Statement (Loc,
595 Expression => New_Occurrence_Of (Standard_True, Loc)));
598 Make_Subprogram_Body (Loc,
600 Make_Function_Specification (Loc,
601 Defining_Unit_Name => Func_Id,
602 Parameter_Specifications => Pspecs,
603 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
604 Declarations => New_List,
605 Handled_Statement_Sequence =>
606 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)),
607 Suppress => Discriminant_Check);
609 if not Debug_Generated_Code then
610 Set_Debug_Info_Off (Func_Id);
613 Set_Is_Pure (Func_Id);
615 end Build_Record_VS_Func;
617 ----------------------------------
618 -- Compile_Stream_Body_In_Scope --
619 ----------------------------------
621 procedure Compile_Stream_Body_In_Scope
627 Installed : Boolean := False;
628 Scop : constant Entity_Id := Scope (Arr);
629 Curr : constant Entity_Id := Current_Scope;
633 and then not In_Open_Scopes (Scop)
634 and then Ekind (Scop) = E_Package
636 -- If we are within an instance body, then all visibility has been
637 -- established already and there is no need to install the package.
639 and then not In_Instance_Body
642 Install_Visible_Declarations (Scop);
643 Install_Private_Declarations (Scop);
646 -- The entities in the package are now visible, but the generated
647 -- stream entity must appear in the current scope (usually an
648 -- enclosing stream function) so that itypes all have their proper
655 Insert_Action (N, Decl);
657 Insert_Action (N, Decl, Suppress => All_Checks);
662 -- Remove extra copy of current scope, and package itself
665 End_Package_Scope (Scop);
667 end Compile_Stream_Body_In_Scope;
669 -----------------------------------
670 -- Expand_Access_To_Protected_Op --
671 -----------------------------------
673 procedure Expand_Access_To_Protected_Op
678 -- The value of the attribute_reference is a record containing two
679 -- fields: an access to the protected object, and an access to the
680 -- subprogram itself. The prefix is a selected component.
682 Loc : constant Source_Ptr := Sloc (N);
684 Btyp : constant Entity_Id := Base_Type (Typ);
687 E_T : constant Entity_Id := Equivalent_Type (Btyp);
688 Acc : constant Entity_Id :=
689 Etype (Next_Component (First_Component (E_T)));
693 -- Start of processing for Expand_Access_To_Protected_Op
696 -- Within the body of the protected type, the prefix designates a local
697 -- operation, and the object is the first parameter of the corresponding
698 -- protected body of the current enclosing operation.
700 if Is_Entity_Name (Pref) then
701 -- All indirect calls are external calls, so must do locking and
702 -- barrier reevaluation, even if the 'Access occurs within the
703 -- protected body. Hence the call to External_Subprogram, as opposed
704 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means
705 -- that indirect calls from within the same protected body will
706 -- deadlock, as allowed by RM-9.5.1(8,15,17).
708 Sub := New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc);
710 -- Don't traverse the scopes when the attribute occurs within an init
711 -- proc, because we directly use the _init formal of the init proc in
714 Curr := Current_Scope;
715 if not Is_Init_Proc (Curr) then
716 pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
718 while Scope (Curr) /= Scope (Entity (Pref)) loop
719 Curr := Scope (Curr);
723 -- In case of protected entries the first formal of its Protected_
724 -- Body_Subprogram is the address of the object.
726 if Ekind (Curr) = E_Entry then
730 (Protected_Body_Subprogram (Curr)), Loc);
732 -- If the current scope is an init proc, then use the address of the
733 -- _init formal as the object reference.
735 elsif Is_Init_Proc (Curr) then
737 Make_Attribute_Reference (Loc,
738 Prefix => New_Occurrence_Of (First_Formal (Curr), Loc),
739 Attribute_Name => Name_Address);
741 -- In case of protected subprograms the first formal of its
742 -- Protected_Body_Subprogram is the object and we get its address.
746 Make_Attribute_Reference (Loc,
750 (Protected_Body_Subprogram (Curr)), Loc),
751 Attribute_Name => Name_Address);
754 -- Case where the prefix is not an entity name. Find the
755 -- version of the protected operation to be called from
756 -- outside the protected object.
762 (Entity (Selector_Name (Pref))), Loc);
765 Make_Attribute_Reference (Loc,
766 Prefix => Relocate_Node (Prefix (Pref)),
767 Attribute_Name => Name_Address);
771 Make_Attribute_Reference (Loc,
773 Attribute_Name => Name_Access);
775 -- We set the type of the access reference to the already generated
776 -- access_to_subprogram type, and declare the reference analyzed, to
777 -- prevent further expansion when the enclosing aggregate is analyzed.
779 Set_Etype (Sub_Ref, Acc);
780 Set_Analyzed (Sub_Ref);
784 Expressions => New_List (Obj_Ref, Sub_Ref));
786 -- Sub_Ref has been marked as analyzed, but we still need to make sure
787 -- Sub is correctly frozen.
789 Freeze_Before (N, Entity (Sub));
792 Analyze_And_Resolve (N, E_T);
794 -- For subsequent analysis, the node must retain its type. The backend
795 -- will replace it with the equivalent type where needed.
798 end Expand_Access_To_Protected_Op;
800 --------------------------
801 -- Expand_Fpt_Attribute --
802 --------------------------
804 procedure Expand_Fpt_Attribute
810 Loc : constant Source_Ptr := Sloc (N);
811 Typ : constant Entity_Id := Etype (N);
815 -- The function name is the selected component Attr_xxx.yyy where
816 -- Attr_xxx is the package name, and yyy is the argument Nam.
818 -- Note: it would be more usual to have separate RE entries for each
819 -- of the entities in the Fat packages, but first they have identical
820 -- names (so we would have to have lots of renaming declarations to
821 -- meet the normal RE rule of separate names for all runtime entities),
822 -- and second there would be an awful lot of them.
825 Make_Selected_Component (Loc,
826 Prefix => New_Occurrence_Of (RTE (Pkg), Loc),
827 Selector_Name => Make_Identifier (Loc, Nam));
829 -- The generated call is given the provided set of parameters, and then
830 -- wrapped in a conversion which converts the result to the target type
831 -- We use the base type as the target because a range check may be
835 Unchecked_Convert_To (Base_Type (Etype (N)),
836 Make_Function_Call (Loc,
838 Parameter_Associations => Args)));
840 Analyze_And_Resolve (N, Typ);
841 end Expand_Fpt_Attribute;
843 ----------------------------
844 -- Expand_Fpt_Attribute_R --
845 ----------------------------
847 -- The single argument is converted to its root type to call the
848 -- appropriate runtime function, with the actual call being built
849 -- by Expand_Fpt_Attribute
851 procedure Expand_Fpt_Attribute_R (N : Node_Id) is
852 E1 : constant Node_Id := First (Expressions (N));
856 Find_Fat_Info (Etype (E1), Ftp, Pkg);
858 (N, Pkg, Attribute_Name (N),
859 New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1))));
860 end Expand_Fpt_Attribute_R;
862 -----------------------------
863 -- Expand_Fpt_Attribute_RI --
864 -----------------------------
866 -- The first argument is converted to its root type and the second
867 -- argument is converted to standard long long integer to call the
868 -- appropriate runtime function, with the actual call being built
869 -- by Expand_Fpt_Attribute
871 procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
872 E1 : constant Node_Id := First (Expressions (N));
875 E2 : constant Node_Id := Next (E1);
877 Find_Fat_Info (Etype (E1), Ftp, Pkg);
879 (N, Pkg, Attribute_Name (N),
881 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
882 Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
883 end Expand_Fpt_Attribute_RI;
885 -----------------------------
886 -- Expand_Fpt_Attribute_RR --
887 -----------------------------
889 -- The two arguments are converted to their root types to call the
890 -- appropriate runtime function, with the actual call being built
891 -- by Expand_Fpt_Attribute
893 procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
894 E1 : constant Node_Id := First (Expressions (N));
895 E2 : constant Node_Id := Next (E1);
900 Find_Fat_Info (Etype (E1), Ftp, Pkg);
902 (N, Pkg, Attribute_Name (N),
904 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
905 Unchecked_Convert_To (Ftp, Relocate_Node (E2))));
906 end Expand_Fpt_Attribute_RR;
908 ---------------------------------
909 -- Expand_Loop_Entry_Attribute --
910 ---------------------------------
912 procedure Expand_Loop_Entry_Attribute (N : Node_Id) is
913 procedure Build_Conditional_Block
917 If_Stmt : out Node_Id;
918 Blk_Stmt : out Node_Id);
919 -- Create a block Blk_Stmt with an empty declarative list and a single
920 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
921 -- condition Cond. If_Stmt is Empty when there is no condition provided.
923 function Is_Array_Iteration (N : Node_Id) return Boolean;
924 -- Determine whether loop statement N denotes an Ada 2012 iteration over
927 -----------------------------
928 -- Build_Conditional_Block --
929 -----------------------------
931 procedure Build_Conditional_Block
935 If_Stmt : out Node_Id;
936 Blk_Stmt : out Node_Id)
939 -- Do not reanalyze the original loop statement because it is simply
942 Set_Analyzed (Loop_Stmt);
945 Make_Block_Statement (Loc,
946 Declarations => New_List,
947 Handled_Statement_Sequence =>
948 Make_Handled_Sequence_Of_Statements (Loc,
949 Statements => New_List (Loop_Stmt)));
951 if Present (Cond) then
953 Make_If_Statement (Loc,
955 Then_Statements => New_List (Blk_Stmt));
959 end Build_Conditional_Block;
961 ------------------------
962 -- Is_Array_Iteration --
963 ------------------------
965 function Is_Array_Iteration (N : Node_Id) return Boolean is
966 Stmt : constant Node_Id := Original_Node (N);
970 if Nkind (Stmt) = N_Loop_Statement
971 and then Present (Iteration_Scheme (Stmt))
972 and then Present (Iterator_Specification (Iteration_Scheme (Stmt)))
974 Iter := Iterator_Specification (Iteration_Scheme (Stmt));
977 Of_Present (Iter) and then Is_Array_Type (Etype (Name (Iter)));
981 end Is_Array_Iteration;
985 Exprs : constant List_Id := Expressions (N);
986 Pref : constant Node_Id := Prefix (N);
987 Typ : constant Entity_Id := Etype (Pref);
1000 Temp_Id : Entity_Id;
1002 -- Start of processing for Expand_Loop_Entry_Attribute
1005 -- Step 1: Find the related loop
1007 -- The loop label variant of attribute 'Loop_Entry already has all the
1008 -- information in its expression.
1010 if Present (Exprs) then
1011 Loop_Id := Entity (First (Exprs));
1012 Loop_Stmt := Label_Construct (Parent (Loop_Id));
1014 -- Climb the parent chain to find the nearest enclosing loop. Skip all
1015 -- internally generated loops for quantified expressions.
1019 while Present (Loop_Stmt) loop
1020 if Nkind (Loop_Stmt) = N_Loop_Statement
1021 and then Present (Identifier (Loop_Stmt))
1026 Loop_Stmt := Parent (Loop_Stmt);
1029 Loop_Id := Entity (Identifier (Loop_Stmt));
1032 Loc := Sloc (Loop_Stmt);
1034 -- Step 2: Transform the loop
1036 -- The loop has already been transformed during the expansion of a prior
1037 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
1039 if Has_Loop_Entry_Attributes (Loop_Id) then
1041 -- When the related loop name appears as the argument of attribute
1042 -- Loop_Entry, the corresponding label construct is the generated
1043 -- block statement. This is because the expander reuses the label.
1045 if Nkind (Loop_Stmt) = N_Block_Statement then
1046 Decls := Declarations (Loop_Stmt);
1048 -- In all other cases, the loop must appear in the handled sequence
1049 -- of statements of the generated block.
1053 (Nkind (Parent (Loop_Stmt)) = N_Handled_Sequence_Of_Statements
1055 Nkind (Parent (Parent (Loop_Stmt))) = N_Block_Statement);
1057 Decls := Declarations (Parent (Parent (Loop_Stmt)));
1062 -- Transform the loop into a conditional block
1065 Set_Has_Loop_Entry_Attributes (Loop_Id);
1066 Scheme := Iteration_Scheme (Loop_Stmt);
1068 -- Infinite loops are transformed into:
1071 -- Temp1 : constant <type of Pref1> := <Pref1>;
1073 -- TempN : constant <type of PrefN> := <PrefN>;
1076 -- <original source statements with attribute rewrites>
1081 Build_Conditional_Block (Loc,
1083 Loop_Stmt => Relocate_Node (Loop_Stmt),
1089 -- While loops are transformed into:
1091 -- function Fnn return Boolean is
1093 -- <condition actions>
1094 -- return <condition>;
1099 -- Temp1 : constant <type of Pref1> := <Pref1>;
1101 -- TempN : constant <type of PrefN> := <PrefN>;
1104 -- <original source statements with attribute rewrites>
1105 -- exit when not Fnn;
1110 -- Note that loops over iterators and containers are already
1111 -- converted into while loops.
1113 elsif Present (Condition (Scheme)) then
1115 Func_Decl : Node_Id;
1116 Func_Id : Entity_Id;
1120 -- Wrap the condition of the while loop in a Boolean function.
1121 -- This avoids the duplication of the same code which may lead
1122 -- to gigi issues with respect to multiple declaration of the
1123 -- same entity in the presence of side effects or checks. Note
1124 -- that the condition actions must also be relocated to the
1125 -- wrapping function.
1128 -- <condition actions>
1129 -- return <condition>;
1131 if Present (Condition_Actions (Scheme)) then
1132 Stmts := Condition_Actions (Scheme);
1138 Make_Simple_Return_Statement (Loc,
1139 Expression => Relocate_Node (Condition (Scheme))));
1142 -- function Fnn return Boolean is
1147 Func_Id := Make_Temporary (Loc, 'F');
1149 Make_Subprogram_Body (Loc,
1151 Make_Function_Specification (Loc,
1152 Defining_Unit_Name => Func_Id,
1153 Result_Definition =>
1154 New_Occurrence_Of (Standard_Boolean, Loc)),
1155 Declarations => Empty_List,
1156 Handled_Statement_Sequence =>
1157 Make_Handled_Sequence_Of_Statements (Loc,
1158 Statements => Stmts));
1160 -- The function is inserted before the related loop. Make sure
1161 -- to analyze it in the context of the loop's enclosing scope.
1163 Push_Scope (Scope (Loop_Id));
1164 Insert_Action (Loop_Stmt, Func_Decl);
1167 -- Transform the original while loop into an infinite loop
1168 -- where the last statement checks the negated condition. This
1169 -- placement ensures that the condition will not be evaluated
1170 -- twice on the first iteration.
1172 Set_Iteration_Scheme (Loop_Stmt, Empty);
1176 -- exit when not Fnn;
1178 Append_To (Statements (Loop_Stmt),
1179 Make_Exit_Statement (Loc,
1183 Make_Function_Call (Loc,
1184 Name => New_Occurrence_Of (Func_Id, Loc)))));
1186 Build_Conditional_Block (Loc,
1188 Make_Function_Call (Loc,
1189 Name => New_Occurrence_Of (Func_Id, Loc)),
1190 Loop_Stmt => Relocate_Node (Loop_Stmt),
1195 -- Ada 2012 iteration over an array is transformed into:
1197 -- if <Array_Nam>'Length (1) > 0
1198 -- and then <Array_Nam>'Length (N) > 0
1201 -- Temp1 : constant <type of Pref1> := <Pref1>;
1203 -- TempN : constant <type of PrefN> := <PrefN>;
1205 -- for X in ... loop -- multiple loops depending on dims
1206 -- <original source statements with attribute rewrites>
1211 elsif Is_Array_Iteration (Loop_Stmt) then
1213 Array_Nam : constant Entity_Id :=
1214 Entity (Name (Iterator_Specification
1215 (Iteration_Scheme (Original_Node (Loop_Stmt)))));
1216 Num_Dims : constant Pos :=
1217 Number_Dimensions (Etype (Array_Nam));
1218 Cond : Node_Id := Empty;
1222 -- Generate a check which determines whether all dimensions of
1223 -- the array are non-null.
1225 for Dim in 1 .. Num_Dims loop
1229 Make_Attribute_Reference (Loc,
1230 Prefix => New_Occurrence_Of (Array_Nam, Loc),
1231 Attribute_Name => Name_Length,
1232 Expressions => New_List (
1233 Make_Integer_Literal (Loc, Dim))),
1235 Make_Integer_Literal (Loc, 0));
1243 Right_Opnd => Check);
1247 Build_Conditional_Block (Loc,
1249 Loop_Stmt => Relocate_Node (Loop_Stmt),
1254 -- For loops are transformed into:
1256 -- if <Low> <= <High> then
1258 -- Temp1 : constant <type of Pref1> := <Pref1>;
1260 -- TempN : constant <type of PrefN> := <PrefN>;
1262 -- for <Def_Id> in <Low> .. <High> loop
1263 -- <original source statements with attribute rewrites>
1268 elsif Present (Loop_Parameter_Specification (Scheme)) then
1270 Loop_Spec : constant Node_Id :=
1271 Loop_Parameter_Specification (Scheme);
1276 Subt_Def := Discrete_Subtype_Definition (Loop_Spec);
1278 -- When the loop iterates over a subtype indication with a
1279 -- range, use the low and high bounds of the subtype itself.
1281 if Nkind (Subt_Def) = N_Subtype_Indication then
1282 Subt_Def := Scalar_Range (Etype (Subt_Def));
1285 pragma Assert (Nkind (Subt_Def) = N_Range);
1292 Left_Opnd => New_Copy_Tree (Low_Bound (Subt_Def)),
1293 Right_Opnd => New_Copy_Tree (High_Bound (Subt_Def)));
1295 Build_Conditional_Block (Loc,
1297 Loop_Stmt => Relocate_Node (Loop_Stmt),
1303 Decls := Declarations (Blk);
1306 -- Step 3: Create a constant to capture the value of the prefix at the
1307 -- entry point into the loop.
1309 Temp_Id := Make_Temporary (Loc, 'P');
1311 -- Preserve the tag of the prefix by offering a specific view of the
1312 -- class-wide version of the prefix.
1314 if Is_Tagged_Type (Typ) then
1317 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
1319 CW_Temp := Make_Temporary (Loc, 'T');
1320 CW_Typ := Class_Wide_Type (Typ);
1323 Make_Object_Declaration (Loc,
1324 Defining_Identifier => CW_Temp,
1325 Constant_Present => True,
1326 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
1328 Convert_To (CW_Typ, Relocate_Node (Pref)));
1329 Append_To (Decls, CW_Decl);
1332 -- Temp : Typ renames Typ (CW_Temp);
1335 Make_Object_Renaming_Declaration (Loc,
1336 Defining_Identifier => Temp_Id,
1337 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
1339 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)));
1340 Append_To (Decls, Temp_Decl);
1348 -- Temp : constant Typ := Pref;
1351 Make_Object_Declaration (Loc,
1352 Defining_Identifier => Temp_Id,
1353 Constant_Present => True,
1354 Object_Definition => New_Occurrence_Of (Typ, Loc),
1355 Expression => Relocate_Node (Pref));
1356 Append_To (Decls, Temp_Decl);
1359 -- Step 4: Analyze all bits
1361 Installed := Current_Scope = Scope (Loop_Id);
1363 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1364 -- associated loop, ensure the proper visibility for analysis.
1366 if not Installed then
1367 Push_Scope (Scope (Loop_Id));
1370 -- The analysis of the conditional block takes care of the constant
1373 if Present (Result) then
1374 Rewrite (Loop_Stmt, Result);
1375 Analyze (Loop_Stmt);
1377 -- The conditional block was analyzed when a previous 'Loop_Entry was
1378 -- expanded. There is no point in reanalyzing the block, simply analyze
1379 -- the declaration of the constant.
1382 if Present (CW_Decl) then
1386 Analyze (Temp_Decl);
1389 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
1392 if not Installed then
1395 end Expand_Loop_Entry_Attribute;
1397 ------------------------------
1398 -- Expand_Min_Max_Attribute --
1399 ------------------------------
1401 procedure Expand_Min_Max_Attribute (N : Node_Id) is
1403 -- Min and Max are handled by the back end (except that static cases
1404 -- have already been evaluated during semantic processing, although the
1405 -- back end should not count on this). The one bit of special processing
1406 -- required in the normal case is that these two attributes typically
1407 -- generate conditionals in the code, so check the relevant restriction.
1409 Check_Restriction (No_Implicit_Conditionals, N);
1411 -- In Modify_Tree_For_C mode, we rewrite as an if expression
1413 if Modify_Tree_For_C then
1415 Loc : constant Source_Ptr := Sloc (N);
1416 Typ : constant Entity_Id := Etype (N);
1417 Expr : constant Node_Id := First (Expressions (N));
1418 Left : constant Node_Id := Relocate_Node (Expr);
1419 Right : constant Node_Id := Relocate_Node (Next (Expr));
1421 function Make_Compare (Left, Right : Node_Id) return Node_Id;
1422 -- Returns Left >= Right for Max, Left <= Right for Min
1428 function Make_Compare (Left, Right : Node_Id) return Node_Id is
1430 if Attribute_Name (N) = Name_Max then
1434 Right_Opnd => Right);
1439 Right_Opnd => Right);
1443 -- Start of processing for Min_Max
1446 -- If both Left and Right are side effect free, then we can just
1447 -- use Duplicate_Expr to duplicate the references and return
1449 -- (if Left >=|<= Right then Left else Right)
1451 if Side_Effect_Free (Left) and then Side_Effect_Free (Right) then
1453 Make_If_Expression (Loc,
1454 Expressions => New_List (
1455 Make_Compare (Left, Right),
1456 Duplicate_Subexpr_No_Checks (Left),
1457 Duplicate_Subexpr_No_Checks (Right))));
1459 -- Otherwise we generate declarations to capture the values. We
1460 -- can't put these declarations inside the if expression, since
1461 -- we could end up with an N_Expression_With_Actions which has
1462 -- declarations in the actions, forbidden for Modify_Tree_For_C.
1464 -- The translation is
1466 -- T1 : styp; -- inserted high up in tree
1467 -- T2 : styp; -- inserted high up in tree
1470 -- T1 := styp!(Left);
1471 -- T2 := styp!(Right);
1473 -- (if T1 >=|<= T2 then typ!(T1) else typ!(T2))
1476 -- We insert the T1,T2 declarations with Insert_Declaration which
1477 -- inserts these declarations high up in the tree unconditionally.
1478 -- This is safe since no code is associated with the declarations.
1479 -- Here styp is a standard type whose Esize matches the size of
1480 -- our type. We do this because the actual type may be a result of
1481 -- some local declaration which would not be visible at the point
1482 -- where we insert the declarations of T1 and T2.
1486 T1 : constant Entity_Id := Make_Temporary (Loc, 'T', Left);
1487 T2 : constant Entity_Id := Make_Temporary (Loc, 'T', Left);
1488 Styp : constant Entity_Id := Matching_Standard_Type (Typ);
1491 Insert_Declaration (N,
1492 Make_Object_Declaration (Loc,
1493 Defining_Identifier => T1,
1494 Object_Definition => New_Occurrence_Of (Styp, Loc)));
1496 Insert_Declaration (N,
1497 Make_Object_Declaration (Loc,
1498 Defining_Identifier => T2,
1499 Object_Definition => New_Occurrence_Of (Styp, Loc)));
1502 Make_Expression_With_Actions (Loc,
1503 Actions => New_List (
1504 Make_Assignment_Statement (Loc,
1505 Name => New_Occurrence_Of (T1, Loc),
1506 Expression => Unchecked_Convert_To (Styp, Left)),
1507 Make_Assignment_Statement (Loc,
1508 Name => New_Occurrence_Of (T2, Loc),
1509 Expression => Unchecked_Convert_To (Styp, Right))),
1512 Make_If_Expression (Loc,
1513 Expressions => New_List (
1515 (New_Occurrence_Of (T1, Loc),
1516 New_Occurrence_Of (T2, Loc)),
1517 Unchecked_Convert_To (Typ,
1518 New_Occurrence_Of (T1, Loc)),
1519 Unchecked_Convert_To (Typ,
1520 New_Occurrence_Of (T2, Loc))))));
1524 Analyze_And_Resolve (N, Typ);
1527 end Expand_Min_Max_Attribute;
1529 ----------------------------------
1530 -- Expand_N_Attribute_Reference --
1531 ----------------------------------
1533 procedure Expand_N_Attribute_Reference (N : Node_Id) is
1534 Loc : constant Source_Ptr := Sloc (N);
1535 Typ : constant Entity_Id := Etype (N);
1536 Btyp : constant Entity_Id := Base_Type (Typ);
1537 Pref : constant Node_Id := Prefix (N);
1538 Ptyp : constant Entity_Id := Etype (Pref);
1539 Exprs : constant List_Id := Expressions (N);
1540 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
1542 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
1543 -- Rewrites a stream attribute for Read, Write or Output with the
1544 -- procedure call. Pname is the entity for the procedure to call.
1546 ------------------------------
1547 -- Rewrite_Stream_Proc_Call --
1548 ------------------------------
1550 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
1551 Item : constant Node_Id := Next (First (Exprs));
1552 Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
1553 Formal_Typ : constant Entity_Id := Etype (Formal);
1554 Is_Written : constant Boolean := (Ekind (Formal) /= E_In_Parameter);
1557 -- The expansion depends on Item, the second actual, which is
1558 -- the object being streamed in or out.
1560 -- If the item is a component of a packed array type, and
1561 -- a conversion is needed on exit, we introduce a temporary to
1562 -- hold the value, because otherwise the packed reference will
1563 -- not be properly expanded.
1565 if Nkind (Item) = N_Indexed_Component
1566 and then Is_Packed (Base_Type (Etype (Prefix (Item))))
1567 and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
1571 Temp : constant Entity_Id := Make_Temporary (Loc, 'V');
1577 Make_Object_Declaration (Loc,
1578 Defining_Identifier => Temp,
1579 Object_Definition =>
1580 New_Occurrence_Of (Formal_Typ, Loc));
1581 Set_Etype (Temp, Formal_Typ);
1584 Make_Assignment_Statement (Loc,
1585 Name => New_Copy_Tree (Item),
1587 Unchecked_Convert_To
1588 (Etype (Item), New_Occurrence_Of (Temp, Loc)));
1590 Rewrite (Item, New_Occurrence_Of (Temp, Loc));
1594 Make_Procedure_Call_Statement (Loc,
1595 Name => New_Occurrence_Of (Pname, Loc),
1596 Parameter_Associations => Exprs),
1599 Rewrite (N, Make_Null_Statement (Loc));
1604 -- For the class-wide dispatching cases, and for cases in which
1605 -- the base type of the second argument matches the base type of
1606 -- the corresponding formal parameter (that is to say the stream
1607 -- operation is not inherited), we are all set, and can use the
1608 -- argument unchanged.
1610 -- For all other cases we do an unchecked conversion of the second
1611 -- parameter to the type of the formal of the procedure we are
1612 -- calling. This deals with the private type cases, and with going
1613 -- to the root type as required in elementary type case.
1615 if not Is_Class_Wide_Type (Entity (Pref))
1616 and then not Is_Class_Wide_Type (Etype (Item))
1617 and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
1620 Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
1622 -- For untagged derived types set Assignment_OK, to prevent
1623 -- copies from being created when the unchecked conversion
1624 -- is expanded (which would happen in Remove_Side_Effects
1625 -- if Expand_N_Unchecked_Conversion were allowed to call
1626 -- Force_Evaluation). The copy could violate Ada semantics in
1627 -- cases such as an actual that is an out parameter. Note that
1628 -- this approach is also used in exp_ch7 for calls to controlled
1629 -- type operations to prevent problems with actuals wrapped in
1630 -- unchecked conversions.
1632 if Is_Untagged_Derivation (Etype (Expression (Item))) then
1633 Set_Assignment_OK (Item);
1637 -- The stream operation to call may be a renaming created by an
1638 -- attribute definition clause, and may not be frozen yet. Ensure
1639 -- that it has the necessary extra formals.
1641 if not Is_Frozen (Pname) then
1642 Create_Extra_Formals (Pname);
1645 -- And now rewrite the call
1648 Make_Procedure_Call_Statement (Loc,
1649 Name => New_Occurrence_Of (Pname, Loc),
1650 Parameter_Associations => Exprs));
1653 end Rewrite_Stream_Proc_Call;
1655 -- Start of processing for Expand_N_Attribute_Reference
1658 -- Do required validity checking, if enabled. Do not apply check to
1659 -- output parameters of an Asm instruction, since the value of this
1660 -- is not set till after the attribute has been elaborated, and do
1661 -- not apply the check to the arguments of a 'Read or 'Input attribute
1662 -- reference since the scalar argument is an OUT scalar.
1664 if Validity_Checks_On and then Validity_Check_Operands
1665 and then Id /= Attribute_Asm_Output
1666 and then Id /= Attribute_Read
1667 and then Id /= Attribute_Input
1672 Expr := First (Expressions (N));
1673 while Present (Expr) loop
1674 Ensure_Valid (Expr);
1680 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
1681 -- place function, then a temporary return object needs to be created
1682 -- and access to it must be passed to the function. Currently we limit
1683 -- such functions to those with inherently limited result subtypes, but
1684 -- eventually we plan to expand the functions that are treated as
1685 -- build-in-place to include other composite result types.
1687 if Ada_Version >= Ada_2005
1688 and then Is_Build_In_Place_Function_Call (Pref)
1690 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
1693 -- If prefix is a protected type name, this is a reference to the
1694 -- current instance of the type. For a component definition, nothing
1695 -- to do (expansion will occur in the init proc). In other contexts,
1696 -- rewrite into reference to current instance.
1698 if Is_Protected_Self_Reference (Pref)
1700 (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint,
1701 N_Discriminant_Association)
1702 and then Nkind (Parent (Parent (Parent (Parent (N))))) =
1703 N_Component_Definition)
1705 -- No action needed for these attributes since the current instance
1706 -- will be rewritten to be the name of the _object parameter
1707 -- associated with the enclosing protected subprogram (see below).
1709 and then Id /= Attribute_Access
1710 and then Id /= Attribute_Unchecked_Access
1711 and then Id /= Attribute_Unrestricted_Access
1713 Rewrite (Pref, Concurrent_Ref (Pref));
1717 -- Remaining processing depends on specific attribute
1719 -- Note: individual sections of the following case statement are
1720 -- allowed to assume there is no code after the case statement, and
1721 -- are legitimately allowed to execute return statements if they have
1722 -- nothing more to do.
1726 -- Attributes related to Ada 2012 iterators
1728 when Attribute_Constant_Indexing |
1729 Attribute_Default_Iterator |
1730 Attribute_Implicit_Dereference |
1731 Attribute_Iterable |
1732 Attribute_Iterator_Element |
1733 Attribute_Variable_Indexing =>
1736 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
1737 -- were already rejected by the parser. Thus they shouldn't appear here.
1739 when Internal_Attribute_Id =>
1740 raise Program_Error;
1746 when Attribute_Access |
1747 Attribute_Unchecked_Access |
1748 Attribute_Unrestricted_Access =>
1750 Access_Cases : declare
1751 Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
1752 Btyp_DDT : Entity_Id;
1754 function Enclosing_Object (N : Node_Id) return Node_Id;
1755 -- If N denotes a compound name (selected component, indexed
1756 -- component, or slice), returns the name of the outermost such
1757 -- enclosing object. Otherwise returns N. If the object is a
1758 -- renaming, then the renamed object is returned.
1760 ----------------------
1761 -- Enclosing_Object --
1762 ----------------------
1764 function Enclosing_Object (N : Node_Id) return Node_Id is
1769 while Nkind_In (Obj_Name, N_Selected_Component,
1770 N_Indexed_Component,
1773 Obj_Name := Prefix (Obj_Name);
1776 return Get_Referenced_Object (Obj_Name);
1777 end Enclosing_Object;
1779 -- Local declarations
1781 Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
1783 -- Start of processing for Access_Cases
1786 Btyp_DDT := Designated_Type (Btyp);
1788 -- Handle designated types that come from the limited view
1790 if Ekind (Btyp_DDT) = E_Incomplete_Type
1791 and then From_Limited_With (Btyp_DDT)
1792 and then Present (Non_Limited_View (Btyp_DDT))
1794 Btyp_DDT := Non_Limited_View (Btyp_DDT);
1796 elsif Is_Class_Wide_Type (Btyp_DDT)
1797 and then Ekind (Etype (Btyp_DDT)) = E_Incomplete_Type
1798 and then From_Limited_With (Etype (Btyp_DDT))
1799 and then Present (Non_Limited_View (Etype (Btyp_DDT)))
1800 and then Present (Class_Wide_Type
1801 (Non_Limited_View (Etype (Btyp_DDT))))
1804 Class_Wide_Type (Non_Limited_View (Etype (Btyp_DDT)));
1807 -- In order to improve the text of error messages, the designated
1808 -- type of access-to-subprogram itypes is set by the semantics as
1809 -- the associated subprogram entity (see sem_attr). Now we replace
1810 -- such node with the proper E_Subprogram_Type itype.
1812 if Id = Attribute_Unrestricted_Access
1813 and then Is_Subprogram (Directly_Designated_Type (Typ))
1815 -- The following conditions ensure that this special management
1816 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
1817 -- At this stage other cases in which the designated type is
1818 -- still a subprogram (instead of an E_Subprogram_Type) are
1819 -- wrong because the semantics must have overridden the type of
1820 -- the node with the type imposed by the context.
1822 if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
1823 and then Etype (Parent (N)) = RTE (RE_Prim_Ptr)
1825 Set_Etype (N, RTE (RE_Prim_Ptr));
1829 Subp : constant Entity_Id :=
1830 Directly_Designated_Type (Typ);
1832 Extra : Entity_Id := Empty;
1833 New_Formal : Entity_Id;
1834 Old_Formal : Entity_Id := First_Formal (Subp);
1835 Subp_Typ : Entity_Id;
1838 Subp_Typ := Create_Itype (E_Subprogram_Type, N);
1839 Set_Etype (Subp_Typ, Etype (Subp));
1840 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
1842 if Present (Old_Formal) then
1843 New_Formal := New_Copy (Old_Formal);
1844 Set_First_Entity (Subp_Typ, New_Formal);
1847 Set_Scope (New_Formal, Subp_Typ);
1848 Etyp := Etype (New_Formal);
1850 -- Handle itypes. There is no need to duplicate
1851 -- here the itypes associated with record types
1852 -- (i.e the implicit full view of private types).
1855 and then Ekind (Base_Type (Etyp)) /= E_Record_Type
1857 Extra := New_Copy (Etyp);
1858 Set_Parent (Extra, New_Formal);
1859 Set_Etype (New_Formal, Extra);
1860 Set_Scope (Extra, Subp_Typ);
1863 Extra := New_Formal;
1864 Next_Formal (Old_Formal);
1865 exit when No (Old_Formal);
1867 Set_Next_Entity (New_Formal,
1868 New_Copy (Old_Formal));
1869 Next_Entity (New_Formal);
1872 Set_Next_Entity (New_Formal, Empty);
1873 Set_Last_Entity (Subp_Typ, Extra);
1876 -- Now that the explicit formals have been duplicated,
1877 -- any extra formals needed by the subprogram must be
1880 if Present (Extra) then
1881 Set_Extra_Formal (Extra, Empty);
1884 Create_Extra_Formals (Subp_Typ);
1885 Set_Directly_Designated_Type (Typ, Subp_Typ);
1890 if Is_Access_Protected_Subprogram_Type (Btyp) then
1891 Expand_Access_To_Protected_Op (N, Pref, Typ);
1893 -- If prefix is a type name, this is a reference to the current
1894 -- instance of the type, within its initialization procedure.
1896 elsif Is_Entity_Name (Pref)
1897 and then Is_Type (Entity (Pref))
1904 -- If the current instance name denotes a task type, then
1905 -- the access attribute is rewritten to be the name of the
1906 -- "_task" parameter associated with the task type's task
1907 -- procedure. An unchecked conversion is applied to ensure
1908 -- a type match in cases of expander-generated calls (e.g.
1911 if Is_Task_Type (Entity (Pref)) then
1913 First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
1914 while Present (Formal) loop
1915 exit when Chars (Formal) = Name_uTask;
1916 Next_Entity (Formal);
1919 pragma Assert (Present (Formal));
1922 Unchecked_Convert_To (Typ,
1923 New_Occurrence_Of (Formal, Loc)));
1926 elsif Is_Protected_Type (Entity (Pref)) then
1928 -- No action needed for current instance located in a
1929 -- component definition (expansion will occur in the
1932 if Is_Protected_Type (Current_Scope) then
1935 -- If the current instance reference is located in a
1936 -- protected subprogram or entry then rewrite the access
1937 -- attribute to be the name of the "_object" parameter.
1938 -- An unchecked conversion is applied to ensure a type
1939 -- match in cases of expander-generated calls (e.g. init
1942 -- The code may be nested in a block, so find enclosing
1943 -- scope that is a protected operation.
1950 Subp := Current_Scope;
1951 while Ekind_In (Subp, E_Loop, E_Block) loop
1952 Subp := Scope (Subp);
1957 (Protected_Body_Subprogram (Subp));
1959 -- For a protected subprogram the _Object parameter
1960 -- is the protected record, so we create an access
1961 -- to it. The _Object parameter of an entry is an
1964 if Ekind (Subp) = E_Entry then
1966 Unchecked_Convert_To (Typ,
1967 New_Occurrence_Of (Formal, Loc)));
1972 Unchecked_Convert_To (Typ,
1973 Make_Attribute_Reference (Loc,
1974 Attribute_Name => Name_Unrestricted_Access,
1976 New_Occurrence_Of (Formal, Loc))));
1977 Analyze_And_Resolve (N);
1982 -- The expression must appear in a default expression,
1983 -- (which in the initialization procedure is the right-hand
1984 -- side of an assignment), and not in a discriminant
1989 while Present (Par) loop
1990 exit when Nkind (Par) = N_Assignment_Statement;
1992 if Nkind (Par) = N_Component_Declaration then
1996 Par := Parent (Par);
1999 if Present (Par) then
2001 Make_Attribute_Reference (Loc,
2002 Prefix => Make_Identifier (Loc, Name_uInit),
2003 Attribute_Name => Attribute_Name (N)));
2005 Analyze_And_Resolve (N, Typ);
2010 -- If the prefix of an Access attribute is a dereference of an
2011 -- access parameter (or a renaming of such a dereference, or a
2012 -- subcomponent of such a dereference) and the context is a
2013 -- general access type (including the type of an object or
2014 -- component with an access_definition, but not the anonymous
2015 -- type of an access parameter or access discriminant), then
2016 -- apply an accessibility check to the access parameter. We used
2017 -- to rewrite the access parameter as a type conversion, but that
2018 -- could only be done if the immediate prefix of the Access
2019 -- attribute was the dereference, and didn't handle cases where
2020 -- the attribute is applied to a subcomponent of the dereference,
2021 -- since there's generally no available, appropriate access type
2022 -- to convert to in that case. The attribute is passed as the
2023 -- point to insert the check, because the access parameter may
2024 -- come from a renaming, possibly in a different scope, and the
2025 -- check must be associated with the attribute itself.
2027 elsif Id = Attribute_Access
2028 and then Nkind (Enc_Object) = N_Explicit_Dereference
2029 and then Is_Entity_Name (Prefix (Enc_Object))
2030 and then (Ekind (Btyp) = E_General_Access_Type
2031 or else Is_Local_Anonymous_Access (Btyp))
2032 and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind
2033 and then Ekind (Etype (Entity (Prefix (Enc_Object))))
2034 = E_Anonymous_Access_Type
2035 and then Present (Extra_Accessibility
2036 (Entity (Prefix (Enc_Object))))
2038 Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N);
2040 -- Ada 2005 (AI-251): If the designated type is an interface we
2041 -- add an implicit conversion to force the displacement of the
2042 -- pointer to reference the secondary dispatch table.
2044 elsif Is_Interface (Btyp_DDT)
2045 and then (Comes_From_Source (N)
2046 or else Comes_From_Source (Ref_Object)
2047 or else (Nkind (Ref_Object) in N_Has_Chars
2048 and then Chars (Ref_Object) = Name_uInit))
2050 if Nkind (Ref_Object) /= N_Explicit_Dereference then
2052 -- No implicit conversion required if types match, or if
2053 -- the prefix is the class_wide_type of the interface. In
2054 -- either case passing an object of the interface type has
2055 -- already set the pointer correctly.
2057 if Btyp_DDT = Etype (Ref_Object)
2058 or else (Is_Class_Wide_Type (Etype (Ref_Object))
2060 Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object))
2065 Rewrite (Prefix (N),
2066 Convert_To (Btyp_DDT,
2067 New_Copy_Tree (Prefix (N))));
2069 Analyze_And_Resolve (Prefix (N), Btyp_DDT);
2072 -- When the object is an explicit dereference, convert the
2073 -- dereference's prefix.
2077 Obj_DDT : constant Entity_Id :=
2079 (Directly_Designated_Type
2080 (Etype (Prefix (Ref_Object))));
2082 -- No implicit conversion required if designated types
2083 -- match, or if we have an unrestricted access.
2085 if Obj_DDT /= Btyp_DDT
2086 and then Id /= Attribute_Unrestricted_Access
2087 and then not (Is_Class_Wide_Type (Obj_DDT)
2088 and then Etype (Obj_DDT) = Btyp_DDT)
2092 New_Copy_Tree (Prefix (Ref_Object))));
2093 Analyze_And_Resolve (N, Typ);
2104 -- Transforms 'Adjacent into a call to the floating-point attribute
2105 -- function Adjacent in Fat_xxx (where xxx is the root type)
2107 when Attribute_Adjacent =>
2108 Expand_Fpt_Attribute_RR (N);
2114 when Attribute_Address => Address : declare
2115 Task_Proc : Entity_Id;
2118 -- If the prefix is a task or a task type, the useful address is that
2119 -- of the procedure for the task body, i.e. the actual program unit.
2120 -- We replace the original entity with that of the procedure.
2122 if Is_Entity_Name (Pref)
2123 and then Is_Task_Type (Entity (Pref))
2125 Task_Proc := Next_Entity (Root_Type (Ptyp));
2127 while Present (Task_Proc) loop
2128 exit when Ekind (Task_Proc) = E_Procedure
2129 and then Etype (First_Formal (Task_Proc)) =
2130 Corresponding_Record_Type (Ptyp);
2131 Next_Entity (Task_Proc);
2134 if Present (Task_Proc) then
2135 Set_Entity (Pref, Task_Proc);
2136 Set_Etype (Pref, Etype (Task_Proc));
2139 -- Similarly, the address of a protected operation is the address
2140 -- of the corresponding protected body, regardless of the protected
2141 -- object from which it is selected.
2143 elsif Nkind (Pref) = N_Selected_Component
2144 and then Is_Subprogram (Entity (Selector_Name (Pref)))
2145 and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref))))
2149 External_Subprogram (Entity (Selector_Name (Pref))), Loc));
2151 elsif Nkind (Pref) = N_Explicit_Dereference
2152 and then Ekind (Ptyp) = E_Subprogram_Type
2153 and then Convention (Ptyp) = Convention_Protected
2155 -- The prefix is be a dereference of an access_to_protected_
2156 -- subprogram. The desired address is the second component of
2157 -- the record that represents the access.
2160 Addr : constant Entity_Id := Etype (N);
2161 Ptr : constant Node_Id := Prefix (Pref);
2162 T : constant Entity_Id :=
2163 Equivalent_Type (Base_Type (Etype (Ptr)));
2167 Unchecked_Convert_To (Addr,
2168 Make_Selected_Component (Loc,
2169 Prefix => Unchecked_Convert_To (T, Ptr),
2170 Selector_Name => New_Occurrence_Of (
2171 Next_Entity (First_Entity (T)), Loc))));
2173 Analyze_And_Resolve (N, Addr);
2176 -- Ada 2005 (AI-251): Class-wide interface objects are always
2177 -- "displaced" to reference the tag associated with the interface
2178 -- type. In order to obtain the real address of such objects we
2179 -- generate a call to a run-time subprogram that returns the base
2180 -- address of the object.
2182 -- This processing is not needed in the VM case, where dispatching
2183 -- issues are taken care of by the virtual machine.
2185 elsif Is_Class_Wide_Type (Ptyp)
2186 and then Is_Interface (Ptyp)
2187 and then Tagged_Type_Expansion
2188 and then not (Nkind (Pref) in N_Has_Entity
2189 and then Is_Subprogram (Entity (Pref)))
2192 Make_Function_Call (Loc,
2193 Name => New_Occurrence_Of (RTE (RE_Base_Address), Loc),
2194 Parameter_Associations => New_List (
2195 Relocate_Node (N))));
2200 -- Deal with packed array reference, other cases are handled by
2203 if Involves_Packed_Array_Reference (Pref) then
2204 Expand_Packed_Address_Reference (N);
2212 when Attribute_Alignment => Alignment : declare
2216 -- For class-wide types, X'Class'Alignment is transformed into a
2217 -- direct reference to the Alignment of the class type, so that the
2218 -- back end does not have to deal with the X'Class'Alignment
2221 if Is_Entity_Name (Pref)
2222 and then Is_Class_Wide_Type (Entity (Pref))
2224 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
2227 -- For x'Alignment applied to an object of a class wide type,
2228 -- transform X'Alignment into a call to the predefined primitive
2229 -- operation _Alignment applied to X.
2231 elsif Is_Class_Wide_Type (Ptyp) then
2233 Make_Attribute_Reference (Loc,
2235 Attribute_Name => Name_Tag);
2237 if VM_Target = No_VM then
2238 New_Node := Build_Get_Alignment (Loc, New_Node);
2241 Make_Function_Call (Loc,
2242 Name => New_Occurrence_Of (RTE (RE_Get_Alignment), Loc),
2243 Parameter_Associations => New_List (New_Node));
2246 -- Case where the context is a specific integer type with which
2247 -- the original attribute was compatible. The function has a
2248 -- specific type as well, so to preserve the compatibility we
2249 -- must convert explicitly.
2251 if Typ /= Standard_Integer then
2252 New_Node := Convert_To (Typ, New_Node);
2255 Rewrite (N, New_Node);
2256 Analyze_And_Resolve (N, Typ);
2259 -- For all other cases, we just have to deal with the case of
2260 -- the fact that the result can be universal.
2263 Apply_Universal_Integer_Attribute_Checks (N);
2271 -- We compute this if a packed array reference was present, otherwise we
2272 -- leave the computation up to the back end.
2274 when Attribute_Bit =>
2275 if Involves_Packed_Array_Reference (Pref) then
2276 Expand_Packed_Bit_Reference (N);
2278 Apply_Universal_Integer_Attribute_Checks (N);
2285 -- We compute this if a component clause was present, otherwise we leave
2286 -- the computation up to the back end, since we don't know what layout
2289 -- Note that the attribute can apply to a naked record component
2290 -- in generated code (i.e. the prefix is an identifier that
2291 -- references the component or discriminant entity).
2293 when Attribute_Bit_Position => Bit_Position : declare
2297 if Nkind (Pref) = N_Identifier then
2298 CE := Entity (Pref);
2300 CE := Entity (Selector_Name (Pref));
2303 if Known_Static_Component_Bit_Offset (CE) then
2305 Make_Integer_Literal (Loc,
2306 Intval => Component_Bit_Offset (CE)));
2307 Analyze_And_Resolve (N, Typ);
2310 Apply_Universal_Integer_Attribute_Checks (N);
2318 -- A reference to P'Body_Version or P'Version is expanded to
2321 -- pragma Import (C, Vnn, "uuuuT");
2323 -- Get_Version_String (Vnn)
2325 -- where uuuu is the unit name (dots replaced by double underscore)
2326 -- and T is B for the cases of Body_Version, or Version applied to a
2327 -- subprogram acting as its own spec, and S for Version applied to a
2328 -- subprogram spec or package. This sequence of code references the
2329 -- unsigned constant created in the main program by the binder.
2331 -- A special exception occurs for Standard, where the string returned
2332 -- is a copy of the library string in gnatvsn.ads.
2334 when Attribute_Body_Version | Attribute_Version => Version : declare
2335 E : constant Entity_Id := Make_Temporary (Loc, 'V');
2340 -- If not library unit, get to containing library unit
2342 Pent := Entity (Pref);
2343 while Pent /= Standard_Standard
2344 and then Scope (Pent) /= Standard_Standard
2345 and then not Is_Child_Unit (Pent)
2347 Pent := Scope (Pent);
2350 -- Special case Standard and Standard.ASCII
2352 if Pent = Standard_Standard or else Pent = Standard_ASCII then
2354 Make_String_Literal (Loc,
2355 Strval => Verbose_Library_Version));
2360 -- Build required string constant
2362 Get_Name_String (Get_Unit_Name (Pent));
2365 for J in 1 .. Name_Len - 2 loop
2366 if Name_Buffer (J) = '.' then
2367 Store_String_Chars ("__");
2369 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
2373 -- Case of subprogram acting as its own spec, always use body
2375 if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
2376 and then Nkind (Parent (Declaration_Node (Pent))) =
2378 and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
2380 Store_String_Chars ("B");
2382 -- Case of no body present, always use spec
2384 elsif not Unit_Requires_Body (Pent) then
2385 Store_String_Chars ("S");
2387 -- Otherwise use B for Body_Version, S for spec
2389 elsif Id = Attribute_Body_Version then
2390 Store_String_Chars ("B");
2392 Store_String_Chars ("S");
2396 Lib.Version_Referenced (S);
2398 -- Insert the object declaration
2400 Insert_Actions (N, New_List (
2401 Make_Object_Declaration (Loc,
2402 Defining_Identifier => E,
2403 Object_Definition =>
2404 New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
2406 -- Set entity as imported with correct external name
2408 Set_Is_Imported (E);
2409 Set_Interface_Name (E, Make_String_Literal (Loc, S));
2411 -- Set entity as internal to ensure proper Sprint output of its
2412 -- implicit importation.
2414 Set_Is_Internal (E);
2416 -- And now rewrite original reference
2419 Make_Function_Call (Loc,
2420 Name => New_Occurrence_Of (RTE (RE_Get_Version_String), Loc),
2421 Parameter_Associations => New_List (
2422 New_Occurrence_Of (E, Loc))));
2425 Analyze_And_Resolve (N, RTE (RE_Version_String));
2432 -- Transforms 'Ceiling into a call to the floating-point attribute
2433 -- function Ceiling in Fat_xxx (where xxx is the root type)
2435 when Attribute_Ceiling =>
2436 Expand_Fpt_Attribute_R (N);
2442 -- Transforms 'Callable attribute into a call to the Callable function
2444 when Attribute_Callable => Callable :
2446 -- We have an object of a task interface class-wide type as a prefix
2447 -- to Callable. Generate:
2448 -- callable (Task_Id (Pref._disp_get_task_id));
2450 if Ada_Version >= Ada_2005
2451 and then Ekind (Ptyp) = E_Class_Wide_Type
2452 and then Is_Interface (Ptyp)
2453 and then Is_Task_Interface (Ptyp)
2456 Make_Function_Call (Loc,
2458 New_Occurrence_Of (RTE (RE_Callable), Loc),
2459 Parameter_Associations => New_List (
2460 Make_Unchecked_Type_Conversion (Loc,
2462 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
2464 Make_Selected_Component (Loc,
2466 New_Copy_Tree (Pref),
2468 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
2472 Build_Call_With_Task (Pref, RTE (RE_Callable)));
2475 Analyze_And_Resolve (N, Standard_Boolean);
2482 -- Transforms 'Caller attribute into a call to either the
2483 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2485 when Attribute_Caller => Caller : declare
2486 Id_Kind : constant Entity_Id := RTE (RO_AT_Task_Id);
2487 Ent : constant Entity_Id := Entity (Pref);
2488 Conctype : constant Entity_Id := Scope (Ent);
2489 Nest_Depth : Integer := 0;
2496 if Is_Protected_Type (Conctype) then
2497 case Corresponding_Runtime_Package (Conctype) is
2498 when System_Tasking_Protected_Objects_Entries =>
2501 (RTE (RE_Protected_Entry_Caller), Loc);
2503 when System_Tasking_Protected_Objects_Single_Entry =>
2506 (RTE (RE_Protected_Single_Entry_Caller), Loc);
2509 raise Program_Error;
2513 Unchecked_Convert_To (Id_Kind,
2514 Make_Function_Call (Loc,
2516 Parameter_Associations => New_List (
2518 (Find_Protection_Object (Current_Scope), Loc)))));
2523 -- Determine the nesting depth of the E'Caller attribute, that
2524 -- is, how many accept statements are nested within the accept
2525 -- statement for E at the point of E'Caller. The runtime uses
2526 -- this depth to find the specified entry call.
2528 for J in reverse 0 .. Scope_Stack.Last loop
2529 S := Scope_Stack.Table (J).Entity;
2531 -- We should not reach the scope of the entry, as it should
2532 -- already have been checked in Sem_Attr that this attribute
2533 -- reference is within a matching accept statement.
2535 pragma Assert (S /= Conctype);
2540 elsif Is_Entry (S) then
2541 Nest_Depth := Nest_Depth + 1;
2546 Unchecked_Convert_To (Id_Kind,
2547 Make_Function_Call (Loc,
2549 New_Occurrence_Of (RTE (RE_Task_Entry_Caller), Loc),
2550 Parameter_Associations => New_List (
2551 Make_Integer_Literal (Loc,
2552 Intval => Int (Nest_Depth))))));
2555 Analyze_And_Resolve (N, Id_Kind);
2562 -- Transforms 'Compose into a call to the floating-point attribute
2563 -- function Compose in Fat_xxx (where xxx is the root type)
2565 -- Note: we strictly should have special code here to deal with the
2566 -- case of absurdly negative arguments (less than Integer'First)
2567 -- which will return a (signed) zero value, but it hardly seems
2568 -- worth the effort. Absurdly large positive arguments will raise
2569 -- constraint error which is fine.
2571 when Attribute_Compose =>
2572 Expand_Fpt_Attribute_RI (N);
2578 when Attribute_Constrained => Constrained : declare
2579 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
2581 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
2582 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
2583 -- view of an aliased object whose subtype is constrained.
2585 ---------------------------------
2586 -- Is_Constrained_Aliased_View --
2587 ---------------------------------
2589 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
2593 if Is_Entity_Name (Obj) then
2596 if Present (Renamed_Object (E)) then
2597 return Is_Constrained_Aliased_View (Renamed_Object (E));
2599 return Is_Aliased (E) and then Is_Constrained (Etype (E));
2603 return Is_Aliased_View (Obj)
2605 (Is_Constrained (Etype (Obj))
2607 (Nkind (Obj) = N_Explicit_Dereference
2609 not Object_Type_Has_Constrained_Partial_View
2610 (Typ => Base_Type (Etype (Obj)),
2611 Scop => Current_Scope)));
2613 end Is_Constrained_Aliased_View;
2615 -- Start of processing for Constrained
2618 -- Reference to a parameter where the value is passed as an extra
2619 -- actual, corresponding to the extra formal referenced by the
2620 -- Extra_Constrained field of the corresponding formal. If this
2621 -- is an entry in-parameter, it is replaced by a constant renaming
2622 -- for which Extra_Constrained is never created.
2624 if Present (Formal_Ent)
2625 and then Ekind (Formal_Ent) /= E_Constant
2626 and then Present (Extra_Constrained (Formal_Ent))
2630 (Extra_Constrained (Formal_Ent), Sloc (N)));
2632 -- For variables with a Extra_Constrained field, we use the
2633 -- corresponding entity.
2635 elsif Nkind (Pref) = N_Identifier
2636 and then Ekind (Entity (Pref)) = E_Variable
2637 and then Present (Extra_Constrained (Entity (Pref)))
2641 (Extra_Constrained (Entity (Pref)), Sloc (N)));
2643 -- For all other entity names, we can tell at compile time
2645 elsif Is_Entity_Name (Pref) then
2647 Ent : constant Entity_Id := Entity (Pref);
2651 -- (RM J.4) obsolescent cases
2653 if Is_Type (Ent) then
2657 if Is_Private_Type (Ent) then
2658 Res := not Has_Discriminants (Ent)
2659 or else Is_Constrained (Ent);
2661 -- It not a private type, must be a generic actual type
2662 -- that corresponded to a private type. We know that this
2663 -- correspondence holds, since otherwise the reference
2664 -- within the generic template would have been illegal.
2667 if Is_Composite_Type (Underlying_Type (Ent)) then
2668 Res := Is_Constrained (Ent);
2674 -- If the prefix is not a variable or is aliased, then
2675 -- definitely true; if it's a formal parameter without an
2676 -- associated extra formal, then treat it as constrained.
2678 -- Ada 2005 (AI-363): An aliased prefix must be known to be
2679 -- constrained in order to set the attribute to True.
2681 elsif not Is_Variable (Pref)
2682 or else Present (Formal_Ent)
2683 or else (Ada_Version < Ada_2005
2684 and then Is_Aliased_View (Pref))
2685 or else (Ada_Version >= Ada_2005
2686 and then Is_Constrained_Aliased_View (Pref))
2690 -- Variable case, look at type to see if it is constrained.
2691 -- Note that the one case where this is not accurate (the
2692 -- procedure formal case), has been handled above.
2694 -- We use the Underlying_Type here (and below) in case the
2695 -- type is private without discriminants, but the full type
2696 -- has discriminants. This case is illegal, but we generate it
2697 -- internally for passing to the Extra_Constrained parameter.
2700 -- In Ada 2012, test for case of a limited tagged type, in
2701 -- which case the attribute is always required to return
2702 -- True. The underlying type is tested, to make sure we also
2703 -- return True for cases where there is an unconstrained
2704 -- object with an untagged limited partial view which has
2705 -- defaulted discriminants (such objects always produce a
2706 -- False in earlier versions of Ada). (Ada 2012: AI05-0214)
2708 Res := Is_Constrained (Underlying_Type (Etype (Ent)))
2710 (Ada_Version >= Ada_2012
2711 and then Is_Tagged_Type (Underlying_Type (Ptyp))
2712 and then Is_Limited_Type (Ptyp));
2715 Rewrite (N, New_Occurrence_Of (Boolean_Literals (Res), Loc));
2718 -- Prefix is not an entity name. These are also cases where we can
2719 -- always tell at compile time by looking at the form and type of the
2720 -- prefix. If an explicit dereference of an object with constrained
2721 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
2722 -- underlying type is a limited tagged type, then Constrained is
2723 -- required to always return True (Ada 2012: AI05-0214).
2729 not Is_Variable (Pref)
2731 (Nkind (Pref) = N_Explicit_Dereference
2733 not Object_Type_Has_Constrained_Partial_View
2734 (Typ => Base_Type (Ptyp),
2735 Scop => Current_Scope))
2736 or else Is_Constrained (Underlying_Type (Ptyp))
2737 or else (Ada_Version >= Ada_2012
2738 and then Is_Tagged_Type (Underlying_Type (Ptyp))
2739 and then Is_Limited_Type (Ptyp))),
2743 Analyze_And_Resolve (N, Standard_Boolean);
2750 -- Transforms 'Copy_Sign into a call to the floating-point attribute
2751 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
2753 when Attribute_Copy_Sign =>
2754 Expand_Fpt_Attribute_RR (N);
2760 -- Transforms 'Count attribute into a call to the Count function
2762 when Attribute_Count => Count : declare
2764 Conctyp : Entity_Id;
2766 Entry_Id : Entity_Id;
2771 -- If the prefix is a member of an entry family, retrieve both
2772 -- entry name and index. For a simple entry there is no index.
2774 if Nkind (Pref) = N_Indexed_Component then
2775 Entnam := Prefix (Pref);
2776 Index := First (Expressions (Pref));
2782 Entry_Id := Entity (Entnam);
2784 -- Find the concurrent type in which this attribute is referenced
2785 -- (there had better be one).
2787 Conctyp := Current_Scope;
2788 while not Is_Concurrent_Type (Conctyp) loop
2789 Conctyp := Scope (Conctyp);
2794 if Is_Protected_Type (Conctyp) then
2795 case Corresponding_Runtime_Package (Conctyp) is
2796 when System_Tasking_Protected_Objects_Entries =>
2797 Name := New_Occurrence_Of (RTE (RE_Protected_Count), Loc);
2800 Make_Function_Call (Loc,
2802 Parameter_Associations => New_List (
2804 (Find_Protection_Object (Current_Scope), Loc),
2805 Entry_Index_Expression
2806 (Loc, Entry_Id, Index, Scope (Entry_Id))));
2808 when System_Tasking_Protected_Objects_Single_Entry =>
2810 New_Occurrence_Of (RTE (RE_Protected_Count_Entry), Loc);
2813 Make_Function_Call (Loc,
2815 Parameter_Associations => New_List (
2817 (Find_Protection_Object (Current_Scope), Loc)));
2820 raise Program_Error;
2827 Make_Function_Call (Loc,
2828 Name => New_Occurrence_Of (RTE (RE_Task_Count), Loc),
2829 Parameter_Associations => New_List (
2830 Entry_Index_Expression (Loc,
2831 Entry_Id, Index, Scope (Entry_Id))));
2834 -- The call returns type Natural but the context is universal integer
2835 -- so any integer type is allowed. The attribute was already resolved
2836 -- so its Etype is the required result type. If the base type of the
2837 -- context type is other than Standard.Integer we put in a conversion
2838 -- to the required type. This can be a normal typed conversion since
2839 -- both input and output types of the conversion are integer types
2841 if Base_Type (Typ) /= Base_Type (Standard_Integer) then
2842 Rewrite (N, Convert_To (Typ, Call));
2847 Analyze_And_Resolve (N, Typ);
2850 ---------------------
2851 -- Descriptor_Size --
2852 ---------------------
2854 when Attribute_Descriptor_Size =>
2856 -- Attribute Descriptor_Size is handled by the back end when applied
2857 -- to an unconstrained array type.
2859 if Is_Array_Type (Ptyp)
2860 and then not Is_Constrained (Ptyp)
2862 Apply_Universal_Integer_Attribute_Checks (N);
2864 -- For any other type, the descriptor size is 0 because there is no
2865 -- actual descriptor, but the result is not formally static.
2868 Rewrite (N, Make_Integer_Literal (Loc, 0));
2870 Set_Is_Static_Expression (N, False);
2877 -- This processing is shared by Elab_Spec
2879 -- What we do is to insert the following declarations
2882 -- pragma Import (C, enn, "name___elabb/s");
2884 -- and then the Elab_Body/Spec attribute is replaced by a reference
2885 -- to this defining identifier.
2887 when Attribute_Elab_Body |
2888 Attribute_Elab_Spec =>
2890 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
2891 -- back-end knows how to handle these attributes directly.
2893 if CodePeer_Mode then
2898 Ent : constant Entity_Id := Make_Temporary (Loc, 'E');
2902 procedure Make_Elab_String (Nod : Node_Id);
2903 -- Given Nod, an identifier, or a selected component, put the
2904 -- image into the current string literal, with double underline
2905 -- between components.
2907 ----------------------
2908 -- Make_Elab_String --
2909 ----------------------
2911 procedure Make_Elab_String (Nod : Node_Id) is
2913 if Nkind (Nod) = N_Selected_Component then
2914 Make_Elab_String (Prefix (Nod));
2918 Store_String_Char ('$');
2920 Store_String_Char ('.');
2922 Store_String_Char ('_');
2923 Store_String_Char ('_');
2926 Get_Name_String (Chars (Selector_Name (Nod)));
2929 pragma Assert (Nkind (Nod) = N_Identifier);
2930 Get_Name_String (Chars (Nod));
2933 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2934 end Make_Elab_String;
2936 -- Start of processing for Elab_Body/Elab_Spec
2939 -- First we need to prepare the string literal for the name of
2940 -- the elaboration routine to be referenced.
2943 Make_Elab_String (Pref);
2945 if VM_Target = No_VM then
2946 Store_String_Chars ("___elab");
2947 Lang := Make_Identifier (Loc, Name_C);
2949 Store_String_Chars ("._elab");
2950 Lang := Make_Identifier (Loc, Name_Ada);
2953 if Id = Attribute_Elab_Body then
2954 Store_String_Char ('b');
2956 Store_String_Char ('s');
2961 Insert_Actions (N, New_List (
2962 Make_Subprogram_Declaration (Loc,
2964 Make_Procedure_Specification (Loc,
2965 Defining_Unit_Name => Ent)),
2968 Chars => Name_Import,
2969 Pragma_Argument_Associations => New_List (
2970 Make_Pragma_Argument_Association (Loc, Expression => Lang),
2972 Make_Pragma_Argument_Association (Loc,
2973 Expression => Make_Identifier (Loc, Chars (Ent))),
2975 Make_Pragma_Argument_Association (Loc,
2976 Expression => Make_String_Literal (Loc, Str))))));
2978 Set_Entity (N, Ent);
2979 Rewrite (N, New_Occurrence_Of (Ent, Loc));
2982 --------------------
2983 -- Elab_Subp_Body --
2984 --------------------
2986 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
2987 -- this attribute directly, and if we are not in CodePeer mode it is
2988 -- entirely ignored ???
2990 when Attribute_Elab_Subp_Body =>
2997 -- Elaborated is always True for preelaborated units, predefined units,
2998 -- pure units and units which have Elaborate_Body pragmas. These units
2999 -- have no elaboration entity.
3001 -- Note: The Elaborated attribute is never passed to the back end
3003 when Attribute_Elaborated => Elaborated : declare
3004 Ent : constant Entity_Id := Entity (Pref);
3007 if Present (Elaboration_Entity (Ent)) then
3011 New_Occurrence_Of (Elaboration_Entity (Ent), Loc),
3013 Make_Integer_Literal (Loc, Uint_0)));
3014 Analyze_And_Resolve (N, Typ);
3016 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
3024 when Attribute_Enum_Rep => Enum_Rep :
3026 -- X'Enum_Rep (Y) expands to
3030 -- This is simply a direct conversion from the enumeration type to
3031 -- the target integer type, which is treated by the back end as a
3032 -- normal integer conversion, treating the enumeration type as an
3033 -- integer, which is exactly what we want. We set Conversion_OK to
3034 -- make sure that the analyzer does not complain about what otherwise
3035 -- might be an illegal conversion.
3037 if Is_Non_Empty_List (Exprs) then
3039 OK_Convert_To (Typ, Relocate_Node (First (Exprs))));
3041 -- X'Enum_Rep where X is an enumeration literal is replaced by
3042 -- the literal value.
3044 elsif Ekind (Entity (Pref)) = E_Enumeration_Literal then
3046 Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref))));
3048 -- If this is a renaming of a literal, recover the representation
3051 elsif Ekind (Entity (Pref)) = E_Constant
3052 and then Present (Renamed_Object (Entity (Pref)))
3054 Ekind (Entity (Renamed_Object (Entity (Pref))))
3055 = E_Enumeration_Literal
3058 Make_Integer_Literal (Loc,
3059 Enumeration_Rep (Entity (Renamed_Object (Entity (Pref))))));
3061 -- X'Enum_Rep where X is an object does a direct unchecked conversion
3062 -- of the object value, as described for the type case above.
3066 OK_Convert_To (Typ, Relocate_Node (Pref)));
3070 Analyze_And_Resolve (N, Typ);
3077 when Attribute_Enum_Val => Enum_Val : declare
3079 Btyp : constant Entity_Id := Base_Type (Ptyp);
3082 -- X'Enum_Val (Y) expands to
3084 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
3087 Expr := Unchecked_Convert_To (Ptyp, First (Exprs));
3090 Make_Raise_Constraint_Error (Loc,
3094 Make_Function_Call (Loc,
3096 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
3097 Parameter_Associations => New_List (
3098 Relocate_Node (Duplicate_Subexpr (Expr)),
3099 New_Occurrence_Of (Standard_False, Loc))),
3101 Right_Opnd => Make_Integer_Literal (Loc, -1)),
3102 Reason => CE_Range_Check_Failed));
3105 Analyze_And_Resolve (N, Ptyp);
3112 -- Transforms 'Exponent into a call to the floating-point attribute
3113 -- function Exponent in Fat_xxx (where xxx is the root type)
3115 when Attribute_Exponent =>
3116 Expand_Fpt_Attribute_R (N);
3122 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
3124 when Attribute_External_Tag => External_Tag :
3127 Make_Function_Call (Loc,
3128 Name => New_Occurrence_Of (RTE (RE_External_Tag), Loc),
3129 Parameter_Associations => New_List (
3130 Make_Attribute_Reference (Loc,
3131 Attribute_Name => Name_Tag,
3132 Prefix => Prefix (N)))));
3134 Analyze_And_Resolve (N, Standard_String);
3141 when Attribute_First =>
3143 -- If the prefix type is a constrained packed array type which
3144 -- already has a Packed_Array_Impl_Type representation defined, then
3145 -- replace this attribute with a direct reference to 'First of the
3146 -- appropriate index subtype (since otherwise the back end will try
3147 -- to give us the value of 'First for this implementation type).
3149 if Is_Constrained_Packed_Array (Ptyp) then
3151 Make_Attribute_Reference (Loc,
3152 Attribute_Name => Name_First,
3154 New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
3155 Analyze_And_Resolve (N, Typ);
3157 -- For access type, apply access check as needed
3159 elsif Is_Access_Type (Ptyp) then
3160 Apply_Access_Check (N);
3162 -- For scalar type, if low bound is a reference to an entity, just
3163 -- replace with a direct reference. Note that we can only have a
3164 -- reference to a constant entity at this stage, anything else would
3165 -- have already been rewritten.
3167 elsif Is_Scalar_Type (Ptyp) then
3169 Lo : constant Node_Id := Type_Low_Bound (Ptyp);
3171 if Is_Entity_Name (Lo) then
3172 Rewrite (N, New_Occurrence_Of (Entity (Lo), Loc));
3181 -- Compute this if component clause was present, otherwise we leave the
3182 -- computation to be completed in the back-end, since we don't know what
3183 -- layout will be chosen.
3185 when Attribute_First_Bit => First_Bit_Attr : declare
3186 CE : constant Entity_Id := Entity (Selector_Name (Pref));
3189 -- In Ada 2005 (or later) if we have the non-default bit order, then
3190 -- we return the original value as given in the component clause
3191 -- (RM 2005 13.5.2(3/2)).
3193 if Present (Component_Clause (CE))
3194 and then Ada_Version >= Ada_2005
3195 and then Reverse_Bit_Order (Scope (CE))
3198 Make_Integer_Literal (Loc,
3199 Intval => Expr_Value (First_Bit (Component_Clause (CE)))));
3200 Analyze_And_Resolve (N, Typ);
3202 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3203 -- rewrite with normalized value if we know it statically.
3205 elsif Known_Static_Component_Bit_Offset (CE) then
3207 Make_Integer_Literal (Loc,
3208 Component_Bit_Offset (CE) mod System_Storage_Unit));
3209 Analyze_And_Resolve (N, Typ);
3211 -- Otherwise left to back end, just do universal integer checks
3214 Apply_Universal_Integer_Attribute_Checks (N);
3224 -- fixtype'Fixed_Value (integer-value)
3228 -- fixtype(integer-value)
3230 -- We do all the required analysis of the conversion here, because we do
3231 -- not want this to go through the fixed-point conversion circuits. Note
3232 -- that the back end always treats fixed-point as equivalent to the
3233 -- corresponding integer type anyway.
3235 when Attribute_Fixed_Value => Fixed_Value :
3238 Make_Type_Conversion (Loc,
3239 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
3240 Expression => Relocate_Node (First (Exprs))));
3241 Set_Etype (N, Entity (Pref));
3244 -- Note: it might appear that a properly analyzed unchecked conversion
3245 -- would be just fine here, but that's not the case, since the full
3246 -- range checks performed by the following call are critical.
3248 Apply_Type_Conversion_Checks (N);
3255 -- Transforms 'Floor into a call to the floating-point attribute
3256 -- function Floor in Fat_xxx (where xxx is the root type)
3258 when Attribute_Floor =>
3259 Expand_Fpt_Attribute_R (N);
3265 -- For the fixed-point type Typ:
3271 -- Result_Type (System.Fore (Universal_Real (Type'First)),
3272 -- Universal_Real (Type'Last))
3274 -- Note that we know that the type is a non-static subtype, or Fore
3275 -- would have itself been computed dynamically in Eval_Attribute.
3277 when Attribute_Fore => Fore : begin
3280 Make_Function_Call (Loc,
3281 Name => New_Occurrence_Of (RTE (RE_Fore), Loc),
3283 Parameter_Associations => New_List (
3284 Convert_To (Universal_Real,
3285 Make_Attribute_Reference (Loc,
3286 Prefix => New_Occurrence_Of (Ptyp, Loc),
3287 Attribute_Name => Name_First)),
3289 Convert_To (Universal_Real,
3290 Make_Attribute_Reference (Loc,
3291 Prefix => New_Occurrence_Of (Ptyp, Loc),
3292 Attribute_Name => Name_Last))))));
3294 Analyze_And_Resolve (N, Typ);
3301 -- Transforms 'Fraction into a call to the floating-point attribute
3302 -- function Fraction in Fat_xxx (where xxx is the root type)
3304 when Attribute_Fraction =>
3305 Expand_Fpt_Attribute_R (N);
3311 when Attribute_From_Any => From_Any : declare
3312 P_Type : constant Entity_Id := Etype (Pref);
3313 Decls : constant List_Id := New_List;
3316 Build_From_Any_Call (P_Type,
3317 Relocate_Node (First (Exprs)),
3319 Insert_Actions (N, Decls);
3320 Analyze_And_Resolve (N, P_Type);
3323 ----------------------
3324 -- Has_Same_Storage --
3325 ----------------------
3327 when Attribute_Has_Same_Storage => Has_Same_Storage : declare
3328 Loc : constant Source_Ptr := Sloc (N);
3330 X : constant Node_Id := Prefix (N);
3331 Y : constant Node_Id := First (Expressions (N));
3334 X_Addr, Y_Addr : Node_Id;
3335 -- Rhe expressions for their addresses
3337 X_Size, Y_Size : Node_Id;
3338 -- Rhe expressions for their sizes
3341 -- The attribute is expanded as:
3343 -- (X'address = Y'address)
3344 -- and then (X'Size = Y'Size)
3346 -- If both arguments have the same Etype the second conjunct can be
3350 Make_Attribute_Reference (Loc,
3351 Attribute_Name => Name_Address,
3352 Prefix => New_Copy_Tree (X));
3355 Make_Attribute_Reference (Loc,
3356 Attribute_Name => Name_Address,
3357 Prefix => New_Copy_Tree (Y));
3360 Make_Attribute_Reference (Loc,
3361 Attribute_Name => Name_Size,
3362 Prefix => New_Copy_Tree (X));
3365 Make_Attribute_Reference (Loc,
3366 Attribute_Name => Name_Size,
3367 Prefix => New_Copy_Tree (Y));
3369 if Etype (X) = Etype (Y) then
3372 Left_Opnd => X_Addr,
3373 Right_Opnd => Y_Addr)));
3379 Left_Opnd => X_Addr,
3380 Right_Opnd => Y_Addr),
3383 Left_Opnd => X_Size,
3384 Right_Opnd => Y_Size)));
3387 Analyze_And_Resolve (N, Standard_Boolean);
3388 end Has_Same_Storage;
3394 -- For an exception returns a reference to the exception data:
3395 -- Exception_Id!(Prefix'Reference)
3397 -- For a task it returns a reference to the _task_id component of
3398 -- corresponding record:
3400 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
3402 -- in Ada.Task_Identification
3404 when Attribute_Identity => Identity : declare
3405 Id_Kind : Entity_Id;
3408 if Ptyp = Standard_Exception_Type then
3409 Id_Kind := RTE (RE_Exception_Id);
3411 if Present (Renamed_Object (Entity (Pref))) then
3412 Set_Entity (Pref, Renamed_Object (Entity (Pref)));
3416 Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref)));
3418 Id_Kind := RTE (RO_AT_Task_Id);
3420 -- If the prefix is a task interface, the Task_Id is obtained
3421 -- dynamically through a dispatching call, as for other task
3422 -- attributes applied to interfaces.
3424 if Ada_Version >= Ada_2005
3425 and then Ekind (Ptyp) = E_Class_Wide_Type
3426 and then Is_Interface (Ptyp)
3427 and then Is_Task_Interface (Ptyp)
3430 Unchecked_Convert_To (Id_Kind,
3431 Make_Selected_Component (Loc,
3433 New_Copy_Tree (Pref),
3435 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))));
3439 Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
3443 Analyze_And_Resolve (N, Id_Kind);
3450 -- Image attribute is handled in separate unit Exp_Imgv
3452 when Attribute_Image =>
3453 Exp_Imgv.Expand_Image_Attribute (N);
3459 -- X'Img is expanded to typ'Image (X), where typ is the type of X
3461 when Attribute_Img => Img :
3464 Make_Attribute_Reference (Loc,
3465 Prefix => New_Occurrence_Of (Ptyp, Loc),
3466 Attribute_Name => Name_Image,
3467 Expressions => New_List (Relocate_Node (Pref))));
3469 Analyze_And_Resolve (N, Standard_String);
3476 when Attribute_Input => Input : declare
3477 P_Type : constant Entity_Id := Entity (Pref);
3478 B_Type : constant Entity_Id := Base_Type (P_Type);
3479 U_Type : constant Entity_Id := Underlying_Type (P_Type);
3480 Strm : constant Node_Id := First (Exprs);
3488 Cntrl : Node_Id := Empty;
3489 -- Value for controlling argument in call. Always Empty except in
3490 -- the dispatching (class-wide type) case, where it is a reference
3491 -- to the dummy object initialized to the right internal tag.
3493 procedure Freeze_Stream_Subprogram (F : Entity_Id);
3494 -- The expansion of the attribute reference may generate a call to
3495 -- a user-defined stream subprogram that is frozen by the call. This
3496 -- can lead to access-before-elaboration problem if the reference
3497 -- appears in an object declaration and the subprogram body has not
3498 -- been seen. The freezing of the subprogram requires special code
3499 -- because it appears in an expanded context where expressions do
3500 -- not freeze their constituents.
3502 ------------------------------
3503 -- Freeze_Stream_Subprogram --
3504 ------------------------------
3506 procedure Freeze_Stream_Subprogram (F : Entity_Id) is
3507 Decl : constant Node_Id := Unit_Declaration_Node (F);
3511 -- If this is user-defined subprogram, the corresponding
3512 -- stream function appears as a renaming-as-body, and the
3513 -- user subprogram must be retrieved by tree traversal.
3516 and then Nkind (Decl) = N_Subprogram_Declaration
3517 and then Present (Corresponding_Body (Decl))
3519 Bod := Corresponding_Body (Decl);
3521 if Nkind (Unit_Declaration_Node (Bod)) =
3522 N_Subprogram_Renaming_Declaration
3524 Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod))));
3527 end Freeze_Stream_Subprogram;
3529 -- Start of processing for Input
3532 -- If no underlying type, we have an error that will be diagnosed
3533 -- elsewhere, so here we just completely ignore the expansion.
3539 -- Stream operations can appear in user code even if the restriction
3540 -- No_Streams is active (for example, when instantiating a predefined
3541 -- container). In that case rewrite the attribute as a Raise to
3542 -- prevent any run-time use.
3544 if Restriction_Active (No_Streams) then
3546 Make_Raise_Program_Error (Sloc (N),
3547 Reason => PE_Stream_Operation_Not_Allowed));
3548 Set_Etype (N, B_Type);
3552 -- If there is a TSS for Input, just call it
3554 Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
3556 if Present (Fname) then
3560 -- If there is a Stream_Convert pragma, use it, we rewrite
3562 -- sourcetyp'Input (stream)
3566 -- sourcetyp (streamread (strmtyp'Input (stream)));
3568 -- where streamread is the given Read function that converts an
3569 -- argument of type strmtyp to type sourcetyp or a type from which
3570 -- it is derived (extra conversion required for the derived case).
3572 Prag := Get_Stream_Convert_Pragma (P_Type);
3574 if Present (Prag) then
3575 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
3576 Rfunc := Entity (Expression (Arg2));
3580 Make_Function_Call (Loc,
3581 Name => New_Occurrence_Of (Rfunc, Loc),
3582 Parameter_Associations => New_List (
3583 Make_Attribute_Reference (Loc,
3586 (Etype (First_Formal (Rfunc)), Loc),
3587 Attribute_Name => Name_Input,
3588 Expressions => Exprs)))));
3590 Analyze_And_Resolve (N, B_Type);
3595 elsif Is_Elementary_Type (U_Type) then
3597 -- A special case arises if we have a defined _Read routine,
3598 -- since in this case we are required to call this routine.
3600 if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then
3601 Build_Record_Or_Elementary_Input_Function
3602 (Loc, U_Type, Decl, Fname);
3603 Insert_Action (N, Decl);
3605 -- For normal cases, we call the I_xxx routine directly
3608 Rewrite (N, Build_Elementary_Input_Call (N));
3609 Analyze_And_Resolve (N, P_Type);
3615 elsif Is_Array_Type (U_Type) then
3616 Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
3617 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3619 -- Dispatching case with class-wide type
3621 elsif Is_Class_Wide_Type (P_Type) then
3623 -- No need to do anything else compiling under restriction
3624 -- No_Dispatching_Calls. During the semantic analysis we
3625 -- already notified such violation.
3627 if Restriction_Active (No_Dispatching_Calls) then
3632 Rtyp : constant Entity_Id := Root_Type (P_Type);
3636 -- Read the internal tag (RM 13.13.2(34)) and use it to
3637 -- initialize a dummy tag value:
3639 -- Descendant_Tag (String'Input (Strm), P_Type);
3641 -- This value is used only to provide a controlling
3642 -- argument for the eventual _Input call. Descendant_Tag is
3643 -- called rather than Internal_Tag to ensure that we have a
3644 -- tag for a type that is descended from the prefix type and
3645 -- declared at the same accessibility level (the exception
3646 -- Tag_Error will be raised otherwise). The level check is
3647 -- required for Ada 2005 because tagged types can be
3648 -- extended in nested scopes (AI-344).
3650 -- Note: we used to generate an explicit declaration of a
3651 -- constant Ada.Tags.Tag object, and use an occurrence of
3652 -- this constant in Cntrl, but this caused a secondary stack
3656 Make_Function_Call (Loc,
3658 New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
3659 Parameter_Associations => New_List (
3660 Make_Attribute_Reference (Loc,
3662 New_Occurrence_Of (Standard_String, Loc),
3663 Attribute_Name => Name_Input,
3664 Expressions => New_List (
3665 Relocate_Node (Duplicate_Subexpr (Strm)))),
3666 Make_Attribute_Reference (Loc,
3667 Prefix => New_Occurrence_Of (P_Type, Loc),
3668 Attribute_Name => Name_Tag)));
3669 Set_Etype (Expr, RTE (RE_Tag));
3671 -- Now we need to get the entity for the call, and construct
3672 -- a function call node, where we preset a reference to Dnn
3673 -- as the controlling argument (doing an unchecked convert
3674 -- to the class-wide tagged type to make it look like a real
3677 Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
3678 Cntrl := Unchecked_Convert_To (P_Type, Expr);
3679 Set_Etype (Cntrl, P_Type);
3680 Set_Parent (Cntrl, N);
3683 -- For tagged types, use the primitive Input function
3685 elsif Is_Tagged_Type (U_Type) then
3686 Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
3688 -- All other record type cases, including protected records. The
3689 -- latter only arise for expander generated code for handling
3690 -- shared passive partition access.
3694 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
3696 -- Ada 2005 (AI-216): Program_Error is raised executing default
3697 -- implementation of the Input attribute of an unchecked union
3698 -- type if the type lacks default discriminant values.
3700 if Is_Unchecked_Union (Base_Type (U_Type))
3701 and then No (Discriminant_Constraint (U_Type))
3704 Make_Raise_Program_Error (Loc,
3705 Reason => PE_Unchecked_Union_Restriction));
3710 -- Build the type's Input function, passing the subtype rather
3711 -- than its base type, because checks are needed in the case of
3712 -- constrained discriminants (see Ada 2012 AI05-0192).
3714 Build_Record_Or_Elementary_Input_Function
3715 (Loc, U_Type, Decl, Fname);
3716 Insert_Action (N, Decl);
3718 if Nkind (Parent (N)) = N_Object_Declaration
3719 and then Is_Record_Type (U_Type)
3721 -- The stream function may contain calls to user-defined
3722 -- Read procedures for individual components.
3729 Comp := First_Component (U_Type);
3730 while Present (Comp) loop
3732 Find_Stream_Subprogram
3733 (Etype (Comp), TSS_Stream_Read);
3735 if Present (Func) then
3736 Freeze_Stream_Subprogram (Func);
3739 Next_Component (Comp);
3746 -- If we fall through, Fname is the function to be called. The result
3747 -- is obtained by calling the appropriate function, then converting
3748 -- the result. The conversion does a subtype check.
3751 Make_Function_Call (Loc,
3752 Name => New_Occurrence_Of (Fname, Loc),
3753 Parameter_Associations => New_List (
3754 Relocate_Node (Strm)));
3756 Set_Controlling_Argument (Call, Cntrl);
3757 Rewrite (N, Unchecked_Convert_To (P_Type, Call));
3758 Analyze_And_Resolve (N, P_Type);
3760 if Nkind (Parent (N)) = N_Object_Declaration then
3761 Freeze_Stream_Subprogram (Fname);
3771 -- inttype'Fixed_Value (fixed-value)
3775 -- inttype(integer-value))
3777 -- we do all the required analysis of the conversion here, because we do
3778 -- not want this to go through the fixed-point conversion circuits. Note
3779 -- that the back end always treats fixed-point as equivalent to the
3780 -- corresponding integer type anyway.
3782 when Attribute_Integer_Value => Integer_Value :
3785 Make_Type_Conversion (Loc,
3786 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
3787 Expression => Relocate_Node (First (Exprs))));
3788 Set_Etype (N, Entity (Pref));
3791 -- Note: it might appear that a properly analyzed unchecked conversion
3792 -- would be just fine here, but that's not the case, since the full
3793 -- range checks performed by the following call are critical.
3795 Apply_Type_Conversion_Checks (N);
3802 when Attribute_Invalid_Value =>
3803 Rewrite (N, Get_Simple_Init_Val (Ptyp, N));
3809 when Attribute_Last =>
3811 -- If the prefix type is a constrained packed array type which
3812 -- already has a Packed_Array_Impl_Type representation defined, then
3813 -- replace this attribute with a direct reference to 'Last of the
3814 -- appropriate index subtype (since otherwise the back end will try
3815 -- to give us the value of 'Last for this implementation type).
3817 if Is_Constrained_Packed_Array (Ptyp) then
3819 Make_Attribute_Reference (Loc,
3820 Attribute_Name => Name_Last,
3821 Prefix => New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
3822 Analyze_And_Resolve (N, Typ);
3824 -- For access type, apply access check as needed
3826 elsif Is_Access_Type (Ptyp) then
3827 Apply_Access_Check (N);
3829 -- For scalar type, if low bound is a reference to an entity, just
3830 -- replace with a direct reference. Note that we can only have a
3831 -- reference to a constant entity at this stage, anything else would
3832 -- have already been rewritten.
3834 elsif Is_Scalar_Type (Ptyp) then
3836 Hi : constant Node_Id := Type_High_Bound (Ptyp);
3838 if Is_Entity_Name (Hi) then
3839 Rewrite (N, New_Occurrence_Of (Entity (Hi), Loc));
3848 -- We compute this if a component clause was present, otherwise we leave
3849 -- the computation up to the back end, since we don't know what layout
3852 when Attribute_Last_Bit => Last_Bit_Attr : declare
3853 CE : constant Entity_Id := Entity (Selector_Name (Pref));
3856 -- In Ada 2005 (or later) if we have the non-default bit order, then
3857 -- we return the original value as given in the component clause
3858 -- (RM 2005 13.5.2(3/2)).
3860 if Present (Component_Clause (CE))
3861 and then Ada_Version >= Ada_2005
3862 and then Reverse_Bit_Order (Scope (CE))
3865 Make_Integer_Literal (Loc,
3866 Intval => Expr_Value (Last_Bit (Component_Clause (CE)))));
3867 Analyze_And_Resolve (N, Typ);
3869 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3870 -- rewrite with normalized value if we know it statically.
3872 elsif Known_Static_Component_Bit_Offset (CE)
3873 and then Known_Static_Esize (CE)
3876 Make_Integer_Literal (Loc,
3877 Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
3879 Analyze_And_Resolve (N, Typ);
3881 -- Otherwise leave to back end, just apply universal integer checks
3884 Apply_Universal_Integer_Attribute_Checks (N);
3892 -- Transforms 'Leading_Part into a call to the floating-point attribute
3893 -- function Leading_Part in Fat_xxx (where xxx is the root type)
3895 -- Note: strictly, we should generate special case code to deal with
3896 -- absurdly large positive arguments (greater than Integer'Last), which
3897 -- result in returning the first argument unchanged, but it hardly seems
3898 -- worth the effort. We raise constraint error for absurdly negative
3899 -- arguments which is fine.
3901 when Attribute_Leading_Part =>
3902 Expand_Fpt_Attribute_RI (N);
3908 when Attribute_Length => Length : declare
3913 -- Processing for packed array types
3915 if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
3916 Ityp := Get_Index_Subtype (N);
3918 -- If the index type, Ityp, is an enumeration type with holes,
3919 -- then we calculate X'Length explicitly using
3922 -- (0, Ityp'Pos (X'Last (N)) -
3923 -- Ityp'Pos (X'First (N)) + 1);
3925 -- Since the bounds in the template are the representation values
3926 -- and the back end would get the wrong value.
3928 if Is_Enumeration_Type (Ityp)
3929 and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
3934 Xnum := Expr_Value (First (Expressions (N)));
3938 Make_Attribute_Reference (Loc,
3939 Prefix => New_Occurrence_Of (Typ, Loc),
3940 Attribute_Name => Name_Max,
3941 Expressions => New_List
3942 (Make_Integer_Literal (Loc, 0),
3946 Make_Op_Subtract (Loc,
3948 Make_Attribute_Reference (Loc,
3949 Prefix => New_Occurrence_Of (Ityp, Loc),
3950 Attribute_Name => Name_Pos,
3952 Expressions => New_List (
3953 Make_Attribute_Reference (Loc,
3954 Prefix => Duplicate_Subexpr (Pref),
3955 Attribute_Name => Name_Last,
3956 Expressions => New_List (
3957 Make_Integer_Literal (Loc, Xnum))))),
3960 Make_Attribute_Reference (Loc,
3961 Prefix => New_Occurrence_Of (Ityp, Loc),
3962 Attribute_Name => Name_Pos,
3964 Expressions => New_List (
3965 Make_Attribute_Reference (Loc,
3967 Duplicate_Subexpr_No_Checks (Pref),
3968 Attribute_Name => Name_First,
3969 Expressions => New_List (
3970 Make_Integer_Literal (Loc, Xnum)))))),
3972 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
3974 Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
3977 -- If the prefix type is a constrained packed array type which
3978 -- already has a Packed_Array_Impl_Type representation defined,
3979 -- then replace this attribute with a reference to 'Range_Length
3980 -- of the appropriate index subtype (since otherwise the
3981 -- back end will try to give us the value of 'Length for
3982 -- this implementation type).s
3984 elsif Is_Constrained (Ptyp) then
3986 Make_Attribute_Reference (Loc,
3987 Attribute_Name => Name_Range_Length,
3988 Prefix => New_Occurrence_Of (Ityp, Loc)));
3989 Analyze_And_Resolve (N, Typ);
3994 elsif Is_Access_Type (Ptyp) then
3995 Apply_Access_Check (N);
3997 -- If the designated type is a packed array type, then we convert
3998 -- the reference to:
4001 -- xtyp'Pos (Pref'Last (Expr)) -
4002 -- xtyp'Pos (Pref'First (Expr)));
4004 -- This is a bit complex, but it is the easiest thing to do that
4005 -- works in all cases including enum types with holes xtyp here
4006 -- is the appropriate index type.
4009 Dtyp : constant Entity_Id := Designated_Type (Ptyp);
4013 if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
4014 Xtyp := Get_Index_Subtype (N);
4017 Make_Attribute_Reference (Loc,
4018 Prefix => New_Occurrence_Of (Typ, Loc),
4019 Attribute_Name => Name_Max,
4020 Expressions => New_List (
4021 Make_Integer_Literal (Loc, 0),
4024 Make_Integer_Literal (Loc, 1),
4025 Make_Op_Subtract (Loc,
4027 Make_Attribute_Reference (Loc,
4028 Prefix => New_Occurrence_Of (Xtyp, Loc),
4029 Attribute_Name => Name_Pos,
4030 Expressions => New_List (
4031 Make_Attribute_Reference (Loc,
4032 Prefix => Duplicate_Subexpr (Pref),
4033 Attribute_Name => Name_Last,
4035 New_Copy_List (Exprs)))),
4038 Make_Attribute_Reference (Loc,
4039 Prefix => New_Occurrence_Of (Xtyp, Loc),
4040 Attribute_Name => Name_Pos,
4041 Expressions => New_List (
4042 Make_Attribute_Reference (Loc,
4044 Duplicate_Subexpr_No_Checks (Pref),
4045 Attribute_Name => Name_First,
4047 New_Copy_List (Exprs)))))))));
4049 Analyze_And_Resolve (N, Typ);
4053 -- Otherwise leave it to the back end
4056 Apply_Universal_Integer_Attribute_Checks (N);
4060 -- Attribute Loop_Entry is replaced with a reference to a constant value
4061 -- which captures the prefix at the entry point of the related loop. The
4062 -- loop itself may be transformed into a conditional block.
4064 when Attribute_Loop_Entry =>
4065 Expand_Loop_Entry_Attribute (N);
4071 -- Transforms 'Machine into a call to the floating-point attribute
4072 -- function Machine in Fat_xxx (where xxx is the root type).
4073 -- Expansion is avoided for cases the back end can handle directly.
4075 when Attribute_Machine =>
4076 if not Is_Inline_Floating_Point_Attribute (N) then
4077 Expand_Fpt_Attribute_R (N);
4080 ----------------------
4081 -- Machine_Rounding --
4082 ----------------------
4084 -- Transforms 'Machine_Rounding into a call to the floating-point
4085 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
4086 -- type). Expansion is avoided for cases the back end can handle
4089 when Attribute_Machine_Rounding =>
4090 if not Is_Inline_Floating_Point_Attribute (N) then
4091 Expand_Fpt_Attribute_R (N);
4098 -- Machine_Size is equivalent to Object_Size, so transform it into
4099 -- Object_Size and that way the back end never sees Machine_Size.
4101 when Attribute_Machine_Size =>
4103 Make_Attribute_Reference (Loc,
4104 Prefix => Prefix (N),
4105 Attribute_Name => Name_Object_Size));
4107 Analyze_And_Resolve (N, Typ);
4113 -- The only case that can get this far is the dynamic case of the old
4114 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
4121 -- ityp (System.Mantissa.Mantissa_Value
4122 -- (Integer'Integer_Value (typ'First),
4123 -- Integer'Integer_Value (typ'Last)));
4125 when Attribute_Mantissa => Mantissa : begin
4128 Make_Function_Call (Loc,
4129 Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
4131 Parameter_Associations => New_List (
4133 Make_Attribute_Reference (Loc,
4134 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
4135 Attribute_Name => Name_Integer_Value,
4136 Expressions => New_List (
4138 Make_Attribute_Reference (Loc,
4139 Prefix => New_Occurrence_Of (Ptyp, Loc),
4140 Attribute_Name => Name_First))),
4142 Make_Attribute_Reference (Loc,
4143 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
4144 Attribute_Name => Name_Integer_Value,
4145 Expressions => New_List (
4147 Make_Attribute_Reference (Loc,
4148 Prefix => New_Occurrence_Of (Ptyp, Loc),
4149 Attribute_Name => Name_Last)))))));
4151 Analyze_And_Resolve (N, Typ);
4158 when Attribute_Max =>
4159 Expand_Min_Max_Attribute (N);
4161 ----------------------------------
4162 -- Max_Size_In_Storage_Elements --
4163 ----------------------------------
4165 when Attribute_Max_Size_In_Storage_Elements => declare
4166 Typ : constant Entity_Id := Etype (N);
4169 Conversion_Added : Boolean := False;
4170 -- A flag which tracks whether the original attribute has been
4171 -- wrapped inside a type conversion.
4174 -- If the prefix is X'Class, we transform it into a direct reference
4175 -- to the class-wide type, because the back end must not see a 'Class
4176 -- reference. See also 'Size.
4178 if Is_Entity_Name (Pref)
4179 and then Is_Class_Wide_Type (Entity (Pref))
4181 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
4185 Apply_Universal_Integer_Attribute_Checks (N);
4187 -- The universal integer check may sometimes add a type conversion,
4188 -- retrieve the original attribute reference from the expression.
4192 if Nkind (Attr) = N_Type_Conversion then
4193 Attr := Expression (Attr);
4194 Conversion_Added := True;
4197 pragma Assert (Nkind (Attr) = N_Attribute_Reference);
4199 -- Heap-allocated controlled objects contain two extra pointers which
4200 -- are not part of the actual type. Transform the attribute reference
4201 -- into a runtime expression to add the size of the hidden header.
4203 -- Do not perform this expansion on .NET/JVM targets because the
4204 -- two pointers are already present in the type.
4206 if VM_Target = No_VM
4207 and then Needs_Finalization (Ptyp)
4208 and then not Header_Size_Added (Attr)
4210 Set_Header_Size_Added (Attr);
4213 -- P'Max_Size_In_Storage_Elements +
4214 -- Universal_Integer
4215 -- (Header_Size_With_Padding (Ptyp'Alignment))
4219 Left_Opnd => Relocate_Node (Attr),
4221 Convert_To (Universal_Integer,
4222 Make_Function_Call (Loc,
4225 (RTE (RE_Header_Size_With_Padding), Loc),
4227 Parameter_Associations => New_List (
4228 Make_Attribute_Reference (Loc,
4230 New_Occurrence_Of (Ptyp, Loc),
4231 Attribute_Name => Name_Alignment))))));
4233 -- Add a conversion to the target type
4235 if not Conversion_Added then
4237 Make_Type_Conversion (Loc,
4238 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4239 Expression => Relocate_Node (Attr)));
4247 --------------------
4248 -- Mechanism_Code --
4249 --------------------
4251 when Attribute_Mechanism_Code =>
4253 -- We must replace the prefix i the renamed case
4255 if Is_Entity_Name (Pref)
4256 and then Present (Alias (Entity (Pref)))
4258 Set_Renamed_Subprogram (Pref, Alias (Entity (Pref)));
4265 when Attribute_Min =>
4266 Expand_Min_Max_Attribute (N);
4272 when Attribute_Mod => Mod_Case : declare
4273 Arg : constant Node_Id := Relocate_Node (First (Exprs));
4274 Hi : constant Node_Id := Type_High_Bound (Etype (Arg));
4275 Modv : constant Uint := Modulus (Btyp);
4279 -- This is not so simple. The issue is what type to use for the
4280 -- computation of the modular value.
4282 -- The easy case is when the modulus value is within the bounds
4283 -- of the signed integer type of the argument. In this case we can
4284 -- just do the computation in that signed integer type, and then
4285 -- do an ordinary conversion to the target type.
4287 if Modv <= Expr_Value (Hi) then
4292 Right_Opnd => Make_Integer_Literal (Loc, Modv))));
4294 -- Here we know that the modulus is larger than type'Last of the
4295 -- integer type. There are two cases to consider:
4297 -- a) The integer value is non-negative. In this case, it is
4298 -- returned as the result (since it is less than the modulus).
4300 -- b) The integer value is negative. In this case, we know that the
4301 -- result is modulus + value, where the value might be as small as
4302 -- -modulus. The trouble is what type do we use to do the subtract.
4303 -- No type will do, since modulus can be as big as 2**64, and no
4304 -- integer type accommodates this value. Let's do bit of algebra
4307 -- = modulus - (-value)
4308 -- = (modulus - 1) - (-value - 1)
4310 -- Now modulus - 1 is certainly in range of the modular type.
4311 -- -value is in the range 1 .. modulus, so -value -1 is in the
4312 -- range 0 .. modulus-1 which is in range of the modular type.
4313 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
4314 -- which we can compute using the integer base type.
4316 -- Once this is done we analyze the if expression without range
4317 -- checks, because we know everything is in range, and we want
4318 -- to prevent spurious warnings on either branch.
4322 Make_If_Expression (Loc,
4323 Expressions => New_List (
4325 Left_Opnd => Duplicate_Subexpr (Arg),
4326 Right_Opnd => Make_Integer_Literal (Loc, 0)),
4329 Duplicate_Subexpr_No_Checks (Arg)),
4331 Make_Op_Subtract (Loc,
4333 Make_Integer_Literal (Loc,
4334 Intval => Modv - 1),
4340 Left_Opnd => Duplicate_Subexpr_No_Checks (Arg),
4342 Make_Integer_Literal (Loc,
4343 Intval => 1))))))));
4347 Analyze_And_Resolve (N, Btyp, Suppress => All_Checks);
4354 -- Transforms 'Model into a call to the floating-point attribute
4355 -- function Model in Fat_xxx (where xxx is the root type).
4356 -- Expansion is avoided for cases the back end can handle directly.
4358 when Attribute_Model =>
4359 if not Is_Inline_Floating_Point_Attribute (N) then
4360 Expand_Fpt_Attribute_R (N);
4367 -- The processing for Object_Size shares the processing for Size
4373 when Attribute_Old => Old : declare
4374 Typ : constant Entity_Id := Etype (N);
4375 CW_Temp : Entity_Id;
4381 -- Climb the parent chain looking for subprogram _Postconditions
4384 while Present (Subp) loop
4385 exit when Nkind (Subp) = N_Subprogram_Body
4386 and then Chars (Defining_Entity (Subp)) = Name_uPostconditions;
4388 -- If assertions are disabled, no need to create the declaration
4389 -- that preserves the value. The postcondition pragma in which
4390 -- 'Old appears will be checked or disabled according to the
4391 -- current policy in effect.
4393 if Nkind (Subp) = N_Pragma and then not Is_Checked (Subp) then
4397 Subp := Parent (Subp);
4400 -- 'Old can only appear in a postcondition, the generated body of
4401 -- _Postconditions must be in the tree.
4403 pragma Assert (Present (Subp));
4405 Temp := Make_Temporary (Loc, 'T', Pref);
4407 -- Set the entity kind now in order to mark the temporary as a
4408 -- handler of attribute 'Old's prefix.
4410 Set_Ekind (Temp, E_Constant);
4411 Set_Stores_Attribute_Old_Prefix (Temp);
4413 -- Push the scope of the related subprogram where _Postcondition
4414 -- resides as this ensures that the object will be analyzed in the
4417 Push_Scope (Scope (Defining_Entity (Subp)));
4419 -- Preserve the tag of the prefix by offering a specific view of the
4420 -- class-wide version of the prefix.
4422 if Is_Tagged_Type (Typ) then
4425 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
4427 CW_Temp := Make_Temporary (Loc, 'T');
4428 CW_Typ := Class_Wide_Type (Typ);
4430 Insert_Before_And_Analyze (Subp,
4431 Make_Object_Declaration (Loc,
4432 Defining_Identifier => CW_Temp,
4433 Constant_Present => True,
4434 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
4436 Convert_To (CW_Typ, Relocate_Node (Pref))));
4439 -- Temp : Typ renames Typ (CW_Temp);
4441 Insert_Before_And_Analyze (Subp,
4442 Make_Object_Renaming_Declaration (Loc,
4443 Defining_Identifier => Temp,
4444 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4446 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))));
4452 -- Temp : constant Typ := Pref;
4454 Insert_Before_And_Analyze (Subp,
4455 Make_Object_Declaration (Loc,
4456 Defining_Identifier => Temp,
4457 Constant_Present => True,
4458 Object_Definition => New_Occurrence_Of (Typ, Loc),
4459 Expression => Relocate_Node (Pref)));
4464 -- Ensure that the prefix of attribute 'Old is valid. The check must
4465 -- be inserted after the expansion of the attribute has taken place
4466 -- to reflect the new placement of the prefix.
4468 if Validity_Checks_On and then Validity_Check_Operands then
4469 Ensure_Valid (Pref);
4472 Rewrite (N, New_Occurrence_Of (Temp, Loc));
4475 ----------------------
4476 -- Overlaps_Storage --
4477 ----------------------
4479 when Attribute_Overlaps_Storage => Overlaps_Storage : declare
4480 Loc : constant Source_Ptr := Sloc (N);
4482 X : constant Node_Id := Prefix (N);
4483 Y : constant Node_Id := First (Expressions (N));
4486 X_Addr, Y_Addr : Node_Id;
4487 -- the expressions for their integer addresses
4489 X_Size, Y_Size : Node_Id;
4490 -- the expressions for their sizes
4495 -- Attribute expands into:
4497 -- if X'Address < Y'address then
4498 -- (X'address + X'Size - 1) >= Y'address
4500 -- (Y'address + Y'size - 1) >= X'Address
4503 -- with the proper address operations. We convert addresses to
4504 -- integer addresses to use predefined arithmetic. The size is
4505 -- expressed in storage units.
4508 Unchecked_Convert_To (RTE (RE_Integer_Address),
4509 Make_Attribute_Reference (Loc,
4510 Attribute_Name => Name_Address,
4511 Prefix => New_Copy_Tree (X)));
4514 Unchecked_Convert_To (RTE (RE_Integer_Address),
4515 Make_Attribute_Reference (Loc,
4516 Attribute_Name => Name_Address,
4517 Prefix => New_Copy_Tree (Y)));
4520 Make_Op_Divide (Loc,
4522 Make_Attribute_Reference (Loc,
4523 Attribute_Name => Name_Size,
4524 Prefix => New_Copy_Tree (X)),
4526 Make_Integer_Literal (Loc, System_Storage_Unit));
4529 Make_Op_Divide (Loc,
4531 Make_Attribute_Reference (Loc,
4532 Attribute_Name => Name_Size,
4533 Prefix => New_Copy_Tree (Y)),
4535 Make_Integer_Literal (Loc, System_Storage_Unit));
4539 Left_Opnd => X_Addr,
4540 Right_Opnd => Y_Addr);
4543 Make_If_Expression (Loc,
4550 Left_Opnd => X_Addr,
4552 Make_Op_Subtract (Loc,
4553 Left_Opnd => X_Size,
4554 Right_Opnd => Make_Integer_Literal (Loc, 1))),
4555 Right_Opnd => Y_Addr),
4559 Left_Opnd => Y_Addr,
4561 Make_Op_Subtract (Loc,
4562 Left_Opnd => Y_Size,
4563 Right_Opnd => Make_Integer_Literal (Loc, 1))),
4564 Right_Opnd => X_Addr))));
4566 Analyze_And_Resolve (N, Standard_Boolean);
4567 end Overlaps_Storage;
4573 when Attribute_Output => Output : declare
4574 P_Type : constant Entity_Id := Entity (Pref);
4575 U_Type : constant Entity_Id := Underlying_Type (P_Type);
4583 -- If no underlying type, we have an error that will be diagnosed
4584 -- elsewhere, so here we just completely ignore the expansion.
4590 -- Stream operations can appear in user code even if the restriction
4591 -- No_Streams is active (for example, when instantiating a predefined
4592 -- container). In that case rewrite the attribute as a Raise to
4593 -- prevent any run-time use.
4595 if Restriction_Active (No_Streams) then
4597 Make_Raise_Program_Error (Sloc (N),
4598 Reason => PE_Stream_Operation_Not_Allowed));
4599 Set_Etype (N, Standard_Void_Type);
4603 -- If TSS for Output is present, just call it
4605 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
4607 if Present (Pname) then
4611 -- If there is a Stream_Convert pragma, use it, we rewrite
4613 -- sourcetyp'Output (stream, Item)
4617 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
4619 -- where strmwrite is the given Write function that converts an
4620 -- argument of type sourcetyp or a type acctyp, from which it is
4621 -- derived to type strmtyp. The conversion to acttyp is required
4622 -- for the derived case.
4624 Prag := Get_Stream_Convert_Pragma (P_Type);
4626 if Present (Prag) then
4628 Next (Next (First (Pragma_Argument_Associations (Prag))));
4629 Wfunc := Entity (Expression (Arg3));
4632 Make_Attribute_Reference (Loc,
4633 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
4634 Attribute_Name => Name_Output,
4635 Expressions => New_List (
4636 Relocate_Node (First (Exprs)),
4637 Make_Function_Call (Loc,
4638 Name => New_Occurrence_Of (Wfunc, Loc),
4639 Parameter_Associations => New_List (
4640 OK_Convert_To (Etype (First_Formal (Wfunc)),
4641 Relocate_Node (Next (First (Exprs)))))))));
4646 -- For elementary types, we call the W_xxx routine directly. Note
4647 -- that the effect of Write and Output is identical for the case
4648 -- of an elementary type (there are no discriminants or bounds).
4650 elsif Is_Elementary_Type (U_Type) then
4652 -- A special case arises if we have a defined _Write routine,
4653 -- since in this case we are required to call this routine.
4655 if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then
4656 Build_Record_Or_Elementary_Output_Procedure
4657 (Loc, U_Type, Decl, Pname);
4658 Insert_Action (N, Decl);
4660 -- For normal cases, we call the W_xxx routine directly
4663 Rewrite (N, Build_Elementary_Write_Call (N));
4670 elsif Is_Array_Type (U_Type) then
4671 Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
4672 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
4674 -- Class-wide case, first output external tag, then dispatch
4675 -- to the appropriate primitive Output function (RM 13.13.2(31)).
4677 elsif Is_Class_Wide_Type (P_Type) then
4679 -- No need to do anything else compiling under restriction
4680 -- No_Dispatching_Calls. During the semantic analysis we
4681 -- already notified such violation.
4683 if Restriction_Active (No_Dispatching_Calls) then
4688 Strm : constant Node_Id := First (Exprs);
4689 Item : constant Node_Id := Next (Strm);
4692 -- Ada 2005 (AI-344): Check that the accessibility level
4693 -- of the type of the output object is not deeper than
4694 -- that of the attribute's prefix type.
4696 -- if Get_Access_Level (Item'Tag)
4697 -- /= Get_Access_Level (P_Type'Tag)
4702 -- String'Output (Strm, External_Tag (Item'Tag));
4704 -- We cannot figure out a practical way to implement this
4705 -- accessibility check on virtual machines, so we omit it.
4707 if Ada_Version >= Ada_2005
4708 and then Tagged_Type_Expansion
4711 Make_Implicit_If_Statement (N,
4715 Build_Get_Access_Level (Loc,
4716 Make_Attribute_Reference (Loc,
4719 Duplicate_Subexpr (Item,
4721 Attribute_Name => Name_Tag)),
4724 Make_Integer_Literal (Loc,
4725 Type_Access_Level (P_Type))),
4728 New_List (Make_Raise_Statement (Loc,
4730 RTE (RE_Tag_Error), Loc)))));
4734 Make_Attribute_Reference (Loc,
4735 Prefix => New_Occurrence_Of (Standard_String, Loc),
4736 Attribute_Name => Name_Output,
4737 Expressions => New_List (
4738 Relocate_Node (Duplicate_Subexpr (Strm)),
4739 Make_Function_Call (Loc,
4741 New_Occurrence_Of (RTE (RE_External_Tag), Loc),
4742 Parameter_Associations => New_List (
4743 Make_Attribute_Reference (Loc,
4746 (Duplicate_Subexpr (Item, Name_Req => True)),
4747 Attribute_Name => Name_Tag))))));
4750 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
4752 -- Tagged type case, use the primitive Output function
4754 elsif Is_Tagged_Type (U_Type) then
4755 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
4757 -- All other record type cases, including protected records.
4758 -- The latter only arise for expander generated code for
4759 -- handling shared passive partition access.
4763 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
4765 -- Ada 2005 (AI-216): Program_Error is raised when executing
4766 -- the default implementation of the Output attribute of an
4767 -- unchecked union type if the type lacks default discriminant
4770 if Is_Unchecked_Union (Base_Type (U_Type))
4771 and then No (Discriminant_Constraint (U_Type))
4774 Make_Raise_Program_Error (Loc,
4775 Reason => PE_Unchecked_Union_Restriction));
4780 Build_Record_Or_Elementary_Output_Procedure
4781 (Loc, Base_Type (U_Type), Decl, Pname);
4782 Insert_Action (N, Decl);
4786 -- If we fall through, Pname is the name of the procedure to call
4788 Rewrite_Stream_Proc_Call (Pname);
4795 -- For enumeration types with a standard representation, Pos is
4796 -- handled by the back end.
4798 -- For enumeration types, with a non-standard representation we generate
4799 -- a call to the _Rep_To_Pos function created when the type was frozen.
4800 -- The call has the form
4802 -- _rep_to_pos (expr, flag)
4804 -- The parameter flag is True if range checks are enabled, causing
4805 -- Program_Error to be raised if the expression has an invalid
4806 -- representation, and False if range checks are suppressed.
4808 -- For integer types, Pos is equivalent to a simple integer
4809 -- conversion and we rewrite it as such
4811 when Attribute_Pos => Pos :
4813 Etyp : Entity_Id := Base_Type (Entity (Pref));
4816 -- Deal with zero/non-zero boolean values
4818 if Is_Boolean_Type (Etyp) then
4819 Adjust_Condition (First (Exprs));
4820 Etyp := Standard_Boolean;
4821 Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
4824 -- Case of enumeration type
4826 if Is_Enumeration_Type (Etyp) then
4828 -- Non-standard enumeration type (generate call)
4830 if Present (Enum_Pos_To_Rep (Etyp)) then
4831 Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
4834 Make_Function_Call (Loc,
4836 New_Occurrence_Of (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4837 Parameter_Associations => Exprs)));
4839 Analyze_And_Resolve (N, Typ);
4841 -- Standard enumeration type (do universal integer check)
4844 Apply_Universal_Integer_Attribute_Checks (N);
4847 -- Deal with integer types (replace by conversion)
4849 elsif Is_Integer_Type (Etyp) then
4850 Rewrite (N, Convert_To (Typ, First (Exprs)));
4851 Analyze_And_Resolve (N, Typ);
4860 -- We compute this if a component clause was present, otherwise we leave
4861 -- the computation up to the back end, since we don't know what layout
4864 when Attribute_Position => Position_Attr :
4866 CE : constant Entity_Id := Entity (Selector_Name (Pref));
4869 if Present (Component_Clause (CE)) then
4871 -- In Ada 2005 (or later) if we have the non-default bit order,
4872 -- then we return the original value as given in the component
4873 -- clause (RM 2005 13.5.2(2/2)).
4875 if Ada_Version >= Ada_2005
4876 and then Reverse_Bit_Order (Scope (CE))
4879 Make_Integer_Literal (Loc,
4880 Intval => Expr_Value (Position (Component_Clause (CE)))));
4882 -- Otherwise (Ada 83 or 95, or default bit order specified in
4883 -- later Ada version), return the normalized value.
4887 Make_Integer_Literal (Loc,
4888 Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
4891 Analyze_And_Resolve (N, Typ);
4893 -- If back end is doing things, just apply universal integer checks
4896 Apply_Universal_Integer_Attribute_Checks (N);
4904 -- 1. Deal with enumeration types with holes.
4905 -- 2. For floating-point, generate call to attribute function.
4906 -- 3. For other cases, deal with constraint checking.
4908 when Attribute_Pred => Pred :
4910 Etyp : constant Entity_Id := Base_Type (Ptyp);
4914 -- For enumeration types with non-standard representations, we
4915 -- expand typ'Pred (x) into
4917 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
4919 -- If the representation is contiguous, we compute instead
4920 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
4921 -- The conversion function Enum_Pos_To_Rep is defined on the
4922 -- base type, not the subtype, so we have to use the base type
4923 -- explicitly for this and other enumeration attributes.
4925 if Is_Enumeration_Type (Ptyp)
4926 and then Present (Enum_Pos_To_Rep (Etyp))
4928 if Has_Contiguous_Rep (Etyp) then
4930 Unchecked_Convert_To (Ptyp,
4933 Make_Integer_Literal (Loc,
4934 Enumeration_Rep (First_Literal (Ptyp))),
4936 Make_Function_Call (Loc,
4939 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4941 Parameter_Associations =>
4943 Unchecked_Convert_To (Ptyp,
4944 Make_Op_Subtract (Loc,
4946 Unchecked_Convert_To (Standard_Integer,
4947 Relocate_Node (First (Exprs))),
4949 Make_Integer_Literal (Loc, 1))),
4950 Rep_To_Pos_Flag (Ptyp, Loc))))));
4953 -- Add Boolean parameter True, to request program errror if
4954 -- we have a bad representation on our hands. If checks are
4955 -- suppressed, then add False instead
4957 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
4959 Make_Indexed_Component (Loc,
4962 (Enum_Pos_To_Rep (Etyp), Loc),
4963 Expressions => New_List (
4964 Make_Op_Subtract (Loc,
4966 Make_Function_Call (Loc,
4969 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4970 Parameter_Associations => Exprs),
4971 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
4974 Analyze_And_Resolve (N, Typ);
4976 -- For floating-point, we transform 'Pred into a call to the Pred
4977 -- floating-point attribute function in Fat_xxx (xxx is root type).
4978 -- Note that this function takes care of the overflow case.
4980 elsif Is_Floating_Point_Type (Ptyp) then
4981 Expand_Fpt_Attribute_R (N);
4982 Analyze_And_Resolve (N, Typ);
4984 -- For modular types, nothing to do (no overflow, since wraps)
4986 elsif Is_Modular_Integer_Type (Ptyp) then
4989 -- For other types, if argument is marked as needing a range check or
4990 -- overflow checking is enabled, we must generate a check.
4992 elsif not Overflow_Checks_Suppressed (Ptyp)
4993 or else Do_Range_Check (First (Exprs))
4995 Set_Do_Range_Check (First (Exprs), False);
4996 Expand_Pred_Succ_Attribute (N);
5004 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5006 -- We rewrite X'Priority as the following run-time call:
5008 -- Get_Ceiling (X._Object)
5010 -- Note that although X'Priority is notionally an object, it is quite
5011 -- deliberately not defined as an aliased object in the RM. This means
5012 -- that it works fine to rewrite it as a call, without having to worry
5013 -- about complications that would other arise from X'Priority'Access,
5014 -- which is illegal, because of the lack of aliasing.
5016 when Attribute_Priority =>
5019 Conctyp : Entity_Id;
5020 Object_Parm : Node_Id;
5022 RT_Subprg_Name : Node_Id;
5025 -- Look for the enclosing concurrent type
5027 Conctyp := Current_Scope;
5028 while not Is_Concurrent_Type (Conctyp) loop
5029 Conctyp := Scope (Conctyp);
5032 pragma Assert (Is_Protected_Type (Conctyp));
5034 -- Generate the actual of the call
5036 Subprg := Current_Scope;
5037 while not Present (Protected_Body_Subprogram (Subprg)) loop
5038 Subprg := Scope (Subprg);
5041 -- Use of 'Priority inside protected entries and barriers (in
5042 -- both cases the type of the first formal of their expanded
5043 -- subprogram is Address)
5045 if Etype (First_Entity (Protected_Body_Subprogram (Subprg)))
5049 New_Itype : Entity_Id;
5052 -- In the expansion of protected entries the type of the
5053 -- first formal of the Protected_Body_Subprogram is an
5054 -- Address. In order to reference the _object component
5057 -- type T is access p__ptTV;
5060 New_Itype := Create_Itype (E_Access_Type, N);
5061 Set_Etype (New_Itype, New_Itype);
5062 Set_Directly_Designated_Type (New_Itype,
5063 Corresponding_Record_Type (Conctyp));
5064 Freeze_Itype (New_Itype, N);
5067 -- T!(O)._object'unchecked_access
5070 Make_Attribute_Reference (Loc,
5072 Make_Selected_Component (Loc,
5074 Unchecked_Convert_To (New_Itype,
5077 (Protected_Body_Subprogram (Subprg)),
5080 Make_Identifier (Loc, Name_uObject)),
5081 Attribute_Name => Name_Unchecked_Access);
5084 -- Use of 'Priority inside a protected subprogram
5088 Make_Attribute_Reference (Loc,
5090 Make_Selected_Component (Loc,
5091 Prefix => New_Occurrence_Of
5093 (Protected_Body_Subprogram (Subprg)),
5095 Selector_Name => Make_Identifier (Loc, Name_uObject)),
5096 Attribute_Name => Name_Unchecked_Access);
5099 -- Select the appropriate run-time subprogram
5101 if Number_Entries (Conctyp) = 0 then
5103 New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc);
5106 New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc);
5110 Make_Function_Call (Loc,
5111 Name => RT_Subprg_Name,
5112 Parameter_Associations => New_List (Object_Parm));
5116 -- Avoid the generation of extra checks on the pointer to the
5117 -- protected object.
5119 Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
5126 when Attribute_Range_Length => Range_Length : begin
5128 -- The only special processing required is for the case where
5129 -- Range_Length is applied to an enumeration type with holes.
5130 -- In this case we transform
5136 -- X'Pos (X'Last) - X'Pos (X'First) + 1
5138 -- So that the result reflects the proper Pos values instead
5139 -- of the underlying representations.
5141 if Is_Enumeration_Type (Ptyp)
5142 and then Has_Non_Standard_Rep (Ptyp)
5147 Make_Op_Subtract (Loc,
5149 Make_Attribute_Reference (Loc,
5150 Attribute_Name => Name_Pos,
5151 Prefix => New_Occurrence_Of (Ptyp, Loc),
5152 Expressions => New_List (
5153 Make_Attribute_Reference (Loc,
5154 Attribute_Name => Name_Last,
5155 Prefix => New_Occurrence_Of (Ptyp, Loc)))),
5158 Make_Attribute_Reference (Loc,
5159 Attribute_Name => Name_Pos,
5160 Prefix => New_Occurrence_Of (Ptyp, Loc),
5161 Expressions => New_List (
5162 Make_Attribute_Reference (Loc,
5163 Attribute_Name => Name_First,
5164 Prefix => New_Occurrence_Of (Ptyp, Loc))))),
5166 Right_Opnd => Make_Integer_Literal (Loc, 1)));
5168 Analyze_And_Resolve (N, Typ);
5170 -- For all other cases, the attribute is handled by the back end, but
5171 -- we need to deal with the case of the range check on a universal
5175 Apply_Universal_Integer_Attribute_Checks (N);
5183 when Attribute_Read => Read : declare
5184 P_Type : constant Entity_Id := Entity (Pref);
5185 B_Type : constant Entity_Id := Base_Type (P_Type);
5186 U_Type : constant Entity_Id := Underlying_Type (P_Type);
5196 -- If no underlying type, we have an error that will be diagnosed
5197 -- elsewhere, so here we just completely ignore the expansion.
5203 -- Stream operations can appear in user code even if the restriction
5204 -- No_Streams is active (for example, when instantiating a predefined
5205 -- container). In that case rewrite the attribute as a Raise to
5206 -- prevent any run-time use.
5208 if Restriction_Active (No_Streams) then
5210 Make_Raise_Program_Error (Sloc (N),
5211 Reason => PE_Stream_Operation_Not_Allowed));
5212 Set_Etype (N, B_Type);
5216 -- The simple case, if there is a TSS for Read, just call it
5218 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
5220 if Present (Pname) then
5224 -- If there is a Stream_Convert pragma, use it, we rewrite
5226 -- sourcetyp'Read (stream, Item)
5230 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
5232 -- where strmread is the given Read function that converts an
5233 -- argument of type strmtyp to type sourcetyp or a type from which
5234 -- it is derived. The conversion to sourcetyp is required in the
5237 -- A special case arises if Item is a type conversion in which
5238 -- case, we have to expand to:
5240 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
5242 -- where Itemx is the expression of the type conversion (i.e.
5243 -- the actual object), and typex is the type of Itemx.
5245 Prag := Get_Stream_Convert_Pragma (P_Type);
5247 if Present (Prag) then
5248 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
5249 Rfunc := Entity (Expression (Arg2));
5250 Lhs := Relocate_Node (Next (First (Exprs)));
5252 OK_Convert_To (B_Type,
5253 Make_Function_Call (Loc,
5254 Name => New_Occurrence_Of (Rfunc, Loc),
5255 Parameter_Associations => New_List (
5256 Make_Attribute_Reference (Loc,
5259 (Etype (First_Formal (Rfunc)), Loc),
5260 Attribute_Name => Name_Input,
5261 Expressions => New_List (
5262 Relocate_Node (First (Exprs)))))));
5264 if Nkind (Lhs) = N_Type_Conversion then
5265 Lhs := Expression (Lhs);
5266 Rhs := Convert_To (Etype (Lhs), Rhs);
5270 Make_Assignment_Statement (Loc,
5272 Expression => Rhs));
5273 Set_Assignment_OK (Lhs);
5277 -- For elementary types, we call the I_xxx routine using the first
5278 -- parameter and then assign the result into the second parameter.
5279 -- We set Assignment_OK to deal with the conversion case.
5281 elsif Is_Elementary_Type (U_Type) then
5287 Lhs := Relocate_Node (Next (First (Exprs)));
5288 Rhs := Build_Elementary_Input_Call (N);
5290 if Nkind (Lhs) = N_Type_Conversion then
5291 Lhs := Expression (Lhs);
5292 Rhs := Convert_To (Etype (Lhs), Rhs);
5295 Set_Assignment_OK (Lhs);
5298 Make_Assignment_Statement (Loc,
5300 Expression => Rhs));
5308 elsif Is_Array_Type (U_Type) then
5309 Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
5310 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
5312 -- Tagged type case, use the primitive Read function. Note that
5313 -- this will dispatch in the class-wide case which is what we want
5315 elsif Is_Tagged_Type (U_Type) then
5316 Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
5318 -- All other record type cases, including protected records. The
5319 -- latter only arise for expander generated code for handling
5320 -- shared passive partition access.
5324 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
5326 -- Ada 2005 (AI-216): Program_Error is raised when executing
5327 -- the default implementation of the Read attribute of an
5328 -- Unchecked_Union type.
5330 if Is_Unchecked_Union (Base_Type (U_Type)) then
5332 Make_Raise_Program_Error (Loc,
5333 Reason => PE_Unchecked_Union_Restriction));
5336 if Has_Discriminants (U_Type)
5338 (Discriminant_Default_Value (First_Discriminant (U_Type)))
5340 Build_Mutable_Record_Read_Procedure
5341 (Loc, Full_Base (U_Type), Decl, Pname);
5343 Build_Record_Read_Procedure
5344 (Loc, Full_Base (U_Type), Decl, Pname);
5347 -- Suppress checks, uninitialized or otherwise invalid
5348 -- data does not cause constraint errors to be raised for
5349 -- a complete record read.
5351 Insert_Action (N, Decl, All_Checks);
5355 Rewrite_Stream_Proc_Call (Pname);
5362 -- Ref is identical to To_Address, see To_Address for processing
5368 -- Transforms 'Remainder into a call to the floating-point attribute
5369 -- function Remainder in Fat_xxx (where xxx is the root type)
5371 when Attribute_Remainder =>
5372 Expand_Fpt_Attribute_RR (N);
5378 -- Transform 'Result into reference to _Result formal. At the point
5379 -- where a legal 'Result attribute is expanded, we know that we are in
5380 -- the context of a _Postcondition function with a _Result parameter.
5382 when Attribute_Result =>
5383 Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult));
5384 Analyze_And_Resolve (N, Typ);
5390 -- The handling of the Round attribute is quite delicate. The processing
5391 -- in Sem_Attr introduced a conversion to universal real, reflecting the
5392 -- semantics of Round, but we do not want anything to do with universal
5393 -- real at runtime, since this corresponds to using floating-point
5396 -- What we have now is that the Etype of the Round attribute correctly
5397 -- indicates the final result type. The operand of the Round is the
5398 -- conversion to universal real, described above, and the operand of
5399 -- this conversion is the actual operand of Round, which may be the
5400 -- special case of a fixed point multiplication or division (Etype =
5403 -- The exapander will expand first the operand of the conversion, then
5404 -- the conversion, and finally the round attribute itself, since we
5405 -- always work inside out. But we cannot simply process naively in this
5406 -- order. In the semantic world where universal fixed and real really
5407 -- exist and have infinite precision, there is no problem, but in the
5408 -- implementation world, where universal real is a floating-point type,
5409 -- we would get the wrong result.
5411 -- So the approach is as follows. First, when expanding a multiply or
5412 -- divide whose type is universal fixed, we do nothing at all, instead
5413 -- deferring the operation till later.
5415 -- The actual processing is done in Expand_N_Type_Conversion which
5416 -- handles the special case of Round by looking at its parent to see if
5417 -- it is a Round attribute, and if it is, handling the conversion (or
5418 -- its fixed multiply/divide child) in an appropriate manner.
5420 -- This means that by the time we get to expanding the Round attribute
5421 -- itself, the Round is nothing more than a type conversion (and will
5422 -- often be a null type conversion), so we just replace it with the
5423 -- appropriate conversion operation.
5425 when Attribute_Round =>
5427 Convert_To (Etype (N), Relocate_Node (First (Exprs))));
5428 Analyze_And_Resolve (N);
5434 -- Transforms 'Rounding into a call to the floating-point attribute
5435 -- function Rounding in Fat_xxx (where xxx is the root type)
5436 -- Expansion is avoided for cases the back end can handle directly.
5438 when Attribute_Rounding =>
5439 if not Is_Inline_Floating_Point_Attribute (N) then
5440 Expand_Fpt_Attribute_R (N);
5447 -- Transforms 'Scaling into a call to the floating-point attribute
5448 -- function Scaling in Fat_xxx (where xxx is the root type)
5450 when Attribute_Scaling =>
5451 Expand_Fpt_Attribute_RI (N);
5453 -------------------------
5454 -- Simple_Storage_Pool --
5455 -------------------------
5457 when Attribute_Simple_Storage_Pool =>
5459 Make_Type_Conversion (Loc,
5460 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
5461 Expression => New_Occurrence_Of (Entity (N), Loc)));
5462 Analyze_And_Resolve (N, Typ);
5468 when Attribute_Size |
5469 Attribute_Object_Size |
5470 Attribute_Value_Size |
5471 Attribute_VADS_Size => Size :
5478 -- Processing for VADS_Size case. Note that this processing removes
5479 -- all traces of VADS_Size from the tree, and completes all required
5480 -- processing for VADS_Size by translating the attribute reference
5481 -- to an appropriate Size or Object_Size reference.
5483 if Id = Attribute_VADS_Size
5484 or else (Use_VADS_Size and then Id = Attribute_Size)
5486 -- If the size is specified, then we simply use the specified
5487 -- size. This applies to both types and objects. The size of an
5488 -- object can be specified in the following ways:
5490 -- An explicit size object is given for an object
5491 -- A component size is specified for an indexed component
5492 -- A component clause is specified for a selected component
5493 -- The object is a component of a packed composite object
5495 -- If the size is specified, then VADS_Size of an object
5497 if (Is_Entity_Name (Pref)
5498 and then Present (Size_Clause (Entity (Pref))))
5500 (Nkind (Pref) = N_Component_Clause
5501 and then (Present (Component_Clause
5502 (Entity (Selector_Name (Pref))))
5503 or else Is_Packed (Etype (Prefix (Pref)))))
5505 (Nkind (Pref) = N_Indexed_Component
5506 and then (Component_Size (Etype (Prefix (Pref))) /= 0
5507 or else Is_Packed (Etype (Prefix (Pref)))))
5509 Set_Attribute_Name (N, Name_Size);
5511 -- Otherwise if we have an object rather than a type, then the
5512 -- VADS_Size attribute applies to the type of the object, rather
5513 -- than the object itself. This is one of the respects in which
5514 -- VADS_Size differs from Size.
5517 if (not Is_Entity_Name (Pref)
5518 or else not Is_Type (Entity (Pref)))
5519 and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp))
5521 Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
5524 -- For a scalar type for which no size was explicitly given,
5525 -- VADS_Size means Object_Size. This is the other respect in
5526 -- which VADS_Size differs from Size.
5528 if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then
5529 Set_Attribute_Name (N, Name_Object_Size);
5531 -- In all other cases, Size and VADS_Size are the sane
5534 Set_Attribute_Name (N, Name_Size);
5539 -- If the prefix is X'Class, we transform it into a direct reference
5540 -- to the class-wide type, because the back end must not see a 'Class
5543 if Is_Entity_Name (Pref)
5544 and then Is_Class_Wide_Type (Entity (Pref))
5546 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
5549 -- For X'Size applied to an object of a class-wide type, transform
5550 -- X'Size into a call to the primitive operation _Size applied to X.
5552 elsif Is_Class_Wide_Type (Ptyp)
5553 or else (Id = Attribute_Size
5554 and then Is_Tagged_Type (Ptyp)
5555 and then Has_Unknown_Discriminants (Ptyp))
5557 -- No need to do anything else compiling under restriction
5558 -- No_Dispatching_Calls. During the semantic analysis we
5559 -- already notified such violation.
5561 if Restriction_Active (No_Dispatching_Calls) then
5566 Make_Function_Call (Loc,
5567 Name => New_Occurrence_Of
5568 (Find_Prim_Op (Ptyp, Name_uSize), Loc),
5569 Parameter_Associations => New_List (Pref));
5571 if Typ /= Standard_Long_Long_Integer then
5573 -- The context is a specific integer type with which the
5574 -- original attribute was compatible. The function has a
5575 -- specific type as well, so to preserve the compatibility
5576 -- we must convert explicitly.
5578 New_Node := Convert_To (Typ, New_Node);
5581 Rewrite (N, New_Node);
5582 Analyze_And_Resolve (N, Typ);
5585 -- Case of known RM_Size of a type
5587 elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
5588 and then Is_Entity_Name (Pref)
5589 and then Is_Type (Entity (Pref))
5590 and then Known_Static_RM_Size (Entity (Pref))
5592 Siz := RM_Size (Entity (Pref));
5594 -- Case of known Esize of a type
5596 elsif Id = Attribute_Object_Size
5597 and then Is_Entity_Name (Pref)
5598 and then Is_Type (Entity (Pref))
5599 and then Known_Static_Esize (Entity (Pref))
5601 Siz := Esize (Entity (Pref));
5603 -- Case of known size of object
5605 elsif Id = Attribute_Size
5606 and then Is_Entity_Name (Pref)
5607 and then Is_Object (Entity (Pref))
5608 and then Known_Esize (Entity (Pref))
5609 and then Known_Static_Esize (Entity (Pref))
5611 Siz := Esize (Entity (Pref));
5613 -- For an array component, we can do Size in the front end
5614 -- if the component_size of the array is set.
5616 elsif Nkind (Pref) = N_Indexed_Component then
5617 Siz := Component_Size (Etype (Prefix (Pref)));
5619 -- For a record component, we can do Size in the front end if there
5620 -- is a component clause, or if the record is packed and the
5621 -- component's size is known at compile time.
5623 elsif Nkind (Pref) = N_Selected_Component then
5625 Rec : constant Entity_Id := Etype (Prefix (Pref));
5626 Comp : constant Entity_Id := Entity (Selector_Name (Pref));
5629 if Present (Component_Clause (Comp)) then
5630 Siz := Esize (Comp);
5632 elsif Is_Packed (Rec) then
5633 Siz := RM_Size (Ptyp);
5636 Apply_Universal_Integer_Attribute_Checks (N);
5641 -- All other cases are handled by the back end
5644 Apply_Universal_Integer_Attribute_Checks (N);
5646 -- If Size is applied to a formal parameter that is of a packed
5647 -- array subtype, then apply Size to the actual subtype.
5649 if Is_Entity_Name (Pref)
5650 and then Is_Formal (Entity (Pref))
5651 and then Is_Array_Type (Ptyp)
5652 and then Is_Packed (Ptyp)
5655 Make_Attribute_Reference (Loc,
5657 New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
5658 Attribute_Name => Name_Size));
5659 Analyze_And_Resolve (N, Typ);
5662 -- If Size applies to a dereference of an access to unconstrained
5663 -- packed array, the back end needs to see its unconstrained
5664 -- nominal type, but also a hint to the actual constrained type.
5666 if Nkind (Pref) = N_Explicit_Dereference
5667 and then Is_Array_Type (Ptyp)
5668 and then not Is_Constrained (Ptyp)
5669 and then Is_Packed (Ptyp)
5671 Set_Actual_Designated_Subtype (Pref,
5672 Get_Actual_Subtype (Pref));
5678 -- Common processing for record and array component case
5680 if Siz /= No_Uint and then Siz /= 0 then
5682 CS : constant Boolean := Comes_From_Source (N);
5685 Rewrite (N, Make_Integer_Literal (Loc, Siz));
5687 -- This integer literal is not a static expression. We do not
5688 -- call Analyze_And_Resolve here, because this would activate
5689 -- the circuit for deciding that a static value was out of
5690 -- range, and we don't want that.
5692 -- So just manually set the type, mark the expression as non-
5693 -- static, and then ensure that the result is checked properly
5694 -- if the attribute comes from source (if it was internally
5695 -- generated, we never need a constraint check).
5698 Set_Is_Static_Expression (N, False);
5701 Apply_Constraint_Check (N, Typ);
5711 when Attribute_Storage_Pool =>
5713 Make_Type_Conversion (Loc,
5714 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
5715 Expression => New_Occurrence_Of (Entity (N), Loc)));
5716 Analyze_And_Resolve (N, Typ);
5722 when Attribute_Storage_Size => Storage_Size : declare
5723 Alloc_Op : Entity_Id := Empty;
5727 -- Access type case, always go to the root type
5729 -- The case of access types results in a value of zero for the case
5730 -- where no storage size attribute clause has been given. If a
5731 -- storage size has been given, then the attribute is converted
5732 -- to a reference to the variable used to hold this value.
5734 if Is_Access_Type (Ptyp) then
5735 if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
5737 Make_Attribute_Reference (Loc,
5738 Prefix => New_Occurrence_Of (Typ, Loc),
5739 Attribute_Name => Name_Max,
5740 Expressions => New_List (
5741 Make_Integer_Literal (Loc, 0),
5744 (Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
5746 elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
5748 -- If the access type is associated with a simple storage pool
5749 -- object, then attempt to locate the optional Storage_Size
5750 -- function of the simple storage pool type. If not found,
5751 -- then the result will default to zero.
5753 if Present (Get_Rep_Pragma (Root_Type (Ptyp),
5754 Name_Simple_Storage_Pool_Type))
5757 Pool_Type : constant Entity_Id :=
5758 Base_Type (Etype (Entity (N)));
5761 Alloc_Op := Get_Name_Entity_Id (Name_Storage_Size);
5762 while Present (Alloc_Op) loop
5763 if Scope (Alloc_Op) = Scope (Pool_Type)
5764 and then Present (First_Formal (Alloc_Op))
5765 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
5770 Alloc_Op := Homonym (Alloc_Op);
5774 -- In the normal Storage_Pool case, retrieve the primitive
5775 -- function associated with the pool type.
5780 (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
5781 Attribute_Name (N));
5784 -- If Storage_Size wasn't found (can only occur in the simple
5785 -- storage pool case), then simply use zero for the result.
5787 if not Present (Alloc_Op) then
5788 Rewrite (N, Make_Integer_Literal (Loc, 0));
5790 -- Otherwise, rewrite the allocator as a call to pool type's
5791 -- Storage_Size function.
5796 Make_Function_Call (Loc,
5798 New_Occurrence_Of (Alloc_Op, Loc),
5800 Parameter_Associations => New_List (
5802 (Associated_Storage_Pool
5803 (Root_Type (Ptyp)), Loc)))));
5807 Rewrite (N, Make_Integer_Literal (Loc, 0));
5810 Analyze_And_Resolve (N, Typ);
5812 -- For tasks, we retrieve the size directly from the TCB. The
5813 -- size may depend on a discriminant of the type, and therefore
5814 -- can be a per-object expression, so type-level information is
5815 -- not sufficient in general. There are four cases to consider:
5817 -- a) If the attribute appears within a task body, the designated
5818 -- TCB is obtained by a call to Self.
5820 -- b) If the prefix of the attribute is the name of a task object,
5821 -- the designated TCB is the one stored in the corresponding record.
5823 -- c) If the prefix is a task type, the size is obtained from the
5824 -- size variable created for each task type
5826 -- d) If no storage_size was specified for the type , there is no
5827 -- size variable, and the value is a system-specific default.
5830 if In_Open_Scopes (Ptyp) then
5832 -- Storage_Size (Self)
5836 Make_Function_Call (Loc,
5838 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
5839 Parameter_Associations =>
5841 Make_Function_Call (Loc,
5843 New_Occurrence_Of (RTE (RE_Self), Loc))))));
5845 elsif not Is_Entity_Name (Pref)
5846 or else not Is_Type (Entity (Pref))
5848 -- Storage_Size (Rec (Obj).Size)
5852 Make_Function_Call (Loc,
5854 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
5855 Parameter_Associations =>
5857 Make_Selected_Component (Loc,
5859 Unchecked_Convert_To (
5860 Corresponding_Record_Type (Ptyp),
5861 New_Copy_Tree (Pref)),
5863 Make_Identifier (Loc, Name_uTask_Id))))));
5865 elsif Present (Storage_Size_Variable (Ptyp)) then
5867 -- Static storage size pragma given for type: retrieve value
5868 -- from its allocated storage variable.
5872 Make_Function_Call (Loc,
5873 Name => New_Occurrence_Of (
5874 RTE (RE_Adjust_Storage_Size), Loc),
5875 Parameter_Associations =>
5878 Storage_Size_Variable (Ptyp), Loc)))));
5880 -- Get system default
5884 Make_Function_Call (Loc,
5887 RTE (RE_Default_Stack_Size), Loc))));
5890 Analyze_And_Resolve (N, Typ);
5898 when Attribute_Stream_Size =>
5900 Make_Integer_Literal (Loc, Intval => Get_Stream_Size (Ptyp)));
5901 Analyze_And_Resolve (N, Typ);
5907 -- 1. Deal with enumeration types with holes.
5908 -- 2. For floating-point, generate call to attribute function.
5909 -- 3. For other cases, deal with constraint checking.
5911 when Attribute_Succ => Succ : declare
5912 Etyp : constant Entity_Id := Base_Type (Ptyp);
5916 -- For enumeration types with non-standard representations, we
5917 -- expand typ'Succ (x) into
5919 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
5921 -- If the representation is contiguous, we compute instead
5922 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
5924 if Is_Enumeration_Type (Ptyp)
5925 and then Present (Enum_Pos_To_Rep (Etyp))
5927 if Has_Contiguous_Rep (Etyp) then
5929 Unchecked_Convert_To (Ptyp,
5932 Make_Integer_Literal (Loc,
5933 Enumeration_Rep (First_Literal (Ptyp))),
5935 Make_Function_Call (Loc,
5938 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5940 Parameter_Associations =>
5942 Unchecked_Convert_To (Ptyp,
5945 Unchecked_Convert_To (Standard_Integer,
5946 Relocate_Node (First (Exprs))),
5948 Make_Integer_Literal (Loc, 1))),
5949 Rep_To_Pos_Flag (Ptyp, Loc))))));
5951 -- Add Boolean parameter True, to request program errror if
5952 -- we have a bad representation on our hands. Add False if
5953 -- checks are suppressed.
5955 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
5957 Make_Indexed_Component (Loc,
5960 (Enum_Pos_To_Rep (Etyp), Loc),
5961 Expressions => New_List (
5964 Make_Function_Call (Loc,
5967 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5968 Parameter_Associations => Exprs),
5969 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
5972 Analyze_And_Resolve (N, Typ);
5974 -- For floating-point, we transform 'Succ into a call to the Succ
5975 -- floating-point attribute function in Fat_xxx (xxx is root type)
5977 elsif Is_Floating_Point_Type (Ptyp) then
5978 Expand_Fpt_Attribute_R (N);
5979 Analyze_And_Resolve (N, Typ);
5981 -- For modular types, nothing to do (no overflow, since wraps)
5983 elsif Is_Modular_Integer_Type (Ptyp) then
5986 -- For other types, if argument is marked as needing a range check or
5987 -- overflow checking is enabled, we must generate a check.
5989 elsif not Overflow_Checks_Suppressed (Ptyp)
5990 or else Do_Range_Check (First (Exprs))
5992 Set_Do_Range_Check (First (Exprs), False);
5993 Expand_Pred_Succ_Attribute (N);
6001 -- Transforms X'Tag into a direct reference to the tag of X
6003 when Attribute_Tag => Tag : declare
6005 Prefix_Is_Type : Boolean;
6008 if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then
6009 Ttyp := Entity (Pref);
6010 Prefix_Is_Type := True;
6013 Prefix_Is_Type := False;
6016 if Is_Class_Wide_Type (Ttyp) then
6017 Ttyp := Root_Type (Ttyp);
6020 Ttyp := Underlying_Type (Ttyp);
6022 -- Ada 2005: The type may be a synchronized tagged type, in which
6023 -- case the tag information is stored in the corresponding record.
6025 if Is_Concurrent_Type (Ttyp) then
6026 Ttyp := Corresponding_Record_Type (Ttyp);
6029 if Prefix_Is_Type then
6031 -- For VMs we leave the type attribute unexpanded because
6032 -- there's not a dispatching table to reference.
6034 if Tagged_Type_Expansion then
6036 Unchecked_Convert_To (RTE (RE_Tag),
6038 (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc)));
6039 Analyze_And_Resolve (N, RTE (RE_Tag));
6042 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
6043 -- references the primary tag of the actual object. If 'Tag is
6044 -- applied to class-wide interface objects we generate code that
6045 -- displaces "this" to reference the base of the object.
6047 elsif Comes_From_Source (N)
6048 and then Is_Class_Wide_Type (Etype (Prefix (N)))
6049 and then Is_Interface (Etype (Prefix (N)))
6052 -- (To_Tag_Ptr (Prefix'Address)).all
6054 -- Note that Prefix'Address is recursively expanded into a call
6055 -- to Base_Address (Obj.Tag)
6057 -- Not needed for VM targets, since all handled by the VM
6059 if Tagged_Type_Expansion then
6061 Make_Explicit_Dereference (Loc,
6062 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6063 Make_Attribute_Reference (Loc,
6064 Prefix => Relocate_Node (Pref),
6065 Attribute_Name => Name_Address))));
6066 Analyze_And_Resolve (N, RTE (RE_Tag));
6071 Make_Selected_Component (Loc,
6072 Prefix => Relocate_Node (Pref),
6074 New_Occurrence_Of (First_Tag_Component (Ttyp), Loc)));
6075 Analyze_And_Resolve (N, RTE (RE_Tag));
6083 -- Transforms 'Terminated attribute into a call to Terminated function
6085 when Attribute_Terminated => Terminated :
6087 -- The prefix of Terminated is of a task interface class-wide type.
6089 -- terminated (Task_Id (Pref._disp_get_task_id));
6091 if Ada_Version >= Ada_2005
6092 and then Ekind (Ptyp) = E_Class_Wide_Type
6093 and then Is_Interface (Ptyp)
6094 and then Is_Task_Interface (Ptyp)
6097 Make_Function_Call (Loc,
6099 New_Occurrence_Of (RTE (RE_Terminated), Loc),
6100 Parameter_Associations => New_List (
6101 Make_Unchecked_Type_Conversion (Loc,
6103 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
6105 Make_Selected_Component (Loc,
6107 New_Copy_Tree (Pref),
6109 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
6111 elsif Restricted_Profile then
6113 Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
6117 Build_Call_With_Task (Pref, RTE (RE_Terminated)));
6120 Analyze_And_Resolve (N, Standard_Boolean);
6127 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
6128 -- unchecked conversion from (integral) type of X to type address.
6130 when Attribute_To_Address | Attribute_Ref =>
6132 Unchecked_Convert_To (RTE (RE_Address),
6133 Relocate_Node (First (Exprs))));
6134 Analyze_And_Resolve (N, RTE (RE_Address));
6140 when Attribute_To_Any => To_Any : declare
6141 P_Type : constant Entity_Id := Etype (Pref);
6142 Decls : constant List_Id := New_List;
6148 Relocate_Node (First (Exprs))), Decls));
6149 Insert_Actions (N, Decls);
6150 Analyze_And_Resolve (N, RTE (RE_Any));
6157 -- Transforms 'Truncation into a call to the floating-point attribute
6158 -- function Truncation in Fat_xxx (where xxx is the root type).
6159 -- Expansion is avoided for cases the back end can handle directly.
6161 when Attribute_Truncation =>
6162 if not Is_Inline_Floating_Point_Attribute (N) then
6163 Expand_Fpt_Attribute_R (N);
6170 when Attribute_TypeCode => TypeCode : declare
6171 P_Type : constant Entity_Id := Etype (Pref);
6172 Decls : constant List_Id := New_List;
6174 Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls));
6175 Insert_Actions (N, Decls);
6176 Analyze_And_Resolve (N, RTE (RE_TypeCode));
6179 -----------------------
6180 -- Unbiased_Rounding --
6181 -----------------------
6183 -- Transforms 'Unbiased_Rounding into a call to the floating-point
6184 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
6185 -- root type). Expansion is avoided for cases the back end can handle
6188 when Attribute_Unbiased_Rounding =>
6189 if not Is_Inline_Floating_Point_Attribute (N) then
6190 Expand_Fpt_Attribute_R (N);
6197 when Attribute_UET_Address => UET_Address : declare
6198 Ent : constant Entity_Id := Make_Temporary (Loc, 'T');
6202 Make_Object_Declaration (Loc,
6203 Defining_Identifier => Ent,
6204 Aliased_Present => True,
6205 Object_Definition =>
6206 New_Occurrence_Of (RTE (RE_Address), Loc)));
6208 -- Construct name __gnat_xxx__SDP, where xxx is the unit name
6209 -- in normal external form.
6211 Get_External_Unit_Name_String (Get_Unit_Name (Pref));
6212 Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
6213 Name_Len := Name_Len + 7;
6214 Name_Buffer (1 .. 7) := "__gnat_";
6215 Name_Buffer (Name_Len + 1 .. Name_Len + 5) := "__SDP";
6216 Name_Len := Name_Len + 5;
6218 Set_Is_Imported (Ent);
6219 Set_Interface_Name (Ent,
6220 Make_String_Literal (Loc,
6221 Strval => String_From_Name_Buffer));
6223 -- Set entity as internal to ensure proper Sprint output of its
6224 -- implicit importation.
6226 Set_Is_Internal (Ent);
6229 Make_Attribute_Reference (Loc,
6230 Prefix => New_Occurrence_Of (Ent, Loc),
6231 Attribute_Name => Name_Address));
6233 Analyze_And_Resolve (N, Typ);
6240 when Attribute_Update =>
6241 Expand_Update_Attribute (N);
6247 -- The processing for VADS_Size is shared with Size
6253 -- For enumeration types with a standard representation, and for all
6254 -- other types, Val is handled by the back end. For enumeration types
6255 -- with a non-standard representation we use the _Pos_To_Rep array that
6256 -- was created when the type was frozen.
6258 when Attribute_Val => Val : declare
6259 Etyp : constant Entity_Id := Base_Type (Entity (Pref));
6262 if Is_Enumeration_Type (Etyp)
6263 and then Present (Enum_Pos_To_Rep (Etyp))
6265 if Has_Contiguous_Rep (Etyp) then
6267 Rep_Node : constant Node_Id :=
6268 Unchecked_Convert_To (Etyp,
6271 Make_Integer_Literal (Loc,
6272 Enumeration_Rep (First_Literal (Etyp))),
6274 (Convert_To (Standard_Integer,
6275 Relocate_Node (First (Exprs))))));
6279 Unchecked_Convert_To (Etyp,
6282 Make_Integer_Literal (Loc,
6283 Enumeration_Rep (First_Literal (Etyp))),
6285 Make_Function_Call (Loc,
6288 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
6289 Parameter_Associations => New_List (
6291 Rep_To_Pos_Flag (Etyp, Loc))))));
6296 Make_Indexed_Component (Loc,
6297 Prefix => New_Occurrence_Of (Enum_Pos_To_Rep (Etyp), Loc),
6298 Expressions => New_List (
6299 Convert_To (Standard_Integer,
6300 Relocate_Node (First (Exprs))))));
6303 Analyze_And_Resolve (N, Typ);
6305 -- If the argument is marked as requiring a range check then generate
6308 elsif Do_Range_Check (First (Exprs)) then
6309 Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
6317 -- The code for valid is dependent on the particular types involved.
6318 -- See separate sections below for the generated code in each case.
6320 when Attribute_Valid => Valid : declare
6321 Btyp : Entity_Id := Base_Type (Ptyp);
6324 Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
6325 -- Save the validity checking mode. We always turn off validity
6326 -- checking during process of 'Valid since this is one place
6327 -- where we do not want the implicit validity checks to intefere
6328 -- with the explicit validity check that the programmer is doing.
6330 function Make_Range_Test return Node_Id;
6331 -- Build the code for a range test of the form
6332 -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
6334 ---------------------
6335 -- Make_Range_Test --
6336 ---------------------
6338 function Make_Range_Test return Node_Id is
6339 Temp : constant Node_Id := Duplicate_Subexpr (Pref);
6342 -- The value whose validity is being checked has been captured in
6343 -- an object declaration. We certainly don't want this object to
6344 -- appear valid because the declaration initializes it.
6346 if Is_Entity_Name (Temp) then
6347 Set_Is_Known_Valid (Entity (Temp), False);
6353 Unchecked_Convert_To (Btyp, Temp),
6357 Unchecked_Convert_To (Btyp,
6358 Make_Attribute_Reference (Loc,
6359 Prefix => New_Occurrence_Of (Ptyp, Loc),
6360 Attribute_Name => Name_First)),
6362 Unchecked_Convert_To (Btyp,
6363 Make_Attribute_Reference (Loc,
6364 Prefix => New_Occurrence_Of (Ptyp, Loc),
6365 Attribute_Name => Name_Last))));
6366 end Make_Range_Test;
6368 -- Start of processing for Attribute_Valid
6371 -- Do not expand sourced code 'Valid reference in CodePeer mode,
6372 -- will be handled by the back-end directly.
6374 if CodePeer_Mode and then Comes_From_Source (N) then
6378 -- Turn off validity checks. We do not want any implicit validity
6379 -- checks to intefere with the explicit check from the attribute
6381 Validity_Checks_On := False;
6383 -- Retrieve the base type. Handle the case where the base type is a
6384 -- private enumeration type.
6386 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
6387 Btyp := Full_View (Btyp);
6390 -- Floating-point case. This case is handled by the Valid attribute
6391 -- code in the floating-point attribute run-time library.
6393 if Is_Floating_Point_Type (Ptyp) then
6394 Float_Valid : declare
6398 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id;
6399 -- Return entity for Pkg.Nam
6401 --------------------
6402 -- Get_Fat_Entity --
6403 --------------------
6405 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id is
6406 Exp_Name : constant Node_Id :=
6407 Make_Selected_Component (Loc,
6408 Prefix => New_Occurrence_Of (RTE (Pkg), Loc),
6409 Selector_Name => Make_Identifier (Loc, Nam));
6411 Find_Selected_Component (Exp_Name);
6412 return Entity (Exp_Name);
6415 -- Start of processing for Float_Valid
6418 case Float_Rep (Btyp) is
6420 -- The AAMP back end handles Valid for floating-point types
6423 Analyze_And_Resolve (Pref, Ptyp);
6424 Set_Etype (N, Standard_Boolean);
6428 Find_Fat_Info (Ptyp, Ftp, Pkg);
6430 -- If the prefix is a reverse SSO component, or is
6431 -- possibly unaligned, first create a temporary copy
6432 -- that is in native SSO, and properly aligned. Make it
6433 -- Volatile to prevent folding in the back-end. Note
6434 -- that we use an intermediate constrained string type
6435 -- to initialize the temporary, as the value at hand
6436 -- might be invalid, and in that case it cannot be copied
6437 -- using a floating point register.
6439 if In_Reverse_Storage_Order_Object (Pref)
6441 Is_Possibly_Unaligned_Object (Pref)
6444 Temp : constant Entity_Id :=
6445 Make_Temporary (Loc, 'F');
6447 Fat_S : constant Entity_Id :=
6448 Get_Fat_Entity (Name_S);
6449 -- Constrained string subtype of appropriate size
6451 Fat_P : constant Entity_Id :=
6452 Get_Fat_Entity (Name_P);
6455 Decl : constant Node_Id :=
6456 Make_Object_Declaration (Loc,
6457 Defining_Identifier => Temp,
6458 Aliased_Present => True,
6459 Object_Definition =>
6460 New_Occurrence_Of (Ptyp, Loc));
6463 Set_Aspect_Specifications (Decl, New_List (
6464 Make_Aspect_Specification (Loc,
6466 Make_Identifier (Loc, Name_Volatile))));
6472 Make_Assignment_Statement (Loc,
6474 Make_Explicit_Dereference (Loc,
6476 Unchecked_Convert_To (Fat_P,
6477 Make_Attribute_Reference (Loc,
6479 New_Occurrence_Of (Temp, Loc),
6481 Name_Unrestricted_Access))),
6483 Unchecked_Convert_To (Fat_S,
6484 Relocate_Node (Pref)))),
6486 Suppress => All_Checks);
6488 Rewrite (Pref, New_Occurrence_Of (Temp, Loc));
6492 -- We now have an object of the proper endianness and
6493 -- alignment, and can construct a Valid attribute.
6495 -- We make sure the prefix of this valid attribute is
6496 -- marked as not coming from source, to avoid losing
6497 -- warnings from 'Valid looking like a possible update.
6499 Set_Comes_From_Source (Pref, False);
6501 Expand_Fpt_Attribute
6502 (N, Pkg, Name_Valid,
6504 Make_Attribute_Reference (Loc,
6505 Prefix => Unchecked_Convert_To (Ftp, Pref),
6506 Attribute_Name => Name_Unrestricted_Access)));
6509 -- One more task, we still need a range check. Required
6510 -- only if we have a constraint, since the Valid routine
6511 -- catches infinities properly (infinities are never valid).
6513 -- The way we do the range check is simply to create the
6514 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
6516 if not Subtypes_Statically_Match (Ptyp, Btyp) then
6519 Left_Opnd => Relocate_Node (N),
6522 Left_Opnd => Convert_To (Btyp, Pref),
6523 Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
6527 -- Enumeration type with holes
6529 -- For enumeration types with holes, the Pos value constructed by
6530 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
6531 -- second argument of False returns minus one for an invalid value,
6532 -- and the non-negative pos value for a valid value, so the
6533 -- expansion of X'Valid is simply:
6535 -- type(X)'Pos (X) >= 0
6537 -- We can't quite generate it that way because of the requirement
6538 -- for the non-standard second argument of False in the resulting
6539 -- rep_to_pos call, so we have to explicitly create:
6541 -- _rep_to_pos (X, False) >= 0
6543 -- If we have an enumeration subtype, we also check that the
6544 -- value is in range:
6546 -- _rep_to_pos (X, False) >= 0
6548 -- (X >= type(X)'First and then type(X)'Last <= X)
6550 elsif Is_Enumeration_Type (Ptyp)
6551 and then Present (Enum_Pos_To_Rep (Btyp))
6556 Make_Function_Call (Loc,
6558 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
6559 Parameter_Associations => New_List (
6561 New_Occurrence_Of (Standard_False, Loc))),
6562 Right_Opnd => Make_Integer_Literal (Loc, 0));
6566 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
6568 Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
6570 -- The call to Make_Range_Test will create declarations
6571 -- that need a proper insertion point, but Pref is now
6572 -- attached to a node with no ancestor. Attach to tree
6573 -- even if it is to be rewritten below.
6575 Set_Parent (Tst, Parent (N));
6579 Left_Opnd => Make_Range_Test,
6585 -- Fortran convention booleans
6587 -- For the very special case of Fortran convention booleans, the
6588 -- value is always valid, since it is an integer with the semantics
6589 -- that non-zero is true, and any value is permissible.
6591 elsif Is_Boolean_Type (Ptyp)
6592 and then Convention (Ptyp) = Convention_Fortran
6594 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6596 -- For biased representations, we will be doing an unchecked
6597 -- conversion without unbiasing the result. That means that the range
6598 -- test has to take this into account, and the proper form of the
6601 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
6603 elsif Has_Biased_Representation (Ptyp) then
6604 Btyp := RTE (RE_Unsigned_32);
6608 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
6610 Unchecked_Convert_To (Btyp,
6611 Make_Attribute_Reference (Loc,
6612 Prefix => New_Occurrence_Of (Ptyp, Loc),
6613 Attribute_Name => Name_Range_Length))));
6615 -- For all other scalar types, what we want logically is a
6618 -- X in type(X)'First .. type(X)'Last
6620 -- But that's precisely what won't work because of possible
6621 -- unwanted optimization (and indeed the basic motivation for
6622 -- the Valid attribute is exactly that this test does not work).
6623 -- What will work is:
6625 -- Btyp!(X) >= Btyp!(type(X)'First)
6627 -- Btyp!(X) <= Btyp!(type(X)'Last)
6629 -- where Btyp is an integer type large enough to cover the full
6630 -- range of possible stored values (i.e. it is chosen on the basis
6631 -- of the size of the type, not the range of the values). We write
6632 -- this as two tests, rather than a range check, so that static
6633 -- evaluation will easily remove either or both of the checks if
6634 -- they can be -statically determined to be true (this happens
6635 -- when the type of X is static and the range extends to the full
6636 -- range of stored values).
6638 -- Unsigned types. Note: it is safe to consider only whether the
6639 -- subtype is unsigned, since we will in that case be doing all
6640 -- unsigned comparisons based on the subtype range. Since we use the
6641 -- actual subtype object size, this is appropriate.
6643 -- For example, if we have
6645 -- subtype x is integer range 1 .. 200;
6646 -- for x'Object_Size use 8;
6648 -- Now the base type is signed, but objects of this type are bits
6649 -- unsigned, and doing an unsigned test of the range 1 to 200 is
6650 -- correct, even though a value greater than 127 looks signed to a
6651 -- signed comparison.
6653 elsif Is_Unsigned_Type (Ptyp) then
6654 if Esize (Ptyp) <= 32 then
6655 Btyp := RTE (RE_Unsigned_32);
6657 Btyp := RTE (RE_Unsigned_64);
6660 Rewrite (N, Make_Range_Test);
6665 if Esize (Ptyp) <= Esize (Standard_Integer) then
6666 Btyp := Standard_Integer;
6668 Btyp := Universal_Integer;
6671 Rewrite (N, Make_Range_Test);
6674 -- If a predicate is present, then we do the predicate test, even if
6675 -- within the predicate function (infinite recursion is warned about
6676 -- in Sem_Attr in that case).
6679 Pred_Func : constant Entity_Id := Predicate_Function (Ptyp);
6682 if Present (Pred_Func) then
6685 Left_Opnd => Relocate_Node (N),
6686 Right_Opnd => Make_Predicate_Call (Ptyp, Pref)));
6690 Analyze_And_Resolve (N, Standard_Boolean);
6691 Validity_Checks_On := Save_Validity_Checks_On;
6698 when Attribute_Valid_Scalars => Valid_Scalars : declare
6702 if Present (Underlying_Type (Ptyp)) then
6703 Ftyp := Underlying_Type (Ptyp);
6708 -- Replace by True if no scalar parts
6710 if not Scalar_Part_Present (Ftyp) then
6711 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6713 -- For scalar types, Valid_Scalars is the same as Valid
6715 elsif Is_Scalar_Type (Ftyp) then
6717 Make_Attribute_Reference (Loc,
6718 Attribute_Name => Name_Valid,
6721 -- For array types, we construct a function that determines if there
6722 -- are any non-valid scalar subcomponents, and call the function.
6723 -- We only do this for arrays whose component type needs checking
6725 elsif Is_Array_Type (Ftyp)
6726 and then Scalar_Part_Present (Component_Type (Ftyp))
6729 Make_Function_Call (Loc,
6731 New_Occurrence_Of (Build_Array_VS_Func (Ftyp, N), Loc),
6732 Parameter_Associations => New_List (Pref)));
6734 -- For record types, we construct a function that determines if there
6735 -- are any non-valid scalar subcomponents, and call the function.
6737 elsif Is_Record_Type (Ftyp)
6738 and then Nkind (Type_Definition (Declaration_Node (Ftyp))) =
6742 Make_Function_Call (Loc,
6744 New_Occurrence_Of (Build_Record_VS_Func (Ftyp, N), Loc),
6745 Parameter_Associations => New_List (Pref)));
6747 -- Other record types or types with discriminants
6749 elsif Is_Record_Type (Ftyp) or else Has_Discriminants (Ptyp) then
6751 -- Build expression with list of equality tests
6759 X := New_Occurrence_Of (Standard_True, Loc);
6760 C := First_Component_Or_Discriminant (Ptyp);
6761 while Present (C) loop
6762 if not Scalar_Part_Present (Etype (C)) then
6764 elsif Is_Scalar_Type (Etype (C)) then
6767 A := Name_Valid_Scalars;
6774 Make_Attribute_Reference (Loc,
6775 Attribute_Name => A,
6777 Make_Selected_Component (Loc,
6779 Duplicate_Subexpr (Pref, Name_Req => True),
6781 New_Occurrence_Of (C, Loc))));
6783 Next_Component_Or_Discriminant (C);
6789 -- For all other types, result is True
6792 Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc));
6795 -- Result is always boolean, but never static
6797 Analyze_And_Resolve (N, Standard_Boolean);
6798 Set_Is_Static_Expression (N, False);
6805 -- Value attribute is handled in separate unit Exp_Imgv
6807 when Attribute_Value =>
6808 Exp_Imgv.Expand_Value_Attribute (N);
6814 -- The processing for Value_Size shares the processing for Size
6820 -- The processing for Version shares the processing for Body_Version
6826 -- Wide_Image attribute is handled in separate unit Exp_Imgv
6828 when Attribute_Wide_Image =>
6829 Exp_Imgv.Expand_Wide_Image_Attribute (N);
6831 ---------------------
6832 -- Wide_Wide_Image --
6833 ---------------------
6835 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
6837 when Attribute_Wide_Wide_Image =>
6838 Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N);
6844 -- We expand typ'Wide_Value (X) into
6847 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
6849 -- Wide_String_To_String is a runtime function that converts its wide
6850 -- string argument to String, converting any non-translatable characters
6851 -- into appropriate escape sequences. This preserves the required
6852 -- semantics of Wide_Value in all cases, and results in a very simple
6853 -- implementation approach.
6855 -- Note: for this approach to be fully standard compliant for the cases
6856 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
6857 -- method must cover the entire character range (e.g. UTF-8). But that
6858 -- is a reasonable requirement when dealing with encoded character
6859 -- sequences. Presumably if one of the restrictive encoding mechanisms
6860 -- is in use such as Shift-JIS, then characters that cannot be
6861 -- represented using this encoding will not appear in any case.
6863 when Attribute_Wide_Value => Wide_Value :
6866 Make_Attribute_Reference (Loc,
6868 Attribute_Name => Name_Value,
6870 Expressions => New_List (
6871 Make_Function_Call (Loc,
6873 New_Occurrence_Of (RTE (RE_Wide_String_To_String), Loc),
6875 Parameter_Associations => New_List (
6876 Relocate_Node (First (Exprs)),
6877 Make_Integer_Literal (Loc,
6878 Intval => Int (Wide_Character_Encoding_Method)))))));
6880 Analyze_And_Resolve (N, Typ);
6883 ---------------------
6884 -- Wide_Wide_Value --
6885 ---------------------
6887 -- We expand typ'Wide_Value_Value (X) into
6890 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
6892 -- Wide_Wide_String_To_String is a runtime function that converts its
6893 -- wide string argument to String, converting any non-translatable
6894 -- characters into appropriate escape sequences. This preserves the
6895 -- required semantics of Wide_Wide_Value in all cases, and results in a
6896 -- very simple implementation approach.
6898 -- It's not quite right where typ = Wide_Wide_Character, because the
6899 -- encoding method may not cover the whole character type ???
6901 when Attribute_Wide_Wide_Value => Wide_Wide_Value :
6904 Make_Attribute_Reference (Loc,
6906 Attribute_Name => Name_Value,
6908 Expressions => New_List (
6909 Make_Function_Call (Loc,
6912 (RTE (RE_Wide_Wide_String_To_String), Loc),
6914 Parameter_Associations => New_List (
6915 Relocate_Node (First (Exprs)),
6916 Make_Integer_Literal (Loc,
6917 Intval => Int (Wide_Character_Encoding_Method)))))));
6919 Analyze_And_Resolve (N, Typ);
6920 end Wide_Wide_Value;
6922 ---------------------
6923 -- Wide_Wide_Width --
6924 ---------------------
6926 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
6928 when Attribute_Wide_Wide_Width =>
6929 Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide);
6935 -- Wide_Width attribute is handled in separate unit Exp_Imgv
6937 when Attribute_Wide_Width =>
6938 Exp_Imgv.Expand_Width_Attribute (N, Wide);
6944 -- Width attribute is handled in separate unit Exp_Imgv
6946 when Attribute_Width =>
6947 Exp_Imgv.Expand_Width_Attribute (N, Normal);
6953 when Attribute_Write => Write : declare
6954 P_Type : constant Entity_Id := Entity (Pref);
6955 U_Type : constant Entity_Id := Underlying_Type (P_Type);
6963 -- If no underlying type, we have an error that will be diagnosed
6964 -- elsewhere, so here we just completely ignore the expansion.
6970 -- Stream operations can appear in user code even if the restriction
6971 -- No_Streams is active (for example, when instantiating a predefined
6972 -- container). In that case rewrite the attribute as a Raise to
6973 -- prevent any run-time use.
6975 if Restriction_Active (No_Streams) then
6977 Make_Raise_Program_Error (Sloc (N),
6978 Reason => PE_Stream_Operation_Not_Allowed));
6979 Set_Etype (N, U_Type);
6983 -- The simple case, if there is a TSS for Write, just call it
6985 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
6987 if Present (Pname) then
6991 -- If there is a Stream_Convert pragma, use it, we rewrite
6993 -- sourcetyp'Output (stream, Item)
6997 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
6999 -- where strmwrite is the given Write function that converts an
7000 -- argument of type sourcetyp or a type acctyp, from which it is
7001 -- derived to type strmtyp. The conversion to acttyp is required
7002 -- for the derived case.
7004 Prag := Get_Stream_Convert_Pragma (P_Type);
7006 if Present (Prag) then
7008 Next (Next (First (Pragma_Argument_Associations (Prag))));
7009 Wfunc := Entity (Expression (Arg3));
7012 Make_Attribute_Reference (Loc,
7013 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
7014 Attribute_Name => Name_Output,
7015 Expressions => New_List (
7016 Relocate_Node (First (Exprs)),
7017 Make_Function_Call (Loc,
7018 Name => New_Occurrence_Of (Wfunc, Loc),
7019 Parameter_Associations => New_List (
7020 OK_Convert_To (Etype (First_Formal (Wfunc)),
7021 Relocate_Node (Next (First (Exprs)))))))));
7026 -- For elementary types, we call the W_xxx routine directly
7028 elsif Is_Elementary_Type (U_Type) then
7029 Rewrite (N, Build_Elementary_Write_Call (N));
7035 elsif Is_Array_Type (U_Type) then
7036 Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
7037 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
7039 -- Tagged type case, use the primitive Write function. Note that
7040 -- this will dispatch in the class-wide case which is what we want
7042 elsif Is_Tagged_Type (U_Type) then
7043 Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
7045 -- All other record type cases, including protected records.
7046 -- The latter only arise for expander generated code for
7047 -- handling shared passive partition access.
7051 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
7053 -- Ada 2005 (AI-216): Program_Error is raised when executing
7054 -- the default implementation of the Write attribute of an
7055 -- Unchecked_Union type. However, if the 'Write reference is
7056 -- within the generated Output stream procedure, Write outputs
7057 -- the components, and the default values of the discriminant
7058 -- are streamed by the Output procedure itself.
7060 if Is_Unchecked_Union (Base_Type (U_Type))
7061 and not Is_TSS (Current_Scope, TSS_Stream_Output)
7064 Make_Raise_Program_Error (Loc,
7065 Reason => PE_Unchecked_Union_Restriction));
7068 if Has_Discriminants (U_Type)
7070 (Discriminant_Default_Value (First_Discriminant (U_Type)))
7072 Build_Mutable_Record_Write_Procedure
7073 (Loc, Full_Base (U_Type), Decl, Pname);
7075 Build_Record_Write_Procedure
7076 (Loc, Full_Base (U_Type), Decl, Pname);
7079 Insert_Action (N, Decl);
7083 -- If we fall through, Pname is the procedure to be called
7085 Rewrite_Stream_Proc_Call (Pname);
7088 -- Component_Size is handled by the back end, unless the component size
7089 -- is known at compile time, which is always true in the packed array
7090 -- case. It is important that the packed array case is handled in the
7091 -- front end (see Eval_Attribute) since the back end would otherwise get
7092 -- confused by the equivalent packed array type.
7094 when Attribute_Component_Size =>
7097 -- The following attributes are handled by the back end (except that
7098 -- static cases have already been evaluated during semantic processing,
7099 -- but in any case the back end should not count on this).
7101 -- The back end also handles the non-class-wide cases of Size
7103 when Attribute_Bit_Order |
7104 Attribute_Code_Address |
7105 Attribute_Definite |
7107 Attribute_Null_Parameter |
7108 Attribute_Passed_By_Reference |
7109 Attribute_Pool_Address |
7110 Attribute_Scalar_Storage_Order =>
7113 -- The following attributes are also handled by the back end, but return
7114 -- a universal integer result, so may need a conversion for checking
7115 -- that the result is in range.
7117 when Attribute_Aft |
7118 Attribute_Max_Alignment_For_Allocation =>
7119 Apply_Universal_Integer_Attribute_Checks (N);
7121 -- The following attributes should not appear at this stage, since they
7122 -- have already been handled by the analyzer (and properly rewritten
7123 -- with corresponding values or entities to represent the right values)
7125 when Attribute_Abort_Signal |
7126 Attribute_Address_Size |
7127 Attribute_Atomic_Always_Lock_Free |
7130 Attribute_Compiler_Version |
7131 Attribute_Default_Bit_Order |
7132 Attribute_Default_Scalar_Storage_Order |
7139 Attribute_Fast_Math |
7140 Attribute_First_Valid |
7141 Attribute_Has_Access_Values |
7142 Attribute_Has_Discriminants |
7143 Attribute_Has_Tagged_Values |
7145 Attribute_Last_Valid |
7146 Attribute_Library_Level |
7147 Attribute_Lock_Free |
7148 Attribute_Machine_Emax |
7149 Attribute_Machine_Emin |
7150 Attribute_Machine_Mantissa |
7151 Attribute_Machine_Overflows |
7152 Attribute_Machine_Radix |
7153 Attribute_Machine_Rounds |
7154 Attribute_Maximum_Alignment |
7155 Attribute_Model_Emin |
7156 Attribute_Model_Epsilon |
7157 Attribute_Model_Mantissa |
7158 Attribute_Model_Small |
7160 Attribute_Partition_ID |
7162 Attribute_Restriction_Set |
7163 Attribute_Safe_Emax |
7164 Attribute_Safe_First |
7165 Attribute_Safe_Large |
7166 Attribute_Safe_Last |
7167 Attribute_Safe_Small |
7169 Attribute_Signed_Zeros |
7171 Attribute_Storage_Unit |
7172 Attribute_Stub_Type |
7173 Attribute_System_Allocator_Alignment |
7174 Attribute_Target_Name |
7175 Attribute_Type_Class |
7176 Attribute_Type_Key |
7177 Attribute_Unconstrained_Array |
7178 Attribute_Universal_Literal_String |
7179 Attribute_Wchar_T_Size |
7180 Attribute_Word_Size =>
7181 raise Program_Error;
7183 -- The Asm_Input and Asm_Output attributes are not expanded at this
7184 -- stage, but will be eliminated in the expansion of the Asm call, see
7185 -- Exp_Intr for details. So the back end will never see these either.
7187 when Attribute_Asm_Input |
7188 Attribute_Asm_Output =>
7192 -- Note: as mentioned earlier, individual sections of the above case
7193 -- statement assume there is no code after the case statement, and are
7194 -- legitimately allowed to execute return statements if they have nothing
7195 -- more to do, so DO NOT add code at this point.
7198 when RE_Not_Available =>
7200 end Expand_N_Attribute_Reference;
7202 --------------------------------
7203 -- Expand_Pred_Succ_Attribute --
7204 --------------------------------
7206 -- For typ'Pred (exp), we generate the check
7208 -- [constraint_error when exp = typ'Base'First]
7210 -- Similarly, for typ'Succ (exp), we generate the check
7212 -- [constraint_error when exp = typ'Base'Last]
7214 -- These checks are not generated for modular types, since the proper
7215 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
7216 -- We also suppress these checks if we are the right side of an assignment
7217 -- statement or the expression of an object declaration, where the flag
7218 -- Suppress_Assignment_Checks is set for the assignment/declaration.
7220 procedure Expand_Pred_Succ_Attribute (N : Node_Id) is
7221 Loc : constant Source_Ptr := Sloc (N);
7222 P : constant Node_Id := Parent (N);
7226 if Attribute_Name (N) = Name_Pred then
7232 if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration)
7233 or else not Suppress_Assignment_Checks (P)
7236 Make_Raise_Constraint_Error (Loc,
7240 Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
7242 Make_Attribute_Reference (Loc,
7244 New_Occurrence_Of (Base_Type (Etype (Prefix (N))), Loc),
7245 Attribute_Name => Cnam)),
7246 Reason => CE_Overflow_Check_Failed));
7248 end Expand_Pred_Succ_Attribute;
7250 -----------------------------
7251 -- Expand_Update_Attribute --
7252 -----------------------------
7254 procedure Expand_Update_Attribute (N : Node_Id) is
7255 procedure Process_Component_Or_Element_Update
7260 -- Generate the statements necessary to update a single component or an
7261 -- element of the prefix. The code is inserted before the attribute N.
7262 -- Temp denotes the entity of the anonymous object created to reflect
7263 -- the changes in values. Comp is the component/index expression to be
7264 -- updated. Expr is an expression yielding the new value of Comp. Typ
7265 -- is the type of the prefix of attribute Update.
7267 procedure Process_Range_Update
7272 -- Generate the statements necessary to update a slice of the prefix.
7273 -- The code is inserted before the attribute N. Temp denotes the entity
7274 -- of the anonymous object created to reflect the changes in values.
7275 -- Comp is range of the slice to be updated. Expr is an expression
7276 -- yielding the new value of Comp. Typ is the type of the prefix of
7277 -- attribute Update.
7279 -----------------------------------------
7280 -- Process_Component_Or_Element_Update --
7281 -----------------------------------------
7283 procedure Process_Component_Or_Element_Update
7289 Loc : constant Source_Ptr := Sloc (Comp);
7294 -- An array element may be modified by the following relations
7295 -- depending on the number of dimensions:
7297 -- 1 => Expr -- one dimensional update
7298 -- (1, ..., N) => Expr -- multi dimensional update
7300 -- The above forms are converted in assignment statements where the
7301 -- left hand side is an indexed component:
7303 -- Temp (1) := Expr; -- one dimensional update
7304 -- Temp (1, ..., N) := Expr; -- multi dimensional update
7306 if Is_Array_Type (Typ) then
7308 -- The index expressions of a multi dimensional array update
7309 -- appear as an aggregate.
7311 if Nkind (Comp) = N_Aggregate then
7312 Exprs := New_Copy_List_Tree (Expressions (Comp));
7314 Exprs := New_List (Relocate_Node (Comp));
7318 Make_Indexed_Component (Loc,
7319 Prefix => New_Occurrence_Of (Temp, Loc),
7320 Expressions => Exprs);
7322 -- A record component update appears in the following form:
7326 -- The above relation is transformed into an assignment statement
7327 -- where the left hand side is a selected component:
7329 -- Temp.Comp := Expr;
7331 else pragma Assert (Is_Record_Type (Typ));
7333 Make_Selected_Component (Loc,
7334 Prefix => New_Occurrence_Of (Temp, Loc),
7335 Selector_Name => Relocate_Node (Comp));
7339 Make_Assignment_Statement (Loc,
7341 Expression => Relocate_Node (Expr)));
7342 end Process_Component_Or_Element_Update;
7344 --------------------------
7345 -- Process_Range_Update --
7346 --------------------------
7348 procedure Process_Range_Update
7354 Index_Typ : constant Entity_Id := Etype (First_Index (Typ));
7355 Loc : constant Source_Ptr := Sloc (Comp);
7359 -- A range update appears as
7361 -- (Low .. High => Expr)
7363 -- The above construct is transformed into a loop that iterates over
7364 -- the given range and modifies the corresponding array values to the
7367 -- for Index in Low .. High loop
7368 -- Temp (<Index_Typ> (Index)) := Expr;
7371 Index := Make_Temporary (Loc, 'I');
7374 Make_Loop_Statement (Loc,
7376 Make_Iteration_Scheme (Loc,
7377 Loop_Parameter_Specification =>
7378 Make_Loop_Parameter_Specification (Loc,
7379 Defining_Identifier => Index,
7380 Discrete_Subtype_Definition => Relocate_Node (Comp))),
7382 Statements => New_List (
7383 Make_Assignment_Statement (Loc,
7385 Make_Indexed_Component (Loc,
7386 Prefix => New_Occurrence_Of (Temp, Loc),
7387 Expressions => New_List (
7388 Convert_To (Index_Typ,
7389 New_Occurrence_Of (Index, Loc)))),
7390 Expression => Relocate_Node (Expr))),
7392 End_Label => Empty));
7393 end Process_Range_Update;
7397 Aggr : constant Node_Id := First (Expressions (N));
7398 Loc : constant Source_Ptr := Sloc (N);
7399 Pref : constant Node_Id := Prefix (N);
7400 Typ : constant Entity_Id := Etype (Pref);
7403 CW_Temp : Entity_Id;
7408 -- Start of processing for Expand_Update_Attribute
7411 -- Create the anonymous object to store the value of the prefix and
7412 -- capture subsequent changes in value.
7414 Temp := Make_Temporary (Loc, 'T', Pref);
7416 -- Preserve the tag of the prefix by offering a specific view of the
7417 -- class-wide version of the prefix.
7419 if Is_Tagged_Type (Typ) then
7422 -- CW_Temp : Typ'Class := Typ'Class (Pref);
7424 CW_Temp := Make_Temporary (Loc, 'T');
7425 CW_Typ := Class_Wide_Type (Typ);
7428 Make_Object_Declaration (Loc,
7429 Defining_Identifier => CW_Temp,
7430 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
7432 Convert_To (CW_Typ, Relocate_Node (Pref))));
7435 -- Temp : Typ renames Typ (CW_Temp);
7438 Make_Object_Renaming_Declaration (Loc,
7439 Defining_Identifier => Temp,
7440 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
7442 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))));
7448 -- Temp : Typ := Pref;
7451 Make_Object_Declaration (Loc,
7452 Defining_Identifier => Temp,
7453 Object_Definition => New_Occurrence_Of (Typ, Loc),
7454 Expression => Relocate_Node (Pref)));
7457 -- Process the update aggregate
7459 Assoc := First (Component_Associations (Aggr));
7460 while Present (Assoc) loop
7461 Comp := First (Choices (Assoc));
7462 Expr := Expression (Assoc);
7463 while Present (Comp) loop
7464 if Nkind (Comp) = N_Range then
7465 Process_Range_Update (Temp, Comp, Expr, Typ);
7467 Process_Component_Or_Element_Update (Temp, Comp, Expr, Typ);
7476 -- The attribute is replaced by a reference to the anonymous object
7478 Rewrite (N, New_Occurrence_Of (Temp, Loc));
7480 end Expand_Update_Attribute;
7486 procedure Find_Fat_Info
7488 Fat_Type : out Entity_Id;
7489 Fat_Pkg : out RE_Id)
7491 Rtyp : constant Entity_Id := Root_Type (T);
7494 -- All we do is use the root type (historically this dealt with
7495 -- VAX-float .. to be cleaned up further later ???)
7499 if Fat_Type = Standard_Short_Float then
7500 Fat_Pkg := RE_Attr_Short_Float;
7502 elsif Fat_Type = Standard_Float then
7503 Fat_Pkg := RE_Attr_Float;
7505 elsif Fat_Type = Standard_Long_Float then
7506 Fat_Pkg := RE_Attr_Long_Float;
7508 elsif Fat_Type = Standard_Long_Long_Float then
7509 Fat_Pkg := RE_Attr_Long_Long_Float;
7511 -- Universal real (which is its own root type) is treated as being
7512 -- equivalent to Standard.Long_Long_Float, since it is defined to
7513 -- have the same precision as the longest Float type.
7515 elsif Fat_Type = Universal_Real then
7516 Fat_Type := Standard_Long_Long_Float;
7517 Fat_Pkg := RE_Attr_Long_Long_Float;
7520 raise Program_Error;
7524 ----------------------------
7525 -- Find_Stream_Subprogram --
7526 ----------------------------
7528 function Find_Stream_Subprogram
7530 Nam : TSS_Name_Type) return Entity_Id
7532 Base_Typ : constant Entity_Id := Base_Type (Typ);
7533 Ent : constant Entity_Id := TSS (Typ, Nam);
7535 function Is_Available (Entity : RE_Id) return Boolean;
7536 pragma Inline (Is_Available);
7537 -- Function to check whether the specified run-time call is available
7538 -- in the run time used. In the case of a configurable run time, it
7539 -- is normal that some subprograms are not there.
7541 -- I don't understand this routine at all, why is this not just a
7542 -- call to RTE_Available? And if for some reason we need a different
7543 -- routine with different semantics, why is not in Rtsfind ???
7549 function Is_Available (Entity : RE_Id) return Boolean is
7551 -- Assume that the unit will always be available when using a
7552 -- "normal" (not configurable) run time.
7554 return not Configurable_Run_Time_Mode or else RTE_Available (Entity);
7557 -- Start of processing for Find_Stream_Subprogram
7560 if Present (Ent) then
7564 -- Stream attributes for strings are expanded into library calls. The
7565 -- following checks are disabled when the run-time is not available or
7566 -- when compiling predefined types due to bootstrap issues. As a result,
7567 -- the compiler will generate in-place stream routines for string types
7568 -- that appear in GNAT's library, but will generate calls via rtsfind
7569 -- to library routines for user code.
7571 -- ??? For now, disable this code for JVM, since this generates a
7572 -- VerifyError exception at run time on e.g. c330001.
7574 -- This is disabled for AAMP, to avoid creating dependences on files not
7575 -- supported in the AAMP library (such as s-fileio.adb).
7577 -- Note: In the case of using a configurable run time, it is very likely
7578 -- that stream routines for string types are not present (they require
7579 -- file system support). In this case, the specific stream routines for
7580 -- strings are not used, relying on the regular stream mechanism
7581 -- instead. That is why we include the test Is_Available when dealing
7582 -- with these cases.
7584 if VM_Target /= JVM_Target
7585 and then not AAMP_On_Target
7587 not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
7589 -- Storage_Array as defined in package System.Storage_Elements
7591 if Is_RTE (Base_Typ, RE_Storage_Array) then
7593 -- Case of No_Stream_Optimizations restriction active
7595 if Restriction_Active (No_Stream_Optimizations) then
7596 if Nam = TSS_Stream_Input
7597 and then Is_Available (RE_Storage_Array_Input)
7599 return RTE (RE_Storage_Array_Input);
7601 elsif Nam = TSS_Stream_Output
7602 and then Is_Available (RE_Storage_Array_Output)
7604 return RTE (RE_Storage_Array_Output);
7606 elsif Nam = TSS_Stream_Read
7607 and then Is_Available (RE_Storage_Array_Read)
7609 return RTE (RE_Storage_Array_Read);
7611 elsif Nam = TSS_Stream_Write
7612 and then Is_Available (RE_Storage_Array_Write)
7614 return RTE (RE_Storage_Array_Write);
7616 elsif Nam /= TSS_Stream_Input and then
7617 Nam /= TSS_Stream_Output and then
7618 Nam /= TSS_Stream_Read and then
7619 Nam /= TSS_Stream_Write
7621 raise Program_Error;
7624 -- Restriction No_Stream_Optimizations is not set, so we can go
7625 -- ahead and optimize using the block IO forms of the routines.
7628 if Nam = TSS_Stream_Input
7629 and then Is_Available (RE_Storage_Array_Input_Blk_IO)
7631 return RTE (RE_Storage_Array_Input_Blk_IO);
7633 elsif Nam = TSS_Stream_Output
7634 and then Is_Available (RE_Storage_Array_Output_Blk_IO)
7636 return RTE (RE_Storage_Array_Output_Blk_IO);
7638 elsif Nam = TSS_Stream_Read
7639 and then Is_Available (RE_Storage_Array_Read_Blk_IO)
7641 return RTE (RE_Storage_Array_Read_Blk_IO);
7643 elsif Nam = TSS_Stream_Write
7644 and then Is_Available (RE_Storage_Array_Write_Blk_IO)
7646 return RTE (RE_Storage_Array_Write_Blk_IO);
7648 elsif Nam /= TSS_Stream_Input and then
7649 Nam /= TSS_Stream_Output and then
7650 Nam /= TSS_Stream_Read and then
7651 Nam /= TSS_Stream_Write
7653 raise Program_Error;
7657 -- Stream_Element_Array as defined in package Ada.Streams
7659 elsif Is_RTE (Base_Typ, RE_Stream_Element_Array) then
7661 -- Case of No_Stream_Optimizations restriction active
7663 if Restriction_Active (No_Stream_Optimizations) then
7664 if Nam = TSS_Stream_Input
7665 and then Is_Available (RE_Stream_Element_Array_Input)
7667 return RTE (RE_Stream_Element_Array_Input);
7669 elsif Nam = TSS_Stream_Output
7670 and then Is_Available (RE_Stream_Element_Array_Output)
7672 return RTE (RE_Stream_Element_Array_Output);
7674 elsif Nam = TSS_Stream_Read
7675 and then Is_Available (RE_Stream_Element_Array_Read)
7677 return RTE (RE_Stream_Element_Array_Read);
7679 elsif Nam = TSS_Stream_Write
7680 and then Is_Available (RE_Stream_Element_Array_Write)
7682 return RTE (RE_Stream_Element_Array_Write);
7684 elsif Nam /= TSS_Stream_Input and then
7685 Nam /= TSS_Stream_Output and then
7686 Nam /= TSS_Stream_Read and then
7687 Nam /= TSS_Stream_Write
7689 raise Program_Error;
7692 -- Restriction No_Stream_Optimizations is not set, so we can go
7693 -- ahead and optimize using the block IO forms of the routines.
7696 if Nam = TSS_Stream_Input
7697 and then Is_Available (RE_Stream_Element_Array_Input_Blk_IO)
7699 return RTE (RE_Stream_Element_Array_Input_Blk_IO);
7701 elsif Nam = TSS_Stream_Output
7702 and then Is_Available (RE_Stream_Element_Array_Output_Blk_IO)
7704 return RTE (RE_Stream_Element_Array_Output_Blk_IO);
7706 elsif Nam = TSS_Stream_Read
7707 and then Is_Available (RE_Stream_Element_Array_Read_Blk_IO)
7709 return RTE (RE_Stream_Element_Array_Read_Blk_IO);
7711 elsif Nam = TSS_Stream_Write
7712 and then Is_Available (RE_Stream_Element_Array_Write_Blk_IO)
7714 return RTE (RE_Stream_Element_Array_Write_Blk_IO);
7716 elsif Nam /= TSS_Stream_Input and then
7717 Nam /= TSS_Stream_Output and then
7718 Nam /= TSS_Stream_Read and then
7719 Nam /= TSS_Stream_Write
7721 raise Program_Error;
7725 -- String as defined in package Ada
7727 elsif Base_Typ = Standard_String then
7729 -- Case of No_Stream_Optimizations restriction active
7731 if Restriction_Active (No_Stream_Optimizations) then
7732 if Nam = TSS_Stream_Input
7733 and then Is_Available (RE_String_Input)
7735 return RTE (RE_String_Input);
7737 elsif Nam = TSS_Stream_Output
7738 and then Is_Available (RE_String_Output)
7740 return RTE (RE_String_Output);
7742 elsif Nam = TSS_Stream_Read
7743 and then Is_Available (RE_String_Read)
7745 return RTE (RE_String_Read);
7747 elsif Nam = TSS_Stream_Write
7748 and then Is_Available (RE_String_Write)
7750 return RTE (RE_String_Write);
7752 elsif Nam /= TSS_Stream_Input and then
7753 Nam /= TSS_Stream_Output and then
7754 Nam /= TSS_Stream_Read and then
7755 Nam /= TSS_Stream_Write
7757 raise Program_Error;
7760 -- Restriction No_Stream_Optimizations is not set, so we can go
7761 -- ahead and optimize using the block IO forms of the routines.
7764 if Nam = TSS_Stream_Input
7765 and then Is_Available (RE_String_Input_Blk_IO)
7767 return RTE (RE_String_Input_Blk_IO);
7769 elsif Nam = TSS_Stream_Output
7770 and then Is_Available (RE_String_Output_Blk_IO)
7772 return RTE (RE_String_Output_Blk_IO);
7774 elsif Nam = TSS_Stream_Read
7775 and then Is_Available (RE_String_Read_Blk_IO)
7777 return RTE (RE_String_Read_Blk_IO);
7779 elsif Nam = TSS_Stream_Write
7780 and then Is_Available (RE_String_Write_Blk_IO)
7782 return RTE (RE_String_Write_Blk_IO);
7784 elsif Nam /= TSS_Stream_Input and then
7785 Nam /= TSS_Stream_Output and then
7786 Nam /= TSS_Stream_Read and then
7787 Nam /= TSS_Stream_Write
7789 raise Program_Error;
7793 -- Wide_String as defined in package Ada
7795 elsif Base_Typ = Standard_Wide_String then
7797 -- Case of No_Stream_Optimizations restriction active
7799 if Restriction_Active (No_Stream_Optimizations) then
7800 if Nam = TSS_Stream_Input
7801 and then Is_Available (RE_Wide_String_Input)
7803 return RTE (RE_Wide_String_Input);
7805 elsif Nam = TSS_Stream_Output
7806 and then Is_Available (RE_Wide_String_Output)
7808 return RTE (RE_Wide_String_Output);
7810 elsif Nam = TSS_Stream_Read
7811 and then Is_Available (RE_Wide_String_Read)
7813 return RTE (RE_Wide_String_Read);
7815 elsif Nam = TSS_Stream_Write
7816 and then Is_Available (RE_Wide_String_Write)
7818 return RTE (RE_Wide_String_Write);
7820 elsif Nam /= TSS_Stream_Input and then
7821 Nam /= TSS_Stream_Output and then
7822 Nam /= TSS_Stream_Read and then
7823 Nam /= TSS_Stream_Write
7825 raise Program_Error;
7828 -- Restriction No_Stream_Optimizations is not set, so we can go
7829 -- ahead and optimize using the block IO forms of the routines.
7832 if Nam = TSS_Stream_Input
7833 and then Is_Available (RE_Wide_String_Input_Blk_IO)
7835 return RTE (RE_Wide_String_Input_Blk_IO);
7837 elsif Nam = TSS_Stream_Output
7838 and then Is_Available (RE_Wide_String_Output_Blk_IO)
7840 return RTE (RE_Wide_String_Output_Blk_IO);
7842 elsif Nam = TSS_Stream_Read
7843 and then Is_Available (RE_Wide_String_Read_Blk_IO)
7845 return RTE (RE_Wide_String_Read_Blk_IO);
7847 elsif Nam = TSS_Stream_Write
7848 and then Is_Available (RE_Wide_String_Write_Blk_IO)
7850 return RTE (RE_Wide_String_Write_Blk_IO);
7852 elsif Nam /= TSS_Stream_Input and then
7853 Nam /= TSS_Stream_Output and then
7854 Nam /= TSS_Stream_Read and then
7855 Nam /= TSS_Stream_Write
7857 raise Program_Error;
7861 -- Wide_Wide_String as defined in package Ada
7863 elsif Base_Typ = Standard_Wide_Wide_String then
7865 -- Case of No_Stream_Optimizations restriction active
7867 if Restriction_Active (No_Stream_Optimizations) then
7868 if Nam = TSS_Stream_Input
7869 and then Is_Available (RE_Wide_Wide_String_Input)
7871 return RTE (RE_Wide_Wide_String_Input);
7873 elsif Nam = TSS_Stream_Output
7874 and then Is_Available (RE_Wide_Wide_String_Output)
7876 return RTE (RE_Wide_Wide_String_Output);
7878 elsif Nam = TSS_Stream_Read
7879 and then Is_Available (RE_Wide_Wide_String_Read)
7881 return RTE (RE_Wide_Wide_String_Read);
7883 elsif Nam = TSS_Stream_Write
7884 and then Is_Available (RE_Wide_Wide_String_Write)
7886 return RTE (RE_Wide_Wide_String_Write);
7888 elsif Nam /= TSS_Stream_Input and then
7889 Nam /= TSS_Stream_Output and then
7890 Nam /= TSS_Stream_Read and then
7891 Nam /= TSS_Stream_Write
7893 raise Program_Error;
7896 -- Restriction No_Stream_Optimizations is not set, so we can go
7897 -- ahead and optimize using the block IO forms of the routines.
7900 if Nam = TSS_Stream_Input
7901 and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO)
7903 return RTE (RE_Wide_Wide_String_Input_Blk_IO);
7905 elsif Nam = TSS_Stream_Output
7906 and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO)
7908 return RTE (RE_Wide_Wide_String_Output_Blk_IO);
7910 elsif Nam = TSS_Stream_Read
7911 and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO)
7913 return RTE (RE_Wide_Wide_String_Read_Blk_IO);
7915 elsif Nam = TSS_Stream_Write
7916 and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO)
7918 return RTE (RE_Wide_Wide_String_Write_Blk_IO);
7920 elsif Nam /= TSS_Stream_Input and then
7921 Nam /= TSS_Stream_Output and then
7922 Nam /= TSS_Stream_Read and then
7923 Nam /= TSS_Stream_Write
7925 raise Program_Error;
7931 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
7932 return Find_Prim_Op (Typ, Nam);
7934 return Find_Inherited_TSS (Typ, Nam);
7936 end Find_Stream_Subprogram;
7942 function Full_Base (T : Entity_Id) return Entity_Id is
7946 BT := Base_Type (T);
7948 if Is_Private_Type (BT)
7949 and then Present (Full_View (BT))
7951 BT := Full_View (BT);
7957 -----------------------
7958 -- Get_Index_Subtype --
7959 -----------------------
7961 function Get_Index_Subtype (N : Node_Id) return Node_Id is
7962 P_Type : Entity_Id := Etype (Prefix (N));
7967 if Is_Access_Type (P_Type) then
7968 P_Type := Designated_Type (P_Type);
7971 if No (Expressions (N)) then
7974 J := UI_To_Int (Expr_Value (First (Expressions (N))));
7977 Indx := First_Index (P_Type);
7983 return Etype (Indx);
7984 end Get_Index_Subtype;
7986 -------------------------------
7987 -- Get_Stream_Convert_Pragma --
7988 -------------------------------
7990 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is
7995 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
7996 -- that a stream convert pragma for a tagged type is not inherited from
7997 -- its parent. Probably what is wrong here is that it is basically
7998 -- incorrect to consider a stream convert pragma to be a representation
7999 -- pragma at all ???
8001 N := First_Rep_Item (Implementation_Base_Type (T));
8002 while Present (N) loop
8003 if Nkind (N) = N_Pragma
8004 and then Pragma_Name (N) = Name_Stream_Convert
8006 -- For tagged types this pragma is not inherited, so we
8007 -- must verify that it is defined for the given type and
8011 Entity (Expression (First (Pragma_Argument_Associations (N))));
8013 if not Is_Tagged_Type (T)
8015 or else (Is_Private_Type (Typ) and then T = Full_View (Typ))
8025 end Get_Stream_Convert_Pragma;
8027 ---------------------------------
8028 -- Is_Constrained_Packed_Array --
8029 ---------------------------------
8031 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is
8032 Arr : Entity_Id := Typ;
8035 if Is_Access_Type (Arr) then
8036 Arr := Designated_Type (Arr);
8039 return Is_Array_Type (Arr)
8040 and then Is_Constrained (Arr)
8041 and then Present (Packed_Array_Impl_Type (Arr));
8042 end Is_Constrained_Packed_Array;
8044 ----------------------------------------
8045 -- Is_Inline_Floating_Point_Attribute --
8046 ----------------------------------------
8048 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is
8049 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
8051 function Is_GCC_Target return Boolean;
8052 -- Return True if we are using a GCC target/back-end
8053 -- ??? Note: the implementation is kludgy/fragile
8059 function Is_GCC_Target return Boolean is
8061 return VM_Target = No_VM and then not CodePeer_Mode
8062 and then not AAMP_On_Target;
8065 -- Start of processing for Exp_Attr
8068 -- Machine and Model can be expanded by the GCC backend only
8070 if Id = Attribute_Machine or else Id = Attribute_Model then
8071 return Is_GCC_Target;
8073 -- Remaining cases handled by all back ends are Rounding and Truncation
8074 -- when appearing as the operand of a conversion to some integer type.
8076 elsif Nkind (Parent (N)) /= N_Type_Conversion
8077 or else not Is_Integer_Type (Etype (Parent (N)))
8082 -- Here we are in the integer conversion context
8084 -- Very probably we should also recognize the cases of Machine_Rounding
8085 -- and unbiased rounding in this conversion context, but the back end is
8086 -- not yet prepared to handle these cases ???
8088 return Id = Attribute_Rounding or else Id = Attribute_Truncation;
8089 end Is_Inline_Floating_Point_Attribute;