1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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. --
18 -- You should have received a copy of the GNU General Public License along --
19 -- with this program; see file COPYING3. If not see --
20 -- <http://www.gnu.org/licenses/>. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
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 Exp_VFpt; use Exp_VFpt;
43 with Fname; use Fname;
44 with Freeze; use Freeze;
45 with Gnatvsn; use Gnatvsn;
46 with Itypes; use Itypes;
48 with Namet; use Namet;
49 with Nmake; use Nmake;
50 with Nlists; use Nlists;
52 with Restrict; use Restrict;
53 with Rident; use Rident;
54 with Rtsfind; use Rtsfind;
56 with Sem_Aux; use Sem_Aux;
57 with Sem_Ch6; use Sem_Ch6;
58 with Sem_Ch7; use Sem_Ch7;
59 with Sem_Ch8; use Sem_Ch8;
60 with Sem_Eval; use Sem_Eval;
61 with Sem_Res; use Sem_Res;
62 with Sem_Util; use Sem_Util;
63 with Sinfo; use Sinfo;
64 with Snames; use Snames;
65 with Stand; use Stand;
66 with Stringt; use Stringt;
67 with Targparm; use Targparm;
68 with Tbuild; use Tbuild;
69 with Ttypes; use Ttypes;
70 with Uintp; use Uintp;
71 with Uname; use Uname;
72 with Validsw; use Validsw;
74 package body Exp_Attr is
76 -----------------------
77 -- Local Subprograms --
78 -----------------------
80 procedure Compile_Stream_Body_In_Scope
85 -- The body for a stream subprogram may be generated outside of the scope
86 -- of the type. If the type is fully private, it may depend on the full
87 -- view of other types (e.g. indices) that are currently private as well.
88 -- We install the declarations of the package in which the type is declared
89 -- before compiling the body in what is its proper environment. The Check
90 -- parameter indicates if checks are to be suppressed for the stream body.
91 -- We suppress checks for array/record reads, since the rule is that these
92 -- are like assignments, out of range values due to uninitialized storage,
93 -- or other invalid values do NOT cause a Constraint_Error to be raised.
95 procedure Expand_Access_To_Protected_Op
100 -- An attribute reference to a protected subprogram is transformed into
101 -- a pair of pointers: one to the object, and one to the operations.
102 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
104 procedure Expand_Fpt_Attribute
109 -- This procedure expands a call to a floating-point attribute function.
110 -- N is the attribute reference node, and Args is a list of arguments to
111 -- be passed to the function call. Pkg identifies the package containing
112 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
113 -- have already been converted to the floating-point type for which Pkg was
114 -- instantiated. The Nam argument is the relevant attribute processing
115 -- routine to be called. This is the same as the attribute name, except in
116 -- the Unaligned_Valid case.
118 procedure Expand_Fpt_Attribute_R (N : Node_Id);
119 -- This procedure expands a call to a floating-point attribute function
120 -- that takes a single floating-point argument. The function to be called
121 -- is always the same as the attribute name.
123 procedure Expand_Fpt_Attribute_RI (N : Node_Id);
124 -- This procedure expands a call to a floating-point attribute function
125 -- that takes one floating-point argument and one integer argument. The
126 -- function to be called is always the same as the attribute name.
128 procedure Expand_Fpt_Attribute_RR (N : Node_Id);
129 -- This procedure expands a call to a floating-point attribute function
130 -- that takes two floating-point arguments. The function to be called
131 -- is always the same as the attribute name.
133 procedure Expand_Pred_Succ (N : Node_Id);
134 -- Handles expansion of Pred or Succ attributes for case of non-real
135 -- operand with overflow checking required.
137 function Get_Index_Subtype (N : Node_Id) return Entity_Id;
138 -- Used for Last, Last, and Length, when the prefix is an array type.
139 -- Obtains the corresponding index subtype.
141 procedure Find_Fat_Info
143 Fat_Type : out Entity_Id;
144 Fat_Pkg : out RE_Id);
145 -- Given a floating-point type T, identifies the package containing the
146 -- attributes for this type (returned in Fat_Pkg), and the corresponding
147 -- type for which this package was instantiated from Fat_Gen. Error if T
148 -- is not a floating-point type.
150 function Find_Stream_Subprogram
152 Nam : TSS_Name_Type) return Entity_Id;
153 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
154 -- types, the corresponding primitive operation is looked up, else the
155 -- appropriate TSS from the type itself, or from its closest ancestor
156 -- defining it, is returned. In both cases, inheritance of representation
157 -- aspects is thus taken into account.
159 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id;
160 -- Given a type, find a corresponding stream convert pragma that applies to
161 -- the implementation base type of this type (Typ). If found, return the
162 -- pragma node, otherwise return Empty if no pragma is found.
164 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
165 -- Utility for array attributes, returns true on packed constrained
166 -- arrays, and on access to same.
168 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean;
169 -- Returns true iff the given node refers to an attribute call that
170 -- can be expanded directly by the back end and does not need front end
171 -- expansion. Typically used for rounding and truncation attributes that
172 -- appear directly inside a conversion to integer.
174 ----------------------------------
175 -- Compile_Stream_Body_In_Scope --
176 ----------------------------------
178 procedure Compile_Stream_Body_In_Scope
184 Installed : Boolean := False;
185 Scop : constant Entity_Id := Scope (Arr);
186 Curr : constant Entity_Id := Current_Scope;
190 and then not In_Open_Scopes (Scop)
191 and then Ekind (Scop) = E_Package
194 Install_Visible_Declarations (Scop);
195 Install_Private_Declarations (Scop);
198 -- The entities in the package are now visible, but the generated
199 -- stream entity must appear in the current scope (usually an
200 -- enclosing stream function) so that itypes all have their proper
207 Insert_Action (N, Decl);
209 Insert_Action (N, Decl, Suppress => All_Checks);
214 -- Remove extra copy of current scope, and package itself
217 End_Package_Scope (Scop);
219 end Compile_Stream_Body_In_Scope;
221 -----------------------------------
222 -- Expand_Access_To_Protected_Op --
223 -----------------------------------
225 procedure Expand_Access_To_Protected_Op
230 -- The value of the attribute_reference is a record containing two
231 -- fields: an access to the protected object, and an access to the
232 -- subprogram itself. The prefix is a selected component.
234 Loc : constant Source_Ptr := Sloc (N);
236 Btyp : constant Entity_Id := Base_Type (Typ);
239 E_T : constant Entity_Id := Equivalent_Type (Btyp);
240 Acc : constant Entity_Id :=
241 Etype (Next_Component (First_Component (E_T)));
245 function May_Be_External_Call return Boolean;
246 -- If the 'Access is to a local operation, but appears in a context
247 -- where it may lead to a call from outside the object, we must treat
248 -- this as an external call. Clearly we cannot tell without full
249 -- flow analysis, and a subsequent call that uses this 'Access may
250 -- lead to a bounded error (trying to seize locks twice, e.g.). For
251 -- now we treat 'Access as a potential external call if it is an actual
252 -- in a call to an outside subprogram.
254 --------------------------
255 -- May_Be_External_Call --
256 --------------------------
258 function May_Be_External_Call return Boolean is
260 Par : Node_Id := Parent (N);
263 -- Account for the case where the Access attribute is part of a
264 -- named parameter association.
266 if Nkind (Par) = N_Parameter_Association then
270 if Nkind_In (Par, N_Procedure_Call_Statement, N_Function_Call)
271 and then Is_Entity_Name (Name (Par))
273 Subp := Entity (Name (Par));
274 return not In_Open_Scopes (Scope (Subp));
278 end May_Be_External_Call;
280 -- Start of processing for Expand_Access_To_Protected_Op
283 -- Within the body of the protected type, the prefix
284 -- designates a local operation, and the object is the first
285 -- parameter of the corresponding protected body of the
286 -- current enclosing operation.
288 if Is_Entity_Name (Pref) then
289 if May_Be_External_Call then
292 (External_Subprogram (Entity (Pref)), Loc);
296 (Protected_Body_Subprogram (Entity (Pref)), Loc);
299 -- Don't traverse the scopes when the attribute occurs within an init
300 -- proc, because we directly use the _init formal of the init proc in
303 Curr := Current_Scope;
304 if not Is_Init_Proc (Curr) then
305 pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
307 while Scope (Curr) /= Scope (Entity (Pref)) loop
308 Curr := Scope (Curr);
312 -- In case of protected entries the first formal of its Protected_
313 -- Body_Subprogram is the address of the object.
315 if Ekind (Curr) = E_Entry then
319 (Protected_Body_Subprogram (Curr)), Loc);
321 -- If the current scope is an init proc, then use the address of the
322 -- _init formal as the object reference.
324 elsif Is_Init_Proc (Curr) then
326 Make_Attribute_Reference (Loc,
327 Prefix => New_Occurrence_Of (First_Formal (Curr), Loc),
328 Attribute_Name => Name_Address);
330 -- In case of protected subprograms the first formal of its
331 -- Protected_Body_Subprogram is the object and we get its address.
335 Make_Attribute_Reference (Loc,
339 (Protected_Body_Subprogram (Curr)), Loc),
340 Attribute_Name => Name_Address);
343 -- Case where the prefix is not an entity name. Find the
344 -- version of the protected operation to be called from
345 -- outside the protected object.
351 (Entity (Selector_Name (Pref))), Loc);
354 Make_Attribute_Reference (Loc,
355 Prefix => Relocate_Node (Prefix (Pref)),
356 Attribute_Name => Name_Address);
360 Make_Attribute_Reference (Loc,
362 Attribute_Name => Name_Access);
364 -- We set the type of the access reference to the already generated
365 -- access_to_subprogram type, and declare the reference analyzed, to
366 -- prevent further expansion when the enclosing aggregate is analyzed.
368 Set_Etype (Sub_Ref, Acc);
369 Set_Analyzed (Sub_Ref);
373 Expressions => New_List (Obj_Ref, Sub_Ref));
376 Analyze_And_Resolve (N, E_T);
378 -- For subsequent analysis, the node must retain its type. The backend
379 -- will replace it with the equivalent type where needed.
382 end Expand_Access_To_Protected_Op;
384 --------------------------
385 -- Expand_Fpt_Attribute --
386 --------------------------
388 procedure Expand_Fpt_Attribute
394 Loc : constant Source_Ptr := Sloc (N);
395 Typ : constant Entity_Id := Etype (N);
399 -- The function name is the selected component Attr_xxx.yyy where
400 -- Attr_xxx is the package name, and yyy is the argument Nam.
402 -- Note: it would be more usual to have separate RE entries for each
403 -- of the entities in the Fat packages, but first they have identical
404 -- names (so we would have to have lots of renaming declarations to
405 -- meet the normal RE rule of separate names for all runtime entities),
406 -- and second there would be an awful lot of them!
409 Make_Selected_Component (Loc,
410 Prefix => New_Reference_To (RTE (Pkg), Loc),
411 Selector_Name => Make_Identifier (Loc, Nam));
413 -- The generated call is given the provided set of parameters, and then
414 -- wrapped in a conversion which converts the result to the target type
415 -- We use the base type as the target because a range check may be
419 Unchecked_Convert_To (Base_Type (Etype (N)),
420 Make_Function_Call (Loc,
422 Parameter_Associations => Args)));
424 Analyze_And_Resolve (N, Typ);
425 end Expand_Fpt_Attribute;
427 ----------------------------
428 -- Expand_Fpt_Attribute_R --
429 ----------------------------
431 -- The single argument is converted to its root type to call the
432 -- appropriate runtime function, with the actual call being built
433 -- by Expand_Fpt_Attribute
435 procedure Expand_Fpt_Attribute_R (N : Node_Id) is
436 E1 : constant Node_Id := First (Expressions (N));
440 Find_Fat_Info (Etype (E1), Ftp, Pkg);
442 (N, Pkg, Attribute_Name (N),
443 New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1))));
444 end Expand_Fpt_Attribute_R;
446 -----------------------------
447 -- Expand_Fpt_Attribute_RI --
448 -----------------------------
450 -- The first argument is converted to its root type and the second
451 -- argument is converted to standard long long integer to call the
452 -- appropriate runtime function, with the actual call being built
453 -- by Expand_Fpt_Attribute
455 procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
456 E1 : constant Node_Id := First (Expressions (N));
459 E2 : constant Node_Id := Next (E1);
461 Find_Fat_Info (Etype (E1), Ftp, Pkg);
463 (N, Pkg, Attribute_Name (N),
465 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
466 Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
467 end Expand_Fpt_Attribute_RI;
469 -----------------------------
470 -- Expand_Fpt_Attribute_RR --
471 -----------------------------
473 -- The two arguments are converted to their root types to call the
474 -- appropriate runtime function, with the actual call being built
475 -- by Expand_Fpt_Attribute
477 procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
478 E1 : constant Node_Id := First (Expressions (N));
481 E2 : constant Node_Id := Next (E1);
483 Find_Fat_Info (Etype (E1), Ftp, Pkg);
485 (N, Pkg, Attribute_Name (N),
487 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
488 Unchecked_Convert_To (Ftp, Relocate_Node (E2))));
489 end Expand_Fpt_Attribute_RR;
491 ----------------------------------
492 -- Expand_N_Attribute_Reference --
493 ----------------------------------
495 procedure Expand_N_Attribute_Reference (N : Node_Id) is
496 Loc : constant Source_Ptr := Sloc (N);
497 Typ : constant Entity_Id := Etype (N);
498 Btyp : constant Entity_Id := Base_Type (Typ);
499 Pref : constant Node_Id := Prefix (N);
500 Ptyp : constant Entity_Id := Etype (Pref);
501 Exprs : constant List_Id := Expressions (N);
502 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
504 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
505 -- Rewrites a stream attribute for Read, Write or Output with the
506 -- procedure call. Pname is the entity for the procedure to call.
508 ------------------------------
509 -- Rewrite_Stream_Proc_Call --
510 ------------------------------
512 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
513 Item : constant Node_Id := Next (First (Exprs));
514 Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
515 Formal_Typ : constant Entity_Id := Etype (Formal);
516 Is_Written : constant Boolean := (Ekind (Formal) /= E_In_Parameter);
519 -- The expansion depends on Item, the second actual, which is
520 -- the object being streamed in or out.
522 -- If the item is a component of a packed array type, and
523 -- a conversion is needed on exit, we introduce a temporary to
524 -- hold the value, because otherwise the packed reference will
525 -- not be properly expanded.
527 if Nkind (Item) = N_Indexed_Component
528 and then Is_Packed (Base_Type (Etype (Prefix (Item))))
529 and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
533 Temp : constant Entity_Id := Make_Temporary (Loc, 'V');
539 Make_Object_Declaration (Loc,
540 Defining_Identifier => Temp,
542 New_Occurrence_Of (Formal_Typ, Loc));
543 Set_Etype (Temp, Formal_Typ);
546 Make_Assignment_Statement (Loc,
547 Name => New_Copy_Tree (Item),
550 (Etype (Item), New_Occurrence_Of (Temp, Loc)));
552 Rewrite (Item, New_Occurrence_Of (Temp, Loc));
556 Make_Procedure_Call_Statement (Loc,
557 Name => New_Occurrence_Of (Pname, Loc),
558 Parameter_Associations => Exprs),
561 Rewrite (N, Make_Null_Statement (Loc));
566 -- For the class-wide dispatching cases, and for cases in which
567 -- the base type of the second argument matches the base type of
568 -- the corresponding formal parameter (that is to say the stream
569 -- operation is not inherited), we are all set, and can use the
570 -- argument unchanged.
572 -- For all other cases we do an unchecked conversion of the second
573 -- parameter to the type of the formal of the procedure we are
574 -- calling. This deals with the private type cases, and with going
575 -- to the root type as required in elementary type case.
577 if not Is_Class_Wide_Type (Entity (Pref))
578 and then not Is_Class_Wide_Type (Etype (Item))
579 and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
582 Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
584 -- For untagged derived types set Assignment_OK, to prevent
585 -- copies from being created when the unchecked conversion
586 -- is expanded (which would happen in Remove_Side_Effects
587 -- if Expand_N_Unchecked_Conversion were allowed to call
588 -- Force_Evaluation). The copy could violate Ada semantics
589 -- in cases such as an actual that is an out parameter.
590 -- Note that this approach is also used in exp_ch7 for calls
591 -- to controlled type operations to prevent problems with
592 -- actuals wrapped in unchecked conversions.
594 if Is_Untagged_Derivation (Etype (Expression (Item))) then
595 Set_Assignment_OK (Item);
599 -- The stream operation to call maybe a renaming created by
600 -- an attribute definition clause, and may not be frozen yet.
601 -- Ensure that it has the necessary extra formals.
603 if not Is_Frozen (Pname) then
604 Create_Extra_Formals (Pname);
607 -- And now rewrite the call
610 Make_Procedure_Call_Statement (Loc,
611 Name => New_Occurrence_Of (Pname, Loc),
612 Parameter_Associations => Exprs));
615 end Rewrite_Stream_Proc_Call;
617 -- Start of processing for Expand_N_Attribute_Reference
620 -- Do required validity checking, if enabled. Do not apply check to
621 -- output parameters of an Asm instruction, since the value of this
622 -- is not set till after the attribute has been elaborated, and do
623 -- not apply the check to the arguments of a 'Read or 'Input attribute
624 -- reference since the scalar argument is an OUT scalar.
626 if Validity_Checks_On and then Validity_Check_Operands
627 and then Id /= Attribute_Asm_Output
628 and then Id /= Attribute_Read
629 and then Id /= Attribute_Input
634 Expr := First (Expressions (N));
635 while Present (Expr) loop
642 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
643 -- place function, then a temporary return object needs to be created
644 -- and access to it must be passed to the function. Currently we limit
645 -- such functions to those with inherently limited result subtypes, but
646 -- eventually we plan to expand the functions that are treated as
647 -- build-in-place to include other composite result types.
649 if Ada_Version >= Ada_05
650 and then Is_Build_In_Place_Function_Call (Pref)
652 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
655 -- If prefix is a protected type name, this is a reference to the
656 -- current instance of the type. For a component definition, nothing
657 -- to do (expansion will occur in the init proc). In other contexts,
658 -- rewrite into reference to current instance.
660 if Is_Protected_Self_Reference (Pref)
662 (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint,
663 N_Discriminant_Association)
664 and then Nkind (Parent (Parent (Parent (Parent (N))))) =
665 N_Component_Definition)
667 Rewrite (Pref, Concurrent_Ref (Pref));
671 -- Remaining processing depends on specific attribute
679 when Attribute_Access |
680 Attribute_Unchecked_Access |
681 Attribute_Unrestricted_Access =>
683 Access_Cases : declare
684 Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
685 Btyp_DDT : Entity_Id;
687 function Enclosing_Object (N : Node_Id) return Node_Id;
688 -- If N denotes a compound name (selected component, indexed
689 -- component, or slice), returns the name of the outermost such
690 -- enclosing object. Otherwise returns N. If the object is a
691 -- renaming, then the renamed object is returned.
693 ----------------------
694 -- Enclosing_Object --
695 ----------------------
697 function Enclosing_Object (N : Node_Id) return Node_Id is
702 while Nkind_In (Obj_Name, N_Selected_Component,
706 Obj_Name := Prefix (Obj_Name);
709 return Get_Referenced_Object (Obj_Name);
710 end Enclosing_Object;
712 -- Local declarations
714 Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
716 -- Start of processing for Access_Cases
719 Btyp_DDT := Designated_Type (Btyp);
721 -- Handle designated types that come from the limited view
723 if Ekind (Btyp_DDT) = E_Incomplete_Type
724 and then From_With_Type (Btyp_DDT)
725 and then Present (Non_Limited_View (Btyp_DDT))
727 Btyp_DDT := Non_Limited_View (Btyp_DDT);
729 elsif Is_Class_Wide_Type (Btyp_DDT)
730 and then Ekind (Etype (Btyp_DDT)) = E_Incomplete_Type
731 and then From_With_Type (Etype (Btyp_DDT))
732 and then Present (Non_Limited_View (Etype (Btyp_DDT)))
733 and then Present (Class_Wide_Type
734 (Non_Limited_View (Etype (Btyp_DDT))))
737 Class_Wide_Type (Non_Limited_View (Etype (Btyp_DDT)));
740 -- In order to improve the text of error messages, the designated
741 -- type of access-to-subprogram itypes is set by the semantics as
742 -- the associated subprogram entity (see sem_attr). Now we replace
743 -- such node with the proper E_Subprogram_Type itype.
745 if Id = Attribute_Unrestricted_Access
746 and then Is_Subprogram (Directly_Designated_Type (Typ))
748 -- The following conditions ensure that this special management
749 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
750 -- At this stage other cases in which the designated type is
751 -- still a subprogram (instead of an E_Subprogram_Type) are
752 -- wrong because the semantics must have overridden the type of
753 -- the node with the type imposed by the context.
755 if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
756 and then Etype (Parent (N)) = RTE (RE_Prim_Ptr)
758 Set_Etype (N, RTE (RE_Prim_Ptr));
762 Subp : constant Entity_Id :=
763 Directly_Designated_Type (Typ);
765 Extra : Entity_Id := Empty;
766 New_Formal : Entity_Id;
767 Old_Formal : Entity_Id := First_Formal (Subp);
768 Subp_Typ : Entity_Id;
771 Subp_Typ := Create_Itype (E_Subprogram_Type, N);
772 Set_Etype (Subp_Typ, Etype (Subp));
773 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
775 if Present (Old_Formal) then
776 New_Formal := New_Copy (Old_Formal);
777 Set_First_Entity (Subp_Typ, New_Formal);
780 Set_Scope (New_Formal, Subp_Typ);
781 Etyp := Etype (New_Formal);
783 -- Handle itypes. There is no need to duplicate
784 -- here the itypes associated with record types
785 -- (i.e the implicit full view of private types).
788 and then Ekind (Base_Type (Etyp)) /= E_Record_Type
790 Extra := New_Copy (Etyp);
791 Set_Parent (Extra, New_Formal);
792 Set_Etype (New_Formal, Extra);
793 Set_Scope (Extra, Subp_Typ);
797 Next_Formal (Old_Formal);
798 exit when No (Old_Formal);
800 Set_Next_Entity (New_Formal,
801 New_Copy (Old_Formal));
802 Next_Entity (New_Formal);
805 Set_Next_Entity (New_Formal, Empty);
806 Set_Last_Entity (Subp_Typ, Extra);
809 -- Now that the explicit formals have been duplicated,
810 -- any extra formals needed by the subprogram must be
813 if Present (Extra) then
814 Set_Extra_Formal (Extra, Empty);
817 Create_Extra_Formals (Subp_Typ);
818 Set_Directly_Designated_Type (Typ, Subp_Typ);
823 if Is_Access_Protected_Subprogram_Type (Btyp) then
824 Expand_Access_To_Protected_Op (N, Pref, Typ);
826 -- If prefix is a type name, this is a reference to the current
827 -- instance of the type, within its initialization procedure.
829 elsif Is_Entity_Name (Pref)
830 and then Is_Type (Entity (Pref))
837 -- If the current instance name denotes a task type, then
838 -- the access attribute is rewritten to be the name of the
839 -- "_task" parameter associated with the task type's task
840 -- procedure. An unchecked conversion is applied to ensure
841 -- a type match in cases of expander-generated calls (e.g.
844 if Is_Task_Type (Entity (Pref)) then
846 First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
847 while Present (Formal) loop
848 exit when Chars (Formal) = Name_uTask;
849 Next_Entity (Formal);
852 pragma Assert (Present (Formal));
855 Unchecked_Convert_To (Typ,
856 New_Occurrence_Of (Formal, Loc)));
859 -- The expression must appear in a default expression,
860 -- (which in the initialization procedure is the
861 -- right-hand side of an assignment), and not in a
862 -- discriminant constraint.
866 while Present (Par) loop
867 exit when Nkind (Par) = N_Assignment_Statement;
869 if Nkind (Par) = N_Component_Declaration then
876 if Present (Par) then
878 Make_Attribute_Reference (Loc,
879 Prefix => Make_Identifier (Loc, Name_uInit),
880 Attribute_Name => Attribute_Name (N)));
882 Analyze_And_Resolve (N, Typ);
887 -- If the prefix of an Access attribute is a dereference of an
888 -- access parameter (or a renaming of such a dereference, or a
889 -- subcomponent of such a dereference) and the context is a
890 -- general access type (including the type of an object or
891 -- component with an access_definition, but not the anonymous
892 -- type of an access parameter or access discriminant), then
893 -- apply an accessibility check to the access parameter. We used
894 -- to rewrite the access parameter as a type conversion, but that
895 -- could only be done if the immediate prefix of the Access
896 -- attribute was the dereference, and didn't handle cases where
897 -- the attribute is applied to a subcomponent of the dereference,
898 -- since there's generally no available, appropriate access type
899 -- to convert to in that case. The attribute is passed as the
900 -- point to insert the check, because the access parameter may
901 -- come from a renaming, possibly in a different scope, and the
902 -- check must be associated with the attribute itself.
904 elsif Id = Attribute_Access
905 and then Nkind (Enc_Object) = N_Explicit_Dereference
906 and then Is_Entity_Name (Prefix (Enc_Object))
907 and then (Ekind (Btyp) = E_General_Access_Type
908 or else Is_Local_Anonymous_Access (Btyp))
909 and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind
910 and then Ekind (Etype (Entity (Prefix (Enc_Object))))
911 = E_Anonymous_Access_Type
912 and then Present (Extra_Accessibility
913 (Entity (Prefix (Enc_Object))))
915 Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N);
917 -- Ada 2005 (AI-251): If the designated type is an interface we
918 -- add an implicit conversion to force the displacement of the
919 -- pointer to reference the secondary dispatch table.
921 elsif Is_Interface (Btyp_DDT)
922 and then (Comes_From_Source (N)
923 or else Comes_From_Source (Ref_Object)
924 or else (Nkind (Ref_Object) in N_Has_Chars
925 and then Chars (Ref_Object) = Name_uInit))
927 if Nkind (Ref_Object) /= N_Explicit_Dereference then
929 -- No implicit conversion required if types match, or if
930 -- the prefix is the class_wide_type of the interface. In
931 -- either case passing an object of the interface type has
932 -- already set the pointer correctly.
934 if Btyp_DDT = Etype (Ref_Object)
935 or else (Is_Class_Wide_Type (Etype (Ref_Object))
937 Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object))
943 Convert_To (Btyp_DDT,
944 New_Copy_Tree (Prefix (N))));
946 Analyze_And_Resolve (Prefix (N), Btyp_DDT);
949 -- When the object is an explicit dereference, convert the
950 -- dereference's prefix.
954 Obj_DDT : constant Entity_Id :=
956 (Directly_Designated_Type
957 (Etype (Prefix (Ref_Object))));
959 -- No implicit conversion required if designated types
962 if Obj_DDT /= Btyp_DDT
963 and then not (Is_Class_Wide_Type (Obj_DDT)
964 and then Etype (Obj_DDT) = Btyp_DDT)
968 New_Copy_Tree (Prefix (Ref_Object))));
969 Analyze_And_Resolve (N, Typ);
980 -- Transforms 'Adjacent into a call to the floating-point attribute
981 -- function Adjacent in Fat_xxx (where xxx is the root type)
983 when Attribute_Adjacent =>
984 Expand_Fpt_Attribute_RR (N);
990 when Attribute_Address => Address : declare
991 Task_Proc : Entity_Id;
994 -- If the prefix is a task or a task type, the useful address is that
995 -- of the procedure for the task body, i.e. the actual program unit.
996 -- We replace the original entity with that of the procedure.
998 if Is_Entity_Name (Pref)
999 and then Is_Task_Type (Entity (Pref))
1001 Task_Proc := Next_Entity (Root_Type (Ptyp));
1003 while Present (Task_Proc) loop
1004 exit when Ekind (Task_Proc) = E_Procedure
1005 and then Etype (First_Formal (Task_Proc)) =
1006 Corresponding_Record_Type (Ptyp);
1007 Next_Entity (Task_Proc);
1010 if Present (Task_Proc) then
1011 Set_Entity (Pref, Task_Proc);
1012 Set_Etype (Pref, Etype (Task_Proc));
1015 -- Similarly, the address of a protected operation is the address
1016 -- of the corresponding protected body, regardless of the protected
1017 -- object from which it is selected.
1019 elsif Nkind (Pref) = N_Selected_Component
1020 and then Is_Subprogram (Entity (Selector_Name (Pref)))
1021 and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref))))
1025 External_Subprogram (Entity (Selector_Name (Pref))), Loc));
1027 elsif Nkind (Pref) = N_Explicit_Dereference
1028 and then Ekind (Ptyp) = E_Subprogram_Type
1029 and then Convention (Ptyp) = Convention_Protected
1031 -- The prefix is be a dereference of an access_to_protected_
1032 -- subprogram. The desired address is the second component of
1033 -- the record that represents the access.
1036 Addr : constant Entity_Id := Etype (N);
1037 Ptr : constant Node_Id := Prefix (Pref);
1038 T : constant Entity_Id :=
1039 Equivalent_Type (Base_Type (Etype (Ptr)));
1043 Unchecked_Convert_To (Addr,
1044 Make_Selected_Component (Loc,
1045 Prefix => Unchecked_Convert_To (T, Ptr),
1046 Selector_Name => New_Occurrence_Of (
1047 Next_Entity (First_Entity (T)), Loc))));
1049 Analyze_And_Resolve (N, Addr);
1052 -- Ada 2005 (AI-251): Class-wide interface objects are always
1053 -- "displaced" to reference the tag associated with the interface
1054 -- type. In order to obtain the real address of such objects we
1055 -- generate a call to a run-time subprogram that returns the base
1056 -- address of the object.
1058 -- This processing is not needed in the VM case, where dispatching
1059 -- issues are taken care of by the virtual machine.
1061 elsif Is_Class_Wide_Type (Ptyp)
1062 and then Is_Interface (Ptyp)
1063 and then Tagged_Type_Expansion
1064 and then not (Nkind (Pref) in N_Has_Entity
1065 and then Is_Subprogram (Entity (Pref)))
1068 Make_Function_Call (Loc,
1069 Name => New_Reference_To (RTE (RE_Base_Address), Loc),
1070 Parameter_Associations => New_List (
1071 Relocate_Node (N))));
1076 -- Deal with packed array reference, other cases are handled by
1079 if Involves_Packed_Array_Reference (Pref) then
1080 Expand_Packed_Address_Reference (N);
1088 when Attribute_Alignment => Alignment : declare
1092 -- For class-wide types, X'Class'Alignment is transformed into a
1093 -- direct reference to the Alignment of the class type, so that the
1094 -- back end does not have to deal with the X'Class'Alignment
1097 if Is_Entity_Name (Pref)
1098 and then Is_Class_Wide_Type (Entity (Pref))
1100 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
1103 -- For x'Alignment applied to an object of a class wide type,
1104 -- transform X'Alignment into a call to the predefined primitive
1105 -- operation _Alignment applied to X.
1107 elsif Is_Class_Wide_Type (Ptyp) then
1109 -- No need to do anything else compiling under restriction
1110 -- No_Dispatching_Calls. During the semantic analysis we
1111 -- already notified such violation.
1113 if Restriction_Active (No_Dispatching_Calls) then
1118 Make_Function_Call (Loc,
1119 Name => New_Reference_To
1120 (Find_Prim_Op (Ptyp, Name_uAlignment), Loc),
1121 Parameter_Associations => New_List (Pref));
1123 if Typ /= Standard_Integer then
1125 -- The context is a specific integer type with which the
1126 -- original attribute was compatible. The function has a
1127 -- specific type as well, so to preserve the compatibility
1128 -- we must convert explicitly.
1130 New_Node := Convert_To (Typ, New_Node);
1133 Rewrite (N, New_Node);
1134 Analyze_And_Resolve (N, Typ);
1137 -- For all other cases, we just have to deal with the case of
1138 -- the fact that the result can be universal.
1141 Apply_Universal_Integer_Attribute_Checks (N);
1149 when Attribute_AST_Entry => AST_Entry : declare
1154 Entry_Ref : Node_Id;
1155 -- The reference to the entry or entry family
1158 -- The index expression for an entry family reference, or
1159 -- the Empty if Entry_Ref references a simple entry.
1162 if Nkind (Pref) = N_Indexed_Component then
1163 Entry_Ref := Prefix (Pref);
1164 Index := First (Expressions (Pref));
1170 -- Get expression for Task_Id and the entry entity
1172 if Nkind (Entry_Ref) = N_Selected_Component then
1174 Make_Attribute_Reference (Loc,
1175 Attribute_Name => Name_Identity,
1176 Prefix => Prefix (Entry_Ref));
1178 Ttyp := Etype (Prefix (Entry_Ref));
1179 Eent := Entity (Selector_Name (Entry_Ref));
1183 Make_Function_Call (Loc,
1184 Name => New_Occurrence_Of (RTE (RE_Current_Task), Loc));
1186 Eent := Entity (Entry_Ref);
1188 -- We have to find the enclosing task to get the task type
1189 -- There must be one, since we already validated this earlier
1191 Ttyp := Current_Scope;
1192 while not Is_Task_Type (Ttyp) loop
1193 Ttyp := Scope (Ttyp);
1197 -- Now rewrite the attribute with a call to Create_AST_Handler
1200 Make_Function_Call (Loc,
1201 Name => New_Occurrence_Of (RTE (RE_Create_AST_Handler), Loc),
1202 Parameter_Associations => New_List (
1204 Entry_Index_Expression (Loc, Eent, Index, Ttyp))));
1206 Analyze_And_Resolve (N, RTE (RE_AST_Handler));
1213 -- We compute this if a packed array reference was present, otherwise we
1214 -- leave the computation up to the back end.
1216 when Attribute_Bit =>
1217 if Involves_Packed_Array_Reference (Pref) then
1218 Expand_Packed_Bit_Reference (N);
1220 Apply_Universal_Integer_Attribute_Checks (N);
1227 -- We compute this if a component clause was present, otherwise we leave
1228 -- the computation up to the back end, since we don't know what layout
1231 -- Note that the attribute can apply to a naked record component
1232 -- in generated code (i.e. the prefix is an identifier that
1233 -- references the component or discriminant entity).
1235 when Attribute_Bit_Position => Bit_Position : declare
1239 if Nkind (Pref) = N_Identifier then
1240 CE := Entity (Pref);
1242 CE := Entity (Selector_Name (Pref));
1245 if Known_Static_Component_Bit_Offset (CE) then
1247 Make_Integer_Literal (Loc,
1248 Intval => Component_Bit_Offset (CE)));
1249 Analyze_And_Resolve (N, Typ);
1252 Apply_Universal_Integer_Attribute_Checks (N);
1260 -- A reference to P'Body_Version or P'Version is expanded to
1263 -- pragma Import (C, Vnn, "uuuuT");
1265 -- Get_Version_String (Vnn)
1267 -- where uuuu is the unit name (dots replaced by double underscore)
1268 -- and T is B for the cases of Body_Version, or Version applied to a
1269 -- subprogram acting as its own spec, and S for Version applied to a
1270 -- subprogram spec or package. This sequence of code references the
1271 -- the unsigned constant created in the main program by the binder.
1273 -- A special exception occurs for Standard, where the string returned
1274 -- is a copy of the library string in gnatvsn.ads.
1276 when Attribute_Body_Version | Attribute_Version => Version : declare
1277 E : constant Entity_Id := Make_Temporary (Loc, 'V');
1282 -- If not library unit, get to containing library unit
1284 Pent := Entity (Pref);
1285 while Pent /= Standard_Standard
1286 and then Scope (Pent) /= Standard_Standard
1287 and then not Is_Child_Unit (Pent)
1289 Pent := Scope (Pent);
1292 -- Special case Standard and Standard.ASCII
1294 if Pent = Standard_Standard or else Pent = Standard_ASCII then
1296 Make_String_Literal (Loc,
1297 Strval => Verbose_Library_Version));
1302 -- Build required string constant
1304 Get_Name_String (Get_Unit_Name (Pent));
1307 for J in 1 .. Name_Len - 2 loop
1308 if Name_Buffer (J) = '.' then
1309 Store_String_Chars ("__");
1311 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
1315 -- Case of subprogram acting as its own spec, always use body
1317 if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
1318 and then Nkind (Parent (Declaration_Node (Pent))) =
1320 and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
1322 Store_String_Chars ("B");
1324 -- Case of no body present, always use spec
1326 elsif not Unit_Requires_Body (Pent) then
1327 Store_String_Chars ("S");
1329 -- Otherwise use B for Body_Version, S for spec
1331 elsif Id = Attribute_Body_Version then
1332 Store_String_Chars ("B");
1334 Store_String_Chars ("S");
1338 Lib.Version_Referenced (S);
1340 -- Insert the object declaration
1342 Insert_Actions (N, New_List (
1343 Make_Object_Declaration (Loc,
1344 Defining_Identifier => E,
1345 Object_Definition =>
1346 New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
1348 -- Set entity as imported with correct external name
1350 Set_Is_Imported (E);
1351 Set_Interface_Name (E, Make_String_Literal (Loc, S));
1353 -- Set entity as internal to ensure proper Sprint output of its
1354 -- implicit importation.
1356 Set_Is_Internal (E);
1358 -- And now rewrite original reference
1361 Make_Function_Call (Loc,
1362 Name => New_Reference_To (RTE (RE_Get_Version_String), Loc),
1363 Parameter_Associations => New_List (
1364 New_Occurrence_Of (E, Loc))));
1367 Analyze_And_Resolve (N, RTE (RE_Version_String));
1374 -- Transforms 'Ceiling into a call to the floating-point attribute
1375 -- function Ceiling in Fat_xxx (where xxx is the root type)
1377 when Attribute_Ceiling =>
1378 Expand_Fpt_Attribute_R (N);
1384 -- Transforms 'Callable attribute into a call to the Callable function
1386 when Attribute_Callable => Callable :
1388 -- We have an object of a task interface class-wide type as a prefix
1389 -- to Callable. Generate:
1390 -- callable (Task_Id (Pref._disp_get_task_id));
1392 if Ada_Version >= Ada_05
1393 and then Ekind (Ptyp) = E_Class_Wide_Type
1394 and then Is_Interface (Ptyp)
1395 and then Is_Task_Interface (Ptyp)
1398 Make_Function_Call (Loc,
1400 New_Reference_To (RTE (RE_Callable), Loc),
1401 Parameter_Associations => New_List (
1402 Make_Unchecked_Type_Conversion (Loc,
1404 New_Reference_To (RTE (RO_ST_Task_Id), Loc),
1406 Make_Selected_Component (Loc,
1408 New_Copy_Tree (Pref),
1410 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
1414 Build_Call_With_Task (Pref, RTE (RE_Callable)));
1417 Analyze_And_Resolve (N, Standard_Boolean);
1424 -- Transforms 'Caller attribute into a call to either the
1425 -- Task_Entry_Caller or the Protected_Entry_Caller function.
1427 when Attribute_Caller => Caller : declare
1428 Id_Kind : constant Entity_Id := RTE (RO_AT_Task_Id);
1429 Ent : constant Entity_Id := Entity (Pref);
1430 Conctype : constant Entity_Id := Scope (Ent);
1431 Nest_Depth : Integer := 0;
1438 if Is_Protected_Type (Conctype) then
1439 case Corresponding_Runtime_Package (Conctype) is
1440 when System_Tasking_Protected_Objects_Entries =>
1443 (RTE (RE_Protected_Entry_Caller), Loc);
1445 when System_Tasking_Protected_Objects_Single_Entry =>
1448 (RTE (RE_Protected_Single_Entry_Caller), Loc);
1451 raise Program_Error;
1455 Unchecked_Convert_To (Id_Kind,
1456 Make_Function_Call (Loc,
1458 Parameter_Associations => New_List (
1460 (Find_Protection_Object (Current_Scope), Loc)))));
1465 -- Determine the nesting depth of the E'Caller attribute, that
1466 -- is, how many accept statements are nested within the accept
1467 -- statement for E at the point of E'Caller. The runtime uses
1468 -- this depth to find the specified entry call.
1470 for J in reverse 0 .. Scope_Stack.Last loop
1471 S := Scope_Stack.Table (J).Entity;
1473 -- We should not reach the scope of the entry, as it should
1474 -- already have been checked in Sem_Attr that this attribute
1475 -- reference is within a matching accept statement.
1477 pragma Assert (S /= Conctype);
1482 elsif Is_Entry (S) then
1483 Nest_Depth := Nest_Depth + 1;
1488 Unchecked_Convert_To (Id_Kind,
1489 Make_Function_Call (Loc,
1491 New_Reference_To (RTE (RE_Task_Entry_Caller), Loc),
1492 Parameter_Associations => New_List (
1493 Make_Integer_Literal (Loc,
1494 Intval => Int (Nest_Depth))))));
1497 Analyze_And_Resolve (N, Id_Kind);
1504 -- Transforms 'Compose into a call to the floating-point attribute
1505 -- function Compose in Fat_xxx (where xxx is the root type)
1507 -- Note: we strictly should have special code here to deal with the
1508 -- case of absurdly negative arguments (less than Integer'First)
1509 -- which will return a (signed) zero value, but it hardly seems
1510 -- worth the effort. Absurdly large positive arguments will raise
1511 -- constraint error which is fine.
1513 when Attribute_Compose =>
1514 Expand_Fpt_Attribute_RI (N);
1520 when Attribute_Constrained => Constrained : declare
1521 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
1523 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
1524 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
1525 -- view of an aliased object whose subtype is constrained.
1527 ---------------------------------
1528 -- Is_Constrained_Aliased_View --
1529 ---------------------------------
1531 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
1535 if Is_Entity_Name (Obj) then
1538 if Present (Renamed_Object (E)) then
1539 return Is_Constrained_Aliased_View (Renamed_Object (E));
1541 return Is_Aliased (E) and then Is_Constrained (Etype (E));
1545 return Is_Aliased_View (Obj)
1547 (Is_Constrained (Etype (Obj))
1548 or else (Nkind (Obj) = N_Explicit_Dereference
1550 not Has_Constrained_Partial_View
1551 (Base_Type (Etype (Obj)))));
1553 end Is_Constrained_Aliased_View;
1555 -- Start of processing for Constrained
1558 -- Reference to a parameter where the value is passed as an extra
1559 -- actual, corresponding to the extra formal referenced by the
1560 -- Extra_Constrained field of the corresponding formal. If this
1561 -- is an entry in-parameter, it is replaced by a constant renaming
1562 -- for which Extra_Constrained is never created.
1564 if Present (Formal_Ent)
1565 and then Ekind (Formal_Ent) /= E_Constant
1566 and then Present (Extra_Constrained (Formal_Ent))
1570 (Extra_Constrained (Formal_Ent), Sloc (N)));
1572 -- For variables with a Extra_Constrained field, we use the
1573 -- corresponding entity.
1575 elsif Nkind (Pref) = N_Identifier
1576 and then Ekind (Entity (Pref)) = E_Variable
1577 and then Present (Extra_Constrained (Entity (Pref)))
1581 (Extra_Constrained (Entity (Pref)), Sloc (N)));
1583 -- For all other entity names, we can tell at compile time
1585 elsif Is_Entity_Name (Pref) then
1587 Ent : constant Entity_Id := Entity (Pref);
1591 -- (RM J.4) obsolescent cases
1593 if Is_Type (Ent) then
1597 if Is_Private_Type (Ent) then
1598 Res := not Has_Discriminants (Ent)
1599 or else Is_Constrained (Ent);
1601 -- It not a private type, must be a generic actual type
1602 -- that corresponded to a private type. We know that this
1603 -- correspondence holds, since otherwise the reference
1604 -- within the generic template would have been illegal.
1607 if Is_Composite_Type (Underlying_Type (Ent)) then
1608 Res := Is_Constrained (Ent);
1614 -- If the prefix is not a variable or is aliased, then
1615 -- definitely true; if it's a formal parameter without an
1616 -- associated extra formal, then treat it as constrained.
1618 -- Ada 2005 (AI-363): An aliased prefix must be known to be
1619 -- constrained in order to set the attribute to True.
1621 elsif not Is_Variable (Pref)
1622 or else Present (Formal_Ent)
1623 or else (Ada_Version < Ada_05
1624 and then Is_Aliased_View (Pref))
1625 or else (Ada_Version >= Ada_05
1626 and then Is_Constrained_Aliased_View (Pref))
1630 -- Variable case, look at type to see if it is constrained.
1631 -- Note that the one case where this is not accurate (the
1632 -- procedure formal case), has been handled above.
1634 -- We use the Underlying_Type here (and below) in case the
1635 -- type is private without discriminants, but the full type
1636 -- has discriminants. This case is illegal, but we generate it
1637 -- internally for passing to the Extra_Constrained parameter.
1640 Res := Is_Constrained (Underlying_Type (Etype (Ent)));
1644 New_Reference_To (Boolean_Literals (Res), Loc));
1647 -- Prefix is not an entity name. These are also cases where we can
1648 -- always tell at compile time by looking at the form and type of the
1649 -- prefix. If an explicit dereference of an object with constrained
1650 -- partial view, this is unconstrained (Ada 2005 AI-363).
1656 not Is_Variable (Pref)
1658 (Nkind (Pref) = N_Explicit_Dereference
1660 not Has_Constrained_Partial_View (Base_Type (Ptyp)))
1661 or else Is_Constrained (Underlying_Type (Ptyp))),
1665 Analyze_And_Resolve (N, Standard_Boolean);
1672 -- Transforms 'Copy_Sign into a call to the floating-point attribute
1673 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
1675 when Attribute_Copy_Sign =>
1676 Expand_Fpt_Attribute_RR (N);
1682 -- Transforms 'Count attribute into a call to the Count function
1684 when Attribute_Count => Count : declare
1686 Conctyp : Entity_Id;
1688 Entry_Id : Entity_Id;
1693 -- If the prefix is a member of an entry family, retrieve both
1694 -- entry name and index. For a simple entry there is no index.
1696 if Nkind (Pref) = N_Indexed_Component then
1697 Entnam := Prefix (Pref);
1698 Index := First (Expressions (Pref));
1704 Entry_Id := Entity (Entnam);
1706 -- Find the concurrent type in which this attribute is referenced
1707 -- (there had better be one).
1709 Conctyp := Current_Scope;
1710 while not Is_Concurrent_Type (Conctyp) loop
1711 Conctyp := Scope (Conctyp);
1716 if Is_Protected_Type (Conctyp) then
1717 case Corresponding_Runtime_Package (Conctyp) is
1718 when System_Tasking_Protected_Objects_Entries =>
1719 Name := New_Reference_To (RTE (RE_Protected_Count), Loc);
1722 Make_Function_Call (Loc,
1724 Parameter_Associations => New_List (
1726 (Find_Protection_Object (Current_Scope), Loc),
1727 Entry_Index_Expression
1728 (Loc, Entry_Id, Index, Scope (Entry_Id))));
1730 when System_Tasking_Protected_Objects_Single_Entry =>
1732 New_Reference_To (RTE (RE_Protected_Count_Entry), Loc);
1735 Make_Function_Call (Loc,
1737 Parameter_Associations => New_List (
1739 (Find_Protection_Object (Current_Scope), Loc)));
1742 raise Program_Error;
1749 Make_Function_Call (Loc,
1750 Name => New_Reference_To (RTE (RE_Task_Count), Loc),
1751 Parameter_Associations => New_List (
1752 Entry_Index_Expression (Loc,
1753 Entry_Id, Index, Scope (Entry_Id))));
1756 -- The call returns type Natural but the context is universal integer
1757 -- so any integer type is allowed. The attribute was already resolved
1758 -- so its Etype is the required result type. If the base type of the
1759 -- context type is other than Standard.Integer we put in a conversion
1760 -- to the required type. This can be a normal typed conversion since
1761 -- both input and output types of the conversion are integer types
1763 if Base_Type (Typ) /= Base_Type (Standard_Integer) then
1764 Rewrite (N, Convert_To (Typ, Call));
1769 Analyze_And_Resolve (N, Typ);
1776 -- This processing is shared by Elab_Spec
1778 -- What we do is to insert the following declarations
1781 -- pragma Import (C, enn, "name___elabb/s");
1783 -- and then the Elab_Body/Spec attribute is replaced by a reference
1784 -- to this defining identifier.
1786 when Attribute_Elab_Body |
1787 Attribute_Elab_Spec =>
1790 Ent : constant Entity_Id := Make_Temporary (Loc, 'E');
1794 procedure Make_Elab_String (Nod : Node_Id);
1795 -- Given Nod, an identifier, or a selected component, put the
1796 -- image into the current string literal, with double underline
1797 -- between components.
1799 ----------------------
1800 -- Make_Elab_String --
1801 ----------------------
1803 procedure Make_Elab_String (Nod : Node_Id) is
1805 if Nkind (Nod) = N_Selected_Component then
1806 Make_Elab_String (Prefix (Nod));
1810 Store_String_Char ('$');
1812 Store_String_Char ('.');
1814 Store_String_Char ('_');
1815 Store_String_Char ('_');
1818 Get_Name_String (Chars (Selector_Name (Nod)));
1821 pragma Assert (Nkind (Nod) = N_Identifier);
1822 Get_Name_String (Chars (Nod));
1825 Store_String_Chars (Name_Buffer (1 .. Name_Len));
1826 end Make_Elab_String;
1828 -- Start of processing for Elab_Body/Elab_Spec
1831 -- First we need to prepare the string literal for the name of
1832 -- the elaboration routine to be referenced.
1835 Make_Elab_String (Pref);
1837 if VM_Target = No_VM then
1838 Store_String_Chars ("___elab");
1839 Lang := Make_Identifier (Loc, Name_C);
1841 Store_String_Chars ("._elab");
1842 Lang := Make_Identifier (Loc, Name_Ada);
1845 if Id = Attribute_Elab_Body then
1846 Store_String_Char ('b');
1848 Store_String_Char ('s');
1853 Insert_Actions (N, New_List (
1854 Make_Subprogram_Declaration (Loc,
1856 Make_Procedure_Specification (Loc,
1857 Defining_Unit_Name => Ent)),
1860 Chars => Name_Import,
1861 Pragma_Argument_Associations => New_List (
1862 Make_Pragma_Argument_Association (Loc,
1863 Expression => Lang),
1865 Make_Pragma_Argument_Association (Loc,
1867 Make_Identifier (Loc, Chars (Ent))),
1869 Make_Pragma_Argument_Association (Loc,
1871 Make_String_Literal (Loc, Str))))));
1873 Set_Entity (N, Ent);
1874 Rewrite (N, New_Occurrence_Of (Ent, Loc));
1881 -- Elaborated is always True for preelaborated units, predefined units,
1882 -- pure units and units which have Elaborate_Body pragmas. These units
1883 -- have no elaboration entity.
1885 -- Note: The Elaborated attribute is never passed to the back end
1887 when Attribute_Elaborated => Elaborated : declare
1888 Ent : constant Entity_Id := Entity (Pref);
1891 if Present (Elaboration_Entity (Ent)) then
1893 New_Occurrence_Of (Elaboration_Entity (Ent), Loc));
1895 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
1903 when Attribute_Enum_Rep => Enum_Rep :
1905 -- X'Enum_Rep (Y) expands to
1909 -- This is simply a direct conversion from the enumeration type to
1910 -- the target integer type, which is treated by the back end as a
1911 -- normal integer conversion, treating the enumeration type as an
1912 -- integer, which is exactly what we want! We set Conversion_OK to
1913 -- make sure that the analyzer does not complain about what otherwise
1914 -- might be an illegal conversion.
1916 if Is_Non_Empty_List (Exprs) then
1918 OK_Convert_To (Typ, Relocate_Node (First (Exprs))));
1920 -- X'Enum_Rep where X is an enumeration literal is replaced by
1921 -- the literal value.
1923 elsif Ekind (Entity (Pref)) = E_Enumeration_Literal then
1925 Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref))));
1927 -- If this is a renaming of a literal, recover the representation
1930 elsif Ekind (Entity (Pref)) = E_Constant
1931 and then Present (Renamed_Object (Entity (Pref)))
1933 Ekind (Entity (Renamed_Object (Entity (Pref))))
1934 = E_Enumeration_Literal
1937 Make_Integer_Literal (Loc,
1938 Enumeration_Rep (Entity (Renamed_Object (Entity (Pref))))));
1940 -- X'Enum_Rep where X is an object does a direct unchecked conversion
1941 -- of the object value, as described for the type case above.
1945 OK_Convert_To (Typ, Relocate_Node (Pref)));
1949 Analyze_And_Resolve (N, Typ);
1956 when Attribute_Enum_Val => Enum_Val : declare
1958 Btyp : constant Entity_Id := Base_Type (Ptyp);
1961 -- X'Enum_Val (Y) expands to
1963 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
1966 Expr := Unchecked_Convert_To (Ptyp, First (Exprs));
1969 Make_Raise_Constraint_Error (Loc,
1973 Make_Function_Call (Loc,
1975 New_Reference_To (TSS (Btyp, TSS_Rep_To_Pos), Loc),
1976 Parameter_Associations => New_List (
1977 Relocate_Node (Duplicate_Subexpr (Expr)),
1978 New_Occurrence_Of (Standard_False, Loc))),
1980 Right_Opnd => Make_Integer_Literal (Loc, -1)),
1981 Reason => CE_Range_Check_Failed));
1984 Analyze_And_Resolve (N, Ptyp);
1991 -- Transforms 'Exponent into a call to the floating-point attribute
1992 -- function Exponent in Fat_xxx (where xxx is the root type)
1994 when Attribute_Exponent =>
1995 Expand_Fpt_Attribute_R (N);
2001 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
2003 when Attribute_External_Tag => External_Tag :
2006 Make_Function_Call (Loc,
2007 Name => New_Reference_To (RTE (RE_External_Tag), Loc),
2008 Parameter_Associations => New_List (
2009 Make_Attribute_Reference (Loc,
2010 Attribute_Name => Name_Tag,
2011 Prefix => Prefix (N)))));
2013 Analyze_And_Resolve (N, Standard_String);
2020 when Attribute_First =>
2022 -- If the prefix type is a constrained packed array type which
2023 -- already has a Packed_Array_Type representation defined, then
2024 -- replace this attribute with a direct reference to 'First of the
2025 -- appropriate index subtype (since otherwise the back end will try
2026 -- to give us the value of 'First for this implementation type).
2028 if Is_Constrained_Packed_Array (Ptyp) then
2030 Make_Attribute_Reference (Loc,
2031 Attribute_Name => Name_First,
2032 Prefix => New_Reference_To (Get_Index_Subtype (N), Loc)));
2033 Analyze_And_Resolve (N, Typ);
2035 elsif Is_Access_Type (Ptyp) then
2036 Apply_Access_Check (N);
2043 -- Compute this if component clause was present, otherwise we leave the
2044 -- computation to be completed in the back-end, since we don't know what
2045 -- layout will be chosen.
2047 when Attribute_First_Bit => First_Bit : declare
2048 CE : constant Entity_Id := Entity (Selector_Name (Pref));
2051 if Known_Static_Component_Bit_Offset (CE) then
2053 Make_Integer_Literal (Loc,
2054 Component_Bit_Offset (CE) mod System_Storage_Unit));
2056 Analyze_And_Resolve (N, Typ);
2059 Apply_Universal_Integer_Attribute_Checks (N);
2069 -- fixtype'Fixed_Value (integer-value)
2073 -- fixtype(integer-value)
2075 -- We do all the required analysis of the conversion here, because we do
2076 -- not want this to go through the fixed-point conversion circuits. Note
2077 -- that the back end always treats fixed-point as equivalent to the
2078 -- corresponding integer type anyway.
2080 when Attribute_Fixed_Value => Fixed_Value :
2083 Make_Type_Conversion (Loc,
2084 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
2085 Expression => Relocate_Node (First (Exprs))));
2086 Set_Etype (N, Entity (Pref));
2089 -- Note: it might appear that a properly analyzed unchecked conversion
2090 -- would be just fine here, but that's not the case, since the full
2091 -- range checks performed by the following call are critical!
2093 Apply_Type_Conversion_Checks (N);
2100 -- Transforms 'Floor into a call to the floating-point attribute
2101 -- function Floor in Fat_xxx (where xxx is the root type)
2103 when Attribute_Floor =>
2104 Expand_Fpt_Attribute_R (N);
2110 -- For the fixed-point type Typ:
2116 -- Result_Type (System.Fore (Universal_Real (Type'First)),
2117 -- Universal_Real (Type'Last))
2119 -- Note that we know that the type is a non-static subtype, or Fore
2120 -- would have itself been computed dynamically in Eval_Attribute.
2122 when Attribute_Fore => Fore : begin
2125 Make_Function_Call (Loc,
2126 Name => New_Reference_To (RTE (RE_Fore), Loc),
2128 Parameter_Associations => New_List (
2129 Convert_To (Universal_Real,
2130 Make_Attribute_Reference (Loc,
2131 Prefix => New_Reference_To (Ptyp, Loc),
2132 Attribute_Name => Name_First)),
2134 Convert_To (Universal_Real,
2135 Make_Attribute_Reference (Loc,
2136 Prefix => New_Reference_To (Ptyp, Loc),
2137 Attribute_Name => Name_Last))))));
2139 Analyze_And_Resolve (N, Typ);
2146 -- Transforms 'Fraction into a call to the floating-point attribute
2147 -- function Fraction in Fat_xxx (where xxx is the root type)
2149 when Attribute_Fraction =>
2150 Expand_Fpt_Attribute_R (N);
2156 when Attribute_From_Any => From_Any : declare
2157 P_Type : constant Entity_Id := Etype (Pref);
2158 Decls : constant List_Id := New_List;
2161 Build_From_Any_Call (P_Type,
2162 Relocate_Node (First (Exprs)),
2164 Insert_Actions (N, Decls);
2165 Analyze_And_Resolve (N, P_Type);
2172 -- For an exception returns a reference to the exception data:
2173 -- Exception_Id!(Prefix'Reference)
2175 -- For a task it returns a reference to the _task_id component of
2176 -- corresponding record:
2178 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
2180 -- in Ada.Task_Identification
2182 when Attribute_Identity => Identity : declare
2183 Id_Kind : Entity_Id;
2186 if Ptyp = Standard_Exception_Type then
2187 Id_Kind := RTE (RE_Exception_Id);
2189 if Present (Renamed_Object (Entity (Pref))) then
2190 Set_Entity (Pref, Renamed_Object (Entity (Pref)));
2194 Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref)));
2196 Id_Kind := RTE (RO_AT_Task_Id);
2198 -- If the prefix is a task interface, the Task_Id is obtained
2199 -- dynamically through a dispatching call, as for other task
2200 -- attributes applied to interfaces.
2202 if Ada_Version >= Ada_05
2203 and then Ekind (Ptyp) = E_Class_Wide_Type
2204 and then Is_Interface (Ptyp)
2205 and then Is_Task_Interface (Ptyp)
2208 Unchecked_Convert_To (Id_Kind,
2209 Make_Selected_Component (Loc,
2211 New_Copy_Tree (Pref),
2213 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))));
2217 Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
2221 Analyze_And_Resolve (N, Id_Kind);
2228 -- Image attribute is handled in separate unit Exp_Imgv
2230 when Attribute_Image =>
2231 Exp_Imgv.Expand_Image_Attribute (N);
2237 -- X'Img is expanded to typ'Image (X), where typ is the type of X
2239 when Attribute_Img => Img :
2242 Make_Attribute_Reference (Loc,
2243 Prefix => New_Reference_To (Ptyp, Loc),
2244 Attribute_Name => Name_Image,
2245 Expressions => New_List (Relocate_Node (Pref))));
2247 Analyze_And_Resolve (N, Standard_String);
2254 when Attribute_Input => Input : declare
2255 P_Type : constant Entity_Id := Entity (Pref);
2256 B_Type : constant Entity_Id := Base_Type (P_Type);
2257 U_Type : constant Entity_Id := Underlying_Type (P_Type);
2258 Strm : constant Node_Id := First (Exprs);
2266 Cntrl : Node_Id := Empty;
2267 -- Value for controlling argument in call. Always Empty except in
2268 -- the dispatching (class-wide type) case, where it is a reference
2269 -- to the dummy object initialized to the right internal tag.
2271 procedure Freeze_Stream_Subprogram (F : Entity_Id);
2272 -- The expansion of the attribute reference may generate a call to
2273 -- a user-defined stream subprogram that is frozen by the call. This
2274 -- can lead to access-before-elaboration problem if the reference
2275 -- appears in an object declaration and the subprogram body has not
2276 -- been seen. The freezing of the subprogram requires special code
2277 -- because it appears in an expanded context where expressions do
2278 -- not freeze their constituents.
2280 ------------------------------
2281 -- Freeze_Stream_Subprogram --
2282 ------------------------------
2284 procedure Freeze_Stream_Subprogram (F : Entity_Id) is
2285 Decl : constant Node_Id := Unit_Declaration_Node (F);
2289 -- If this is user-defined subprogram, the corresponding
2290 -- stream function appears as a renaming-as-body, and the
2291 -- user subprogram must be retrieved by tree traversal.
2294 and then Nkind (Decl) = N_Subprogram_Declaration
2295 and then Present (Corresponding_Body (Decl))
2297 Bod := Corresponding_Body (Decl);
2299 if Nkind (Unit_Declaration_Node (Bod)) =
2300 N_Subprogram_Renaming_Declaration
2302 Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod))));
2305 end Freeze_Stream_Subprogram;
2307 -- Start of processing for Input
2310 -- If no underlying type, we have an error that will be diagnosed
2311 -- elsewhere, so here we just completely ignore the expansion.
2317 -- If there is a TSS for Input, just call it
2319 Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
2321 if Present (Fname) then
2325 -- If there is a Stream_Convert pragma, use it, we rewrite
2327 -- sourcetyp'Input (stream)
2331 -- sourcetyp (streamread (strmtyp'Input (stream)));
2333 -- where streamread is the given Read function that converts an
2334 -- argument of type strmtyp to type sourcetyp or a type from which
2335 -- it is derived (extra conversion required for the derived case).
2337 Prag := Get_Stream_Convert_Pragma (P_Type);
2339 if Present (Prag) then
2340 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
2341 Rfunc := Entity (Expression (Arg2));
2345 Make_Function_Call (Loc,
2346 Name => New_Occurrence_Of (Rfunc, Loc),
2347 Parameter_Associations => New_List (
2348 Make_Attribute_Reference (Loc,
2351 (Etype (First_Formal (Rfunc)), Loc),
2352 Attribute_Name => Name_Input,
2353 Expressions => Exprs)))));
2355 Analyze_And_Resolve (N, B_Type);
2360 elsif Is_Elementary_Type (U_Type) then
2362 -- A special case arises if we have a defined _Read routine,
2363 -- since in this case we are required to call this routine.
2365 if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then
2366 Build_Record_Or_Elementary_Input_Function
2367 (Loc, U_Type, Decl, Fname);
2368 Insert_Action (N, Decl);
2370 -- For normal cases, we call the I_xxx routine directly
2373 Rewrite (N, Build_Elementary_Input_Call (N));
2374 Analyze_And_Resolve (N, P_Type);
2380 elsif Is_Array_Type (U_Type) then
2381 Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
2382 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
2384 -- Dispatching case with class-wide type
2386 elsif Is_Class_Wide_Type (P_Type) then
2388 -- No need to do anything else compiling under restriction
2389 -- No_Dispatching_Calls. During the semantic analysis we
2390 -- already notified such violation.
2392 if Restriction_Active (No_Dispatching_Calls) then
2397 Rtyp : constant Entity_Id := Root_Type (P_Type);
2403 -- Read the internal tag (RM 13.13.2(34)) and use it to
2404 -- initialize a dummy tag object:
2406 -- Dnn : Ada.Tags.Tag :=
2407 -- Descendant_Tag (String'Input (Strm), P_Type);
2409 -- This dummy object is used only to provide a controlling
2410 -- argument for the eventual _Input call. Descendant_Tag is
2411 -- called rather than Internal_Tag to ensure that we have a
2412 -- tag for a type that is descended from the prefix type and
2413 -- declared at the same accessibility level (the exception
2414 -- Tag_Error will be raised otherwise). The level check is
2415 -- required for Ada 2005 because tagged types can be
2416 -- extended in nested scopes (AI-344).
2419 Make_Function_Call (Loc,
2421 New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
2422 Parameter_Associations => New_List (
2423 Make_Attribute_Reference (Loc,
2424 Prefix => New_Occurrence_Of (Standard_String, Loc),
2425 Attribute_Name => Name_Input,
2426 Expressions => New_List (
2427 Relocate_Node (Duplicate_Subexpr (Strm)))),
2428 Make_Attribute_Reference (Loc,
2429 Prefix => New_Reference_To (P_Type, Loc),
2430 Attribute_Name => Name_Tag)));
2432 Dnn := Make_Temporary (Loc, 'D', Expr);
2435 Make_Object_Declaration (Loc,
2436 Defining_Identifier => Dnn,
2437 Object_Definition =>
2438 New_Occurrence_Of (RTE (RE_Tag), Loc),
2439 Expression => Expr);
2441 Insert_Action (N, Decl);
2443 -- Now we need to get the entity for the call, and construct
2444 -- a function call node, where we preset a reference to Dnn
2445 -- as the controlling argument (doing an unchecked convert
2446 -- to the class-wide tagged type to make it look like a real
2449 Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
2451 Unchecked_Convert_To (P_Type,
2452 New_Occurrence_Of (Dnn, Loc));
2453 Set_Etype (Cntrl, P_Type);
2454 Set_Parent (Cntrl, N);
2457 -- For tagged types, use the primitive Input function
2459 elsif Is_Tagged_Type (U_Type) then
2460 Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
2462 -- All other record type cases, including protected records. The
2463 -- latter only arise for expander generated code for handling
2464 -- shared passive partition access.
2468 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
2470 -- Ada 2005 (AI-216): Program_Error is raised executing default
2471 -- implementation of the Input attribute of an unchecked union
2472 -- type if the type lacks default discriminant values.
2474 if Is_Unchecked_Union (Base_Type (U_Type))
2475 and then No (Discriminant_Constraint (U_Type))
2478 Make_Raise_Program_Error (Loc,
2479 Reason => PE_Unchecked_Union_Restriction));
2484 Build_Record_Or_Elementary_Input_Function
2485 (Loc, Base_Type (U_Type), Decl, Fname);
2486 Insert_Action (N, Decl);
2488 if Nkind (Parent (N)) = N_Object_Declaration
2489 and then Is_Record_Type (U_Type)
2491 -- The stream function may contain calls to user-defined
2492 -- Read procedures for individual components.
2499 Comp := First_Component (U_Type);
2500 while Present (Comp) loop
2502 Find_Stream_Subprogram
2503 (Etype (Comp), TSS_Stream_Read);
2505 if Present (Func) then
2506 Freeze_Stream_Subprogram (Func);
2509 Next_Component (Comp);
2516 -- If we fall through, Fname is the function to be called. The result
2517 -- is obtained by calling the appropriate function, then converting
2518 -- the result. The conversion does a subtype check.
2521 Make_Function_Call (Loc,
2522 Name => New_Occurrence_Of (Fname, Loc),
2523 Parameter_Associations => New_List (
2524 Relocate_Node (Strm)));
2526 Set_Controlling_Argument (Call, Cntrl);
2527 Rewrite (N, Unchecked_Convert_To (P_Type, Call));
2528 Analyze_And_Resolve (N, P_Type);
2530 if Nkind (Parent (N)) = N_Object_Declaration then
2531 Freeze_Stream_Subprogram (Fname);
2541 -- inttype'Fixed_Value (fixed-value)
2545 -- inttype(integer-value))
2547 -- we do all the required analysis of the conversion here, because we do
2548 -- not want this to go through the fixed-point conversion circuits. Note
2549 -- that the back end always treats fixed-point as equivalent to the
2550 -- corresponding integer type anyway.
2552 when Attribute_Integer_Value => Integer_Value :
2555 Make_Type_Conversion (Loc,
2556 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
2557 Expression => Relocate_Node (First (Exprs))));
2558 Set_Etype (N, Entity (Pref));
2561 -- Note: it might appear that a properly analyzed unchecked conversion
2562 -- would be just fine here, but that's not the case, since the full
2563 -- range checks performed by the following call are critical!
2565 Apply_Type_Conversion_Checks (N);
2572 when Attribute_Invalid_Value =>
2573 Rewrite (N, Get_Simple_Init_Val (Ptyp, N));
2579 when Attribute_Last =>
2581 -- If the prefix type is a constrained packed array type which
2582 -- already has a Packed_Array_Type representation defined, then
2583 -- replace this attribute with a direct reference to 'Last of the
2584 -- appropriate index subtype (since otherwise the back end will try
2585 -- to give us the value of 'Last for this implementation type).
2587 if Is_Constrained_Packed_Array (Ptyp) then
2589 Make_Attribute_Reference (Loc,
2590 Attribute_Name => Name_Last,
2591 Prefix => New_Reference_To (Get_Index_Subtype (N), Loc)));
2592 Analyze_And_Resolve (N, Typ);
2594 elsif Is_Access_Type (Ptyp) then
2595 Apply_Access_Check (N);
2602 -- We compute this if a component clause was present, otherwise we leave
2603 -- the computation up to the back end, since we don't know what layout
2606 when Attribute_Last_Bit => Last_Bit : declare
2607 CE : constant Entity_Id := Entity (Selector_Name (Pref));
2610 if Known_Static_Component_Bit_Offset (CE)
2611 and then Known_Static_Esize (CE)
2614 Make_Integer_Literal (Loc,
2615 Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
2618 Analyze_And_Resolve (N, Typ);
2621 Apply_Universal_Integer_Attribute_Checks (N);
2629 -- Transforms 'Leading_Part into a call to the floating-point attribute
2630 -- function Leading_Part in Fat_xxx (where xxx is the root type)
2632 -- Note: strictly, we should generate special case code to deal with
2633 -- absurdly large positive arguments (greater than Integer'Last), which
2634 -- result in returning the first argument unchanged, but it hardly seems
2635 -- worth the effort. We raise constraint error for absurdly negative
2636 -- arguments which is fine.
2638 when Attribute_Leading_Part =>
2639 Expand_Fpt_Attribute_RI (N);
2645 when Attribute_Length => declare
2650 -- Processing for packed array types
2652 if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
2653 Ityp := Get_Index_Subtype (N);
2655 -- If the index type, Ityp, is an enumeration type with holes,
2656 -- then we calculate X'Length explicitly using
2659 -- (0, Ityp'Pos (X'Last (N)) -
2660 -- Ityp'Pos (X'First (N)) + 1);
2662 -- Since the bounds in the template are the representation values
2663 -- and the back end would get the wrong value.
2665 if Is_Enumeration_Type (Ityp)
2666 and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
2671 Xnum := Expr_Value (First (Expressions (N)));
2675 Make_Attribute_Reference (Loc,
2676 Prefix => New_Occurrence_Of (Typ, Loc),
2677 Attribute_Name => Name_Max,
2678 Expressions => New_List
2679 (Make_Integer_Literal (Loc, 0),
2683 Make_Op_Subtract (Loc,
2685 Make_Attribute_Reference (Loc,
2686 Prefix => New_Occurrence_Of (Ityp, Loc),
2687 Attribute_Name => Name_Pos,
2689 Expressions => New_List (
2690 Make_Attribute_Reference (Loc,
2691 Prefix => Duplicate_Subexpr (Pref),
2692 Attribute_Name => Name_Last,
2693 Expressions => New_List (
2694 Make_Integer_Literal (Loc, Xnum))))),
2697 Make_Attribute_Reference (Loc,
2698 Prefix => New_Occurrence_Of (Ityp, Loc),
2699 Attribute_Name => Name_Pos,
2701 Expressions => New_List (
2702 Make_Attribute_Reference (Loc,
2704 Duplicate_Subexpr_No_Checks (Pref),
2705 Attribute_Name => Name_First,
2706 Expressions => New_List (
2707 Make_Integer_Literal (Loc, Xnum)))))),
2709 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
2711 Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
2714 -- If the prefix type is a constrained packed array type which
2715 -- already has a Packed_Array_Type representation defined, then
2716 -- replace this attribute with a direct reference to 'Range_Length
2717 -- of the appropriate index subtype (since otherwise the back end
2718 -- will try to give us the value of 'Length for this
2719 -- implementation type).
2721 elsif Is_Constrained (Ptyp) then
2723 Make_Attribute_Reference (Loc,
2724 Attribute_Name => Name_Range_Length,
2725 Prefix => New_Reference_To (Ityp, Loc)));
2726 Analyze_And_Resolve (N, Typ);
2731 elsif Is_Access_Type (Ptyp) then
2732 Apply_Access_Check (N);
2734 -- If the designated type is a packed array type, then we convert
2735 -- the reference to:
2738 -- xtyp'Pos (Pref'Last (Expr)) -
2739 -- xtyp'Pos (Pref'First (Expr)));
2741 -- This is a bit complex, but it is the easiest thing to do that
2742 -- works in all cases including enum types with holes xtyp here
2743 -- is the appropriate index type.
2746 Dtyp : constant Entity_Id := Designated_Type (Ptyp);
2750 if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
2751 Xtyp := Get_Index_Subtype (N);
2754 Make_Attribute_Reference (Loc,
2755 Prefix => New_Occurrence_Of (Typ, Loc),
2756 Attribute_Name => Name_Max,
2757 Expressions => New_List (
2758 Make_Integer_Literal (Loc, 0),
2761 Make_Integer_Literal (Loc, 1),
2762 Make_Op_Subtract (Loc,
2764 Make_Attribute_Reference (Loc,
2765 Prefix => New_Occurrence_Of (Xtyp, Loc),
2766 Attribute_Name => Name_Pos,
2767 Expressions => New_List (
2768 Make_Attribute_Reference (Loc,
2769 Prefix => Duplicate_Subexpr (Pref),
2770 Attribute_Name => Name_Last,
2772 New_Copy_List (Exprs)))),
2775 Make_Attribute_Reference (Loc,
2776 Prefix => New_Occurrence_Of (Xtyp, Loc),
2777 Attribute_Name => Name_Pos,
2778 Expressions => New_List (
2779 Make_Attribute_Reference (Loc,
2781 Duplicate_Subexpr_No_Checks (Pref),
2782 Attribute_Name => Name_First,
2784 New_Copy_List (Exprs)))))))));
2786 Analyze_And_Resolve (N, Typ);
2790 -- Otherwise leave it to the back end
2793 Apply_Universal_Integer_Attribute_Checks (N);
2801 -- Transforms 'Machine into a call to the floating-point attribute
2802 -- function Machine in Fat_xxx (where xxx is the root type)
2804 when Attribute_Machine =>
2805 Expand_Fpt_Attribute_R (N);
2807 ----------------------
2808 -- Machine_Rounding --
2809 ----------------------
2811 -- Transforms 'Machine_Rounding into a call to the floating-point
2812 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
2813 -- type). Expansion is avoided for cases the back end can handle
2816 when Attribute_Machine_Rounding =>
2817 if not Is_Inline_Floating_Point_Attribute (N) then
2818 Expand_Fpt_Attribute_R (N);
2825 -- Machine_Size is equivalent to Object_Size, so transform it into
2826 -- Object_Size and that way the back end never sees Machine_Size.
2828 when Attribute_Machine_Size =>
2830 Make_Attribute_Reference (Loc,
2831 Prefix => Prefix (N),
2832 Attribute_Name => Name_Object_Size));
2834 Analyze_And_Resolve (N, Typ);
2840 -- The only case that can get this far is the dynamic case of the old
2841 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
2848 -- ityp (System.Mantissa.Mantissa_Value
2849 -- (Integer'Integer_Value (typ'First),
2850 -- Integer'Integer_Value (typ'Last)));
2852 when Attribute_Mantissa => Mantissa : begin
2855 Make_Function_Call (Loc,
2856 Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
2858 Parameter_Associations => New_List (
2860 Make_Attribute_Reference (Loc,
2861 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2862 Attribute_Name => Name_Integer_Value,
2863 Expressions => New_List (
2865 Make_Attribute_Reference (Loc,
2866 Prefix => New_Occurrence_Of (Ptyp, Loc),
2867 Attribute_Name => Name_First))),
2869 Make_Attribute_Reference (Loc,
2870 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2871 Attribute_Name => Name_Integer_Value,
2872 Expressions => New_List (
2874 Make_Attribute_Reference (Loc,
2875 Prefix => New_Occurrence_Of (Ptyp, Loc),
2876 Attribute_Name => Name_Last)))))));
2878 Analyze_And_Resolve (N, Typ);
2881 --------------------
2882 -- Mechanism_Code --
2883 --------------------
2885 when Attribute_Mechanism_Code =>
2887 -- We must replace the prefix in the renamed case
2889 if Is_Entity_Name (Pref)
2890 and then Present (Alias (Entity (Pref)))
2892 Set_Renamed_Subprogram (Pref, Alias (Entity (Pref)));
2899 when Attribute_Mod => Mod_Case : declare
2900 Arg : constant Node_Id := Relocate_Node (First (Exprs));
2901 Hi : constant Node_Id := Type_High_Bound (Etype (Arg));
2902 Modv : constant Uint := Modulus (Btyp);
2906 -- This is not so simple. The issue is what type to use for the
2907 -- computation of the modular value.
2909 -- The easy case is when the modulus value is within the bounds
2910 -- of the signed integer type of the argument. In this case we can
2911 -- just do the computation in that signed integer type, and then
2912 -- do an ordinary conversion to the target type.
2914 if Modv <= Expr_Value (Hi) then
2919 Right_Opnd => Make_Integer_Literal (Loc, Modv))));
2921 -- Here we know that the modulus is larger than type'Last of the
2922 -- integer type. There are two cases to consider:
2924 -- a) The integer value is non-negative. In this case, it is
2925 -- returned as the result (since it is less than the modulus).
2927 -- b) The integer value is negative. In this case, we know that the
2928 -- result is modulus + value, where the value might be as small as
2929 -- -modulus. The trouble is what type do we use to do the subtract.
2930 -- No type will do, since modulus can be as big as 2**64, and no
2931 -- integer type accommodates this value. Let's do bit of algebra
2934 -- = modulus - (-value)
2935 -- = (modulus - 1) - (-value - 1)
2937 -- Now modulus - 1 is certainly in range of the modular type.
2938 -- -value is in the range 1 .. modulus, so -value -1 is in the
2939 -- range 0 .. modulus-1 which is in range of the modular type.
2940 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
2941 -- which we can compute using the integer base type.
2943 -- Once this is done we analyze the conditional expression without
2944 -- range checks, because we know everything is in range, and we
2945 -- want to prevent spurious warnings on either branch.
2949 Make_Conditional_Expression (Loc,
2950 Expressions => New_List (
2952 Left_Opnd => Duplicate_Subexpr (Arg),
2953 Right_Opnd => Make_Integer_Literal (Loc, 0)),
2956 Duplicate_Subexpr_No_Checks (Arg)),
2958 Make_Op_Subtract (Loc,
2960 Make_Integer_Literal (Loc,
2961 Intval => Modv - 1),
2967 Left_Opnd => Duplicate_Subexpr_No_Checks (Arg),
2969 Make_Integer_Literal (Loc,
2970 Intval => 1))))))));
2974 Analyze_And_Resolve (N, Btyp, Suppress => All_Checks);
2981 -- Transforms 'Model into a call to the floating-point attribute
2982 -- function Model in Fat_xxx (where xxx is the root type)
2984 when Attribute_Model =>
2985 Expand_Fpt_Attribute_R (N);
2991 -- The processing for Object_Size shares the processing for Size
2997 when Attribute_Old => Old : declare
2998 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', Pref);
3003 -- Find the nearest subprogram body, ignoring _Preconditions
3007 Subp := Parent (Subp);
3008 exit when Nkind (Subp) = N_Subprogram_Body
3009 and then Chars (Defining_Entity (Subp)) /= Name_uPostconditions;
3012 -- Insert the assignment at the start of the declarations
3015 Make_Object_Declaration (Loc,
3016 Defining_Identifier => Tnn,
3017 Constant_Present => True,
3018 Object_Definition => New_Occurrence_Of (Etype (N), Loc),
3019 Expression => Pref);
3021 if Is_Empty_List (Declarations (Subp)) then
3022 Set_Declarations (Subp, New_List (Asn_Stm));
3025 Insert_Action (First (Declarations (Subp)), Asn_Stm);
3028 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
3035 when Attribute_Output => Output : declare
3036 P_Type : constant Entity_Id := Entity (Pref);
3037 U_Type : constant Entity_Id := Underlying_Type (P_Type);
3045 -- If no underlying type, we have an error that will be diagnosed
3046 -- elsewhere, so here we just completely ignore the expansion.
3052 -- If TSS for Output is present, just call it
3054 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
3056 if Present (Pname) then
3060 -- If there is a Stream_Convert pragma, use it, we rewrite
3062 -- sourcetyp'Output (stream, Item)
3066 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
3068 -- where strmwrite is the given Write function that converts an
3069 -- argument of type sourcetyp or a type acctyp, from which it is
3070 -- derived to type strmtyp. The conversion to acttyp is required
3071 -- for the derived case.
3073 Prag := Get_Stream_Convert_Pragma (P_Type);
3075 if Present (Prag) then
3077 Next (Next (First (Pragma_Argument_Associations (Prag))));
3078 Wfunc := Entity (Expression (Arg3));
3081 Make_Attribute_Reference (Loc,
3082 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
3083 Attribute_Name => Name_Output,
3084 Expressions => New_List (
3085 Relocate_Node (First (Exprs)),
3086 Make_Function_Call (Loc,
3087 Name => New_Occurrence_Of (Wfunc, Loc),
3088 Parameter_Associations => New_List (
3089 OK_Convert_To (Etype (First_Formal (Wfunc)),
3090 Relocate_Node (Next (First (Exprs)))))))));
3095 -- For elementary types, we call the W_xxx routine directly.
3096 -- Note that the effect of Write and Output is identical for
3097 -- the case of an elementary type, since there are no
3098 -- discriminants or bounds.
3100 elsif Is_Elementary_Type (U_Type) then
3102 -- A special case arises if we have a defined _Write routine,
3103 -- since in this case we are required to call this routine.
3105 if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then
3106 Build_Record_Or_Elementary_Output_Procedure
3107 (Loc, U_Type, Decl, Pname);
3108 Insert_Action (N, Decl);
3110 -- For normal cases, we call the W_xxx routine directly
3113 Rewrite (N, Build_Elementary_Write_Call (N));
3120 elsif Is_Array_Type (U_Type) then
3121 Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
3122 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3124 -- Class-wide case, first output external tag, then dispatch
3125 -- to the appropriate primitive Output function (RM 13.13.2(31)).
3127 elsif Is_Class_Wide_Type (P_Type) then
3129 -- No need to do anything else compiling under restriction
3130 -- No_Dispatching_Calls. During the semantic analysis we
3131 -- already notified such violation.
3133 if Restriction_Active (No_Dispatching_Calls) then
3138 Strm : constant Node_Id := First (Exprs);
3139 Item : constant Node_Id := Next (Strm);
3142 -- Ada 2005 (AI-344): Check that the accessibility level
3143 -- of the type of the output object is not deeper than
3144 -- that of the attribute's prefix type.
3146 -- if Get_Access_Level (Item'Tag)
3147 -- /= Get_Access_Level (P_Type'Tag)
3152 -- String'Output (Strm, External_Tag (Item'Tag));
3154 -- We cannot figure out a practical way to implement this
3155 -- accessibility check on virtual machines, so we omit it.
3157 if Ada_Version >= Ada_05
3158 and then Tagged_Type_Expansion
3161 Make_Implicit_If_Statement (N,
3165 Build_Get_Access_Level (Loc,
3166 Make_Attribute_Reference (Loc,
3169 Duplicate_Subexpr (Item,
3171 Attribute_Name => Name_Tag)),
3174 Make_Integer_Literal (Loc,
3175 Type_Access_Level (P_Type))),
3178 New_List (Make_Raise_Statement (Loc,
3180 RTE (RE_Tag_Error), Loc)))));
3184 Make_Attribute_Reference (Loc,
3185 Prefix => New_Occurrence_Of (Standard_String, Loc),
3186 Attribute_Name => Name_Output,
3187 Expressions => New_List (
3188 Relocate_Node (Duplicate_Subexpr (Strm)),
3189 Make_Function_Call (Loc,
3191 New_Occurrence_Of (RTE (RE_External_Tag), Loc),
3192 Parameter_Associations => New_List (
3193 Make_Attribute_Reference (Loc,
3196 (Duplicate_Subexpr (Item, Name_Req => True)),
3197 Attribute_Name => Name_Tag))))));
3200 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
3202 -- Tagged type case, use the primitive Output function
3204 elsif Is_Tagged_Type (U_Type) then
3205 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
3207 -- All other record type cases, including protected records.
3208 -- The latter only arise for expander generated code for
3209 -- handling shared passive partition access.
3213 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
3215 -- Ada 2005 (AI-216): Program_Error is raised when executing
3216 -- the default implementation of the Output attribute of an
3217 -- unchecked union type if the type lacks default discriminant
3220 if Is_Unchecked_Union (Base_Type (U_Type))
3221 and then No (Discriminant_Constraint (U_Type))
3224 Make_Raise_Program_Error (Loc,
3225 Reason => PE_Unchecked_Union_Restriction));
3230 Build_Record_Or_Elementary_Output_Procedure
3231 (Loc, Base_Type (U_Type), Decl, Pname);
3232 Insert_Action (N, Decl);
3236 -- If we fall through, Pname is the name of the procedure to call
3238 Rewrite_Stream_Proc_Call (Pname);
3245 -- For enumeration types with a standard representation, Pos is
3246 -- handled by the back end.
3248 -- For enumeration types, with a non-standard representation we generate
3249 -- a call to the _Rep_To_Pos function created when the type was frozen.
3250 -- The call has the form
3252 -- _rep_to_pos (expr, flag)
3254 -- The parameter flag is True if range checks are enabled, causing
3255 -- Program_Error to be raised if the expression has an invalid
3256 -- representation, and False if range checks are suppressed.
3258 -- For integer types, Pos is equivalent to a simple integer
3259 -- conversion and we rewrite it as such
3261 when Attribute_Pos => Pos :
3263 Etyp : Entity_Id := Base_Type (Entity (Pref));
3266 -- Deal with zero/non-zero boolean values
3268 if Is_Boolean_Type (Etyp) then
3269 Adjust_Condition (First (Exprs));
3270 Etyp := Standard_Boolean;
3271 Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
3274 -- Case of enumeration type
3276 if Is_Enumeration_Type (Etyp) then
3278 -- Non-standard enumeration type (generate call)
3280 if Present (Enum_Pos_To_Rep (Etyp)) then
3281 Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
3284 Make_Function_Call (Loc,
3286 New_Reference_To (TSS (Etyp, TSS_Rep_To_Pos), Loc),
3287 Parameter_Associations => Exprs)));
3289 Analyze_And_Resolve (N, Typ);
3291 -- Standard enumeration type (do universal integer check)
3294 Apply_Universal_Integer_Attribute_Checks (N);
3297 -- Deal with integer types (replace by conversion)
3299 elsif Is_Integer_Type (Etyp) then
3300 Rewrite (N, Convert_To (Typ, First (Exprs)));
3301 Analyze_And_Resolve (N, Typ);
3310 -- We compute this if a component clause was present, otherwise we leave
3311 -- the computation up to the back end, since we don't know what layout
3314 when Attribute_Position => Position :
3316 CE : constant Entity_Id := Entity (Selector_Name (Pref));
3319 if Present (Component_Clause (CE)) then
3321 Make_Integer_Literal (Loc,
3322 Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
3323 Analyze_And_Resolve (N, Typ);
3326 Apply_Universal_Integer_Attribute_Checks (N);
3334 -- 1. Deal with enumeration types with holes
3335 -- 2. For floating-point, generate call to attribute function
3336 -- 3. For other cases, deal with constraint checking
3338 when Attribute_Pred => Pred :
3340 Etyp : constant Entity_Id := Base_Type (Ptyp);
3344 -- For enumeration types with non-standard representations, we
3345 -- expand typ'Pred (x) into
3347 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
3349 -- If the representation is contiguous, we compute instead
3350 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
3351 -- The conversion function Enum_Pos_To_Rep is defined on the
3352 -- base type, not the subtype, so we have to use the base type
3353 -- explicitly for this and other enumeration attributes.
3355 if Is_Enumeration_Type (Ptyp)
3356 and then Present (Enum_Pos_To_Rep (Etyp))
3358 if Has_Contiguous_Rep (Etyp) then
3360 Unchecked_Convert_To (Ptyp,
3363 Make_Integer_Literal (Loc,
3364 Enumeration_Rep (First_Literal (Ptyp))),
3366 Make_Function_Call (Loc,
3369 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
3371 Parameter_Associations =>
3373 Unchecked_Convert_To (Ptyp,
3374 Make_Op_Subtract (Loc,
3376 Unchecked_Convert_To (Standard_Integer,
3377 Relocate_Node (First (Exprs))),
3379 Make_Integer_Literal (Loc, 1))),
3380 Rep_To_Pos_Flag (Ptyp, Loc))))));
3383 -- Add Boolean parameter True, to request program errror if
3384 -- we have a bad representation on our hands. If checks are
3385 -- suppressed, then add False instead
3387 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
3389 Make_Indexed_Component (Loc,
3392 (Enum_Pos_To_Rep (Etyp), Loc),
3393 Expressions => New_List (
3394 Make_Op_Subtract (Loc,
3396 Make_Function_Call (Loc,
3399 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
3400 Parameter_Associations => Exprs),
3401 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
3404 Analyze_And_Resolve (N, Typ);
3406 -- For floating-point, we transform 'Pred into a call to the Pred
3407 -- floating-point attribute function in Fat_xxx (xxx is root type)
3409 elsif Is_Floating_Point_Type (Ptyp) then
3410 Expand_Fpt_Attribute_R (N);
3411 Analyze_And_Resolve (N, Typ);
3413 -- For modular types, nothing to do (no overflow, since wraps)
3415 elsif Is_Modular_Integer_Type (Ptyp) then
3418 -- For other types, if argument is marked as needing a range check or
3419 -- overflow checking is enabled, we must generate a check.
3421 elsif not Overflow_Checks_Suppressed (Ptyp)
3422 or else Do_Range_Check (First (Exprs))
3424 Set_Do_Range_Check (First (Exprs), False);
3425 Expand_Pred_Succ (N);
3433 -- Ada 2005 (AI-327): Dynamic ceiling priorities
3435 -- We rewrite X'Priority as the following run-time call:
3437 -- Get_Ceiling (X._Object)
3439 -- Note that although X'Priority is notionally an object, it is quite
3440 -- deliberately not defined as an aliased object in the RM. This means
3441 -- that it works fine to rewrite it as a call, without having to worry
3442 -- about complications that would other arise from X'Priority'Access,
3443 -- which is illegal, because of the lack of aliasing.
3445 when Attribute_Priority =>
3448 Conctyp : Entity_Id;
3449 Object_Parm : Node_Id;
3451 RT_Subprg_Name : Node_Id;
3454 -- Look for the enclosing concurrent type
3456 Conctyp := Current_Scope;
3457 while not Is_Concurrent_Type (Conctyp) loop
3458 Conctyp := Scope (Conctyp);
3461 pragma Assert (Is_Protected_Type (Conctyp));
3463 -- Generate the actual of the call
3465 Subprg := Current_Scope;
3466 while not Present (Protected_Body_Subprogram (Subprg)) loop
3467 Subprg := Scope (Subprg);
3470 -- Use of 'Priority inside protected entries and barriers (in
3471 -- both cases the type of the first formal of their expanded
3472 -- subprogram is Address)
3474 if Etype (First_Entity (Protected_Body_Subprogram (Subprg)))
3478 New_Itype : Entity_Id;
3481 -- In the expansion of protected entries the type of the
3482 -- first formal of the Protected_Body_Subprogram is an
3483 -- Address. In order to reference the _object component
3486 -- type T is access p__ptTV;
3489 New_Itype := Create_Itype (E_Access_Type, N);
3490 Set_Etype (New_Itype, New_Itype);
3491 Set_Directly_Designated_Type (New_Itype,
3492 Corresponding_Record_Type (Conctyp));
3493 Freeze_Itype (New_Itype, N);
3496 -- T!(O)._object'unchecked_access
3499 Make_Attribute_Reference (Loc,
3501 Make_Selected_Component (Loc,
3503 Unchecked_Convert_To (New_Itype,
3506 (Protected_Body_Subprogram (Subprg)),
3509 Make_Identifier (Loc, Name_uObject)),
3510 Attribute_Name => Name_Unchecked_Access);
3513 -- Use of 'Priority inside a protected subprogram
3517 Make_Attribute_Reference (Loc,
3519 Make_Selected_Component (Loc,
3520 Prefix => New_Reference_To
3522 (Protected_Body_Subprogram (Subprg)),
3525 Make_Identifier (Loc, Name_uObject)),
3526 Attribute_Name => Name_Unchecked_Access);
3529 -- Select the appropriate run-time subprogram
3531 if Number_Entries (Conctyp) = 0 then
3533 New_Reference_To (RTE (RE_Get_Ceiling), Loc);
3536 New_Reference_To (RTE (RO_PE_Get_Ceiling), Loc);
3540 Make_Function_Call (Loc,
3541 Name => RT_Subprg_Name,
3542 Parameter_Associations => New_List (Object_Parm));
3546 -- Avoid the generation of extra checks on the pointer to the
3547 -- protected object.
3549 Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
3556 when Attribute_Range_Length => Range_Length : begin
3558 -- The only special processing required is for the case where
3559 -- Range_Length is applied to an enumeration type with holes.
3560 -- In this case we transform
3566 -- X'Pos (X'Last) - X'Pos (X'First) + 1
3568 -- So that the result reflects the proper Pos values instead
3569 -- of the underlying representations.
3571 if Is_Enumeration_Type (Ptyp)
3572 and then Has_Non_Standard_Rep (Ptyp)
3577 Make_Op_Subtract (Loc,
3579 Make_Attribute_Reference (Loc,
3580 Attribute_Name => Name_Pos,
3581 Prefix => New_Occurrence_Of (Ptyp, Loc),
3582 Expressions => New_List (
3583 Make_Attribute_Reference (Loc,
3584 Attribute_Name => Name_Last,
3585 Prefix => New_Occurrence_Of (Ptyp, Loc)))),
3588 Make_Attribute_Reference (Loc,
3589 Attribute_Name => Name_Pos,
3590 Prefix => New_Occurrence_Of (Ptyp, Loc),
3591 Expressions => New_List (
3592 Make_Attribute_Reference (Loc,
3593 Attribute_Name => Name_First,
3594 Prefix => New_Occurrence_Of (Ptyp, Loc))))),
3596 Right_Opnd => Make_Integer_Literal (Loc, 1)));
3598 Analyze_And_Resolve (N, Typ);
3600 -- For all other cases, the attribute is handled by the back end, but
3601 -- we need to deal with the case of the range check on a universal
3605 Apply_Universal_Integer_Attribute_Checks (N);
3613 when Attribute_Read => Read : declare
3614 P_Type : constant Entity_Id := Entity (Pref);
3615 B_Type : constant Entity_Id := Base_Type (P_Type);
3616 U_Type : constant Entity_Id := Underlying_Type (P_Type);
3626 -- If no underlying type, we have an error that will be diagnosed
3627 -- elsewhere, so here we just completely ignore the expansion.
3633 -- The simple case, if there is a TSS for Read, just call it
3635 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
3637 if Present (Pname) then
3641 -- If there is a Stream_Convert pragma, use it, we rewrite
3643 -- sourcetyp'Read (stream, Item)
3647 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
3649 -- where strmread is the given Read function that converts an
3650 -- argument of type strmtyp to type sourcetyp or a type from which
3651 -- it is derived. The conversion to sourcetyp is required in the
3654 -- A special case arises if Item is a type conversion in which
3655 -- case, we have to expand to:
3657 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
3659 -- where Itemx is the expression of the type conversion (i.e.
3660 -- the actual object), and typex is the type of Itemx.
3662 Prag := Get_Stream_Convert_Pragma (P_Type);
3664 if Present (Prag) then
3665 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
3666 Rfunc := Entity (Expression (Arg2));
3667 Lhs := Relocate_Node (Next (First (Exprs)));
3669 OK_Convert_To (B_Type,
3670 Make_Function_Call (Loc,
3671 Name => New_Occurrence_Of (Rfunc, Loc),
3672 Parameter_Associations => New_List (
3673 Make_Attribute_Reference (Loc,
3676 (Etype (First_Formal (Rfunc)), Loc),
3677 Attribute_Name => Name_Input,
3678 Expressions => New_List (
3679 Relocate_Node (First (Exprs)))))));
3681 if Nkind (Lhs) = N_Type_Conversion then
3682 Lhs := Expression (Lhs);
3683 Rhs := Convert_To (Etype (Lhs), Rhs);
3687 Make_Assignment_Statement (Loc,
3689 Expression => Rhs));
3690 Set_Assignment_OK (Lhs);
3694 -- For elementary types, we call the I_xxx routine using the first
3695 -- parameter and then assign the result into the second parameter.
3696 -- We set Assignment_OK to deal with the conversion case.
3698 elsif Is_Elementary_Type (U_Type) then
3704 Lhs := Relocate_Node (Next (First (Exprs)));
3705 Rhs := Build_Elementary_Input_Call (N);
3707 if Nkind (Lhs) = N_Type_Conversion then
3708 Lhs := Expression (Lhs);
3709 Rhs := Convert_To (Etype (Lhs), Rhs);
3712 Set_Assignment_OK (Lhs);
3715 Make_Assignment_Statement (Loc,
3717 Expression => Rhs));
3725 elsif Is_Array_Type (U_Type) then
3726 Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
3727 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3729 -- Tagged type case, use the primitive Read function. Note that
3730 -- this will dispatch in the class-wide case which is what we want
3732 elsif Is_Tagged_Type (U_Type) then
3733 Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
3735 -- All other record type cases, including protected records. The
3736 -- latter only arise for expander generated code for handling
3737 -- shared passive partition access.
3741 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
3743 -- Ada 2005 (AI-216): Program_Error is raised when executing
3744 -- the default implementation of the Read attribute of an
3745 -- Unchecked_Union type.
3747 if Is_Unchecked_Union (Base_Type (U_Type)) then
3749 Make_Raise_Program_Error (Loc,
3750 Reason => PE_Unchecked_Union_Restriction));
3753 if Has_Discriminants (U_Type)
3755 (Discriminant_Default_Value (First_Discriminant (U_Type)))
3757 Build_Mutable_Record_Read_Procedure
3758 (Loc, Base_Type (U_Type), Decl, Pname);
3760 Build_Record_Read_Procedure
3761 (Loc, Base_Type (U_Type), Decl, Pname);
3764 -- Suppress checks, uninitialized or otherwise invalid
3765 -- data does not cause constraint errors to be raised for
3766 -- a complete record read.
3768 Insert_Action (N, Decl, All_Checks);
3772 Rewrite_Stream_Proc_Call (Pname);
3779 -- Transforms 'Remainder into a call to the floating-point attribute
3780 -- function Remainder in Fat_xxx (where xxx is the root type)
3782 when Attribute_Remainder =>
3783 Expand_Fpt_Attribute_RR (N);
3789 -- Transform 'Result into reference to _Result formal. At the point
3790 -- where a legal 'Result attribute is expanded, we know that we are in
3791 -- the context of a _Postcondition function with a _Result parameter.
3793 when Attribute_Result =>
3794 Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult));
3795 Analyze_And_Resolve (N, Typ);
3801 -- The handling of the Round attribute is quite delicate. The processing
3802 -- in Sem_Attr introduced a conversion to universal real, reflecting the
3803 -- semantics of Round, but we do not want anything to do with universal
3804 -- real at runtime, since this corresponds to using floating-point
3807 -- What we have now is that the Etype of the Round attribute correctly
3808 -- indicates the final result type. The operand of the Round is the
3809 -- conversion to universal real, described above, and the operand of
3810 -- this conversion is the actual operand of Round, which may be the
3811 -- special case of a fixed point multiplication or division (Etype =
3814 -- The exapander will expand first the operand of the conversion, then
3815 -- the conversion, and finally the round attribute itself, since we
3816 -- always work inside out. But we cannot simply process naively in this
3817 -- order. In the semantic world where universal fixed and real really
3818 -- exist and have infinite precision, there is no problem, but in the
3819 -- implementation world, where universal real is a floating-point type,
3820 -- we would get the wrong result.
3822 -- So the approach is as follows. First, when expanding a multiply or
3823 -- divide whose type is universal fixed, we do nothing at all, instead
3824 -- deferring the operation till later.
3826 -- The actual processing is done in Expand_N_Type_Conversion which
3827 -- handles the special case of Round by looking at its parent to see if
3828 -- it is a Round attribute, and if it is, handling the conversion (or
3829 -- its fixed multiply/divide child) in an appropriate manner.
3831 -- This means that by the time we get to expanding the Round attribute
3832 -- itself, the Round is nothing more than a type conversion (and will
3833 -- often be a null type conversion), so we just replace it with the
3834 -- appropriate conversion operation.
3836 when Attribute_Round =>
3838 Convert_To (Etype (N), Relocate_Node (First (Exprs))));
3839 Analyze_And_Resolve (N);
3845 -- Transforms 'Rounding into a call to the floating-point attribute
3846 -- function Rounding in Fat_xxx (where xxx is the root type)
3848 when Attribute_Rounding =>
3849 Expand_Fpt_Attribute_R (N);
3855 -- Transforms 'Scaling into a call to the floating-point attribute
3856 -- function Scaling in Fat_xxx (where xxx is the root type)
3858 when Attribute_Scaling =>
3859 Expand_Fpt_Attribute_RI (N);
3865 when Attribute_Size |
3866 Attribute_Object_Size |
3867 Attribute_Value_Size |
3868 Attribute_VADS_Size => Size :
3875 -- Processing for VADS_Size case. Note that this processing removes
3876 -- all traces of VADS_Size from the tree, and completes all required
3877 -- processing for VADS_Size by translating the attribute reference
3878 -- to an appropriate Size or Object_Size reference.
3880 if Id = Attribute_VADS_Size
3881 or else (Use_VADS_Size and then Id = Attribute_Size)
3883 -- If the size is specified, then we simply use the specified
3884 -- size. This applies to both types and objects. The size of an
3885 -- object can be specified in the following ways:
3887 -- An explicit size object is given for an object
3888 -- A component size is specified for an indexed component
3889 -- A component clause is specified for a selected component
3890 -- The object is a component of a packed composite object
3892 -- If the size is specified, then VADS_Size of an object
3894 if (Is_Entity_Name (Pref)
3895 and then Present (Size_Clause (Entity (Pref))))
3897 (Nkind (Pref) = N_Component_Clause
3898 and then (Present (Component_Clause
3899 (Entity (Selector_Name (Pref))))
3900 or else Is_Packed (Etype (Prefix (Pref)))))
3902 (Nkind (Pref) = N_Indexed_Component
3903 and then (Component_Size (Etype (Prefix (Pref))) /= 0
3904 or else Is_Packed (Etype (Prefix (Pref)))))
3906 Set_Attribute_Name (N, Name_Size);
3908 -- Otherwise if we have an object rather than a type, then the
3909 -- VADS_Size attribute applies to the type of the object, rather
3910 -- than the object itself. This is one of the respects in which
3911 -- VADS_Size differs from Size.
3914 if (not Is_Entity_Name (Pref)
3915 or else not Is_Type (Entity (Pref)))
3916 and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp))
3918 Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
3921 -- For a scalar type for which no size was explicitly given,
3922 -- VADS_Size means Object_Size. This is the other respect in
3923 -- which VADS_Size differs from Size.
3925 if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then
3926 Set_Attribute_Name (N, Name_Object_Size);
3928 -- In all other cases, Size and VADS_Size are the sane
3931 Set_Attribute_Name (N, Name_Size);
3936 -- For class-wide types, X'Class'Size is transformed into a direct
3937 -- reference to the Size of the class type, so that the back end does
3938 -- not have to deal with the X'Class'Size reference.
3940 if Is_Entity_Name (Pref)
3941 and then Is_Class_Wide_Type (Entity (Pref))
3943 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
3946 -- For X'Size applied to an object of a class-wide type, transform
3947 -- X'Size into a call to the primitive operation _Size applied to X.
3949 elsif Is_Class_Wide_Type (Ptyp)
3950 or else (Id = Attribute_Size
3951 and then Is_Tagged_Type (Ptyp)
3952 and then Has_Unknown_Discriminants (Ptyp))
3954 -- No need to do anything else compiling under restriction
3955 -- No_Dispatching_Calls. During the semantic analysis we
3956 -- already notified such violation.
3958 if Restriction_Active (No_Dispatching_Calls) then
3963 Make_Function_Call (Loc,
3964 Name => New_Reference_To
3965 (Find_Prim_Op (Ptyp, Name_uSize), Loc),
3966 Parameter_Associations => New_List (Pref));
3968 if Typ /= Standard_Long_Long_Integer then
3970 -- The context is a specific integer type with which the
3971 -- original attribute was compatible. The function has a
3972 -- specific type as well, so to preserve the compatibility
3973 -- we must convert explicitly.
3975 New_Node := Convert_To (Typ, New_Node);
3978 Rewrite (N, New_Node);
3979 Analyze_And_Resolve (N, Typ);
3982 -- Case of known RM_Size of a type
3984 elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
3985 and then Is_Entity_Name (Pref)
3986 and then Is_Type (Entity (Pref))
3987 and then Known_Static_RM_Size (Entity (Pref))
3989 Siz := RM_Size (Entity (Pref));
3991 -- Case of known Esize of a type
3993 elsif Id = Attribute_Object_Size
3994 and then Is_Entity_Name (Pref)
3995 and then Is_Type (Entity (Pref))
3996 and then Known_Static_Esize (Entity (Pref))
3998 Siz := Esize (Entity (Pref));
4000 -- Case of known size of object
4002 elsif Id = Attribute_Size
4003 and then Is_Entity_Name (Pref)
4004 and then Is_Object (Entity (Pref))
4005 and then Known_Esize (Entity (Pref))
4006 and then Known_Static_Esize (Entity (Pref))
4008 Siz := Esize (Entity (Pref));
4010 -- For an array component, we can do Size in the front end
4011 -- if the component_size of the array is set.
4013 elsif Nkind (Pref) = N_Indexed_Component then
4014 Siz := Component_Size (Etype (Prefix (Pref)));
4016 -- For a record component, we can do Size in the front end if there
4017 -- is a component clause, or if the record is packed and the
4018 -- component's size is known at compile time.
4020 elsif Nkind (Pref) = N_Selected_Component then
4022 Rec : constant Entity_Id := Etype (Prefix (Pref));
4023 Comp : constant Entity_Id := Entity (Selector_Name (Pref));
4026 if Present (Component_Clause (Comp)) then
4027 Siz := Esize (Comp);
4029 elsif Is_Packed (Rec) then
4030 Siz := RM_Size (Ptyp);
4033 Apply_Universal_Integer_Attribute_Checks (N);
4038 -- All other cases are handled by the back end
4041 Apply_Universal_Integer_Attribute_Checks (N);
4043 -- If Size is applied to a formal parameter that is of a packed
4044 -- array subtype, then apply Size to the actual subtype.
4046 if Is_Entity_Name (Pref)
4047 and then Is_Formal (Entity (Pref))
4048 and then Is_Array_Type (Ptyp)
4049 and then Is_Packed (Ptyp)
4052 Make_Attribute_Reference (Loc,
4054 New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
4055 Attribute_Name => Name_Size));
4056 Analyze_And_Resolve (N, Typ);
4059 -- If Size applies to a dereference of an access to unconstrained
4060 -- packed array, the back end needs to see its unconstrained
4061 -- nominal type, but also a hint to the actual constrained type.
4063 if Nkind (Pref) = N_Explicit_Dereference
4064 and then Is_Array_Type (Ptyp)
4065 and then not Is_Constrained (Ptyp)
4066 and then Is_Packed (Ptyp)
4068 Set_Actual_Designated_Subtype (Pref,
4069 Get_Actual_Subtype (Pref));
4075 -- Common processing for record and array component case
4077 if Siz /= No_Uint and then Siz /= 0 then
4079 CS : constant Boolean := Comes_From_Source (N);
4082 Rewrite (N, Make_Integer_Literal (Loc, Siz));
4084 -- This integer literal is not a static expression. We do not
4085 -- call Analyze_And_Resolve here, because this would activate
4086 -- the circuit for deciding that a static value was out of
4087 -- range, and we don't want that.
4089 -- So just manually set the type, mark the expression as non-
4090 -- static, and then ensure that the result is checked properly
4091 -- if the attribute comes from source (if it was internally
4092 -- generated, we never need a constraint check).
4095 Set_Is_Static_Expression (N, False);
4098 Apply_Constraint_Check (N, Typ);
4108 when Attribute_Storage_Pool =>
4110 Make_Type_Conversion (Loc,
4111 Subtype_Mark => New_Reference_To (Etype (N), Loc),
4112 Expression => New_Reference_To (Entity (N), Loc)));
4113 Analyze_And_Resolve (N, Typ);
4119 when Attribute_Storage_Size => Storage_Size : begin
4121 -- Access type case, always go to the root type
4123 -- The case of access types results in a value of zero for the case
4124 -- where no storage size attribute clause has been given. If a
4125 -- storage size has been given, then the attribute is converted
4126 -- to a reference to the variable used to hold this value.
4128 if Is_Access_Type (Ptyp) then
4129 if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
4131 Make_Attribute_Reference (Loc,
4132 Prefix => New_Reference_To (Typ, Loc),
4133 Attribute_Name => Name_Max,
4134 Expressions => New_List (
4135 Make_Integer_Literal (Loc, 0),
4138 (Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
4140 elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
4143 Make_Function_Call (Loc,
4147 (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
4148 Attribute_Name (N)),
4151 Parameter_Associations => New_List (
4153 (Associated_Storage_Pool (Root_Type (Ptyp)), Loc)))));
4156 Rewrite (N, Make_Integer_Literal (Loc, 0));
4159 Analyze_And_Resolve (N, Typ);
4161 -- For tasks, we retrieve the size directly from the TCB. The
4162 -- size may depend on a discriminant of the type, and therefore
4163 -- can be a per-object expression, so type-level information is
4164 -- not sufficient in general. There are four cases to consider:
4166 -- a) If the attribute appears within a task body, the designated
4167 -- TCB is obtained by a call to Self.
4169 -- b) If the prefix of the attribute is the name of a task object,
4170 -- the designated TCB is the one stored in the corresponding record.
4172 -- c) If the prefix is a task type, the size is obtained from the
4173 -- size variable created for each task type
4175 -- d) If no storage_size was specified for the type , there is no
4176 -- size variable, and the value is a system-specific default.
4179 if In_Open_Scopes (Ptyp) then
4181 -- Storage_Size (Self)
4185 Make_Function_Call (Loc,
4187 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
4188 Parameter_Associations =>
4190 Make_Function_Call (Loc,
4192 New_Reference_To (RTE (RE_Self), Loc))))));
4194 elsif not Is_Entity_Name (Pref)
4195 or else not Is_Type (Entity (Pref))
4197 -- Storage_Size (Rec (Obj).Size)
4201 Make_Function_Call (Loc,
4203 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
4204 Parameter_Associations =>
4206 Make_Selected_Component (Loc,
4208 Unchecked_Convert_To (
4209 Corresponding_Record_Type (Ptyp),
4210 New_Copy_Tree (Pref)),
4212 Make_Identifier (Loc, Name_uTask_Id))))));
4214 elsif Present (Storage_Size_Variable (Ptyp)) then
4216 -- Static storage size pragma given for type: retrieve value
4217 -- from its allocated storage variable.
4221 Make_Function_Call (Loc,
4222 Name => New_Occurrence_Of (
4223 RTE (RE_Adjust_Storage_Size), Loc),
4224 Parameter_Associations =>
4227 Storage_Size_Variable (Ptyp), Loc)))));
4229 -- Get system default
4233 Make_Function_Call (Loc,
4236 RTE (RE_Default_Stack_Size), Loc))));
4239 Analyze_And_Resolve (N, Typ);
4247 when Attribute_Stream_Size => Stream_Size : declare
4251 -- If we have a Stream_Size clause for this type use it, otherwise
4252 -- the Stream_Size if the size of the type.
4254 if Has_Stream_Size_Clause (Ptyp) then
4257 (Static_Integer (Expression (Stream_Size_Clause (Ptyp))));
4259 Size := UI_To_Int (Esize (Ptyp));
4262 Rewrite (N, Make_Integer_Literal (Loc, Intval => Size));
4263 Analyze_And_Resolve (N, Typ);
4270 -- 1. Deal with enumeration types with holes
4271 -- 2. For floating-point, generate call to attribute function
4272 -- 3. For other cases, deal with constraint checking
4274 when Attribute_Succ => Succ : declare
4275 Etyp : constant Entity_Id := Base_Type (Ptyp);
4279 -- For enumeration types with non-standard representations, we
4280 -- expand typ'Succ (x) into
4282 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
4284 -- If the representation is contiguous, we compute instead
4285 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
4287 if Is_Enumeration_Type (Ptyp)
4288 and then Present (Enum_Pos_To_Rep (Etyp))
4290 if Has_Contiguous_Rep (Etyp) then
4292 Unchecked_Convert_To (Ptyp,
4295 Make_Integer_Literal (Loc,
4296 Enumeration_Rep (First_Literal (Ptyp))),
4298 Make_Function_Call (Loc,
4301 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4303 Parameter_Associations =>
4305 Unchecked_Convert_To (Ptyp,
4308 Unchecked_Convert_To (Standard_Integer,
4309 Relocate_Node (First (Exprs))),
4311 Make_Integer_Literal (Loc, 1))),
4312 Rep_To_Pos_Flag (Ptyp, Loc))))));
4314 -- Add Boolean parameter True, to request program errror if
4315 -- we have a bad representation on our hands. Add False if
4316 -- checks are suppressed.
4318 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
4320 Make_Indexed_Component (Loc,
4323 (Enum_Pos_To_Rep (Etyp), Loc),
4324 Expressions => New_List (
4327 Make_Function_Call (Loc,
4330 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4331 Parameter_Associations => Exprs),
4332 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
4335 Analyze_And_Resolve (N, Typ);
4337 -- For floating-point, we transform 'Succ into a call to the Succ
4338 -- floating-point attribute function in Fat_xxx (xxx is root type)
4340 elsif Is_Floating_Point_Type (Ptyp) then
4341 Expand_Fpt_Attribute_R (N);
4342 Analyze_And_Resolve (N, Typ);
4344 -- For modular types, nothing to do (no overflow, since wraps)
4346 elsif Is_Modular_Integer_Type (Ptyp) then
4349 -- For other types, if argument is marked as needing a range check or
4350 -- overflow checking is enabled, we must generate a check.
4352 elsif not Overflow_Checks_Suppressed (Ptyp)
4353 or else Do_Range_Check (First (Exprs))
4355 Set_Do_Range_Check (First (Exprs), False);
4356 Expand_Pred_Succ (N);
4364 -- Transforms X'Tag into a direct reference to the tag of X
4366 when Attribute_Tag => Tag : declare
4368 Prefix_Is_Type : Boolean;
4371 if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then
4372 Ttyp := Entity (Pref);
4373 Prefix_Is_Type := True;
4376 Prefix_Is_Type := False;
4379 if Is_Class_Wide_Type (Ttyp) then
4380 Ttyp := Root_Type (Ttyp);
4383 Ttyp := Underlying_Type (Ttyp);
4385 -- Ada 2005: The type may be a synchronized tagged type, in which
4386 -- case the tag information is stored in the corresponding record.
4388 if Is_Concurrent_Type (Ttyp) then
4389 Ttyp := Corresponding_Record_Type (Ttyp);
4392 if Prefix_Is_Type then
4394 -- For VMs we leave the type attribute unexpanded because
4395 -- there's not a dispatching table to reference.
4397 if Tagged_Type_Expansion then
4399 Unchecked_Convert_To (RTE (RE_Tag),
4401 (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc)));
4402 Analyze_And_Resolve (N, RTE (RE_Tag));
4405 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
4406 -- references the primary tag of the actual object. If 'Tag is
4407 -- applied to class-wide interface objects we generate code that
4408 -- displaces "this" to reference the base of the object.
4410 elsif Comes_From_Source (N)
4411 and then Is_Class_Wide_Type (Etype (Prefix (N)))
4412 and then Is_Interface (Etype (Prefix (N)))
4415 -- (To_Tag_Ptr (Prefix'Address)).all
4417 -- Note that Prefix'Address is recursively expanded into a call
4418 -- to Base_Address (Obj.Tag)
4420 -- Not needed for VM targets, since all handled by the VM
4422 if Tagged_Type_Expansion then
4424 Make_Explicit_Dereference (Loc,
4425 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
4426 Make_Attribute_Reference (Loc,
4427 Prefix => Relocate_Node (Pref),
4428 Attribute_Name => Name_Address))));
4429 Analyze_And_Resolve (N, RTE (RE_Tag));
4434 Make_Selected_Component (Loc,
4435 Prefix => Relocate_Node (Pref),
4437 New_Reference_To (First_Tag_Component (Ttyp), Loc)));
4438 Analyze_And_Resolve (N, RTE (RE_Tag));
4446 -- Transforms 'Terminated attribute into a call to Terminated function
4448 when Attribute_Terminated => Terminated :
4450 -- The prefix of Terminated is of a task interface class-wide type.
4452 -- terminated (Task_Id (Pref._disp_get_task_id));
4454 if Ada_Version >= Ada_05
4455 and then Ekind (Ptyp) = E_Class_Wide_Type
4456 and then Is_Interface (Ptyp)
4457 and then Is_Task_Interface (Ptyp)
4460 Make_Function_Call (Loc,
4462 New_Reference_To (RTE (RE_Terminated), Loc),
4463 Parameter_Associations => New_List (
4464 Make_Unchecked_Type_Conversion (Loc,
4466 New_Reference_To (RTE (RO_ST_Task_Id), Loc),
4468 Make_Selected_Component (Loc,
4470 New_Copy_Tree (Pref),
4472 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
4474 elsif Restricted_Profile then
4476 Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
4480 Build_Call_With_Task (Pref, RTE (RE_Terminated)));
4483 Analyze_And_Resolve (N, Standard_Boolean);
4490 -- Transforms System'To_Address (X) into unchecked conversion
4491 -- from (integral) type of X to type address.
4493 when Attribute_To_Address =>
4495 Unchecked_Convert_To (RTE (RE_Address),
4496 Relocate_Node (First (Exprs))));
4497 Analyze_And_Resolve (N, RTE (RE_Address));
4503 when Attribute_To_Any => To_Any : declare
4504 P_Type : constant Entity_Id := Etype (Pref);
4505 Decls : constant List_Id := New_List;
4509 (Convert_To (P_Type,
4510 Relocate_Node (First (Exprs))), Decls));
4511 Insert_Actions (N, Decls);
4512 Analyze_And_Resolve (N, RTE (RE_Any));
4519 -- Transforms 'Truncation into a call to the floating-point attribute
4520 -- function Truncation in Fat_xxx (where xxx is the root type).
4521 -- Expansion is avoided for cases the back end can handle directly.
4523 when Attribute_Truncation =>
4524 if not Is_Inline_Floating_Point_Attribute (N) then
4525 Expand_Fpt_Attribute_R (N);
4532 when Attribute_TypeCode => TypeCode : declare
4533 P_Type : constant Entity_Id := Etype (Pref);
4534 Decls : constant List_Id := New_List;
4536 Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls));
4537 Insert_Actions (N, Decls);
4538 Analyze_And_Resolve (N, RTE (RE_TypeCode));
4541 -----------------------
4542 -- Unbiased_Rounding --
4543 -----------------------
4545 -- Transforms 'Unbiased_Rounding into a call to the floating-point
4546 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
4547 -- root type). Expansion is avoided for cases the back end can handle
4550 when Attribute_Unbiased_Rounding =>
4551 if not Is_Inline_Floating_Point_Attribute (N) then
4552 Expand_Fpt_Attribute_R (N);
4559 when Attribute_UET_Address => UET_Address : declare
4560 Ent : constant Entity_Id := Make_Temporary (Loc, 'T');
4564 Make_Object_Declaration (Loc,
4565 Defining_Identifier => Ent,
4566 Aliased_Present => True,
4567 Object_Definition =>
4568 New_Occurrence_Of (RTE (RE_Address), Loc)));
4570 -- Construct name __gnat_xxx__SDP, where xxx is the unit name
4571 -- in normal external form.
4573 Get_External_Unit_Name_String (Get_Unit_Name (Pref));
4574 Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
4575 Name_Len := Name_Len + 7;
4576 Name_Buffer (1 .. 7) := "__gnat_";
4577 Name_Buffer (Name_Len + 1 .. Name_Len + 5) := "__SDP";
4578 Name_Len := Name_Len + 5;
4580 Set_Is_Imported (Ent);
4581 Set_Interface_Name (Ent,
4582 Make_String_Literal (Loc,
4583 Strval => String_From_Name_Buffer));
4585 -- Set entity as internal to ensure proper Sprint output of its
4586 -- implicit importation.
4588 Set_Is_Internal (Ent);
4591 Make_Attribute_Reference (Loc,
4592 Prefix => New_Occurrence_Of (Ent, Loc),
4593 Attribute_Name => Name_Address));
4595 Analyze_And_Resolve (N, Typ);
4602 -- The processing for VADS_Size is shared with Size
4608 -- For enumeration types with a standard representation, and for all
4609 -- other types, Val is handled by the back end. For enumeration types
4610 -- with a non-standard representation we use the _Pos_To_Rep array that
4611 -- was created when the type was frozen.
4613 when Attribute_Val => Val : declare
4614 Etyp : constant Entity_Id := Base_Type (Entity (Pref));
4617 if Is_Enumeration_Type (Etyp)
4618 and then Present (Enum_Pos_To_Rep (Etyp))
4620 if Has_Contiguous_Rep (Etyp) then
4622 Rep_Node : constant Node_Id :=
4623 Unchecked_Convert_To (Etyp,
4626 Make_Integer_Literal (Loc,
4627 Enumeration_Rep (First_Literal (Etyp))),
4629 (Convert_To (Standard_Integer,
4630 Relocate_Node (First (Exprs))))));
4634 Unchecked_Convert_To (Etyp,
4637 Make_Integer_Literal (Loc,
4638 Enumeration_Rep (First_Literal (Etyp))),
4640 Make_Function_Call (Loc,
4643 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4644 Parameter_Associations => New_List (
4646 Rep_To_Pos_Flag (Etyp, Loc))))));
4651 Make_Indexed_Component (Loc,
4652 Prefix => New_Reference_To (Enum_Pos_To_Rep (Etyp), Loc),
4653 Expressions => New_List (
4654 Convert_To (Standard_Integer,
4655 Relocate_Node (First (Exprs))))));
4658 Analyze_And_Resolve (N, Typ);
4660 -- If the argument is marked as requiring a range check then generate
4663 elsif Do_Range_Check (First (Exprs)) then
4664 Set_Do_Range_Check (First (Exprs), False);
4665 Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
4673 -- The code for valid is dependent on the particular types involved.
4674 -- See separate sections below for the generated code in each case.
4676 when Attribute_Valid => Valid : declare
4677 Btyp : Entity_Id := Base_Type (Ptyp);
4680 Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
4681 -- Save the validity checking mode. We always turn off validity
4682 -- checking during process of 'Valid since this is one place
4683 -- where we do not want the implicit validity checks to intefere
4684 -- with the explicit validity check that the programmer is doing.
4686 function Make_Range_Test return Node_Id;
4687 -- Build the code for a range test of the form
4688 -- Btyp!(Pref) >= Btyp!(Ptyp'First)
4690 -- Btyp!(Pref) <= Btyp!(Ptyp'Last)
4692 ---------------------
4693 -- Make_Range_Test --
4694 ---------------------
4696 function Make_Range_Test return Node_Id is
4697 Temp : constant Node_Id := Duplicate_Subexpr (Pref);
4700 -- The value whose validity is being checked has been captured in
4701 -- an object declaration. We certainly don't want this object to
4702 -- appear valid because the declaration initializes it!
4704 if Is_Entity_Name (Temp) then
4705 Set_Is_Known_Valid (Entity (Temp), False);
4713 Unchecked_Convert_To (Btyp, Temp),
4716 Unchecked_Convert_To (Btyp,
4717 Make_Attribute_Reference (Loc,
4718 Prefix => New_Occurrence_Of (Ptyp, Loc),
4719 Attribute_Name => Name_First))),
4724 Unchecked_Convert_To (Btyp, Temp),
4727 Unchecked_Convert_To (Btyp,
4728 Make_Attribute_Reference (Loc,
4729 Prefix => New_Occurrence_Of (Ptyp, Loc),
4730 Attribute_Name => Name_Last))));
4731 end Make_Range_Test;
4733 -- Start of processing for Attribute_Valid
4736 -- Turn off validity checks. We do not want any implicit validity
4737 -- checks to intefere with the explicit check from the attribute
4739 Validity_Checks_On := False;
4741 -- Floating-point case. This case is handled by the Valid attribute
4742 -- code in the floating-point attribute run-time library.
4744 if Is_Floating_Point_Type (Ptyp) then
4750 -- For vax fpt types, call appropriate routine in special vax
4751 -- floating point unit. We do not have to worry about loads in
4752 -- this case, since these types have no signalling NaN's.
4754 if Vax_Float (Btyp) then
4755 Expand_Vax_Valid (N);
4757 -- The AAMP back end handles Valid for floating-point types
4759 elsif Is_AAMP_Float (Btyp) then
4760 Analyze_And_Resolve (Pref, Ptyp);
4761 Set_Etype (N, Standard_Boolean);
4764 -- Non VAX float case
4767 Find_Fat_Info (Ptyp, Ftp, Pkg);
4769 -- If the floating-point object might be unaligned, we need
4770 -- to call the special routine Unaligned_Valid, which makes
4771 -- the needed copy, being careful not to load the value into
4772 -- any floating-point register. The argument in this case is
4773 -- obj'Address (see Unaligned_Valid routine in Fat_Gen).
4775 if Is_Possibly_Unaligned_Object (Pref) then
4776 Expand_Fpt_Attribute
4777 (N, Pkg, Name_Unaligned_Valid,
4779 Make_Attribute_Reference (Loc,
4780 Prefix => Relocate_Node (Pref),
4781 Attribute_Name => Name_Address)));
4783 -- In the normal case where we are sure the object is
4784 -- aligned, we generate a call to Valid, and the argument in
4785 -- this case is obj'Unrestricted_Access (after converting
4786 -- obj to the right floating-point type).
4789 Expand_Fpt_Attribute
4790 (N, Pkg, Name_Valid,
4792 Make_Attribute_Reference (Loc,
4793 Prefix => Unchecked_Convert_To (Ftp, Pref),
4794 Attribute_Name => Name_Unrestricted_Access)));
4798 -- One more task, we still need a range check. Required
4799 -- only if we have a constraint, since the Valid routine
4800 -- catches infinities properly (infinities are never valid).
4802 -- The way we do the range check is simply to create the
4803 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
4805 if not Subtypes_Statically_Match (Ptyp, Btyp) then
4808 Left_Opnd => Relocate_Node (N),
4811 Left_Opnd => Convert_To (Btyp, Pref),
4812 Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
4816 -- Enumeration type with holes
4818 -- For enumeration types with holes, the Pos value constructed by
4819 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
4820 -- second argument of False returns minus one for an invalid value,
4821 -- and the non-negative pos value for a valid value, so the
4822 -- expansion of X'Valid is simply:
4824 -- type(X)'Pos (X) >= 0
4826 -- We can't quite generate it that way because of the requirement
4827 -- for the non-standard second argument of False in the resulting
4828 -- rep_to_pos call, so we have to explicitly create:
4830 -- _rep_to_pos (X, False) >= 0
4832 -- If we have an enumeration subtype, we also check that the
4833 -- value is in range:
4835 -- _rep_to_pos (X, False) >= 0
4837 -- (X >= type(X)'First and then type(X)'Last <= X)
4839 elsif Is_Enumeration_Type (Ptyp)
4840 and then Present (Enum_Pos_To_Rep (Base_Type (Ptyp)))
4845 Make_Function_Call (Loc,
4848 (TSS (Base_Type (Ptyp), TSS_Rep_To_Pos), Loc),
4849 Parameter_Associations => New_List (
4851 New_Occurrence_Of (Standard_False, Loc))),
4852 Right_Opnd => Make_Integer_Literal (Loc, 0));
4856 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
4858 Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
4860 -- The call to Make_Range_Test will create declarations
4861 -- that need a proper insertion point, but Pref is now
4862 -- attached to a node with no ancestor. Attach to tree
4863 -- even if it is to be rewritten below.
4865 Set_Parent (Tst, Parent (N));
4869 Left_Opnd => Make_Range_Test,
4875 -- Fortran convention booleans
4877 -- For the very special case of Fortran convention booleans, the
4878 -- value is always valid, since it is an integer with the semantics
4879 -- that non-zero is true, and any value is permissible.
4881 elsif Is_Boolean_Type (Ptyp)
4882 and then Convention (Ptyp) = Convention_Fortran
4884 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
4886 -- For biased representations, we will be doing an unchecked
4887 -- conversion without unbiasing the result. That means that the range
4888 -- test has to take this into account, and the proper form of the
4891 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
4893 elsif Has_Biased_Representation (Ptyp) then
4894 Btyp := RTE (RE_Unsigned_32);
4898 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
4900 Unchecked_Convert_To (Btyp,
4901 Make_Attribute_Reference (Loc,
4902 Prefix => New_Occurrence_Of (Ptyp, Loc),
4903 Attribute_Name => Name_Range_Length))));
4905 -- For all other scalar types, what we want logically is a
4908 -- X in type(X)'First .. type(X)'Last
4910 -- But that's precisely what won't work because of possible
4911 -- unwanted optimization (and indeed the basic motivation for
4912 -- the Valid attribute is exactly that this test does not work!)
4913 -- What will work is:
4915 -- Btyp!(X) >= Btyp!(type(X)'First)
4917 -- Btyp!(X) <= Btyp!(type(X)'Last)
4919 -- where Btyp is an integer type large enough to cover the full
4920 -- range of possible stored values (i.e. it is chosen on the basis
4921 -- of the size of the type, not the range of the values). We write
4922 -- this as two tests, rather than a range check, so that static
4923 -- evaluation will easily remove either or both of the checks if
4924 -- they can be -statically determined to be true (this happens
4925 -- when the type of X is static and the range extends to the full
4926 -- range of stored values).
4928 -- Unsigned types. Note: it is safe to consider only whether the
4929 -- subtype is unsigned, since we will in that case be doing all
4930 -- unsigned comparisons based on the subtype range. Since we use the
4931 -- actual subtype object size, this is appropriate.
4933 -- For example, if we have
4935 -- subtype x is integer range 1 .. 200;
4936 -- for x'Object_Size use 8;
4938 -- Now the base type is signed, but objects of this type are bits
4939 -- unsigned, and doing an unsigned test of the range 1 to 200 is
4940 -- correct, even though a value greater than 127 looks signed to a
4941 -- signed comparison.
4943 elsif Is_Unsigned_Type (Ptyp) then
4944 if Esize (Ptyp) <= 32 then
4945 Btyp := RTE (RE_Unsigned_32);
4947 Btyp := RTE (RE_Unsigned_64);
4950 Rewrite (N, Make_Range_Test);
4955 if Esize (Ptyp) <= Esize (Standard_Integer) then
4956 Btyp := Standard_Integer;
4958 Btyp := Universal_Integer;
4961 Rewrite (N, Make_Range_Test);
4964 Analyze_And_Resolve (N, Standard_Boolean);
4965 Validity_Checks_On := Save_Validity_Checks_On;
4972 -- Value attribute is handled in separate unti Exp_Imgv
4974 when Attribute_Value =>
4975 Exp_Imgv.Expand_Value_Attribute (N);
4981 -- The processing for Value_Size shares the processing for Size
4987 -- The processing for Version shares the processing for Body_Version
4993 -- Wide_Image attribute is handled in separate unit Exp_Imgv
4995 when Attribute_Wide_Image =>
4996 Exp_Imgv.Expand_Wide_Image_Attribute (N);
4998 ---------------------
4999 -- Wide_Wide_Image --
5000 ---------------------
5002 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
5004 when Attribute_Wide_Wide_Image =>
5005 Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N);
5011 -- We expand typ'Wide_Value (X) into
5014 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
5016 -- Wide_String_To_String is a runtime function that converts its wide
5017 -- string argument to String, converting any non-translatable characters
5018 -- into appropriate escape sequences. This preserves the required
5019 -- semantics of Wide_Value in all cases, and results in a very simple
5020 -- implementation approach.
5022 -- Note: for this approach to be fully standard compliant for the cases
5023 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
5024 -- method must cover the entire character range (e.g. UTF-8). But that
5025 -- is a reasonable requirement when dealing with encoded character
5026 -- sequences. Presumably if one of the restrictive encoding mechanisms
5027 -- is in use such as Shift-JIS, then characters that cannot be
5028 -- represented using this encoding will not appear in any case.
5030 when Attribute_Wide_Value => Wide_Value :
5033 Make_Attribute_Reference (Loc,
5035 Attribute_Name => Name_Value,
5037 Expressions => New_List (
5038 Make_Function_Call (Loc,
5040 New_Reference_To (RTE (RE_Wide_String_To_String), Loc),
5042 Parameter_Associations => New_List (
5043 Relocate_Node (First (Exprs)),
5044 Make_Integer_Literal (Loc,
5045 Intval => Int (Wide_Character_Encoding_Method)))))));
5047 Analyze_And_Resolve (N, Typ);
5050 ---------------------
5051 -- Wide_Wide_Value --
5052 ---------------------
5054 -- We expand typ'Wide_Value_Value (X) into
5057 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
5059 -- Wide_Wide_String_To_String is a runtime function that converts its
5060 -- wide string argument to String, converting any non-translatable
5061 -- characters into appropriate escape sequences. This preserves the
5062 -- required semantics of Wide_Wide_Value in all cases, and results in a
5063 -- very simple implementation approach.
5065 -- It's not quite right where typ = Wide_Wide_Character, because the
5066 -- encoding method may not cover the whole character type ???
5068 when Attribute_Wide_Wide_Value => Wide_Wide_Value :
5071 Make_Attribute_Reference (Loc,
5073 Attribute_Name => Name_Value,
5075 Expressions => New_List (
5076 Make_Function_Call (Loc,
5078 New_Reference_To (RTE (RE_Wide_Wide_String_To_String), Loc),
5080 Parameter_Associations => New_List (
5081 Relocate_Node (First (Exprs)),
5082 Make_Integer_Literal (Loc,
5083 Intval => Int (Wide_Character_Encoding_Method)))))));
5085 Analyze_And_Resolve (N, Typ);
5086 end Wide_Wide_Value;
5088 ---------------------
5089 -- Wide_Wide_Width --
5090 ---------------------
5092 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
5094 when Attribute_Wide_Wide_Width =>
5095 Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide);
5101 -- Wide_Width attribute is handled in separate unit Exp_Imgv
5103 when Attribute_Wide_Width =>
5104 Exp_Imgv.Expand_Width_Attribute (N, Wide);
5110 -- Width attribute is handled in separate unit Exp_Imgv
5112 when Attribute_Width =>
5113 Exp_Imgv.Expand_Width_Attribute (N, Normal);
5119 when Attribute_Write => Write : declare
5120 P_Type : constant Entity_Id := Entity (Pref);
5121 U_Type : constant Entity_Id := Underlying_Type (P_Type);
5129 -- If no underlying type, we have an error that will be diagnosed
5130 -- elsewhere, so here we just completely ignore the expansion.
5136 -- The simple case, if there is a TSS for Write, just call it
5138 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
5140 if Present (Pname) then
5144 -- If there is a Stream_Convert pragma, use it, we rewrite
5146 -- sourcetyp'Output (stream, Item)
5150 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
5152 -- where strmwrite is the given Write function that converts an
5153 -- argument of type sourcetyp or a type acctyp, from which it is
5154 -- derived to type strmtyp. The conversion to acttyp is required
5155 -- for the derived case.
5157 Prag := Get_Stream_Convert_Pragma (P_Type);
5159 if Present (Prag) then
5161 Next (Next (First (Pragma_Argument_Associations (Prag))));
5162 Wfunc := Entity (Expression (Arg3));
5165 Make_Attribute_Reference (Loc,
5166 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
5167 Attribute_Name => Name_Output,
5168 Expressions => New_List (
5169 Relocate_Node (First (Exprs)),
5170 Make_Function_Call (Loc,
5171 Name => New_Occurrence_Of (Wfunc, Loc),
5172 Parameter_Associations => New_List (
5173 OK_Convert_To (Etype (First_Formal (Wfunc)),
5174 Relocate_Node (Next (First (Exprs)))))))));
5179 -- For elementary types, we call the W_xxx routine directly
5181 elsif Is_Elementary_Type (U_Type) then
5182 Rewrite (N, Build_Elementary_Write_Call (N));
5188 elsif Is_Array_Type (U_Type) then
5189 Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
5190 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
5192 -- Tagged type case, use the primitive Write function. Note that
5193 -- this will dispatch in the class-wide case which is what we want
5195 elsif Is_Tagged_Type (U_Type) then
5196 Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
5198 -- All other record type cases, including protected records.
5199 -- The latter only arise for expander generated code for
5200 -- handling shared passive partition access.
5204 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
5206 -- Ada 2005 (AI-216): Program_Error is raised when executing
5207 -- the default implementation of the Write attribute of an
5208 -- Unchecked_Union type. However, if the 'Write reference is
5209 -- within the generated Output stream procedure, Write outputs
5210 -- the components, and the default values of the discriminant
5211 -- are streamed by the Output procedure itself.
5213 if Is_Unchecked_Union (Base_Type (U_Type))
5214 and not Is_TSS (Current_Scope, TSS_Stream_Output)
5217 Make_Raise_Program_Error (Loc,
5218 Reason => PE_Unchecked_Union_Restriction));
5221 if Has_Discriminants (U_Type)
5223 (Discriminant_Default_Value (First_Discriminant (U_Type)))
5225 Build_Mutable_Record_Write_Procedure
5226 (Loc, Base_Type (U_Type), Decl, Pname);
5228 Build_Record_Write_Procedure
5229 (Loc, Base_Type (U_Type), Decl, Pname);
5232 Insert_Action (N, Decl);
5236 -- If we fall through, Pname is the procedure to be called
5238 Rewrite_Stream_Proc_Call (Pname);
5241 -- Component_Size is handled by the back end, unless the component size
5242 -- is known at compile time, which is always true in the packed array
5243 -- case. It is important that the packed array case is handled in the
5244 -- front end (see Eval_Attribute) since the back end would otherwise get
5245 -- confused by the equivalent packed array type.
5247 when Attribute_Component_Size =>
5250 -- The following attributes are handled by the back end (except that
5251 -- static cases have already been evaluated during semantic processing,
5252 -- but in any case the back end should not count on this). The one bit
5253 -- of special processing required is that these attributes typically
5254 -- generate conditionals in the code, so we need to check the relevant
5257 when Attribute_Max |
5259 Check_Restriction (No_Implicit_Conditionals, N);
5261 -- The following attributes are handled by the back end (except that
5262 -- static cases have already been evaluated during semantic processing,
5263 -- but in any case the back end should not count on this).
5265 -- The back end also handles the non-class-wide cases of Size
5267 when Attribute_Bit_Order |
5268 Attribute_Code_Address |
5269 Attribute_Definite |
5270 Attribute_Null_Parameter |
5271 Attribute_Passed_By_Reference |
5272 Attribute_Pool_Address =>
5275 -- The following attributes are also handled by the back end, but return
5276 -- a universal integer result, so may need a conversion for checking
5277 -- that the result is in range.
5279 when Attribute_Aft |
5280 Attribute_Max_Size_In_Storage_Elements
5282 Apply_Universal_Integer_Attribute_Checks (N);
5284 -- The following attributes should not appear at this stage, since they
5285 -- have already been handled by the analyzer (and properly rewritten
5286 -- with corresponding values or entities to represent the right values)
5288 when Attribute_Abort_Signal |
5289 Attribute_Address_Size |
5292 Attribute_Compiler_Version |
5293 Attribute_Default_Bit_Order |
5300 Attribute_Fast_Math |
5301 Attribute_Has_Access_Values |
5302 Attribute_Has_Discriminants |
5303 Attribute_Has_Tagged_Values |
5305 Attribute_Machine_Emax |
5306 Attribute_Machine_Emin |
5307 Attribute_Machine_Mantissa |
5308 Attribute_Machine_Overflows |
5309 Attribute_Machine_Radix |
5310 Attribute_Machine_Rounds |
5311 Attribute_Maximum_Alignment |
5312 Attribute_Model_Emin |
5313 Attribute_Model_Epsilon |
5314 Attribute_Model_Mantissa |
5315 Attribute_Model_Small |
5317 Attribute_Partition_ID |
5319 Attribute_Safe_Emax |
5320 Attribute_Safe_First |
5321 Attribute_Safe_Large |
5322 Attribute_Safe_Last |
5323 Attribute_Safe_Small |
5325 Attribute_Signed_Zeros |
5327 Attribute_Storage_Unit |
5328 Attribute_Stub_Type |
5329 Attribute_Target_Name |
5330 Attribute_Type_Class |
5331 Attribute_Unconstrained_Array |
5332 Attribute_Universal_Literal_String |
5333 Attribute_Wchar_T_Size |
5334 Attribute_Word_Size =>
5336 raise Program_Error;
5338 -- The Asm_Input and Asm_Output attributes are not expanded at this
5339 -- stage, but will be eliminated in the expansion of the Asm call, see
5340 -- Exp_Intr for details. So the back end will never see these either.
5342 when Attribute_Asm_Input |
5343 Attribute_Asm_Output =>
5350 when RE_Not_Available =>
5352 end Expand_N_Attribute_Reference;
5354 ----------------------
5355 -- Expand_Pred_Succ --
5356 ----------------------
5358 -- For typ'Pred (exp), we generate the check
5360 -- [constraint_error when exp = typ'Base'First]
5362 -- Similarly, for typ'Succ (exp), we generate the check
5364 -- [constraint_error when exp = typ'Base'Last]
5366 -- These checks are not generated for modular types, since the proper
5367 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
5369 procedure Expand_Pred_Succ (N : Node_Id) is
5370 Loc : constant Source_Ptr := Sloc (N);
5374 if Attribute_Name (N) = Name_Pred then
5381 Make_Raise_Constraint_Error (Loc,
5385 Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
5387 Make_Attribute_Reference (Loc,
5389 New_Reference_To (Base_Type (Etype (Prefix (N))), Loc),
5390 Attribute_Name => Cnam)),
5391 Reason => CE_Overflow_Check_Failed));
5392 end Expand_Pred_Succ;
5398 procedure Find_Fat_Info
5400 Fat_Type : out Entity_Id;
5401 Fat_Pkg : out RE_Id)
5403 Btyp : constant Entity_Id := Base_Type (T);
5404 Rtyp : constant Entity_Id := Root_Type (T);
5405 Digs : constant Nat := UI_To_Int (Digits_Value (Btyp));
5408 -- If the base type is VAX float, then get appropriate VAX float type
5410 if Vax_Float (Btyp) then
5413 Fat_Type := RTE (RE_Fat_VAX_F);
5414 Fat_Pkg := RE_Attr_VAX_F_Float;
5417 Fat_Type := RTE (RE_Fat_VAX_D);
5418 Fat_Pkg := RE_Attr_VAX_D_Float;
5421 Fat_Type := RTE (RE_Fat_VAX_G);
5422 Fat_Pkg := RE_Attr_VAX_G_Float;
5425 raise Program_Error;
5428 -- If root type is VAX float, this is the case where the library has
5429 -- been recompiled in VAX float mode, and we have an IEEE float type.
5430 -- This is when we use the special IEEE Fat packages.
5432 elsif Vax_Float (Rtyp) then
5435 Fat_Type := RTE (RE_Fat_IEEE_Short);
5436 Fat_Pkg := RE_Attr_IEEE_Short;
5439 Fat_Type := RTE (RE_Fat_IEEE_Long);
5440 Fat_Pkg := RE_Attr_IEEE_Long;
5443 raise Program_Error;
5446 -- If neither the base type nor the root type is VAX_Float then VAX
5447 -- float is out of the picture, and we can just use the root type.
5452 if Fat_Type = Standard_Short_Float then
5453 Fat_Pkg := RE_Attr_Short_Float;
5455 elsif Fat_Type = Standard_Float then
5456 Fat_Pkg := RE_Attr_Float;
5458 elsif Fat_Type = Standard_Long_Float then
5459 Fat_Pkg := RE_Attr_Long_Float;
5461 elsif Fat_Type = Standard_Long_Long_Float then
5462 Fat_Pkg := RE_Attr_Long_Long_Float;
5464 -- Universal real (which is its own root type) is treated as being
5465 -- equivalent to Standard.Long_Long_Float, since it is defined to
5466 -- have the same precision as the longest Float type.
5468 elsif Fat_Type = Universal_Real then
5469 Fat_Type := Standard_Long_Long_Float;
5470 Fat_Pkg := RE_Attr_Long_Long_Float;
5473 raise Program_Error;
5478 ----------------------------
5479 -- Find_Stream_Subprogram --
5480 ----------------------------
5482 function Find_Stream_Subprogram
5484 Nam : TSS_Name_Type) return Entity_Id
5486 Base_Typ : constant Entity_Id := Base_Type (Typ);
5487 Ent : constant Entity_Id := TSS (Typ, Nam);
5490 if Present (Ent) then
5494 -- Stream attributes for strings are expanded into library calls. The
5495 -- following checks are disabled when the run-time is not available or
5496 -- when compiling predefined types due to bootstrap issues. As a result,
5497 -- the compiler will generate in-place stream routines for string types
5498 -- that appear in GNAT's library, but will generate calls via rtsfind
5499 -- to library routines for user code.
5500 -- ??? For now, disable this code for JVM, since this generates a
5501 -- VerifyError exception at run-time on e.g. c330001.
5502 -- This is disabled for AAMP, to avoid making dependences on files not
5503 -- supported in the AAMP library (such as s-fileio.adb).
5505 if VM_Target /= JVM_Target
5506 and then not AAMP_On_Target
5508 not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
5510 -- String as defined in package Ada
5512 if Base_Typ = Standard_String then
5513 if Restriction_Active (No_Stream_Optimizations) then
5514 if Nam = TSS_Stream_Input then
5515 return RTE (RE_String_Input);
5517 elsif Nam = TSS_Stream_Output then
5518 return RTE (RE_String_Output);
5520 elsif Nam = TSS_Stream_Read then
5521 return RTE (RE_String_Read);
5523 else pragma Assert (Nam = TSS_Stream_Write);
5524 return RTE (RE_String_Write);
5528 if Nam = TSS_Stream_Input then
5529 return RTE (RE_String_Input_Blk_IO);
5531 elsif Nam = TSS_Stream_Output then
5532 return RTE (RE_String_Output_Blk_IO);
5534 elsif Nam = TSS_Stream_Read then
5535 return RTE (RE_String_Read_Blk_IO);
5537 else pragma Assert (Nam = TSS_Stream_Write);
5538 return RTE (RE_String_Write_Blk_IO);
5542 -- Wide_String as defined in package Ada
5544 elsif Base_Typ = Standard_Wide_String then
5545 if Restriction_Active (No_Stream_Optimizations) then
5546 if Nam = TSS_Stream_Input then
5547 return RTE (RE_Wide_String_Input);
5549 elsif Nam = TSS_Stream_Output then
5550 return RTE (RE_Wide_String_Output);
5552 elsif Nam = TSS_Stream_Read then
5553 return RTE (RE_Wide_String_Read);
5555 else pragma Assert (Nam = TSS_Stream_Write);
5556 return RTE (RE_Wide_String_Write);
5560 if Nam = TSS_Stream_Input then
5561 return RTE (RE_Wide_String_Input_Blk_IO);
5563 elsif Nam = TSS_Stream_Output then
5564 return RTE (RE_Wide_String_Output_Blk_IO);
5566 elsif Nam = TSS_Stream_Read then
5567 return RTE (RE_Wide_String_Read_Blk_IO);
5569 else pragma Assert (Nam = TSS_Stream_Write);
5570 return RTE (RE_Wide_String_Write_Blk_IO);
5574 -- Wide_Wide_String as defined in package Ada
5576 elsif Base_Typ = Standard_Wide_Wide_String then
5577 if Restriction_Active (No_Stream_Optimizations) then
5578 if Nam = TSS_Stream_Input then
5579 return RTE (RE_Wide_Wide_String_Input);
5581 elsif Nam = TSS_Stream_Output then
5582 return RTE (RE_Wide_Wide_String_Output);
5584 elsif Nam = TSS_Stream_Read then
5585 return RTE (RE_Wide_Wide_String_Read);
5587 else pragma Assert (Nam = TSS_Stream_Write);
5588 return RTE (RE_Wide_Wide_String_Write);
5592 if Nam = TSS_Stream_Input then
5593 return RTE (RE_Wide_Wide_String_Input_Blk_IO);
5595 elsif Nam = TSS_Stream_Output then
5596 return RTE (RE_Wide_Wide_String_Output_Blk_IO);
5598 elsif Nam = TSS_Stream_Read then
5599 return RTE (RE_Wide_Wide_String_Read_Blk_IO);
5601 else pragma Assert (Nam = TSS_Stream_Write);
5602 return RTE (RE_Wide_Wide_String_Write_Blk_IO);
5608 if Is_Tagged_Type (Typ)
5609 and then Is_Derived_Type (Typ)
5611 return Find_Prim_Op (Typ, Nam);
5613 return Find_Inherited_TSS (Typ, Nam);
5615 end Find_Stream_Subprogram;
5617 -----------------------
5618 -- Get_Index_Subtype --
5619 -----------------------
5621 function Get_Index_Subtype (N : Node_Id) return Node_Id is
5622 P_Type : Entity_Id := Etype (Prefix (N));
5627 if Is_Access_Type (P_Type) then
5628 P_Type := Designated_Type (P_Type);
5631 if No (Expressions (N)) then
5634 J := UI_To_Int (Expr_Value (First (Expressions (N))));
5637 Indx := First_Index (P_Type);
5643 return Etype (Indx);
5644 end Get_Index_Subtype;
5646 -------------------------------
5647 -- Get_Stream_Convert_Pragma --
5648 -------------------------------
5650 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is
5655 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
5656 -- that a stream convert pragma for a tagged type is not inherited from
5657 -- its parent. Probably what is wrong here is that it is basically
5658 -- incorrect to consider a stream convert pragma to be a representation
5659 -- pragma at all ???
5661 N := First_Rep_Item (Implementation_Base_Type (T));
5662 while Present (N) loop
5663 if Nkind (N) = N_Pragma
5664 and then Pragma_Name (N) = Name_Stream_Convert
5666 -- For tagged types this pragma is not inherited, so we
5667 -- must verify that it is defined for the given type and
5671 Entity (Expression (First (Pragma_Argument_Associations (N))));
5673 if not Is_Tagged_Type (T)
5675 or else (Is_Private_Type (Typ) and then T = Full_View (Typ))
5685 end Get_Stream_Convert_Pragma;
5687 ---------------------------------
5688 -- Is_Constrained_Packed_Array --
5689 ---------------------------------
5691 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is
5692 Arr : Entity_Id := Typ;
5695 if Is_Access_Type (Arr) then
5696 Arr := Designated_Type (Arr);
5699 return Is_Array_Type (Arr)
5700 and then Is_Constrained (Arr)
5701 and then Present (Packed_Array_Type (Arr));
5702 end Is_Constrained_Packed_Array;
5704 ----------------------------------------
5705 -- Is_Inline_Floating_Point_Attribute --
5706 ----------------------------------------
5708 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is
5709 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
5712 if Nkind (Parent (N)) /= N_Type_Conversion
5713 or else not Is_Integer_Type (Etype (Parent (N)))
5718 -- Should also support 'Machine_Rounding and 'Unbiased_Rounding, but
5719 -- required back end support has not been implemented yet ???
5721 return Id = Attribute_Truncation;
5722 end Is_Inline_Floating_Point_Attribute;
OSDN Git Service
