]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/ada/exp_attr.adb
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
2008-08-22 Gary Dismukes <dismukes@adacore.com>
[thirdparty/gcc.git] / gcc / ada / exp_attr.adb
CommitLineData
ee6ba406 1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- E X P _ A T T R --
6-- --
7-- B o d y --
8-- --
4c06b9d2 9-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
ee6ba406 10-- --
11-- GNAT is free software; you can redistribute it and/or modify it under --
12-- terms of the GNU General Public License as published by the Free Soft- --
13-- ware Foundation; either version 2, or (at your option) any later ver- --
14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17-- for more details. You should have received a copy of the GNU General --
18-- Public License distributed with GNAT; see file COPYING. If not, write --
f27cea3a 19-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20-- Boston, MA 02110-1301, USA. --
ee6ba406 21-- --
22-- GNAT was originally developed by the GNAT team at New York University. --
e78e8c8e 23-- Extensive contributions were provided by Ada Core Technologies Inc. --
ee6ba406 24-- --
25------------------------------------------------------------------------------
26
27with Atree; use Atree;
28with Checks; use Checks;
29with Einfo; use Einfo;
00f91aef 30with Elists; use Elists;
99f2248e 31with Exp_Atag; use Exp_Atag;
ee6ba406 32with Exp_Ch2; use Exp_Ch2;
d55c93e0 33with Exp_Ch3; use Exp_Ch3;
34with Exp_Ch6; use Exp_Ch6;
ee6ba406 35with Exp_Ch9; use Exp_Ch9;
5690e662 36with Exp_Dist; use Exp_Dist;
ee6ba406 37with Exp_Imgv; use Exp_Imgv;
38with Exp_Pakd; use Exp_Pakd;
39with Exp_Strm; use Exp_Strm;
40with Exp_Tss; use Exp_Tss;
41with Exp_Util; use Exp_Util;
6e62b6c3 42with Exp_VFpt; use Exp_VFpt;
d55c93e0 43with Fname; use Fname;
db14252c 44with Freeze; use Freeze;
ee6ba406 45with Gnatvsn; use Gnatvsn;
db14252c 46with Itypes; use Itypes;
ee6ba406 47with Lib; use Lib;
48with Namet; use Namet;
49with Nmake; use Nmake;
50with Nlists; use Nlists;
51with Opt; use Opt;
52with Restrict; use Restrict;
1e16c51c 53with Rident; use Rident;
ee6ba406 54with Rtsfind; use Rtsfind;
55with Sem; use Sem;
4c06b9d2 56with Sem_Ch6; use Sem_Ch6;
ee6ba406 57with Sem_Ch7; use Sem_Ch7;
58with Sem_Ch8; use Sem_Ch8;
ee6ba406 59with Sem_Eval; use Sem_Eval;
60with Sem_Res; use Sem_Res;
61with Sem_Util; use Sem_Util;
62with Sinfo; use Sinfo;
63with Snames; use Snames;
64with Stand; use Stand;
65with Stringt; use Stringt;
83aa52b6 66with Targparm; use Targparm;
ee6ba406 67with Tbuild; use Tbuild;
68with Ttypes; use Ttypes;
69with Uintp; use Uintp;
70with Uname; use Uname;
71with Validsw; use Validsw;
72
73package body Exp_Attr is
74
75 -----------------------
76 -- Local Subprograms --
77 -----------------------
78
79 procedure Compile_Stream_Body_In_Scope
80 (N : Node_Id;
81 Decl : Node_Id;
82 Arr : Entity_Id;
83 Check : Boolean);
84 -- The body for a stream subprogram may be generated outside of the scope
85 -- of the type. If the type is fully private, it may depend on the full
86 -- view of other types (e.g. indices) that are currently private as well.
87 -- We install the declarations of the package in which the type is declared
88 -- before compiling the body in what is its proper environment. The Check
89 -- parameter indicates if checks are to be suppressed for the stream body.
90 -- We suppress checks for array/record reads, since the rule is that these
91 -- are like assignments, out of range values due to uninitialized storage,
92 -- or other invalid values do NOT cause a Constraint_Error to be raised.
93
7f8eb6ed 94 procedure Expand_Access_To_Protected_Op
95 (N : Node_Id;
96 Pref : Node_Id;
97 Typ : Entity_Id);
98
99 -- An attribute reference to a protected subprogram is transformed into
100 -- a pair of pointers: one to the object, and one to the operations.
101 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
102
ee6ba406 103 procedure Expand_Fpt_Attribute
9dfe12ae 104 (N : Node_Id;
1550b445 105 Pkg : RE_Id;
9dfe12ae 106 Nam : Name_Id;
ee6ba406 107 Args : List_Id);
108 -- This procedure expands a call to a floating-point attribute function.
109 -- N is the attribute reference node, and Args is a list of arguments to
1550b445 110 -- be passed to the function call. Pkg identifies the package containing
111 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
112 -- have already been converted to the floating-point type for which Pkg was
113 -- instantiated. The Nam argument is the relevant attribute processing
114 -- routine to be called. This is the same as the attribute name, except in
115 -- the Unaligned_Valid case.
ee6ba406 116
117 procedure Expand_Fpt_Attribute_R (N : Node_Id);
118 -- This procedure expands a call to a floating-point attribute function
9dfe12ae 119 -- that takes a single floating-point argument. The function to be called
120 -- is always the same as the attribute name.
ee6ba406 121
122 procedure Expand_Fpt_Attribute_RI (N : Node_Id);
123 -- This procedure expands a call to a floating-point attribute function
9dfe12ae 124 -- that takes one floating-point argument and one integer argument. The
125 -- function to be called is always the same as the attribute name.
ee6ba406 126
127 procedure Expand_Fpt_Attribute_RR (N : Node_Id);
128 -- This procedure expands a call to a floating-point attribute function
9dfe12ae 129 -- that takes two floating-point arguments. The function to be called
130 -- is always the same as the attribute name.
ee6ba406 131
132 procedure Expand_Pred_Succ (N : Node_Id);
133 -- Handles expansion of Pred or Succ attributes for case of non-real
134 -- operand with overflow checking required.
135
136 function Get_Index_Subtype (N : Node_Id) return Entity_Id;
f0bf2ff3 137 -- Used for Last, Last, and Length, when the prefix is an array type.
ee6ba406 138 -- Obtains the corresponding index subtype.
139
1550b445 140 procedure Find_Fat_Info
141 (T : Entity_Id;
142 Fat_Type : out Entity_Id;
143 Fat_Pkg : out RE_Id);
144 -- Given a floating-point type T, identifies the package containing the
145 -- attributes for this type (returned in Fat_Pkg), and the corresponding
146 -- type for which this package was instantiated from Fat_Gen. Error if T
147 -- is not a floating-point type.
148
9dfe12ae 149 function Find_Stream_Subprogram
150 (Typ : Entity_Id;
151 Nam : TSS_Name_Type) return Entity_Id;
152 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
153 -- types, the corresponding primitive operation is looked up, else the
154 -- appropriate TSS from the type itself, or from its closest ancestor
155 -- defining it, is returned. In both cases, inheritance of representation
156 -- aspects is thus taken into account.
ee6ba406 157
5245b786 158 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id;
159 -- Given a type, find a corresponding stream convert pragma that applies to
160 -- the implementation base type of this type (Typ). If found, return the
161 -- pragma node, otherwise return Empty if no pragma is found.
162
ee6ba406 163 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
164 -- Utility for array attributes, returns true on packed constrained
165 -- arrays, and on access to same.
166
99f2248e 167 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean;
168 -- Returns true iff the given node refers to an attribute call that
169 -- can be expanded directly by the back end and does not need front end
170 -- expansion. Typically used for rounding and truncation attributes that
171 -- appear directly inside a conversion to integer.
172
ee6ba406 173 ----------------------------------
174 -- Compile_Stream_Body_In_Scope --
175 ----------------------------------
176
177 procedure Compile_Stream_Body_In_Scope
178 (N : Node_Id;
179 Decl : Node_Id;
180 Arr : Entity_Id;
181 Check : Boolean)
182 is
183 Installed : Boolean := False;
184 Scop : constant Entity_Id := Scope (Arr);
185 Curr : constant Entity_Id := Current_Scope;
186
187 begin
188 if Is_Hidden (Arr)
189 and then not In_Open_Scopes (Scop)
190 and then Ekind (Scop) = E_Package
191 then
83aa52b6 192 Push_Scope (Scop);
ee6ba406 193 Install_Visible_Declarations (Scop);
194 Install_Private_Declarations (Scop);
195 Installed := True;
196
197 -- The entities in the package are now visible, but the generated
198 -- stream entity must appear in the current scope (usually an
199 -- enclosing stream function) so that itypes all have their proper
200 -- scopes.
201
83aa52b6 202 Push_Scope (Curr);
ee6ba406 203 end if;
204
205 if Check then
206 Insert_Action (N, Decl);
207 else
1550b445 208 Insert_Action (N, Decl, Suppress => All_Checks);
ee6ba406 209 end if;
210
211 if Installed then
212
213 -- Remove extra copy of current scope, and package itself
214
215 Pop_Scope;
216 End_Package_Scope (Scop);
217 end if;
218 end Compile_Stream_Body_In_Scope;
219
7f8eb6ed 220 -----------------------------------
221 -- Expand_Access_To_Protected_Op --
222 -----------------------------------
223
224 procedure Expand_Access_To_Protected_Op
225 (N : Node_Id;
226 Pref : Node_Id;
227 Typ : Entity_Id)
228 is
229 -- The value of the attribute_reference is a record containing two
230 -- fields: an access to the protected object, and an access to the
231 -- subprogram itself. The prefix is a selected component.
232
233 Loc : constant Source_Ptr := Sloc (N);
234 Agg : Node_Id;
235 Btyp : constant Entity_Id := Base_Type (Typ);
236 Sub : Entity_Id;
237 E_T : constant Entity_Id := Equivalent_Type (Btyp);
238 Acc : constant Entity_Id :=
239 Etype (Next_Component (First_Component (E_T)));
240 Obj_Ref : Node_Id;
241 Curr : Entity_Id;
242
243 function May_Be_External_Call return Boolean;
244 -- If the 'Access is to a local operation, but appears in a context
245 -- where it may lead to a call from outside the object, we must treat
246 -- this as an external call. Clearly we cannot tell without full
247 -- flow analysis, and a subsequent call that uses this 'Access may
248 -- lead to a bounded error (trying to seize locks twice, e.g.). For
249 -- now we treat 'Access as a potential external call if it is an actual
250 -- in a call to an outside subprogram.
251
252 --------------------------
253 -- May_Be_External_Call --
254 --------------------------
255
256 function May_Be_External_Call return Boolean is
257 Subp : Entity_Id;
d55c93e0 258 Par : Node_Id := Parent (N);
259
7f8eb6ed 260 begin
d55c93e0 261 -- Account for the case where the Access attribute is part of a
262 -- named parameter association.
263
264 if Nkind (Par) = N_Parameter_Association then
265 Par := Parent (Par);
266 end if;
267
268 if Nkind_In (Par, N_Procedure_Call_Statement, N_Function_Call)
269 and then Is_Entity_Name (Name (Par))
7f8eb6ed 270 then
d55c93e0 271 Subp := Entity (Name (Par));
7f8eb6ed 272 return not In_Open_Scopes (Scope (Subp));
273 else
274 return False;
275 end if;
276 end May_Be_External_Call;
277
278 -- Start of processing for Expand_Access_To_Protected_Op
279
280 begin
281 -- Within the body of the protected type, the prefix
282 -- designates a local operation, and the object is the first
283 -- parameter of the corresponding protected body of the
284 -- current enclosing operation.
285
286 if Is_Entity_Name (Pref) then
7f8eb6ed 287 if May_Be_External_Call then
288 Sub :=
289 New_Occurrence_Of
290 (External_Subprogram (Entity (Pref)), Loc);
291 else
292 Sub :=
293 New_Occurrence_Of
294 (Protected_Body_Subprogram (Entity (Pref)), Loc);
295 end if;
296
d55c93e0 297 -- Don't traverse the scopes when the attribute occurs within an init
298 -- proc, because we directly use the _init formal of the init proc in
299 -- that case.
300
7f8eb6ed 301 Curr := Current_Scope;
d55c93e0 302 if not Is_Init_Proc (Curr) then
303 pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
304
305 while Scope (Curr) /= Scope (Entity (Pref)) loop
306 Curr := Scope (Curr);
307 end loop;
308 end if;
7f8eb6ed 309
310 -- In case of protected entries the first formal of its Protected_
311 -- Body_Subprogram is the address of the object.
312
313 if Ekind (Curr) = E_Entry then
314 Obj_Ref :=
315 New_Occurrence_Of
316 (First_Formal
317 (Protected_Body_Subprogram (Curr)), Loc);
318
d55c93e0 319 -- If the current scope is an init proc, then use the address of the
320 -- _init formal as the object reference.
321
322 elsif Is_Init_Proc (Curr) then
323 Obj_Ref :=
324 Make_Attribute_Reference (Loc,
325 Prefix => New_Occurrence_Of (First_Formal (Curr), Loc),
326 Attribute_Name => Name_Address);
327
7f8eb6ed 328 -- In case of protected subprograms the first formal of its
329 -- Protected_Body_Subprogram is the object and we get its address.
330
331 else
332 Obj_Ref :=
333 Make_Attribute_Reference (Loc,
334 Prefix =>
335 New_Occurrence_Of
336 (First_Formal
337 (Protected_Body_Subprogram (Curr)), Loc),
338 Attribute_Name => Name_Address);
339 end if;
340
341 -- Case where the prefix is not an entity name. Find the
342 -- version of the protected operation to be called from
343 -- outside the protected object.
344
345 else
346 Sub :=
347 New_Occurrence_Of
348 (External_Subprogram
349 (Entity (Selector_Name (Pref))), Loc);
350
351 Obj_Ref :=
352 Make_Attribute_Reference (Loc,
353 Prefix => Relocate_Node (Prefix (Pref)),
354 Attribute_Name => Name_Address);
355 end if;
356
357 Agg :=
358 Make_Aggregate (Loc,
359 Expressions =>
360 New_List (
361 Obj_Ref,
362 Unchecked_Convert_To (Acc,
363 Make_Attribute_Reference (Loc,
364 Prefix => Sub,
365 Attribute_Name => Name_Address))));
366
367 Rewrite (N, Agg);
368
369 Analyze_And_Resolve (N, E_T);
370
371 -- For subsequent analysis, the node must retain its type.
372 -- The backend will replace it with the equivalent type where
373 -- needed.
374
375 Set_Etype (N, Typ);
376 end Expand_Access_To_Protected_Op;
377
ee6ba406 378 --------------------------
379 -- Expand_Fpt_Attribute --
380 --------------------------
381
382 procedure Expand_Fpt_Attribute
383 (N : Node_Id;
1550b445 384 Pkg : RE_Id;
9dfe12ae 385 Nam : Name_Id;
ee6ba406 386 Args : List_Id)
387 is
388 Loc : constant Source_Ptr := Sloc (N);
389 Typ : constant Entity_Id := Etype (N);
ee6ba406 390 Fnm : Node_Id;
391
392 begin
1550b445 393 -- The function name is the selected component Attr_xxx.yyy where
394 -- Attr_xxx is the package name, and yyy is the argument Nam.
ee6ba406 395
396 -- Note: it would be more usual to have separate RE entries for each
397 -- of the entities in the Fat packages, but first they have identical
398 -- names (so we would have to have lots of renaming declarations to
399 -- meet the normal RE rule of separate names for all runtime entities),
400 -- and second there would be an awful lot of them!
401
ee6ba406 402 Fnm :=
403 Make_Selected_Component (Loc,
404 Prefix => New_Reference_To (RTE (Pkg), Loc),
9dfe12ae 405 Selector_Name => Make_Identifier (Loc, Nam));
ee6ba406 406
407 -- The generated call is given the provided set of parameters, and then
408 -- wrapped in a conversion which converts the result to the target type
5245b786 409 -- We use the base type as the target because a range check may be
410 -- required.
ee6ba406 411
412 Rewrite (N,
5245b786 413 Unchecked_Convert_To (Base_Type (Etype (N)),
ee6ba406 414 Make_Function_Call (Loc,
1550b445 415 Name => Fnm,
ee6ba406 416 Parameter_Associations => Args)));
417
418 Analyze_And_Resolve (N, Typ);
ee6ba406 419 end Expand_Fpt_Attribute;
420
421 ----------------------------
422 -- Expand_Fpt_Attribute_R --
423 ----------------------------
424
425 -- The single argument is converted to its root type to call the
426 -- appropriate runtime function, with the actual call being built
427 -- by Expand_Fpt_Attribute
428
429 procedure Expand_Fpt_Attribute_R (N : Node_Id) is
430 E1 : constant Node_Id := First (Expressions (N));
1550b445 431 Ftp : Entity_Id;
432 Pkg : RE_Id;
ee6ba406 433 begin
1550b445 434 Find_Fat_Info (Etype (E1), Ftp, Pkg);
9dfe12ae 435 Expand_Fpt_Attribute
1550b445 436 (N, Pkg, Attribute_Name (N),
437 New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1))));
ee6ba406 438 end Expand_Fpt_Attribute_R;
439
440 -----------------------------
441 -- Expand_Fpt_Attribute_RI --
442 -----------------------------
443
444 -- The first argument is converted to its root type and the second
445 -- argument is converted to standard long long integer to call the
446 -- appropriate runtime function, with the actual call being built
447 -- by Expand_Fpt_Attribute
448
449 procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
450 E1 : constant Node_Id := First (Expressions (N));
1550b445 451 Ftp : Entity_Id;
452 Pkg : RE_Id;
ee6ba406 453 E2 : constant Node_Id := Next (E1);
ee6ba406 454 begin
1550b445 455 Find_Fat_Info (Etype (E1), Ftp, Pkg);
9dfe12ae 456 Expand_Fpt_Attribute
1550b445 457 (N, Pkg, Attribute_Name (N),
9dfe12ae 458 New_List (
1550b445 459 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
9dfe12ae 460 Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
ee6ba406 461 end Expand_Fpt_Attribute_RI;
462
463 -----------------------------
464 -- Expand_Fpt_Attribute_RR --
465 -----------------------------
466
99f2248e 467 -- The two arguments are converted to their root types to call the
ee6ba406 468 -- appropriate runtime function, with the actual call being built
469 -- by Expand_Fpt_Attribute
470
471 procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
472 E1 : constant Node_Id := First (Expressions (N));
1550b445 473 Ftp : Entity_Id;
474 Pkg : RE_Id;
ee6ba406 475 E2 : constant Node_Id := Next (E1);
ee6ba406 476 begin
1550b445 477 Find_Fat_Info (Etype (E1), Ftp, Pkg);
9dfe12ae 478 Expand_Fpt_Attribute
1550b445 479 (N, Pkg, Attribute_Name (N),
9dfe12ae 480 New_List (
1550b445 481 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
482 Unchecked_Convert_To (Ftp, Relocate_Node (E2))));
ee6ba406 483 end Expand_Fpt_Attribute_RR;
484
485 ----------------------------------
486 -- Expand_N_Attribute_Reference --
487 ----------------------------------
488
489 procedure Expand_N_Attribute_Reference (N : Node_Id) is
490 Loc : constant Source_Ptr := Sloc (N);
491 Typ : constant Entity_Id := Etype (N);
492 Btyp : constant Entity_Id := Base_Type (Typ);
493 Pref : constant Node_Id := Prefix (N);
d55c93e0 494 Ptyp : constant Entity_Id := Etype (Pref);
ee6ba406 495 Exprs : constant List_Id := Expressions (N);
496 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
497
498 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
499 -- Rewrites a stream attribute for Read, Write or Output with the
500 -- procedure call. Pname is the entity for the procedure to call.
501
502 ------------------------------
503 -- Rewrite_Stream_Proc_Call --
504 ------------------------------
505
506 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
507 Item : constant Node_Id := Next (First (Exprs));
9dfe12ae 508 Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
509 Formal_Typ : constant Entity_Id := Etype (Formal);
510 Is_Written : constant Boolean := (Ekind (Formal) /= E_In_Parameter);
ee6ba406 511
512 begin
9dfe12ae 513 -- The expansion depends on Item, the second actual, which is
514 -- the object being streamed in or out.
515
516 -- If the item is a component of a packed array type, and
517 -- a conversion is needed on exit, we introduce a temporary to
518 -- hold the value, because otherwise the packed reference will
519 -- not be properly expanded.
520
521 if Nkind (Item) = N_Indexed_Component
522 and then Is_Packed (Base_Type (Etype (Prefix (Item))))
523 and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
524 and then Is_Written
525 then
526 declare
527 Temp : constant Entity_Id :=
528 Make_Defining_Identifier
529 (Loc, New_Internal_Name ('V'));
530 Decl : Node_Id;
531 Assn : Node_Id;
532
533 begin
534 Decl :=
535 Make_Object_Declaration (Loc,
536 Defining_Identifier => Temp,
537 Object_Definition =>
538 New_Occurrence_Of (Formal_Typ, Loc));
539 Set_Etype (Temp, Formal_Typ);
540
541 Assn :=
542 Make_Assignment_Statement (Loc,
543 Name => New_Copy_Tree (Item),
544 Expression =>
545 Unchecked_Convert_To
546 (Etype (Item), New_Occurrence_Of (Temp, Loc)));
547
548 Rewrite (Item, New_Occurrence_Of (Temp, Loc));
549 Insert_Actions (N,
550 New_List (
551 Decl,
552 Make_Procedure_Call_Statement (Loc,
553 Name => New_Occurrence_Of (Pname, Loc),
554 Parameter_Associations => Exprs),
555 Assn));
556
557 Rewrite (N, Make_Null_Statement (Loc));
558 return;
559 end;
560 end if;
ee6ba406 561
562 -- For the class-wide dispatching cases, and for cases in which
563 -- the base type of the second argument matches the base type of
9dfe12ae 564 -- the corresponding formal parameter (that is to say the stream
565 -- operation is not inherited), we are all set, and can use the
566 -- argument unchanged.
ee6ba406 567
568 -- For all other cases we do an unchecked conversion of the second
569 -- parameter to the type of the formal of the procedure we are
570 -- calling. This deals with the private type cases, and with going
571 -- to the root type as required in elementary type case.
572
573 if not Is_Class_Wide_Type (Entity (Pref))
9dfe12ae 574 and then not Is_Class_Wide_Type (Etype (Item))
ee6ba406 575 and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
576 then
577 Rewrite (Item,
578 Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
579
580 -- For untagged derived types set Assignment_OK, to prevent
581 -- copies from being created when the unchecked conversion
582 -- is expanded (which would happen in Remove_Side_Effects
583 -- if Expand_N_Unchecked_Conversion were allowed to call
584 -- Force_Evaluation). The copy could violate Ada semantics
585 -- in cases such as an actual that is an out parameter.
586 -- Note that this approach is also used in exp_ch7 for calls
587 -- to controlled type operations to prevent problems with
588 -- actuals wrapped in unchecked conversions.
589
590 if Is_Untagged_Derivation (Etype (Expression (Item))) then
591 Set_Assignment_OK (Item);
592 end if;
593 end if;
594
595 -- And now rewrite the call
596
597 Rewrite (N,
598 Make_Procedure_Call_Statement (Loc,
599 Name => New_Occurrence_Of (Pname, Loc),
600 Parameter_Associations => Exprs));
601
602 Analyze (N);
603 end Rewrite_Stream_Proc_Call;
604
605 -- Start of processing for Expand_N_Attribute_Reference
606
607 begin
7189d17f 608 -- Do required validity checking, if enabled. Do not apply check to
609 -- output parameters of an Asm instruction, since the value of this
610 -- is not set till after the attribute has been elaborated.
ee6ba406 611
7189d17f 612 if Validity_Checks_On and then Validity_Check_Operands
613 and then Id /= Attribute_Asm_Output
614 then
ee6ba406 615 declare
616 Expr : Node_Id;
ee6ba406 617 begin
618 Expr := First (Expressions (N));
619 while Present (Expr) loop
620 Ensure_Valid (Expr);
621 Next (Expr);
622 end loop;
623 end;
624 end if;
625
d55c93e0 626 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
627 -- place function, then a temporary return object needs to be created
628 -- and access to it must be passed to the function. Currently we limit
629 -- such functions to those with inherently limited result subtypes, but
630 -- eventually we plan to expand the functions that are treated as
631 -- build-in-place to include other composite result types.
632
633 if Ada_Version >= Ada_05
634 and then Is_Build_In_Place_Function_Call (Pref)
635 then
636 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
637 end if;
638
98d58e33 639 -- If prefix is a protected type name, this is a reference to
640 -- the current instance of the type.
641
642 if Is_Protected_Self_Reference (Pref) then
643 Rewrite (Pref, Concurrent_Ref (Pref));
644 Analyze (Pref);
645 end if;
646
ee6ba406 647 -- Remaining processing depends on specific attribute
648
649 case Id is
650
651 ------------
652 -- Access --
653 ------------
654
f947f061 655 when Attribute_Access |
656 Attribute_Unchecked_Access |
657 Attribute_Unrestricted_Access =>
ee6ba406 658
5e82d8fe 659 Access_Cases : declare
5e82d8fe 660 Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
d251c56f 661 Btyp_DDT : Entity_Id;
ee6ba406 662
4094dca5 663 function Enclosing_Object (N : Node_Id) return Node_Id;
664 -- If N denotes a compound name (selected component, indexed
665 -- component, or slice), returns the name of the outermost
666 -- such enclosing object. Otherwise returns N. If the object
667 -- is a renaming, then the renamed object is returned.
668
669 ----------------------
670 -- Enclosing_Object --
671 ----------------------
672
673 function Enclosing_Object (N : Node_Id) return Node_Id is
674 Obj_Name : Node_Id;
675
676 begin
677 Obj_Name := N;
678 while Nkind_In (Obj_Name, N_Selected_Component,
679 N_Indexed_Component,
680 N_Slice)
681 loop
682 Obj_Name := Prefix (Obj_Name);
683 end loop;
684
685 return Get_Referenced_Object (Obj_Name);
686 end Enclosing_Object;
687
688 -- Local declarations
689
690 Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
691
692 -- Start of processing for Access_Cases
693
5e82d8fe 694 begin
d251c56f 695 Btyp_DDT := Designated_Type (Btyp);
696
697 -- Handle designated types that come from the limited view
698
699 if Ekind (Btyp_DDT) = E_Incomplete_Type
700 and then From_With_Type (Btyp_DDT)
701 and then Present (Non_Limited_View (Btyp_DDT))
702 then
703 Btyp_DDT := Non_Limited_View (Btyp_DDT);
704
705 elsif Is_Class_Wide_Type (Btyp_DDT)
706 and then Ekind (Etype (Btyp_DDT)) = E_Incomplete_Type
707 and then From_With_Type (Etype (Btyp_DDT))
708 and then Present (Non_Limited_View (Etype (Btyp_DDT)))
709 and then Present (Class_Wide_Type
710 (Non_Limited_View (Etype (Btyp_DDT))))
711 then
712 Btyp_DDT :=
713 Class_Wide_Type (Non_Limited_View (Etype (Btyp_DDT)));
714 end if;
715
4c06b9d2 716 -- In order to improve the text of error messages, the designated
717 -- type of access-to-subprogram itypes is set by the semantics as
718 -- the associated subprogram entity (see sem_attr). Now we replace
719 -- such node with the proper E_Subprogram_Type itype.
720
721 if Id = Attribute_Unrestricted_Access
722 and then Is_Subprogram (Directly_Designated_Type (Typ))
723 then
d55c93e0 724 -- The following conditions ensure that this special management
4c06b9d2 725 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
726 -- At this stage other cases in which the designated type is
727 -- still a subprogram (instead of an E_Subprogram_Type) are
526aedbb 728 -- wrong because the semantics must have overridden the type of
4c06b9d2 729 -- the node with the type imposed by the context.
730
d55c93e0 731 if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
732 and then Etype (Parent (N)) = RTE (RE_Prim_Ptr)
733 then
734 Set_Etype (N, RTE (RE_Prim_Ptr));
4c06b9d2 735
d55c93e0 736 else
737 declare
738 Subp : constant Entity_Id :=
739 Directly_Designated_Type (Typ);
740 Etyp : Entity_Id;
741 Extra : Entity_Id := Empty;
742 New_Formal : Entity_Id;
743 Old_Formal : Entity_Id := First_Formal (Subp);
744 Subp_Typ : Entity_Id;
4c06b9d2 745
d55c93e0 746 begin
747 Subp_Typ := Create_Itype (E_Subprogram_Type, N);
748 Set_Etype (Subp_Typ, Etype (Subp));
749 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
4c06b9d2 750
d55c93e0 751 if Present (Old_Formal) then
752 New_Formal := New_Copy (Old_Formal);
753 Set_First_Entity (Subp_Typ, New_Formal);
4c06b9d2 754
d55c93e0 755 loop
756 Set_Scope (New_Formal, Subp_Typ);
757 Etyp := Etype (New_Formal);
4c06b9d2 758
d55c93e0 759 -- Handle itypes. There is no need to duplicate
760 -- here the itypes associated with record types
761 -- (i.e the implicit full view of private types).
4c06b9d2 762
d55c93e0 763 if Is_Itype (Etyp)
764 and then Ekind (Base_Type (Etyp)) /= E_Record_Type
4c06b9d2 765 then
d55c93e0 766 Extra := New_Copy (Etyp);
767 Set_Parent (Extra, New_Formal);
768 Set_Etype (New_Formal, Extra);
769 Set_Scope (Extra, Subp_Typ);
4c06b9d2 770 end if;
771
d55c93e0 772 Extra := New_Formal;
773 Next_Formal (Old_Formal);
774 exit when No (Old_Formal);
4c06b9d2 775
d55c93e0 776 Set_Next_Entity (New_Formal,
777 New_Copy (Old_Formal));
778 Next_Entity (New_Formal);
779 end loop;
4c06b9d2 780
d55c93e0 781 Set_Next_Entity (New_Formal, Empty);
782 Set_Last_Entity (Subp_Typ, Extra);
783 end if;
4c06b9d2 784
d55c93e0 785 -- Now that the explicit formals have been duplicated,
786 -- any extra formals needed by the subprogram must be
787 -- created.
4c06b9d2 788
d55c93e0 789 if Present (Extra) then
790 Set_Extra_Formal (Extra, Empty);
791 end if;
4c06b9d2 792
d55c93e0 793 Create_Extra_Formals (Subp_Typ);
794 Set_Directly_Designated_Type (Typ, Subp_Typ);
795 end;
796 end if;
4c06b9d2 797 end if;
798
5e82d8fe 799 if Is_Access_Protected_Subprogram_Type (Btyp) then
800 Expand_Access_To_Protected_Op (N, Pref, Typ);
801
802 -- If prefix is a type name, this is a reference to the current
803 -- instance of the type, within its initialization procedure.
804
805 elsif Is_Entity_Name (Pref)
806 and then Is_Type (Entity (Pref))
807 then
808 declare
809 Par : Node_Id;
810 Formal : Entity_Id;
811
812 begin
813 -- If the current instance name denotes a task type, then
814 -- the access attribute is rewritten to be the name of the
815 -- "_task" parameter associated with the task type's task
816 -- procedure. An unchecked conversion is applied to ensure
817 -- a type match in cases of expander-generated calls (e.g.
818 -- init procs).
819
820 if Is_Task_Type (Entity (Pref)) then
821 Formal :=
822 First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
823 while Present (Formal) loop
824 exit when Chars (Formal) = Name_uTask;
825 Next_Entity (Formal);
826 end loop;
827
828 pragma Assert (Present (Formal));
f947f061 829
5e82d8fe 830 Rewrite (N,
831 Unchecked_Convert_To (Typ,
832 New_Occurrence_Of (Formal, Loc)));
833 Set_Etype (N, Typ);
f947f061 834
5e82d8fe 835 -- The expression must appear in a default expression,
836 -- (which in the initialization procedure is the
837 -- right-hand side of an assignment), and not in a
838 -- discriminant constraint.
f947f061 839
5e82d8fe 840 else
841 Par := Parent (N);
842 while Present (Par) loop
843 exit when Nkind (Par) = N_Assignment_Statement;
f947f061 844
5e82d8fe 845 if Nkind (Par) = N_Component_Declaration then
846 return;
847 end if;
f947f061 848
5e82d8fe 849 Par := Parent (Par);
850 end loop;
f947f061 851
5e82d8fe 852 if Present (Par) then
853 Rewrite (N,
854 Make_Attribute_Reference (Loc,
855 Prefix => Make_Identifier (Loc, Name_uInit),
856 Attribute_Name => Attribute_Name (N)));
f947f061 857
5e82d8fe 858 Analyze_And_Resolve (N, Typ);
859 end if;
f947f061 860 end if;
5e82d8fe 861 end;
862
863 -- If the prefix of an Access attribute is a dereference of an
4094dca5 864 -- access parameter (or a renaming of such a dereference, or a
865 -- subcomponent of such a dereference) and the context is a
866 -- general access type (but not an anonymous access type), then
867 -- apply an accessibility check to the access parameter. We used
868 -- to rewrite the access parameter as a type conversion, but that
869 -- could only be done if the immediate prefix of the Access
870 -- attribute was the dereference, and didn't handle cases where
871 -- the attribute is applied to a subcomponent of the dereference,
872 -- since there's generally no available, appropriate access type
55dc6dc2 873 -- to convert to in that case. The attribute is passed as the
874 -- point to insert the check, because the access parameter may
875 -- come from a renaming, possibly in a different scope, and the
876 -- check must be associated with the attribute itself.
4094dca5 877
878 elsif Id = Attribute_Access
879 and then Nkind (Enc_Object) = N_Explicit_Dereference
880 and then Is_Entity_Name (Prefix (Enc_Object))
5e82d8fe 881 and then Ekind (Btyp) = E_General_Access_Type
4094dca5 882 and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind
883 and then Ekind (Etype (Entity (Prefix (Enc_Object))))
5e82d8fe 884 = E_Anonymous_Access_Type
885 and then Present (Extra_Accessibility
4094dca5 886 (Entity (Prefix (Enc_Object))))
5e82d8fe 887 then
55dc6dc2 888 Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N);
5e82d8fe 889
890 -- Ada 2005 (AI-251): If the designated type is an interface we
891 -- add an implicit conversion to force the displacement of the
892 -- pointer to reference the secondary dispatch table.
893
894 elsif Is_Interface (Btyp_DDT)
895 and then (Comes_From_Source (N)
896 or else Comes_From_Source (Ref_Object)
897 or else (Nkind (Ref_Object) in N_Has_Chars
898 and then Chars (Ref_Object) = Name_uInit))
899 then
900 if Nkind (Ref_Object) /= N_Explicit_Dereference then
901
902 -- No implicit conversion required if types match
903
904 if Btyp_DDT /= Etype (Ref_Object) then
905 Rewrite (Prefix (N),
d251c56f 906 Convert_To (Btyp_DDT,
5e82d8fe 907 New_Copy_Tree (Prefix (N))));
908
d251c56f 909 Analyze_And_Resolve (Prefix (N), Btyp_DDT);
ee6ba406 910 end if;
aad6babd 911
5e82d8fe 912 -- When the object is an explicit dereference, convert the
913 -- dereference's prefix.
f947f061 914
5e82d8fe 915 else
916 declare
917 Obj_DDT : constant Entity_Id :=
918 Base_Type
919 (Directly_Designated_Type
920 (Etype (Prefix (Ref_Object))));
921 begin
922 -- No implicit conversion required if designated types
923 -- match.
924
925 if Obj_DDT /= Btyp_DDT
926 and then not (Is_Class_Wide_Type (Obj_DDT)
927 and then Etype (Obj_DDT) = Btyp_DDT)
928 then
929 Rewrite (N,
930 Convert_To (Typ,
931 New_Copy_Tree (Prefix (Ref_Object))));
932 Analyze_And_Resolve (N, Typ);
933 end if;
934 end;
ee6ba406 935 end if;
5e82d8fe 936 end if;
937 end Access_Cases;
ee6ba406 938
939 --------------
940 -- Adjacent --
941 --------------
942
943 -- Transforms 'Adjacent into a call to the floating-point attribute
944 -- function Adjacent in Fat_xxx (where xxx is the root type)
945
946 when Attribute_Adjacent =>
947 Expand_Fpt_Attribute_RR (N);
948
949 -------------
950 -- Address --
951 -------------
952
953 when Attribute_Address => Address : declare
954 Task_Proc : Entity_Id;
955
956 begin
f947f061 957 -- If the prefix is a task or a task type, the useful address is that
958 -- of the procedure for the task body, i.e. the actual program unit.
959 -- We replace the original entity with that of the procedure.
ee6ba406 960
961 if Is_Entity_Name (Pref)
962 and then Is_Task_Type (Entity (Pref))
963 then
d55c93e0 964 Task_Proc := Next_Entity (Root_Type (Ptyp));
ee6ba406 965
966 while Present (Task_Proc) loop
967 exit when Ekind (Task_Proc) = E_Procedure
968 and then Etype (First_Formal (Task_Proc)) =
d55c93e0 969 Corresponding_Record_Type (Ptyp);
ee6ba406 970 Next_Entity (Task_Proc);
971 end loop;
972
973 if Present (Task_Proc) then
974 Set_Entity (Pref, Task_Proc);
975 Set_Etype (Pref, Etype (Task_Proc));
976 end if;
977
978 -- Similarly, the address of a protected operation is the address
979 -- of the corresponding protected body, regardless of the protected
980 -- object from which it is selected.
981
982 elsif Nkind (Pref) = N_Selected_Component
983 and then Is_Subprogram (Entity (Selector_Name (Pref)))
984 and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref))))
985 then
986 Rewrite (Pref,
987 New_Occurrence_Of (
988 External_Subprogram (Entity (Selector_Name (Pref))), Loc));
989
990 elsif Nkind (Pref) = N_Explicit_Dereference
d55c93e0 991 and then Ekind (Ptyp) = E_Subprogram_Type
992 and then Convention (Ptyp) = Convention_Protected
ee6ba406 993 then
994 -- The prefix is be a dereference of an access_to_protected_
995 -- subprogram. The desired address is the second component of
996 -- the record that represents the access.
997
998 declare
999 Addr : constant Entity_Id := Etype (N);
1000 Ptr : constant Node_Id := Prefix (Pref);
1001 T : constant Entity_Id :=
1002 Equivalent_Type (Base_Type (Etype (Ptr)));
1003
1004 begin
1005 Rewrite (N,
1006 Unchecked_Convert_To (Addr,
1007 Make_Selected_Component (Loc,
1008 Prefix => Unchecked_Convert_To (T, Ptr),
1009 Selector_Name => New_Occurrence_Of (
1010 Next_Entity (First_Entity (T)), Loc))));
1011
1012 Analyze_And_Resolve (N, Addr);
1013 end;
99f2248e 1014
1015 -- Ada 2005 (AI-251): Class-wide interface objects are always
1016 -- "displaced" to reference the tag associated with the interface
1017 -- type. In order to obtain the real address of such objects we
1018 -- generate a call to a run-time subprogram that returns the base
1019 -- address of the object.
1020
f0bf2ff3 1021 -- This processing is not needed in the VM case, where dispatching
1022 -- issues are taken care of by the virtual machine.
1023
d55c93e0 1024 elsif Is_Class_Wide_Type (Ptyp)
1025 and then Is_Interface (Ptyp)
f0bf2ff3 1026 and then VM_Target = No_VM
83aa52b6 1027 and then not (Nkind (Pref) in N_Has_Entity
1028 and then Is_Subprogram (Entity (Pref)))
99f2248e 1029 then
1030 Rewrite (N,
1031 Make_Function_Call (Loc,
1032 Name => New_Reference_To (RTE (RE_Base_Address), Loc),
1033 Parameter_Associations => New_List (
1034 Relocate_Node (N))));
1035 Analyze (N);
1036 return;
ee6ba406 1037 end if;
1038
d55c93e0 1039 -- Deal with packed array reference, other cases are handled by
1040 -- the back end.
ee6ba406 1041
1042 if Involves_Packed_Array_Reference (Pref) then
1043 Expand_Packed_Address_Reference (N);
1044 end if;
1045 end Address;
1046
9dfe12ae 1047 ---------------
1048 -- Alignment --
1049 ---------------
1050
1051 when Attribute_Alignment => Alignment : declare
9dfe12ae 1052 New_Node : Node_Id;
1053
1054 begin
1055 -- For class-wide types, X'Class'Alignment is transformed into a
1056 -- direct reference to the Alignment of the class type, so that the
1057 -- back end does not have to deal with the X'Class'Alignment
1058 -- reference.
1059
1060 if Is_Entity_Name (Pref)
1061 and then Is_Class_Wide_Type (Entity (Pref))
1062 then
1063 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
1064 return;
1065
1066 -- For x'Alignment applied to an object of a class wide type,
1067 -- transform X'Alignment into a call to the predefined primitive
1068 -- operation _Alignment applied to X.
1069
1070 elsif Is_Class_Wide_Type (Ptyp) then
99f2248e 1071
1072 -- No need to do anything else compiling under restriction
1073 -- No_Dispatching_Calls. During the semantic analysis we
1074 -- already notified such violation.
1075
1076 if Restriction_Active (No_Dispatching_Calls) then
1077 return;
1078 end if;
1079
9dfe12ae 1080 New_Node :=
1081 Make_Function_Call (Loc,
1082 Name => New_Reference_To
1083 (Find_Prim_Op (Ptyp, Name_uAlignment), Loc),
1084 Parameter_Associations => New_List (Pref));
1085
1086 if Typ /= Standard_Integer then
1087
1088 -- The context is a specific integer type with which the
1089 -- original attribute was compatible. The function has a
1090 -- specific type as well, so to preserve the compatibility
1091 -- we must convert explicitly.
1092
1093 New_Node := Convert_To (Typ, New_Node);
1094 end if;
1095
1096 Rewrite (N, New_Node);
1097 Analyze_And_Resolve (N, Typ);
1098 return;
1099
1100 -- For all other cases, we just have to deal with the case of
1101 -- the fact that the result can be universal.
1102
1103 else
1104 Apply_Universal_Integer_Attribute_Checks (N);
1105 end if;
1106 end Alignment;
1107
ee6ba406 1108 ---------------
1109 -- AST_Entry --
1110 ---------------
1111
1112 when Attribute_AST_Entry => AST_Entry : declare
1113 Ttyp : Entity_Id;
1114 T_Id : Node_Id;
1115 Eent : Entity_Id;
1116
1117 Entry_Ref : Node_Id;
1118 -- The reference to the entry or entry family
1119
1120 Index : Node_Id;
1121 -- The index expression for an entry family reference, or
1122 -- the Empty if Entry_Ref references a simple entry.
1123
1124 begin
1125 if Nkind (Pref) = N_Indexed_Component then
1126 Entry_Ref := Prefix (Pref);
1127 Index := First (Expressions (Pref));
1128 else
1129 Entry_Ref := Pref;
1130 Index := Empty;
1131 end if;
1132
1133 -- Get expression for Task_Id and the entry entity
1134
1135 if Nkind (Entry_Ref) = N_Selected_Component then
1136 T_Id :=
1137 Make_Attribute_Reference (Loc,
1138 Attribute_Name => Name_Identity,
1139 Prefix => Prefix (Entry_Ref));
1140
1141 Ttyp := Etype (Prefix (Entry_Ref));
1142 Eent := Entity (Selector_Name (Entry_Ref));
1143
1144 else
1145 T_Id :=
1146 Make_Function_Call (Loc,
1147 Name => New_Occurrence_Of (RTE (RE_Current_Task), Loc));
1148
1149 Eent := Entity (Entry_Ref);
1150
1151 -- We have to find the enclosing task to get the task type
1152 -- There must be one, since we already validated this earlier
1153
1154 Ttyp := Current_Scope;
1155 while not Is_Task_Type (Ttyp) loop
1156 Ttyp := Scope (Ttyp);
1157 end loop;
1158 end if;
1159
1160 -- Now rewrite the attribute with a call to Create_AST_Handler
1161
1162 Rewrite (N,
1163 Make_Function_Call (Loc,
1164 Name => New_Occurrence_Of (RTE (RE_Create_AST_Handler), Loc),
1165 Parameter_Associations => New_List (
1166 T_Id,
1167 Entry_Index_Expression (Loc, Eent, Index, Ttyp))));
1168
1169 Analyze_And_Resolve (N, RTE (RE_AST_Handler));
1170 end AST_Entry;
1171
1172 ------------------
1173 -- Bit_Position --
1174 ------------------
1175
d55c93e0 1176 -- We compute this if a component clause was present, otherwise we leave
1177 -- the computation up to the back end, since we don't know what layout
1178 -- will be chosen.
ee6ba406 1179
1180 -- Note that the attribute can apply to a naked record component
1181 -- in generated code (i.e. the prefix is an identifier that
1182 -- references the component or discriminant entity).
1183
1184 when Attribute_Bit_Position => Bit_Position :
1185 declare
1186 CE : Entity_Id;
1187
1188 begin
1189 if Nkind (Pref) = N_Identifier then
1190 CE := Entity (Pref);
1191 else
1192 CE := Entity (Selector_Name (Pref));
1193 end if;
1194
1195 if Known_Static_Component_Bit_Offset (CE) then
1196 Rewrite (N,
1197 Make_Integer_Literal (Loc,
1198 Intval => Component_Bit_Offset (CE)));
1199 Analyze_And_Resolve (N, Typ);
1200
1201 else
1202 Apply_Universal_Integer_Attribute_Checks (N);
1203 end if;
1204 end Bit_Position;
1205
1206 ------------------
1207 -- Body_Version --
1208 ------------------
1209
1210 -- A reference to P'Body_Version or P'Version is expanded to
1211
1212 -- Vnn : Unsigned;
1213 -- pragma Import (C, Vnn, "uuuuT";
1214 -- ...
1215 -- Get_Version_String (Vnn)
1216
1217 -- where uuuu is the unit name (dots replaced by double underscore)
1218 -- and T is B for the cases of Body_Version, or Version applied to a
1219 -- subprogram acting as its own spec, and S for Version applied to a
1220 -- subprogram spec or package. This sequence of code references the
1221 -- the unsigned constant created in the main program by the binder.
1222
1223 -- A special exception occurs for Standard, where the string
7f8eb6ed 1224 -- returned is a copy of the library string in gnatvsn.ads.
ee6ba406 1225
1226 when Attribute_Body_Version | Attribute_Version => Version : declare
1227 E : constant Entity_Id :=
1228 Make_Defining_Identifier (Loc, New_Internal_Name ('V'));
f947f061 1229 Pent : Entity_Id;
ee6ba406 1230 S : String_Id;
1231
1232 begin
1233 -- If not library unit, get to containing library unit
1234
f947f061 1235 Pent := Entity (Pref);
ee6ba406 1236 while Pent /= Standard_Standard
1237 and then Scope (Pent) /= Standard_Standard
f947f061 1238 and then not Is_Child_Unit (Pent)
ee6ba406 1239 loop
1240 Pent := Scope (Pent);
1241 end loop;
1242
f947f061 1243 -- Special case Standard and Standard.ASCII
ee6ba406 1244
f947f061 1245 if Pent = Standard_Standard or else Pent = Standard_ASCII then
ee6ba406 1246 Rewrite (N,
1247 Make_String_Literal (Loc,
5245b786 1248 Strval => Verbose_Library_Version));
ee6ba406 1249
1250 -- All other cases
1251
1252 else
1253 -- Build required string constant
1254
1255 Get_Name_String (Get_Unit_Name (Pent));
1256
1257 Start_String;
1258 for J in 1 .. Name_Len - 2 loop
1259 if Name_Buffer (J) = '.' then
1260 Store_String_Chars ("__");
1261 else
1262 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
1263 end if;
1264 end loop;
1265
1266 -- Case of subprogram acting as its own spec, always use body
1267
1268 if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
1269 and then Nkind (Parent (Declaration_Node (Pent))) =
1270 N_Subprogram_Body
1271 and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
1272 then
1273 Store_String_Chars ("B");
1274
1275 -- Case of no body present, always use spec
1276
1277 elsif not Unit_Requires_Body (Pent) then
1278 Store_String_Chars ("S");
1279
1280 -- Otherwise use B for Body_Version, S for spec
1281
1282 elsif Id = Attribute_Body_Version then
1283 Store_String_Chars ("B");
1284 else
1285 Store_String_Chars ("S");
1286 end if;
1287
1288 S := End_String;
1289 Lib.Version_Referenced (S);
1290
1291 -- Insert the object declaration
1292
1293 Insert_Actions (N, New_List (
1294 Make_Object_Declaration (Loc,
1295 Defining_Identifier => E,
1296 Object_Definition =>
1297 New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
1298
1299 -- Set entity as imported with correct external name
1300
1301 Set_Is_Imported (E);
1302 Set_Interface_Name (E, Make_String_Literal (Loc, S));
1303
f947f061 1304 -- Set entity as internal to ensure proper Sprint output of its
1305 -- implicit importation.
1306
1307 Set_Is_Internal (E);
1308
ee6ba406 1309 -- And now rewrite original reference
1310
1311 Rewrite (N,
1312 Make_Function_Call (Loc,
1313 Name => New_Reference_To (RTE (RE_Get_Version_String), Loc),
1314 Parameter_Associations => New_List (
1315 New_Occurrence_Of (E, Loc))));
1316 end if;
1317
1318 Analyze_And_Resolve (N, RTE (RE_Version_String));
1319 end Version;
1320
1321 -------------
1322 -- Ceiling --
1323 -------------
1324
1325 -- Transforms 'Ceiling into a call to the floating-point attribute
1326 -- function Ceiling in Fat_xxx (where xxx is the root type)
1327
1328 when Attribute_Ceiling =>
1329 Expand_Fpt_Attribute_R (N);
1330
1331 --------------
1332 -- Callable --
1333 --------------
1334
aad6babd 1335 -- Transforms 'Callable attribute into a call to the Callable function
ee6ba406 1336
1337 when Attribute_Callable => Callable :
1338 begin
1550b445 1339 -- We have an object of a task interface class-wide type as a prefix
1340 -- to Callable. Generate:
1341
83aa52b6 1342 -- callable (Task_Id (Pref._disp_get_task_id));
1550b445 1343
1344 if Ada_Version >= Ada_05
d55c93e0 1345 and then Ekind (Ptyp) = E_Class_Wide_Type
1346 and then Is_Interface (Ptyp)
1347 and then Is_Task_Interface (Ptyp)
1550b445 1348 then
1349 Rewrite (N,
1350 Make_Function_Call (Loc,
1351 Name =>
1352 New_Reference_To (RTE (RE_Callable), Loc),
1353 Parameter_Associations => New_List (
83aa52b6 1354 Make_Unchecked_Type_Conversion (Loc,
1355 Subtype_Mark =>
1356 New_Reference_To (RTE (RO_ST_Task_Id), Loc),
1357 Expression =>
1358 Make_Selected_Component (Loc,
1359 Prefix =>
1360 New_Copy_Tree (Pref),
1361 Selector_Name =>
1362 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
1363
1550b445 1364 else
1365 Rewrite (N,
1366 Build_Call_With_Task (Pref, RTE (RE_Callable)));
1367 end if;
1368
ee6ba406 1369 Analyze_And_Resolve (N, Standard_Boolean);
1370 end Callable;
1371
1372 ------------
1373 -- Caller --
1374 ------------
1375
1376 -- Transforms 'Caller attribute into a call to either the
1377 -- Task_Entry_Caller or the Protected_Entry_Caller function.
1378
1379 when Attribute_Caller => Caller : declare
7f9be362 1380 Id_Kind : constant Entity_Id := RTE (RO_AT_Task_Id);
9dfe12ae 1381 Ent : constant Entity_Id := Entity (Pref);
1382 Conctype : constant Entity_Id := Scope (Ent);
1383 Nest_Depth : Integer := 0;
ee6ba406 1384 Name : Node_Id;
1385 S : Entity_Id;
1386
1387 begin
1388 -- Protected case
1389
1390 if Is_Protected_Type (Conctype) then
4c06b9d2 1391 case Corresponding_Runtime_Package (Conctype) is
1392 when System_Tasking_Protected_Objects_Entries =>
1393 Name :=
1394 New_Reference_To
1395 (RTE (RE_Protected_Entry_Caller), Loc);
1396
1397 when System_Tasking_Protected_Objects_Single_Entry =>
1398 Name :=
1399 New_Reference_To
1400 (RTE (RE_Protected_Single_Entry_Caller), Loc);
1401
1402 when others =>
1403 raise Program_Error;
1404 end case;
ee6ba406 1405
1406 Rewrite (N,
1407 Unchecked_Convert_To (Id_Kind,
1408 Make_Function_Call (Loc,
1409 Name => Name,
d55c93e0 1410 Parameter_Associations => New_List (
1411 New_Reference_To
1412 (Find_Protection_Object (Current_Scope), Loc)))));
ee6ba406 1413
1414 -- Task case
1415
1416 else
1417 -- Determine the nesting depth of the E'Caller attribute, that
1418 -- is, how many accept statements are nested within the accept
1419 -- statement for E at the point of E'Caller. The runtime uses
1420 -- this depth to find the specified entry call.
1421
1422 for J in reverse 0 .. Scope_Stack.Last loop
1423 S := Scope_Stack.Table (J).Entity;
1424
1425 -- We should not reach the scope of the entry, as it should
1426 -- already have been checked in Sem_Attr that this attribute
1427 -- reference is within a matching accept statement.
1428
1429 pragma Assert (S /= Conctype);
1430
1431 if S = Ent then
1432 exit;
1433
1434 elsif Is_Entry (S) then
1435 Nest_Depth := Nest_Depth + 1;
1436 end if;
1437 end loop;
1438
1439 Rewrite (N,
1440 Unchecked_Convert_To (Id_Kind,
1441 Make_Function_Call (Loc,
d55c93e0 1442 Name =>
1443 New_Reference_To (RTE (RE_Task_Entry_Caller), Loc),
ee6ba406 1444 Parameter_Associations => New_List (
1445 Make_Integer_Literal (Loc,
1446 Intval => Int (Nest_Depth))))));
1447 end if;
1448
1449 Analyze_And_Resolve (N, Id_Kind);
1450 end Caller;
1451
1452 -------------
1453 -- Compose --
1454 -------------
1455
1456 -- Transforms 'Compose into a call to the floating-point attribute
1457 -- function Compose in Fat_xxx (where xxx is the root type)
1458
1459 -- Note: we strictly should have special code here to deal with the
1460 -- case of absurdly negative arguments (less than Integer'First)
1461 -- which will return a (signed) zero value, but it hardly seems
1462 -- worth the effort. Absurdly large positive arguments will raise
1463 -- constraint error which is fine.
1464
1465 when Attribute_Compose =>
1466 Expand_Fpt_Attribute_RI (N);
1467
1468 -----------------
1469 -- Constrained --
1470 -----------------
1471
1472 when Attribute_Constrained => Constrained : declare
1473 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
1474
7f8eb6ed 1475 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
1476 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
1477 -- view of an aliased object whose subtype is constrained.
1478
1479 ---------------------------------
1480 -- Is_Constrained_Aliased_View --
1481 ---------------------------------
1482
1483 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
1484 E : Entity_Id;
1485
1486 begin
1487 if Is_Entity_Name (Obj) then
1488 E := Entity (Obj);
1489
1490 if Present (Renamed_Object (E)) then
1491 return Is_Constrained_Aliased_View (Renamed_Object (E));
7f8eb6ed 1492 else
1493 return Is_Aliased (E) and then Is_Constrained (Etype (E));
1494 end if;
1495
1496 else
1497 return Is_Aliased_View (Obj)
1498 and then
1499 (Is_Constrained (Etype (Obj))
1500 or else (Nkind (Obj) = N_Explicit_Dereference
1501 and then
1502 not Has_Constrained_Partial_View
1503 (Base_Type (Etype (Obj)))));
1504 end if;
1505 end Is_Constrained_Aliased_View;
1506
1507 -- Start of processing for Constrained
1508
ee6ba406 1509 begin
1510 -- Reference to a parameter where the value is passed as an extra
1511 -- actual, corresponding to the extra formal referenced by the
9dfe12ae 1512 -- Extra_Constrained field of the corresponding formal. If this
1513 -- is an entry in-parameter, it is replaced by a constant renaming
1514 -- for which Extra_Constrained is never created.
ee6ba406 1515
1516 if Present (Formal_Ent)
9dfe12ae 1517 and then Ekind (Formal_Ent) /= E_Constant
ee6ba406 1518 and then Present (Extra_Constrained (Formal_Ent))
1519 then
1520 Rewrite (N,
1521 New_Occurrence_Of
1522 (Extra_Constrained (Formal_Ent), Sloc (N)));
1523
1524 -- For variables with a Extra_Constrained field, we use the
1525 -- corresponding entity.
1526
1527 elsif Nkind (Pref) = N_Identifier
1528 and then Ekind (Entity (Pref)) = E_Variable
1529 and then Present (Extra_Constrained (Entity (Pref)))
1530 then
1531 Rewrite (N,
1532 New_Occurrence_Of
1533 (Extra_Constrained (Entity (Pref)), Sloc (N)));
1534
1535 -- For all other entity names, we can tell at compile time
1536
1537 elsif Is_Entity_Name (Pref) then
1538 declare
1539 Ent : constant Entity_Id := Entity (Pref);
1540 Res : Boolean;
1541
1542 begin
1543 -- (RM J.4) obsolescent cases
1544
1545 if Is_Type (Ent) then
1546
1547 -- Private type
1548
1549 if Is_Private_Type (Ent) then
1550 Res := not Has_Discriminants (Ent)
1551 or else Is_Constrained (Ent);
1552
1553 -- It not a private type, must be a generic actual type
1554 -- that corresponded to a private type. We know that this
1555 -- correspondence holds, since otherwise the reference
1556 -- within the generic template would have been illegal.
1557
1558 else
9dfe12ae 1559 if Is_Composite_Type (Underlying_Type (Ent)) then
1560 Res := Is_Constrained (Ent);
1561 else
1562 Res := True;
1563 end if;
ee6ba406 1564 end if;
1565
1566 -- If the prefix is not a variable or is aliased, then
d55c93e0 1567 -- definitely true; if it's a formal parameter without an
1568 -- associated extra formal, then treat it as constrained.
ee6ba406 1569
7f8eb6ed 1570 -- Ada 2005 (AI-363): An aliased prefix must be known to be
1571 -- constrained in order to set the attribute to True.
1572
ee6ba406 1573 elsif not Is_Variable (Pref)
1574 or else Present (Formal_Ent)
7f8eb6ed 1575 or else (Ada_Version < Ada_05
1576 and then Is_Aliased_View (Pref))
1577 or else (Ada_Version >= Ada_05
1578 and then Is_Constrained_Aliased_View (Pref))
ee6ba406 1579 then
1580 Res := True;
1581
d55c93e0 1582 -- Variable case, look at type to see if it is constrained.
1583 -- Note that the one case where this is not accurate (the
1584 -- procedure formal case), has been handled above.
ee6ba406 1585
99f2248e 1586 -- We use the Underlying_Type here (and below) in case the
1587 -- type is private without discriminants, but the full type
1588 -- has discriminants. This case is illegal, but we generate it
1589 -- internally for passing to the Extra_Constrained parameter.
1590
ee6ba406 1591 else
99f2248e 1592 Res := Is_Constrained (Underlying_Type (Etype (Ent)));
ee6ba406 1593 end if;
1594
1bbc9831 1595 Rewrite (N,
1596 New_Reference_To (Boolean_Literals (Res), Loc));
ee6ba406 1597 end;
1598
d55c93e0 1599 -- Prefix is not an entity name. These are also cases where we can
1600 -- always tell at compile time by looking at the form and type of the
1601 -- prefix. If an explicit dereference of an object with constrained
1602 -- partial view, this is unconstrained (Ada 2005 AI-363).
ee6ba406 1603
1604 else
1bbc9831 1605 Rewrite (N,
1606 New_Reference_To (
1607 Boolean_Literals (
1608 not Is_Variable (Pref)
aad6babd 1609 or else
1610 (Nkind (Pref) = N_Explicit_Dereference
1611 and then
d55c93e0 1612 not Has_Constrained_Partial_View (Base_Type (Ptyp)))
1613 or else Is_Constrained (Underlying_Type (Ptyp))),
1bbc9831 1614 Loc));
ee6ba406 1615 end if;
1616
1617 Analyze_And_Resolve (N, Standard_Boolean);
1618 end Constrained;
1619
1620 ---------------
1621 -- Copy_Sign --
1622 ---------------
1623
1624 -- Transforms 'Copy_Sign into a call to the floating-point attribute
1625 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
1626
1627 when Attribute_Copy_Sign =>
1628 Expand_Fpt_Attribute_RR (N);
1629
1630 -----------
1631 -- Count --
1632 -----------
1633
1634 -- Transforms 'Count attribute into a call to the Count function
1635
d55c93e0 1636 when Attribute_Count => Count : declare
1637 Call : Node_Id;
1638 Conctyp : Entity_Id;
1639 Entnam : Node_Id;
1640 Entry_Id : Entity_Id;
1641 Index : Node_Id;
1642 Name : Node_Id;
ee6ba406 1643
1644 begin
1645 -- If the prefix is a member of an entry family, retrieve both
1646 -- entry name and index. For a simple entry there is no index.
1647
1648 if Nkind (Pref) = N_Indexed_Component then
1649 Entnam := Prefix (Pref);
1650 Index := First (Expressions (Pref));
1651 else
1652 Entnam := Pref;
1653 Index := Empty;
1654 end if;
1655
d55c93e0 1656 Entry_Id := Entity (Entnam);
1657
ee6ba406 1658 -- Find the concurrent type in which this attribute is referenced
1659 -- (there had better be one).
1660
1661 Conctyp := Current_Scope;
1662 while not Is_Concurrent_Type (Conctyp) loop
1663 Conctyp := Scope (Conctyp);
1664 end loop;
1665
1666 -- Protected case
1667
1668 if Is_Protected_Type (Conctyp) then
4c06b9d2 1669 case Corresponding_Runtime_Package (Conctyp) is
1670 when System_Tasking_Protected_Objects_Entries =>
1671 Name := New_Reference_To (RTE (RE_Protected_Count), Loc);
1672
1673 Call :=
1674 Make_Function_Call (Loc,
1675 Name => Name,
1676 Parameter_Associations => New_List (
d55c93e0 1677 New_Reference_To
1678 (Find_Protection_Object (Current_Scope), Loc),
1679 Entry_Index_Expression
1680 (Loc, Entry_Id, Index, Scope (Entry_Id))));
4c06b9d2 1681
1682 when System_Tasking_Protected_Objects_Single_Entry =>
d55c93e0 1683 Name :=
1684 New_Reference_To (RTE (RE_Protected_Count_Entry), Loc);
4c06b9d2 1685
1686 Call :=
1687 Make_Function_Call (Loc,
1688 Name => Name,
1689 Parameter_Associations => New_List (
d55c93e0 1690 New_Reference_To
1691 (Find_Protection_Object (Current_Scope), Loc)));
1692
4c06b9d2 1693 when others =>
1694 raise Program_Error;
4c06b9d2 1695 end case;
ee6ba406 1696
1697 -- Task case
1698
1699 else
1700 Call :=
1701 Make_Function_Call (Loc,
1702 Name => New_Reference_To (RTE (RE_Task_Count), Loc),
1703 Parameter_Associations => New_List (
d55c93e0 1704 Entry_Index_Expression (Loc,
1705 Entry_Id, Index, Scope (Entry_Id))));
ee6ba406 1706 end if;
1707
1708 -- The call returns type Natural but the context is universal integer
1709 -- so any integer type is allowed. The attribute was already resolved
1710 -- so its Etype is the required result type. If the base type of the
1711 -- context type is other than Standard.Integer we put in a conversion
1712 -- to the required type. This can be a normal typed conversion since
1713 -- both input and output types of the conversion are integer types
1714
1715 if Base_Type (Typ) /= Base_Type (Standard_Integer) then
1716 Rewrite (N, Convert_To (Typ, Call));
1717 else
1718 Rewrite (N, Call);
1719 end if;
1720
1721 Analyze_And_Resolve (N, Typ);
1722 end Count;
1723
1724 ---------------
1725 -- Elab_Body --
1726 ---------------
1727
1728 -- This processing is shared by Elab_Spec
1729
1730 -- What we do is to insert the following declarations
1731
1732 -- procedure tnn;
1733 -- pragma Import (C, enn, "name___elabb/s");
1734
1735 -- and then the Elab_Body/Spec attribute is replaced by a reference
1736 -- to this defining identifier.
1737
1738 when Attribute_Elab_Body |
1739 Attribute_Elab_Spec =>
1740
1741 Elab_Body : declare
1742 Ent : constant Entity_Id :=
1743 Make_Defining_Identifier (Loc,
1744 New_Internal_Name ('E'));
1745 Str : String_Id;
1746 Lang : Node_Id;
1747
1748 procedure Make_Elab_String (Nod : Node_Id);
1749 -- Given Nod, an identifier, or a selected component, put the
1750 -- image into the current string literal, with double underline
1751 -- between components.
1752
7f8eb6ed 1753 ----------------------
1754 -- Make_Elab_String --
1755 ----------------------
1756
ee6ba406 1757 procedure Make_Elab_String (Nod : Node_Id) is
1758 begin
1759 if Nkind (Nod) = N_Selected_Component then
1760 Make_Elab_String (Prefix (Nod));
7f8eb6ed 1761
83aa52b6 1762 case VM_Target is
1763 when JVM_Target =>
1764 Store_String_Char ('$');
1765 when CLI_Target =>
1766 Store_String_Char ('.');
1767 when No_VM =>
1768 Store_String_Char ('_');
1769 Store_String_Char ('_');
1770 end case;
ee6ba406 1771
1772 Get_Name_String (Chars (Selector_Name (Nod)));
1773
1774 else
1775 pragma Assert (Nkind (Nod) = N_Identifier);
1776 Get_Name_String (Chars (Nod));
1777 end if;
1778
1779 Store_String_Chars (Name_Buffer (1 .. Name_Len));
1780 end Make_Elab_String;
1781
1782 -- Start of processing for Elab_Body/Elab_Spec
1783
1784 begin
1785 -- First we need to prepare the string literal for the name of
1786 -- the elaboration routine to be referenced.
1787
1788 Start_String;
1789 Make_Elab_String (Pref);
1790
83aa52b6 1791 if VM_Target = No_VM then
ee6ba406 1792 Store_String_Chars ("___elab");
1793 Lang := Make_Identifier (Loc, Name_C);
83aa52b6 1794 else
1795 Store_String_Chars ("._elab");
1796 Lang := Make_Identifier (Loc, Name_Ada);
ee6ba406 1797 end if;
1798
1799 if Id = Attribute_Elab_Body then
1800 Store_String_Char ('b');
1801 else
1802 Store_String_Char ('s');
1803 end if;
1804
1805 Str := End_String;
1806
1807 Insert_Actions (N, New_List (
1808 Make_Subprogram_Declaration (Loc,
1809 Specification =>
1810 Make_Procedure_Specification (Loc,
1811 Defining_Unit_Name => Ent)),
1812
1813 Make_Pragma (Loc,
1814 Chars => Name_Import,
1815 Pragma_Argument_Associations => New_List (
1816 Make_Pragma_Argument_Association (Loc,
1817 Expression => Lang),
1818
1819 Make_Pragma_Argument_Association (Loc,
1820 Expression =>
1821 Make_Identifier (Loc, Chars (Ent))),
1822
1823 Make_Pragma_Argument_Association (Loc,
1824 Expression =>
1825 Make_String_Literal (Loc, Str))))));
1826
1827 Set_Entity (N, Ent);
1828 Rewrite (N, New_Occurrence_Of (Ent, Loc));
1829 end Elab_Body;
1830
1831 ----------------
1832 -- Elaborated --
1833 ----------------
1834
d55c93e0 1835 -- Elaborated is always True for preelaborated units, predefined units,
1836 -- pure units and units which have Elaborate_Body pragmas. These units
1837 -- have no elaboration entity.
ee6ba406 1838
d55c93e0 1839 -- Note: The Elaborated attribute is never passed to the back end
ee6ba406 1840
1841 when Attribute_Elaborated => Elaborated : declare
1842 Ent : constant Entity_Id := Entity (Pref);
1843
1844 begin
1845 if Present (Elaboration_Entity (Ent)) then
1846 Rewrite (N,
1847 New_Occurrence_Of (Elaboration_Entity (Ent), Loc));
1848 else
1849 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
1850 end if;
1851 end Elaborated;
1852
1853 --------------
1854 -- Enum_Rep --
1855 --------------
1856
1857 when Attribute_Enum_Rep => Enum_Rep :
1858 begin
1859 -- X'Enum_Rep (Y) expands to
1860
1861 -- target-type (Y)
1862
d55c93e0 1863 -- This is simply a direct conversion from the enumeration type to
1864 -- the target integer type, which is treated by the back end as a
1865 -- normal integer conversion, treating the enumeration type as an
1866 -- integer, which is exactly what we want! We set Conversion_OK to
1867 -- make sure that the analyzer does not complain about what otherwise
1868 -- might be an illegal conversion.
ee6ba406 1869
1870 if Is_Non_Empty_List (Exprs) then
1871 Rewrite (N,
1872 OK_Convert_To (Typ, Relocate_Node (First (Exprs))));
1873
1874 -- X'Enum_Rep where X is an enumeration literal is replaced by
1875 -- the literal value.
1876
1877 elsif Ekind (Entity (Pref)) = E_Enumeration_Literal then
1878 Rewrite (N,
1879 Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref))));
1880
9dfe12ae 1881 -- If this is a renaming of a literal, recover the representation
1882 -- of the original.
1883
1884 elsif Ekind (Entity (Pref)) = E_Constant
1885 and then Present (Renamed_Object (Entity (Pref)))
1886 and then
1887 Ekind (Entity (Renamed_Object (Entity (Pref))))
1888 = E_Enumeration_Literal
1889 then
1890 Rewrite (N,
1891 Make_Integer_Literal (Loc,
1892 Enumeration_Rep (Entity (Renamed_Object (Entity (Pref))))));
1893
ee6ba406 1894 -- X'Enum_Rep where X is an object does a direct unchecked conversion
1895 -- of the object value, as described for the type case above.
1896
1897 else
1898 Rewrite (N,
1899 OK_Convert_To (Typ, Relocate_Node (Pref)));
1900 end if;
1901
1902 Set_Etype (N, Typ);
1903 Analyze_And_Resolve (N, Typ);
ee6ba406 1904 end Enum_Rep;
1905
d55c93e0 1906 --------------
1907 -- Enum_Val --
1908 --------------
1909
1910 when Attribute_Enum_Val => Enum_Val : declare
1911 Expr : Node_Id;
1912 Btyp : constant Entity_Id := Base_Type (Ptyp);
1913
1914 begin
1915 -- X'Enum_Val (Y) expands to
1916
1917 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
1918 -- X!(Y);
1919
1920 Expr := Unchecked_Convert_To (Ptyp, First (Exprs));
1921
1922 Insert_Action (N,
1923 Make_Raise_Constraint_Error (Loc,
1924 Condition =>
1925 Make_Op_Eq (Loc,
1926 Left_Opnd =>
1927 Make_Function_Call (Loc,
1928 Name =>
1929 New_Reference_To (TSS (Btyp, TSS_Rep_To_Pos), Loc),
1930 Parameter_Associations => New_List (
1931 Relocate_Node (Duplicate_Subexpr (Expr)),
1932 New_Occurrence_Of (Standard_False, Loc))),
1933
1934 Right_Opnd => Make_Integer_Literal (Loc, -1)),
1935 Reason => CE_Range_Check_Failed));
1936
1937 Rewrite (N, Expr);
1938 Analyze_And_Resolve (N, Ptyp);
1939 end Enum_Val;
1940
ee6ba406 1941 --------------
1942 -- Exponent --
1943 --------------
1944
1945 -- Transforms 'Exponent into a call to the floating-point attribute
1946 -- function Exponent in Fat_xxx (where xxx is the root type)
1947
1948 when Attribute_Exponent =>
1949 Expand_Fpt_Attribute_R (N);
1950
1951 ------------------
1952 -- External_Tag --
1953 ------------------
1954
1955 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
1956
1957 when Attribute_External_Tag => External_Tag :
1958 begin
1959 Rewrite (N,
1960 Make_Function_Call (Loc,
1961 Name => New_Reference_To (RTE (RE_External_Tag), Loc),
1962 Parameter_Associations => New_List (
1963 Make_Attribute_Reference (Loc,
1964 Attribute_Name => Name_Tag,
1965 Prefix => Prefix (N)))));
1966
1967 Analyze_And_Resolve (N, Standard_String);
1968 end External_Tag;
1969
1970 -----------
1971 -- First --
1972 -----------
1973
d55c93e0 1974 when Attribute_First =>
ee6ba406 1975
ee6ba406 1976 -- If the prefix type is a constrained packed array type which
1977 -- already has a Packed_Array_Type representation defined, then
1978 -- replace this attribute with a direct reference to 'First of the
d55c93e0 1979 -- appropriate index subtype (since otherwise the back end will try
1980 -- to give us the value of 'First for this implementation type).
ee6ba406 1981
1982 if Is_Constrained_Packed_Array (Ptyp) then
1983 Rewrite (N,
1984 Make_Attribute_Reference (Loc,
1985 Attribute_Name => Name_First,
1986 Prefix => New_Reference_To (Get_Index_Subtype (N), Loc)));
1987 Analyze_And_Resolve (N, Typ);
1988
1989 elsif Is_Access_Type (Ptyp) then
1990 Apply_Access_Check (N);
1991 end if;
ee6ba406 1992
1993 ---------------
1994 -- First_Bit --
1995 ---------------
1996
d55c93e0 1997 -- Compute this if component clause was present, otherwise we leave the
1998 -- computation to be completed in the back-end, since we don't know what
ee6ba406 1999 -- layout will be chosen.
2000
d55c93e0 2001 when Attribute_First_Bit => First_Bit : declare
ee6ba406 2002 CE : constant Entity_Id := Entity (Selector_Name (Pref));
2003
2004 begin
2005 if Known_Static_Component_Bit_Offset (CE) then
2006 Rewrite (N,
2007 Make_Integer_Literal (Loc,
2008 Component_Bit_Offset (CE) mod System_Storage_Unit));
2009
2010 Analyze_And_Resolve (N, Typ);
2011
2012 else
2013 Apply_Universal_Integer_Attribute_Checks (N);
2014 end if;
2015 end First_Bit;
2016
2017 -----------------
2018 -- Fixed_Value --
2019 -----------------
2020
2021 -- We transform:
2022
2023 -- fixtype'Fixed_Value (integer-value)
2024
2025 -- into
2026
2027 -- fixtype(integer-value)
2028
d55c93e0 2029 -- We do all the required analysis of the conversion here, because we do
2030 -- not want this to go through the fixed-point conversion circuits. Note
2031 -- that the back end always treats fixed-point as equivalent to the
2032 -- corresponding integer type anyway.
ee6ba406 2033
2034 when Attribute_Fixed_Value => Fixed_Value :
2035 begin
2036 Rewrite (N,
2037 Make_Type_Conversion (Loc,
2038 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
2039 Expression => Relocate_Node (First (Exprs))));
2040 Set_Etype (N, Entity (Pref));
2041 Set_Analyzed (N);
9dfe12ae 2042
2043 -- Note: it might appear that a properly analyzed unchecked conversion
2044 -- would be just fine here, but that's not the case, since the full
2045 -- range checks performed by the following call are critical!
2046
ee6ba406 2047 Apply_Type_Conversion_Checks (N);
2048 end Fixed_Value;
2049
2050 -----------
2051 -- Floor --
2052 -----------
2053
2054 -- Transforms 'Floor into a call to the floating-point attribute
2055 -- function Floor in Fat_xxx (where xxx is the root type)
2056
2057 when Attribute_Floor =>
2058 Expand_Fpt_Attribute_R (N);
2059
2060 ----------
2061 -- Fore --
2062 ----------
2063
2064 -- For the fixed-point type Typ:
2065
2066 -- Typ'Fore
2067
2068 -- expands into
2069
1550b445 2070 -- Result_Type (System.Fore (Universal_Real (Type'First)),
2071 -- Universal_Real (Type'Last))
ee6ba406 2072
2073 -- Note that we know that the type is a non-static subtype, or Fore
2074 -- would have itself been computed dynamically in Eval_Attribute.
2075
d55c93e0 2076 when Attribute_Fore => Fore : begin
ee6ba406 2077 Rewrite (N,
2078 Convert_To (Typ,
2079 Make_Function_Call (Loc,
2080 Name => New_Reference_To (RTE (RE_Fore), Loc),
2081
2082 Parameter_Associations => New_List (
1550b445 2083 Convert_To (Universal_Real,
ee6ba406 2084 Make_Attribute_Reference (Loc,
2085 Prefix => New_Reference_To (Ptyp, Loc),
2086 Attribute_Name => Name_First)),
2087
1550b445 2088 Convert_To (Universal_Real,
ee6ba406 2089 Make_Attribute_Reference (Loc,
2090 Prefix => New_Reference_To (Ptyp, Loc),
2091 Attribute_Name => Name_Last))))));
2092
2093 Analyze_And_Resolve (N, Typ);
2094 end Fore;
2095
2096 --------------
2097 -- Fraction --
2098 --------------
2099
2100 -- Transforms 'Fraction into a call to the floating-point attribute
2101 -- function Fraction in Fat_xxx (where xxx is the root type)
2102
2103 when Attribute_Fraction =>
2104 Expand_Fpt_Attribute_R (N);
2105
5690e662 2106 --------------
2107 -- From_Any --
2108 --------------
2109
2110 when Attribute_From_Any => From_Any : declare
2111 P_Type : constant Entity_Id := Etype (Pref);
2112 Decls : constant List_Id := New_List;
2113 begin
2114 Rewrite (N,
2115 Build_From_Any_Call (P_Type,
2116 Relocate_Node (First (Exprs)),
2117 Decls));
2118 Insert_Actions (N, Decls);
2119 Analyze_And_Resolve (N, P_Type);
2120 end From_Any;
2121
ee6ba406 2122 --------------
2123 -- Identity --
2124 --------------
2125
2126 -- For an exception returns a reference to the exception data:
2127 -- Exception_Id!(Prefix'Reference)
2128
2129 -- For a task it returns a reference to the _task_id component of
2130 -- corresponding record:
2131
7f9be362 2132 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
ee6ba406 2133
aad6babd 2134 -- in Ada.Task_Identification
ee6ba406 2135
2136 when Attribute_Identity => Identity : declare
2137 Id_Kind : Entity_Id;
2138
2139 begin
d55c93e0 2140 if Ptyp = Standard_Exception_Type then
ee6ba406 2141 Id_Kind := RTE (RE_Exception_Id);
2142
2143 if Present (Renamed_Object (Entity (Pref))) then
2144 Set_Entity (Pref, Renamed_Object (Entity (Pref)));
2145 end if;
2146
2147 Rewrite (N,
2148 Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref)));
2149 else
7f9be362 2150 Id_Kind := RTE (RO_AT_Task_Id);
ee6ba406 2151
f0bf2ff3 2152 -- If the prefix is a task interface, the Task_Id is obtained
2153 -- dynamically through a dispatching call, as for other task
2154 -- attributes applied to interfaces.
2155
2156 if Ada_Version >= Ada_05
d55c93e0 2157 and then Ekind (Ptyp) = E_Class_Wide_Type
2158 and then Is_Interface (Ptyp)
2159 and then Is_Task_Interface (Ptyp)
f0bf2ff3 2160 then
2161 Rewrite (N,
2162 Unchecked_Convert_To (Id_Kind,
2163 Make_Selected_Component (Loc,
2164 Prefix =>
2165 New_Copy_Tree (Pref),
2166 Selector_Name =>
2167 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))));
2168
2169 else
2170 Rewrite (N,
2171 Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
2172 end if;
ee6ba406 2173 end if;
2174
2175 Analyze_And_Resolve (N, Id_Kind);
2176 end Identity;
2177
2178 -----------
2179 -- Image --
2180 -----------
2181
2182 -- Image attribute is handled in separate unit Exp_Imgv
2183
2184 when Attribute_Image =>
2185 Exp_Imgv.Expand_Image_Attribute (N);
2186
2187 ---------
2188 -- Img --
2189 ---------
2190
2191 -- X'Img is expanded to typ'Image (X), where typ is the type of X
2192
2193 when Attribute_Img => Img :
2194 begin
2195 Rewrite (N,
2196 Make_Attribute_Reference (Loc,
d55c93e0 2197 Prefix => New_Reference_To (Ptyp, Loc),
ee6ba406 2198 Attribute_Name => Name_Image,
2199 Expressions => New_List (Relocate_Node (Pref))));
2200
2201 Analyze_And_Resolve (N, Standard_String);
2202 end Img;
2203
2204 -----------
2205 -- Input --
2206 -----------
2207
2208 when Attribute_Input => Input : declare
2209 P_Type : constant Entity_Id := Entity (Pref);
2210 B_Type : constant Entity_Id := Base_Type (P_Type);
2211 U_Type : constant Entity_Id := Underlying_Type (P_Type);
2212 Strm : constant Node_Id := First (Exprs);
2213 Fname : Entity_Id;
2214 Decl : Node_Id;
2215 Call : Node_Id;
2216 Prag : Node_Id;
2217 Arg2 : Node_Id;
2218 Rfunc : Node_Id;
2219
2220 Cntrl : Node_Id := Empty;
2221 -- Value for controlling argument in call. Always Empty except in
2222 -- the dispatching (class-wide type) case, where it is a reference
2223 -- to the dummy object initialized to the right internal tag.
2224
d53a018a 2225 procedure Freeze_Stream_Subprogram (F : Entity_Id);
2226 -- The expansion of the attribute reference may generate a call to
2227 -- a user-defined stream subprogram that is frozen by the call. This
2228 -- can lead to access-before-elaboration problem if the reference
2229 -- appears in an object declaration and the subprogram body has not
2230 -- been seen. The freezing of the subprogram requires special code
2231 -- because it appears in an expanded context where expressions do
2232 -- not freeze their constituents.
2233
2234 ------------------------------
2235 -- Freeze_Stream_Subprogram --
2236 ------------------------------
2237
2238 procedure Freeze_Stream_Subprogram (F : Entity_Id) is
2239 Decl : constant Node_Id := Unit_Declaration_Node (F);
2240 Bod : Node_Id;
2241
2242 begin
2243 -- If this is user-defined subprogram, the corresponding
2244 -- stream function appears as a renaming-as-body, and the
2245 -- user subprogram must be retrieved by tree traversal.
2246
2247 if Present (Decl)
2248 and then Nkind (Decl) = N_Subprogram_Declaration
2249 and then Present (Corresponding_Body (Decl))
2250 then
2251 Bod := Corresponding_Body (Decl);
2252
2253 if Nkind (Unit_Declaration_Node (Bod)) =
2254 N_Subprogram_Renaming_Declaration
2255 then
2256 Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod))));
2257 end if;
2258 end if;
2259 end Freeze_Stream_Subprogram;
2260
2261 -- Start of processing for Input
2262
ee6ba406 2263 begin
2264 -- If no underlying type, we have an error that will be diagnosed
2265 -- elsewhere, so here we just completely ignore the expansion.
2266
2267 if No (U_Type) then
2268 return;
2269 end if;
2270
2271 -- If there is a TSS for Input, just call it
2272
9dfe12ae 2273 Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
ee6ba406 2274
2275 if Present (Fname) then
2276 null;
2277
2278 else
2279 -- If there is a Stream_Convert pragma, use it, we rewrite
2280
2281 -- sourcetyp'Input (stream)
2282
2283 -- as
2284
2285 -- sourcetyp (streamread (strmtyp'Input (stream)));
2286
2c145f84 2287 -- where streamread is the given Read function that converts an
d55c93e0 2288 -- argument of type strmtyp to type sourcetyp or a type from which
2289 -- it is derived (extra conversion required for the derived case).
ee6ba406 2290
5245b786 2291 Prag := Get_Stream_Convert_Pragma (P_Type);
ee6ba406 2292
2293 if Present (Prag) then
2294 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
2295 Rfunc := Entity (Expression (Arg2));
2296
2297 Rewrite (N,
2298 Convert_To (B_Type,
2299 Make_Function_Call (Loc,
2300 Name => New_Occurrence_Of (Rfunc, Loc),
2301 Parameter_Associations => New_List (
2302 Make_Attribute_Reference (Loc,
2303 Prefix =>
2304 New_Occurrence_Of
2305 (Etype (First_Formal (Rfunc)), Loc),
2306 Attribute_Name => Name_Input,
2307 Expressions => Exprs)))));
2308
2309 Analyze_And_Resolve (N, B_Type);
2310 return;
2311
2312 -- Elementary types
2313
2314 elsif Is_Elementary_Type (U_Type) then
2315
2316 -- A special case arises if we have a defined _Read routine,
2317 -- since in this case we are required to call this routine.
2318
9dfe12ae 2319 if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then
ee6ba406 2320 Build_Record_Or_Elementary_Input_Function
2321 (Loc, U_Type, Decl, Fname);
2322 Insert_Action (N, Decl);
2323
2324 -- For normal cases, we call the I_xxx routine directly
2325
2326 else
2327 Rewrite (N, Build_Elementary_Input_Call (N));
2328 Analyze_And_Resolve (N, P_Type);
2329 return;
2330 end if;
2331
2332 -- Array type case
2333
2334 elsif Is_Array_Type (U_Type) then
2335 Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
2336 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
2337
2338 -- Dispatching case with class-wide type
2339
2340 elsif Is_Class_Wide_Type (P_Type) then
2341
99f2248e 2342 -- No need to do anything else compiling under restriction
2343 -- No_Dispatching_Calls. During the semantic analysis we
2344 -- already notified such violation.
2345
2346 if Restriction_Active (No_Dispatching_Calls) then
2347 return;
2348 end if;
2349
ee6ba406 2350 declare
2351 Rtyp : constant Entity_Id := Root_Type (P_Type);
2352 Dnn : Entity_Id;
2353 Decl : Node_Id;
2354
2355 begin
2356 -- Read the internal tag (RM 13.13.2(34)) and use it to
2357 -- initialize a dummy tag object:
2358
2359 -- Dnn : Ada.Tags.Tag
aad6babd 2360 -- := Descendant_Tag (String'Input (Strm), P_Type);
ee6ba406 2361
2362 -- This dummy object is used only to provide a controlling
aad6babd 2363 -- argument for the eventual _Input call. Descendant_Tag is
2364 -- called rather than Internal_Tag to ensure that we have a
2365 -- tag for a type that is descended from the prefix type and
2366 -- declared at the same accessibility level (the exception
2367 -- Tag_Error will be raised otherwise). The level check is
2368 -- required for Ada 2005 because tagged types can be
2369 -- extended in nested scopes (AI-344).
ee6ba406 2370
2371 Dnn :=
2372 Make_Defining_Identifier (Loc,
2373 Chars => New_Internal_Name ('D'));
2374
2375 Decl :=
2376 Make_Object_Declaration (Loc,
2377 Defining_Identifier => Dnn,
2378 Object_Definition =>
2379 New_Occurrence_Of (RTE (RE_Tag), Loc),
2380 Expression =>
2381 Make_Function_Call (Loc,
2382 Name =>
aad6babd 2383 New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
ee6ba406 2384 Parameter_Associations => New_List (
2385 Make_Attribute_Reference (Loc,
2386 Prefix =>
2387 New_Occurrence_Of (Standard_String, Loc),
2388 Attribute_Name => Name_Input,
2389 Expressions => New_List (
2390 Relocate_Node
aad6babd 2391 (Duplicate_Subexpr (Strm)))),
2392 Make_Attribute_Reference (Loc,
2393 Prefix => New_Reference_To (P_Type, Loc),
2394 Attribute_Name => Name_Tag))));
ee6ba406 2395
2396 Insert_Action (N, Decl);
2397
2398 -- Now we need to get the entity for the call, and construct
2399 -- a function call node, where we preset a reference to Dnn
aad6babd 2400 -- as the controlling argument (doing an unchecked convert
2401 -- to the class-wide tagged type to make it look like a real
2402 -- tagged object).
ee6ba406 2403
9dfe12ae 2404 Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
2405 Cntrl := Unchecked_Convert_To (P_Type,
ee6ba406 2406 New_Occurrence_Of (Dnn, Loc));
9dfe12ae 2407 Set_Etype (Cntrl, P_Type);
ee6ba406 2408 Set_Parent (Cntrl, N);
2409 end;
2410
2411 -- For tagged types, use the primitive Input function
2412
2413 elsif Is_Tagged_Type (U_Type) then
9dfe12ae 2414 Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
ee6ba406 2415
aad6babd 2416 -- All other record type cases, including protected records. The
2417 -- latter only arise for expander generated code for handling
2418 -- shared passive partition access.
ee6ba406 2419
2420 else
2421 pragma Assert
2422 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
2423
d55c93e0 2424 -- Ada 2005 (AI-216): Program_Error is raised executing default
2425 -- implementation of the Input attribute of an unchecked union
2426 -- type if the type lacks default discriminant values.
00f91aef 2427
2428 if Is_Unchecked_Union (Base_Type (U_Type))
18a40e97 2429 and then No (Discriminant_Constraint (U_Type))
00f91aef 2430 then
2431 Insert_Action (N,
2432 Make_Raise_Program_Error (Loc,
2433 Reason => PE_Unchecked_Union_Restriction));
2434
2435 return;
2436 end if;
2437
ee6ba406 2438 Build_Record_Or_Elementary_Input_Function
2439 (Loc, Base_Type (U_Type), Decl, Fname);
2440 Insert_Action (N, Decl);
d53a018a 2441
2442 if Nkind (Parent (N)) = N_Object_Declaration
2443 and then Is_Record_Type (U_Type)
2444 then
2445 -- The stream function may contain calls to user-defined
2446 -- Read procedures for individual components.
2447
2448 declare
2449 Comp : Entity_Id;
2450 Func : Entity_Id;
2451
2452 begin
2453 Comp := First_Component (U_Type);
2454 while Present (Comp) loop
2455 Func :=
2456 Find_Stream_Subprogram
2457 (Etype (Comp), TSS_Stream_Read);
2458
2459 if Present (Func) then
2460 Freeze_Stream_Subprogram (Func);
2461 end if;
2462
2463 Next_Component (Comp);
2464 end loop;
2465 end;
2466 end if;
ee6ba406 2467 end if;
2468 end if;
2469
aad6babd 2470 -- If we fall through, Fname is the function to be called. The result
2471 -- is obtained by calling the appropriate function, then converting
2472 -- the result. The conversion does a subtype check.
ee6ba406 2473
2474 Call :=
2475 Make_Function_Call (Loc,
2476 Name => New_Occurrence_Of (Fname, Loc),
2477 Parameter_Associations => New_List (
2478 Relocate_Node (Strm)));
2479
2480 Set_Controlling_Argument (Call, Cntrl);
2481 Rewrite (N, Unchecked_Convert_To (P_Type, Call));
2482 Analyze_And_Resolve (N, P_Type);
d53a018a 2483
2484 if Nkind (Parent (N)) = N_Object_Declaration then
2485 Freeze_Stream_Subprogram (Fname);
2486 end if;
ee6ba406 2487 end Input;
2488
2489 -------------------
2490 -- Integer_Value --
2491 -------------------
2492
2493 -- We transform
2494
2495 -- inttype'Fixed_Value (fixed-value)
2496
2497 -- into
2498
2499 -- inttype(integer-value))
2500
d55c93e0 2501 -- we do all the required analysis of the conversion here, because we do
2502 -- not want this to go through the fixed-point conversion circuits. Note
2503 -- that the back end always treats fixed-point as equivalent to the
2504 -- corresponding integer type anyway.
ee6ba406 2505
2506 when Attribute_Integer_Value => Integer_Value :
2507 begin
2508 Rewrite (N,
2509 Make_Type_Conversion (Loc,
2510 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
2511 Expression => Relocate_Node (First (Exprs))));
2512 Set_Etype (N, Entity (Pref));
2513 Set_Analyzed (N);
9dfe12ae 2514
2515 -- Note: it might appear that a properly analyzed unchecked conversion
2516 -- would be just fine here, but that's not the case, since the full
2517 -- range checks performed by the following call are critical!
2518
ee6ba406 2519 Apply_Type_Conversion_Checks (N);
2520 end Integer_Value;
2521
d55c93e0 2522 -------------------
2523 -- Invalid_Value --
2524 -------------------
2525
2526 when Attribute_Invalid_Value =>
2527 Rewrite (N, Get_Simple_Init_Val (Ptyp, N));
2528
ee6ba406 2529 ----------
2530 -- Last --
2531 ----------
2532
d55c93e0 2533 when Attribute_Last =>
ee6ba406 2534
ee6ba406 2535 -- If the prefix type is a constrained packed array type which
2536 -- already has a Packed_Array_Type representation defined, then
2537 -- replace this attribute with a direct reference to 'Last of the
d55c93e0 2538 -- appropriate index subtype (since otherwise the back end will try
2539 -- to give us the value of 'Last for this implementation type).
ee6ba406 2540
2541 if Is_Constrained_Packed_Array (Ptyp) then
2542 Rewrite (N,
2543 Make_Attribute_Reference (Loc,
2544 Attribute_Name => Name_Last,
2545 Prefix => New_Reference_To (Get_Index_Subtype (N), Loc)));
2546 Analyze_And_Resolve (N, Typ);
2547
2548 elsif Is_Access_Type (Ptyp) then
2549 Apply_Access_Check (N);
2550 end if;
ee6ba406 2551
2552 --------------
2553 -- Last_Bit --
2554 --------------
2555
d55c93e0 2556 -- We compute this if a component clause was present, otherwise we leave
2557 -- the computation up to the back end, since we don't know what layout
2558 -- will be chosen.
ee6ba406 2559
d55c93e0 2560 when Attribute_Last_Bit => Last_Bit : declare
ee6ba406 2561 CE : constant Entity_Id := Entity (Selector_Name (Pref));
2562
2563 begin
2564 if Known_Static_Component_Bit_Offset (CE)
2565 and then Known_Static_Esize (CE)
2566 then
2567 Rewrite (N,
2568 Make_Integer_Literal (Loc,
2569 Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
2570 + Esize (CE) - 1));
2571
2572 Analyze_And_Resolve (N, Typ);
2573
2574 else
2575 Apply_Universal_Integer_Attribute_Checks (N);
2576 end if;
2577 end Last_Bit;
2578
2579 ------------------
2580 -- Leading_Part --
2581 ------------------
2582
2583 -- Transforms 'Leading_Part into a call to the floating-point attribute
2584 -- function Leading_Part in Fat_xxx (where xxx is the root type)
2585
d55c93e0 2586 -- Note: strictly, we should generate special case code to deal with
aad6babd 2587 -- absurdly large positive arguments (greater than Integer'Last), which
2588 -- result in returning the first argument unchanged, but it hardly seems
2589 -- worth the effort. We raise constraint error for absurdly negative
2590 -- arguments which is fine.
ee6ba406 2591
2592 when Attribute_Leading_Part =>
2593 Expand_Fpt_Attribute_RI (N);
2594
2595 ------------
2596 -- Length --
2597 ------------
2598
2599 when Attribute_Length => declare
ee6ba406 2600 Ityp : Entity_Id;
2601 Xnum : Uint;
2602
2603 begin
2604 -- Processing for packed array types
2605
2606 if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
2607 Ityp := Get_Index_Subtype (N);
2608
d55c93e0 2609 -- If the index type, Ityp, is an enumeration type with holes,
2610 -- then we calculate X'Length explicitly using
ee6ba406 2611
2612 -- Typ'Max
2613 -- (0, Ityp'Pos (X'Last (N)) -
2614 -- Ityp'Pos (X'First (N)) + 1);
2615
d55c93e0 2616 -- Since the bounds in the template are the representation values
2617 -- and the back end would get the wrong value.
ee6ba406 2618
2619 if Is_Enumeration_Type (Ityp)
2620 and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
2621 then
2622 if No (Exprs) then
2623 Xnum := Uint_1;
2624 else
2625 Xnum := Expr_Value (First (Expressions (N)));
2626 end if;
2627
2628 Rewrite (N,
2629 Make_Attribute_Reference (Loc,
2630 Prefix => New_Occurrence_Of (Typ, Loc),
2631 Attribute_Name => Name_Max,
2632 Expressions => New_List
2633 (Make_Integer_Literal (Loc, 0),
2634
2635 Make_Op_Add (Loc,
2636 Left_Opnd =>
2637 Make_Op_Subtract (Loc,
2638 Left_Opnd =>
2639 Make_Attribute_Reference (Loc,
2640 Prefix => New_Occurrence_Of (Ityp, Loc),
2641 Attribute_Name => Name_Pos,
2642
2643 Expressions => New_List (
2644 Make_Attribute_Reference (Loc,
2645 Prefix => Duplicate_Subexpr (Pref),
2646 Attribute_Name => Name_Last,
2647 Expressions => New_List (
2648 Make_Integer_Literal (Loc, Xnum))))),
2649
2650 Right_Opnd =>
2651 Make_Attribute_Reference (Loc,
2652 Prefix => New_Occurrence_Of (Ityp, Loc),
2653 Attribute_Name => Name_Pos,
2654
2655 Expressions => New_List (
2656 Make_Attribute_Reference (Loc,
9dfe12ae 2657 Prefix =>
2658 Duplicate_Subexpr_No_Checks (Pref),
ee6ba406 2659 Attribute_Name => Name_First,
2660 Expressions => New_List (
2661 Make_Integer_Literal (Loc, Xnum)))))),
2662
2663 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
2664
2665 Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
2666 return;
2667
2668 -- If the prefix type is a constrained packed array type which
2669 -- already has a Packed_Array_Type representation defined, then
2670 -- replace this attribute with a direct reference to 'Range_Length
d55c93e0 2671 -- of the appropriate index subtype (since otherwise the back end
2672 -- will try to give us the value of 'Length for this
2673 -- implementation type).
ee6ba406 2674
2675 elsif Is_Constrained (Ptyp) then
2676 Rewrite (N,
2677 Make_Attribute_Reference (Loc,
2678 Attribute_Name => Name_Range_Length,
2679 Prefix => New_Reference_To (Ityp, Loc)));
2680 Analyze_And_Resolve (N, Typ);
2681 end if;
2682
ee6ba406 2683 -- Access type case
2684
2685 elsif Is_Access_Type (Ptyp) then
2686 Apply_Access_Check (N);
2687
d55c93e0 2688 -- If the designated type is a packed array type, then we convert
2689 -- the reference to:
ee6ba406 2690
2691 -- typ'Max (0, 1 +
2692 -- xtyp'Pos (Pref'Last (Expr)) -
2693 -- xtyp'Pos (Pref'First (Expr)));
2694
d55c93e0 2695 -- This is a bit complex, but it is the easiest thing to do that
2696 -- works in all cases including enum types with holes xtyp here
2697 -- is the appropriate index type.
ee6ba406 2698
2699 declare
2700 Dtyp : constant Entity_Id := Designated_Type (Ptyp);
2701 Xtyp : Entity_Id;
2702
2703 begin
2704 if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
2705 Xtyp := Get_Index_Subtype (N);
2706
2707 Rewrite (N,
2708 Make_Attribute_Reference (Loc,
2709 Prefix => New_Occurrence_Of (Typ, Loc),
2710 Attribute_Name => Name_Max,
2711 Expressions => New_List (
2712 Make_Integer_Literal (Loc, 0),
2713
2714 Make_Op_Add (Loc,
2715 Make_Integer_Literal (Loc, 1),
2716 Make_Op_Subtract (Loc,
2717 Left_Opnd =>
2718 Make_Attribute_Reference (Loc,
2719 Prefix => New_Occurrence_Of (Xtyp, Loc),
2720 Attribute_Name => Name_Pos,
2721 Expressions => New_List (
2722 Make_Attribute_Reference (Loc,
2723 Prefix => Duplicate_Subexpr (Pref),
2724 Attribute_Name => Name_Last,
2725 Expressions =>
2726 New_Copy_List (Exprs)))),
2727
2728 Right_Opnd =>
2729 Make_Attribute_Reference (Loc,
2730 Prefix => New_Occurrence_Of (Xtyp, Loc),
2731 Attribute_Name => Name_Pos,
2732 Expressions => New_List (
2733 Make_Attribute_Reference (Loc,
9dfe12ae 2734 Prefix =>
2735 Duplicate_Subexpr_No_Checks (Pref),
ee6ba406 2736 Attribute_Name => Name_First,
2737 Expressions =>
2738 New_Copy_List (Exprs)))))))));
2739
2740 Analyze_And_Resolve (N, Typ);
2741 end if;
2742 end;
2743
d55c93e0 2744 -- Otherwise leave it to the back end
ee6ba406 2745
2746 else
2747 Apply_Universal_Integer_Attribute_Checks (N);
2748 end if;
2749 end;
2750
2751 -------------
2752 -- Machine --
2753 -------------
2754
2755 -- Transforms 'Machine into a call to the floating-point attribute
2756 -- function Machine in Fat_xxx (where xxx is the root type)
2757
2758 when Attribute_Machine =>
2759 Expand_Fpt_Attribute_R (N);
2760
1550b445 2761 ----------------------
2762 -- Machine_Rounding --
2763 ----------------------
2764
2765 -- Transforms 'Machine_Rounding into a call to the floating-point
2766 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
99f2248e 2767 -- type). Expansion is avoided for cases the back end can handle
2768 -- directly.
1550b445 2769
2770 when Attribute_Machine_Rounding =>
99f2248e 2771 if not Is_Inline_Floating_Point_Attribute (N) then
2772 Expand_Fpt_Attribute_R (N);
2773 end if;
1550b445 2774
ee6ba406 2775 ------------------
2776 -- Machine_Size --
2777 ------------------
2778
2779 -- Machine_Size is equivalent to Object_Size, so transform it into
d55c93e0 2780 -- Object_Size and that way the back end never sees Machine_Size.
ee6ba406 2781
2782 when Attribute_Machine_Size =>
2783 Rewrite (N,
2784 Make_Attribute_Reference (Loc,
2785 Prefix => Prefix (N),
2786 Attribute_Name => Name_Object_Size));
2787
2788 Analyze_And_Resolve (N, Typ);
2789
2790 --------------
2791 -- Mantissa --
2792 --------------
2793
aad6babd 2794 -- The only case that can get this far is the dynamic case of the old
d55c93e0 2795 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
2796 -- we expand:
ee6ba406 2797
2798 -- typ'Mantissa
2799
2800 -- into
2801
2802 -- ityp (System.Mantissa.Mantissa_Value
2803 -- (Integer'Integer_Value (typ'First),
2804 -- Integer'Integer_Value (typ'Last)));
2805
d55c93e0 2806 when Attribute_Mantissa => Mantissa : begin
ee6ba406 2807 Rewrite (N,
2808 Convert_To (Typ,
2809 Make_Function_Call (Loc,
2810 Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
2811
2812 Parameter_Associations => New_List (
2813
2814 Make_Attribute_Reference (Loc,
2815 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2816 Attribute_Name => Name_Integer_Value,
2817 Expressions => New_List (
2818
2819 Make_Attribute_Reference (Loc,
2820 Prefix => New_Occurrence_Of (Ptyp, Loc),
2821 Attribute_Name => Name_First))),
2822
2823 Make_Attribute_Reference (Loc,
2824 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2825 Attribute_Name => Name_Integer_Value,
2826 Expressions => New_List (
2827
2828 Make_Attribute_Reference (Loc,
2829 Prefix => New_Occurrence_Of (Ptyp, Loc),
2830 Attribute_Name => Name_Last)))))));
2831
2832 Analyze_And_Resolve (N, Typ);
2833 end Mantissa;
2834
18a40e97 2835 --------------------
2836 -- Mechanism_Code --
2837 --------------------
2838
2839 when Attribute_Mechanism_Code =>
2840
2841 -- We must replace the prefix in the renamed case
2842
2843 if Is_Entity_Name (Pref)
2844 and then Present (Alias (Entity (Pref)))
2845 then
2846 Set_Renamed_Subprogram (Pref, Alias (Entity (Pref)));
2847 end if;
2848
e0521a36 2849 ---------
2850 -- Mod --
2851 ---------
2852
2853 when Attribute_Mod => Mod_Case : declare
2854 Arg : constant Node_Id := Relocate_Node (First (Exprs));
2855 Hi : constant Node_Id := Type_High_Bound (Etype (Arg));
2856 Modv : constant Uint := Modulus (Btyp);
2857
2858 begin
2859
2860 -- This is not so simple. The issue is what type to use for the
2861 -- computation of the modular value.
2862
2863 -- The easy case is when the modulus value is within the bounds
2864 -- of the signed integer type of the argument. In this case we can
2865 -- just do the computation in that signed integer type, and then
2866 -- do an ordinary conversion to the target type.
2867
2868 if Modv <= Expr_Value (Hi) then
2869 Rewrite (N,
2870 Convert_To (Btyp,
2871 Make_Op_Mod (Loc,
2872 Left_Opnd => Arg,
2873 Right_Opnd => Make_Integer_Literal (Loc, Modv))));
2874
2875 -- Here we know that the modulus is larger than type'Last of the
9eb397d8 2876 -- integer type. There are two cases to consider:
e0521a36 2877
2878 -- a) The integer value is non-negative. In this case, it is
2879 -- returned as the result (since it is less than the modulus).
2880
aad6babd 2881 -- b) The integer value is negative. In this case, we know that the
2882 -- result is modulus + value, where the value might be as small as
2883 -- -modulus. The trouble is what type do we use to do the subtract.
2884 -- No type will do, since modulus can be as big as 2**64, and no
2c145f84 2885 -- integer type accommodates this value. Let's do bit of algebra
e0521a36 2886
2887 -- modulus + value
2888 -- = modulus - (-value)
2889 -- = (modulus - 1) - (-value - 1)
2890
2891 -- Now modulus - 1 is certainly in range of the modular type.
2892 -- -value is in the range 1 .. modulus, so -value -1 is in the
2893 -- range 0 .. modulus-1 which is in range of the modular type.
2894 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
2895 -- which we can compute using the integer base type.
2896
9eb397d8 2897 -- Once this is done we analyze the conditional expression without
2898 -- range checks, because we know everything is in range, and we
2899 -- want to prevent spurious warnings on either branch.
2900
e0521a36 2901 else
2902 Rewrite (N,
2903 Make_Conditional_Expression (Loc,
2904 Expressions => New_List (
2905 Make_Op_Ge (Loc,
2906 Left_Opnd => Duplicate_Subexpr (Arg),
2907 Right_Opnd => Make_Integer_Literal (Loc, 0)),
2908
2909 Convert_To (Btyp,
2910 Duplicate_Subexpr_No_Checks (Arg)),
2911
2912 Make_Op_Subtract (Loc,
2913 Left_Opnd =>
2914 Make_Integer_Literal (Loc,
2915 Intval => Modv - 1),
2916 Right_Opnd =>
2917 Convert_To (Btyp,
2918 Make_Op_Minus (Loc,
2919 Right_Opnd =>
2920 Make_Op_Add (Loc,
2921 Left_Opnd => Duplicate_Subexpr_No_Checks (Arg),
2922 Right_Opnd =>
2923 Make_Integer_Literal (Loc,
2924 Intval => 1))))))));
2925
e0521a36 2926 end if;
2927
1550b445 2928 Analyze_And_Resolve (N, Btyp, Suppress => All_Checks);
e0521a36 2929 end Mod_Case;
2930
ee6ba406 2931 -----------
2932 -- Model --
2933 -----------
2934
2935 -- Transforms 'Model into a call to the floating-point attribute
2936 -- function Model in Fat_xxx (where xxx is the root type)
2937
2938 when Attribute_Model =>
2939 Expand_Fpt_Attribute_R (N);
2940
2941 -----------------
2942 -- Object_Size --
2943 -----------------
2944
2945 -- The processing for Object_Size shares the processing for Size
2946
4c06b9d2 2947 ---------
2948 -- Old --
2949 ---------
2950
2951 when Attribute_Old => Old : declare
2952 Tnn : constant Entity_Id :=
2953 Make_Defining_Identifier (Loc,
2954 Chars => New_Internal_Name ('T'));
2955 Subp : Node_Id;
2956 Asn_Stm : Node_Id;
2957
2958 begin
d55c93e0 2959 -- Find the nearest subprogram body, ignoring _Preconditions
2960
4c06b9d2 2961 Subp := N;
2962 loop
2963 Subp := Parent (Subp);
d55c93e0 2964 exit when Nkind (Subp) = N_Subprogram_Body
2965 and then Chars (Defining_Entity (Subp)) /= Name_uPostconditions;
4c06b9d2 2966 end loop;
2967
d55c93e0 2968 -- Insert the assignment at the start of the declarations
2969
4c06b9d2 2970 Asn_Stm :=
2971 Make_Object_Declaration (Loc,
2972 Defining_Identifier => Tnn,
2973 Constant_Present => True,
2974 Object_Definition => New_Occurrence_Of (Etype (N), Loc),
2975 Expression => Pref);
2976
2977 if Is_Empty_List (Declarations (Subp)) then
2978 Set_Declarations (Subp, New_List (Asn_Stm));
2979 Analyze (Asn_Stm);
2980 else
2981 Insert_Action (First (Declarations (Subp)), Asn_Stm);
2982 end if;
2983
2984 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
2985 end Old;
2986
ee6ba406 2987 ------------
2988 -- Output --
2989 ------------
2990
2991 when Attribute_Output => Output : declare
2992 P_Type : constant Entity_Id := Entity (Pref);
ee6ba406 2993 U_Type : constant Entity_Id := Underlying_Type (P_Type);
2994 Pname : Entity_Id;
2995 Decl : Node_Id;
2996 Prag : Node_Id;
2997 Arg3 : Node_Id;
2998 Wfunc : Node_Id;
2999
3000 begin
3001 -- If no underlying type, we have an error that will be diagnosed
3002 -- elsewhere, so here we just completely ignore the expansion.
3003
3004 if No (U_Type) then
3005 return;
3006 end if;
3007
3008 -- If TSS for Output is present, just call it
3009
9dfe12ae 3010 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
ee6ba406 3011
3012 if Present (Pname) then
3013 null;
3014
3015 else
3016 -- If there is a Stream_Convert pragma, use it, we rewrite
3017
3018 -- sourcetyp'Output (stream, Item)
3019
3020 -- as
3021
3022 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
3023
aad6babd 3024 -- where strmwrite is the given Write function that converts an
3025 -- argument of type sourcetyp or a type acctyp, from which it is
3026 -- derived to type strmtyp. The conversion to acttyp is required
3027 -- for the derived case.
ee6ba406 3028
5245b786 3029 Prag := Get_Stream_Convert_Pragma (P_Type);
ee6ba406 3030
3031 if Present (Prag) then
3032 Arg3 :=
3033 Next (Next (First (Pragma_Argument_Associations (Prag))));
3034 Wfunc := Entity (Expression (Arg3));
3035
3036 Rewrite (N,
3037 Make_Attribute_Reference (Loc,
3038 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
3039 Attribute_Name => Name_Output,
3040 Expressions => New_List (
3041 Relocate_Node (First (Exprs)),
3042 Make_Function_Call (Loc,
3043 Name => New_Occurrence_Of (Wfunc, Loc),
3044 Parameter_Associations => New_List (
83aa52b6 3045 OK_Convert_To (Etype (First_Formal (Wfunc)),
ee6ba406 3046 Relocate_Node (Next (First (Exprs)))))))));
3047
3048 Analyze (N);
3049 return;
3050
3051 -- For elementary types, we call the W_xxx routine directly.
3052 -- Note that the effect of Write and Output is identical for
3053 -- the case of an elementary type, since there are no
3054 -- discriminants or bounds.
3055
3056 elsif Is_Elementary_Type (U_Type) then
3057
3058 -- A special case arises if we have a defined _Write routine,
3059 -- since in this case we are required to call this routine.
3060
9dfe12ae 3061 if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then
ee6ba406 3062 Build_Record_Or_Elementary_Output_Procedure
3063 (Loc, U_Type, Decl, Pname);
3064 Insert_Action (N, Decl);
3065
3066 -- For normal cases, we call the W_xxx routine directly
3067
3068 else
3069 Rewrite (N, Build_Elementary_Write_Call (N));
3070 Analyze (N);
3071 return;
3072 end if;
3073
3074 -- Array type case
3075
3076 elsif Is_Array_Type (U_Type) then
3077 Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
3078 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3079
3080 -- Class-wide case, first output external tag, then dispatch
3081 -- to the appropriate primitive Output function (RM 13.13.2(31)).
3082
3083 elsif Is_Class_Wide_Type (P_Type) then
99f2248e 3084
3085 -- No need to do anything else compiling under restriction
3086 -- No_Dispatching_Calls. During the semantic analysis we
3087 -- already notified such violation.
3088
3089 if Restriction_Active (No_Dispatching_Calls) then
3090 return;
3091 end if;
3092
ee6ba406 3093 Tag_Write : declare
3094 Strm : constant Node_Id := First (Exprs);
3095 Item : constant Node_Id := Next (Strm);
3096
3097 begin
83aa52b6 3098 -- Ada 2005 (AI-344): Check that the accessibility level
3099 -- of the type of the output object is not deeper than
3100 -- that of the attribute's prefix type.
3101
aad6babd 3102 -- if Get_Access_Level (Item'Tag)
3103 -- /= Get_Access_Level (P_Type'Tag)
3104 -- then
3105 -- raise Tag_Error;
3106 -- end if;
83aa52b6 3107
aad6babd 3108 -- String'Output (Strm, External_Tag (Item'Tag));
3109
83aa52b6 3110 -- We cannot figure out a practical way to implement this
3111 -- accessibility check on virtual machines, so we omit it.
aad6babd 3112
83aa52b6 3113 if Ada_Version >= Ada_05
3114 and then VM_Target = No_VM
3115 then
aad6babd 3116 Insert_Action (N,
3117 Make_Implicit_If_Statement (N,
3118 Condition =>
3119 Make_Op_Ne (Loc,
3120 Left_Opnd =>
99f2248e 3121 Build_Get_Access_Level (Loc,
3122 Make_Attribute_Reference (Loc,
3123 Prefix =>
3124 Relocate_Node (
3125 Duplicate_Subexpr (Item,
3126 Name_Req => True)),
3127 Attribute_Name => Name_Tag)),
3128
aad6babd 3129 Right_Opnd =>
99f2248e 3130 Make_Integer_Literal (Loc,
3131 Type_Access_Level (P_Type))),
3132
aad6babd 3133 Then_Statements =>
3134 New_List (Make_Raise_Statement (Loc,
3135 New_Occurrence_Of (
3136 RTE (RE_Tag_Error), Loc)))));
3137 end if;
ee6ba406 3138
3139 Insert_Action (N,
3140 Make_Attribute_Reference (Loc,
3141 Prefix => New_Occurrence_Of (Standard_String, Loc),
3142 Attribute_Name => Name_Output,
3143 Expressions => New_List (
3144 Relocate_Node (Duplicate_Subexpr (Strm)),
3145 Make_Function_Call (Loc,
3146 Name =>
3147 New_Occurrence_Of (RTE (RE_External_Tag), Loc),
3148 Parameter_Associations => New_List (
3149 Make_Attribute_Reference (Loc,
3150 Prefix =>
3151 Relocate_Node
3152 (Duplicate_Subexpr (Item, Name_Req => True)),
3153 Attribute_Name => Name_Tag))))));
3154 end Tag_Write;
3155
9dfe12ae 3156 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
ee6ba406 3157
3158 -- Tagged type case, use the primitive Output function
3159
3160 elsif Is_Tagged_Type (U_Type) then
9dfe12ae 3161 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
ee6ba406 3162
99f2248e 3163 -- All other record type cases, including protected records.
3164 -- The latter only arise for expander generated code for
3165 -- handling shared passive partition access.
ee6ba406 3166
3167 else
3168 pragma Assert
3169 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
3170
00f91aef 3171 -- Ada 2005 (AI-216): Program_Error is raised when executing
3172 -- the default implementation of the Output attribute of an
3173 -- unchecked union type if the type lacks default discriminant
3174 -- values.
3175
3176 if Is_Unchecked_Union (Base_Type (U_Type))
18a40e97 3177 and then No (Discriminant_Constraint (U_Type))
00f91aef 3178 then
3179 Insert_Action (N,
3180 Make_Raise_Program_Error (Loc,
3181 Reason => PE_Unchecked_Union_Restriction));
3182
3183 return;
3184 end if;
3185
ee6ba406 3186 Build_Record_Or_Elementary_Output_Procedure
3187 (Loc, Base_Type (U_Type), Decl, Pname);
3188 Insert_Action (N, Decl);
3189 end if;
3190 end if;
3191
3192 -- If we fall through, Pname is the name of the procedure to call
3193
3194 Rewrite_Stream_Proc_Call (Pname);
3195 end Output;
3196
3197 ---------
3198 -- Pos --
3199 ---------
3200
3201 -- For enumeration types with a standard representation, Pos is
d55c93e0 3202 -- handled by the back end.
ee6ba406 3203
3204 -- For enumeration types, with a non-standard representation we
3205 -- generate a call to the _Rep_To_Pos function created when the
3206 -- type was frozen. The call has the form
3207
9dfe12ae 3208 -- _rep_to_pos (expr, flag)
ee6ba406 3209
9dfe12ae 3210 -- The parameter flag is True if range checks are enabled, causing
3211 -- Program_Error to be raised if the expression has an invalid
3212 -- representation, and False if range checks are suppressed.
ee6ba406 3213
3214 -- For integer types, Pos is equivalent to a simple integer
3215 -- conversion and we rewrite it as such
3216
3217 when Attribute_Pos => Pos :
3218 declare
3219 Etyp : Entity_Id := Base_Type (Entity (Pref));
3220
3221 begin
3222 -- Deal with zero/non-zero boolean values
3223
3224 if Is_Boolean_Type (Etyp) then
3225 Adjust_Condition (First (Exprs));
3226 Etyp := Standard_Boolean;
3227 Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
3228 end if;
3229
3230 -- Case of enumeration type
3231
3232 if Is_Enumeration_Type (Etyp) then
3233
3234 -- Non-standard enumeration type (generate call)
3235
3236 if Present (Enum_Pos_To_Rep (Etyp)) then
9dfe12ae 3237 Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
ee6ba406 3238 Rewrite (N,
3239 Convert_To (Typ,
3240 Make_Function_Call (Loc,
3241 Name =>
9dfe12ae 3242 New_Reference_To (TSS (Etyp, TSS_Rep_To_Pos), Loc),
ee6ba406 3243 Parameter_Associations => Exprs)));
3244
3245 Analyze_And_Resolve (N, Typ);
3246
3247 -- Standard enumeration type (do universal integer check)
3248
3249 else
3250 Apply_Universal_Integer_Attribute_Checks (N);
3251 end if;
3252
3253 -- Deal with integer types (replace by conversion)
3254
3255 elsif Is_Integer_Type (Etyp) then
3256 Rewrite (N, Convert_To (Typ, First (Exprs)));
3257 Analyze_And_Resolve (N, Typ);
3258 end if;
3259
3260 end Pos;
3261
3262 --------------
3263 -- Position --
3264 --------------
3265
d55c93e0 3266 -- We compute this if a component clause was present, otherwise we leave
3267 -- the computation up to the back end, since we don't know what layout
3268 -- will be chosen.
ee6ba406 3269
3270 when Attribute_Position => Position :
3271 declare
3272 CE : constant Entity_Id := Entity (Selector_Name (Pref));
3273
3274 begin
3275 if Present (Component_Clause (CE)) then
3276 Rewrite (N,
3277 Make_Integer_Literal (Loc,
3278 Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
3279 Analyze_And_Resolve (N, Typ);
3280
3281 else
3282 Apply_Universal_Integer_Attribute_Checks (N);
3283 end if;
3284 end Position;
3285
3286 ----------
3287 -- Pred --
3288 ----------
3289
3290 -- 1. Deal with enumeration types with holes
3291 -- 2. For floating-point, generate call to attribute function
3292 -- 3. For other cases, deal with constraint checking
3293
3294 when Attribute_Pred => Pred :
3295 declare
d55c93e0 3296 Etyp : constant Entity_Id := Base_Type (Ptyp);
ee6ba406 3297
3298 begin
d55c93e0 3299
ee6ba406 3300 -- For enumeration types with non-standard representations, we
3301 -- expand typ'Pred (x) into
3302
3303 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
3304
9dfe12ae 3305 -- If the representation is contiguous, we compute instead
3306 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
d55c93e0 3307 -- The conversion function Enum_Pos_To_Rep is defined on the
3308 -- base type, not the subtype, so we have to use the base type
3309 -- explicitly for this and other enumeration attributes.
9dfe12ae 3310
ee6ba406 3311 if Is_Enumeration_Type (Ptyp)
d55c93e0 3312 and then Present (Enum_Pos_To_Rep (Etyp))
ee6ba406 3313 then
d55c93e0 3314 if Has_Contiguous_Rep (Etyp) then
9dfe12ae 3315 Rewrite (N,
3316 Unchecked_Convert_To (Ptyp,
3317 Make_Op_Add (Loc,
3318 Left_Opnd =>
3319 Make_Integer_Literal (Loc,
3320 Enumeration_Rep (First_Literal (Ptyp))),
3321 Right_Opnd =>
3322 Make_Function_Call (Loc,
3323 Name =>
3324 New_Reference_To
d55c93e0 3325 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
9dfe12ae 3326
3327 Parameter_Associations =>
3328 New_List (
3329 Unchecked_Convert_To (Ptyp,
3330 Make_Op_Subtract (Loc,
3331 Left_Opnd =>
3332 Unchecked_Convert_To (Standard_Integer,
3333 Relocate_Node (First (Exprs))),
3334 Right_Opnd =>
3335 Make_Integer_Literal (Loc, 1))),
3336 Rep_To_Pos_Flag (Ptyp, Loc))))));
ee6ba406 3337
9dfe12ae 3338 else
3339 -- Add Boolean parameter True, to request program errror if
3340 -- we have a bad representation on our hands. If checks are
3341 -- suppressed, then add False instead
ee6ba406 3342
9dfe12ae 3343 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
3344 Rewrite (N,
3345 Make_Indexed_Component (Loc,
d55c93e0 3346 Prefix =>
3347 New_Reference_To
3348 (Enum_Pos_To_Rep (Etyp), Loc),
9dfe12ae 3349 Expressions => New_List (
3350 Make_Op_Subtract (Loc,
ee6ba406 3351 Left_Opnd =>
3352 Make_Function_Call (Loc,
3353 Name =>
d55c93e0 3354 New_Reference_To
3355 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
9dfe12ae 3356 Parameter_Associations => Exprs),
ee6ba406 3357 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
9dfe12ae 3358 end if;
ee6ba406 3359
3360 Analyze_And_Resolve (N, Typ);
3361
3362 -- For floating-point, we transform 'Pred into a call to the Pred
3363 -- floating-point attribute function in Fat_xxx (xxx is root type)
3364
3365 elsif Is_Floating_Point_Type (Ptyp) then
3366 Expand_Fpt_Attribute_R (N);
3367 Analyze_And_Resolve (N, Typ);
3368
3369 -- For modular types, nothing to do (no overflow, since wraps)
3370
3371 elsif Is_Modular_Integer_Type (Ptyp) then
3372 null;
3373
3374 -- For other types, if range checking is enabled, we must generate
3375 -- a check if overflow checking is enabled.
3376
3377 elsif not Overflow_Checks_Suppressed (Ptyp) then
3378 Expand_Pred_Succ (N);
3379 end if;
ee6ba406 3380 end Pred;
3381
7f8eb6ed 3382 --------------
3383 -- Priority --
3384 --------------
3385
3386 -- Ada 2005 (AI-327): Dynamic ceiling priorities
3387
3388 -- We rewrite X'Priority as the following run-time call:
3389
3390 -- Get_Ceiling (X._Object)
3391
3392 -- Note that although X'Priority is notionally an object, it is quite
3393 -- deliberately not defined as an aliased object in the RM. This means
3394 -- that it works fine to rewrite it as a call, without having to worry
3395 -- about complications that would other arise from X'Priority'Access,
3396 -- which is illegal, because of the lack of aliasing.
3397
3398 when Attribute_Priority =>
3399 declare
3400 Call : Node_Id;
3401 Conctyp : Entity_Id;
3402 Object_Parm : Node_Id;
3403 Subprg : Entity_Id;
3404 RT_Subprg_Name : Node_Id;
3405
3406 begin
3407 -- Look for the enclosing concurrent type
3408
3409 Conctyp := Current_Scope;
3410 while not Is_Concurrent_Type (Conctyp) loop
3411 Conctyp := Scope (Conctyp);
3412 end loop;
3413
3414 pragma Assert (Is_Protected_Type (Conctyp));
3415
3416 -- Generate the actual of the call
3417
3418 Subprg := Current_Scope;
3419 while not Present (Protected_Body_Subprogram (Subprg)) loop
3420 Subprg := Scope (Subprg);
3421 end loop;
3422
db14252c 3423 -- Use of 'Priority inside protected entries and barriers (in
3424 -- both cases the type of the first formal of their expanded
3425 -- subprogram is Address)
3426
3427 if Etype (First_Entity (Protected_Body_Subprogram (Subprg)))
3428 = RTE (RE_Address)
3429 then
3430 declare
3431 New_Itype : Entity_Id;
3432
3433 begin
3434 -- In the expansion of protected entries the type of the
3435 -- first formal of the Protected_Body_Subprogram is an
3436 -- Address. In order to reference the _object component
3437 -- we generate:
3438
3439 -- type T is access p__ptTV;
3440 -- freeze T []
3441
3442 New_Itype := Create_Itype (E_Access_Type, N);
3443 Set_Etype (New_Itype, New_Itype);
db14252c 3444 Set_Directly_Designated_Type (New_Itype,
3445 Corresponding_Record_Type (Conctyp));
3446 Freeze_Itype (New_Itype, N);
3447
3448 -- Generate:
3449 -- T!(O)._object'unchecked_access
3450
3451 Object_Parm :=
3452 Make_Attribute_Reference (Loc,
3453 Prefix =>
3454 Make_Selected_Component (Loc,
3455 Prefix =>
3456 Unchecked_Convert_To (New_Itype,
3457 New_Reference_To
7f8eb6ed 3458 (First_Entity
db14252c 3459 (Protected_Body_Subprogram (Subprg)),
3460 Loc)),
3461 Selector_Name =>
3462 Make_Identifier (Loc, Name_uObject)),
3463 Attribute_Name => Name_Unchecked_Access);
3464 end;
3465
3466 -- Use of 'Priority inside a protected subprogram
3467
3468 else
3469 Object_Parm :=
3470 Make_Attribute_Reference (Loc,
3471 Prefix =>
3472 Make_Selected_Component (Loc,
3473 Prefix => New_Reference_To
3474 (First_Entity
3475 (Protected_Body_Subprogram (Subprg)),
3476 Loc),
3477 Selector_Name =>
3478 Make_Identifier (Loc, Name_uObject)),
3479 Attribute_Name => Name_Unchecked_Access);
3480 end if;
7f8eb6ed 3481
3482 -- Select the appropriate run-time subprogram
3483
3484 if Number_Entries (Conctyp) = 0 then
3485 RT_Subprg_Name :=
3486 New_Reference_To (RTE (RE_Get_Ceiling), Loc);
3487 else
3488 RT_Subprg_Name :=
3489 New_Reference_To (RTE (RO_PE_Get_Ceiling), Loc);
3490 end if;
3491
3492 Call :=
3493 Make_Function_Call (Loc,
3494 Name => RT_Subprg_Name,
3495 Parameter_Associations => New_List (Object_Parm));
3496
3497 Rewrite (N, Call);
db14252c 3498
3499 -- Avoid the generation of extra checks on the pointer to the
3500 -- protected object.
3501
3502 Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
7f8eb6ed 3503 end;
3504
ee6ba406 3505 ------------------
3506 -- Range_Length --
3507 ------------------
3508
d55c93e0 3509 when Attribute_Range_Length => Range_Length : begin
ee6ba406 3510 -- The only special processing required is for the case where
3511 -- Range_Length is applied to an enumeration type with holes.
3512 -- In this case we transform
3513
3514 -- X'Range_Length
3515
3516 -- to
3517
3518 -- X'Pos (X'Last) - X'Pos (X'First) + 1
3519
3520 -- So that the result reflects the proper Pos values instead
3521 -- of the underlying representations.
3522
d55c93e0 3523 if Is_Enumeration_Type (Ptyp)
3524 and then Has_Non_Standard_Rep (Ptyp)
ee6ba406 3525 then
3526 Rewrite (N,
3527 Make_Op_Add (Loc,
3528 Left_Opnd =>
3529 Make_Op_Subtract (Loc,
3530 Left_Opnd =>
3531 Make_Attribute_Reference (Loc,
3532 Attribute_Name => Name_Pos,
d55c93e0 3533 Prefix => New_Occurrence_Of (Ptyp, Loc),
ee6ba406 3534 Expressions => New_List (
3535 Make_Attribute_Reference (Loc,
3536 Attribute_Name => Name_Last,
d55c93e0 3537 Prefix => New_Occurrence_Of (Ptyp, Loc)))),
ee6ba406 3538
3539 Right_Opnd =>
3540 Make_Attribute_Reference (Loc,
3541 Attribute_Name => Name_Pos,
d55c93e0 3542 Prefix => New_Occurrence_Of (Ptyp, Loc),
ee6ba406 3543 Expressions => New_List (
3544 Make_Attribute_Reference (Loc,
3545 Attribute_Name => Name_First,
d55c93e0 3546 Prefix => New_Occurrence_Of (Ptyp, Loc))))),
ee6ba406 3547
3548 Right_Opnd =>
3549 Make_Integer_Literal (Loc, 1)));
3550
3551 Analyze_And_Resolve (N, Typ);
3552
d55c93e0 3553 -- For all other cases, the attribute is handled by the back end, but
3554 -- we need to deal with the case of the range check on a universal
3555 -- integer.
ee6ba406 3556
3557 else
3558 Apply_Universal_Integer_Attribute_Checks (N);
3559 end if;
ee6ba406 3560 end Range_Length;
3561
3562 ----------
3563 -- Read --
3564 ----------
3565
3566 when Attribute_Read => Read : declare
3567 P_Type : constant Entity_Id := Entity (Pref);
3568 B_Type : constant Entity_Id := Base_Type (P_Type);
3569 U_Type : constant Entity_Id := Underlying_Type (P_Type);
3570 Pname : Entity_Id;
3571 Decl : Node_Id;
3572 Prag : Node_Id;
3573 Arg2 : Node_Id;
3574 Rfunc : Node_Id;
3575 Lhs : Node_Id;
3576 Rhs : Node_Id;
3577
3578 begin
3579 -- If no underlying type, we have an error that will be diagnosed
3580 -- elsewhere, so here we just completely ignore the expansion.
3581
3582 if No (U_Type) then
3583 return;
3584 end if;
3585
3586 -- The simple case, if there is a TSS for Read, just call it
3587
9dfe12ae 3588 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
ee6ba406 3589
3590 if Present (Pname) then
3591 null;
3592
3593 else
3594 -- If there is a Stream_Convert pragma, use it, we rewrite
3595
3596 -- sourcetyp'Read (stream, Item)
3597
3598 -- as
3599
3600 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
3601
aad6babd 3602 -- where strmread is the given Read function that converts an
3603 -- argument of type strmtyp to type sourcetyp or a type from which
3604 -- it is derived. The conversion to sourcetyp is required in the
3605 -- latter case.
ee6ba406 3606
3607 -- A special case arises if Item is a type conversion in which
3608 -- case, we have to expand to:
3609
3610 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
3611
3612 -- where Itemx is the expression of the type conversion (i.e.
3613 -- the actual object), and typex is the type of Itemx.
3614
5245b786 3615 Prag := Get_Stream_Convert_Pragma (P_Type);
ee6ba406 3616
3617 if Present (Prag) then
3618 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
3619 Rfunc := Entity (Expression (Arg2));
3620 Lhs := Relocate_Node (Next (First (Exprs)));
3621 Rhs :=
83aa52b6 3622 OK_Convert_To (B_Type,
ee6ba406 3623 Make_Function_Call (Loc,
3624 Name => New_Occurrence_Of (Rfunc, Loc),
3625 Parameter_Associations => New_List (
3626 Make_Attribute_Reference (Loc,
3627 Prefix =>
3628 New_Occurrence_Of
3629 (Etype (First_Formal (Rfunc)), Loc),
3630 Attribute_Name => Name_Input,
3631 Expressions => New_List (
3632 Relocate_Node (First (Exprs)))))));
3633
3634 if Nkind (Lhs) = N_Type_Conversion then
3635 Lhs := Expression (Lhs);
3636 Rhs := Convert_To (Etype (Lhs), Rhs);
3637 end if;
3638
3639 Rewrite (N,
3640 Make_Assignment_Statement (Loc,
9dfe12ae 3641 Name => Lhs,
ee6ba406 3642 Expression => Rhs));
3643 Set_Assignment_OK (Lhs);
3644 Analyze (N);
3645 return;
3646
3647 -- For elementary types, we call the I_xxx routine using the first
3648 -- parameter and then assign the result into the second parameter.
3649 -- We set Assignment_OK to deal with the conversion case.
3650
3651 elsif Is_Elementary_Type (U_Type) then
3652 declare
3653 Lhs : Node_Id;
3654 Rhs : Node_Id;
3655
3656 begin
3657 Lhs := Relocate_Node (Next (First (Exprs)));
3658 Rhs := Build_Elementary_Input_Call (N);
3659
3660 if Nkind (Lhs) = N_Type_Conversion then
3661 Lhs := Expression (Lhs);
3662 Rhs := Convert_To (Etype (Lhs), Rhs);
3663 end if;
3664
3665 Set_Assignment_OK (Lhs);
3666
3667 Rewrite (N,
3668 Make_Assignment_Statement (Loc,
3669 Name => Lhs,
3670 Expression => Rhs));
3671
3672 Analyze (N);
3673 return;
3674 end;
3675
3676 -- Array type case
3677
3678 elsif Is_Array_Type (U_Type) then
3679 Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
3680 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3681
3682 -- Tagged type case, use the primitive Read function. Note that
3683 -- this will dispatch in the class-wide case which is what we want
3684
3685 elsif Is_Tagged_Type (U_Type) then
9dfe12ae 3686 Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
ee6ba406 3687
aad6babd 3688 -- All other record type cases, including protected records. The
3689 -- latter only arise for expander generated code for handling
3690 -- shared passive partition access.
ee6ba406 3691
3692 else
3693 pragma Assert
3694 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
3695
00f91aef 3696 -- Ada 2005 (AI-216): Program_Error is raised when executing
3697 -- the default implementation of the Read attribute of an
3698 -- Unchecked_Union type.
3699
3700 if Is_Unchecked_Union (Base_Type (U_Type)) then
3701 Insert_Action (N,
3702 Make_Raise_Program_Error (Loc,
3703 Reason => PE_Unchecked_Union_Restriction));
3704 end if;
3705
ee6ba406 3706 if Has_Discriminants (U_Type)
3707 and then Present
3708 (Discriminant_Default_Value (First_Discriminant (U_Type)))
3709 then
3710 Build_Mutable_Record_Read_Procedure
3711 (Loc, Base_Type (U_Type), Decl, Pname);
ee6ba406 3712 else
3713 Build_Record_Read_Procedure
3714 (Loc, Base_Type (U_Type), Decl, Pname);
3715 end if;
3716
3717 -- Suppress checks, uninitialized or otherwise invalid
3718 -- data does not cause constraint errors to be raised for
3719 -- a complete record read.
3720
3721 Insert_Action (N, Decl, All_Checks);
3722 end if;
3723 end if;
3724
3725 Rewrite_Stream_Proc_Call (Pname);
3726 end Read;
3727
3728 ---------------
3729 -- Remainder --
3730 ---------------
3731
3732 -- Transforms 'Remainder into a call to the floating-point attribute
3733 -- function Remainder in Fat_xxx (where xxx is the root type)
3734
3735 when Attribute_Remainder =>
3736 Expand_Fpt_Attribute_RR (N);
3737
d55c93e0 3738 ------------
3739 -- Result --
3740 ------------
3741
3742 -- Transform 'Result into reference to _Result formal. At the point
3743 -- where a legal 'Result attribute is expanded, we know that we are in
3744 -- the context of a _Postcondition function with a _Result parameter.
3745
3746 when Attribute_Result =>
3747 Rewrite (N,
3748 Make_Identifier (Loc,
3749 Chars => Name_uResult));
3750 Analyze_And_Resolve (N, Typ);
3751
ee6ba406 3752 -----------
3753 -- Round --
3754 -----------
3755
aad6babd 3756 -- The handling of the Round attribute is quite delicate. The processing
3757 -- in Sem_Attr introduced a conversion to universal real, reflecting the
3758 -- semantics of Round, but we do not want anything to do with universal
3759 -- real at runtime, since this corresponds to using floating-point
3760 -- arithmetic.
3761
3762 -- What we have now is that the Etype of the Round attribute correctly
3763 -- indicates the final result type. The operand of the Round is the
3764 -- conversion to universal real, described above, and the operand of
3765 -- this conversion is the actual operand of Round, which may be the
3766 -- special case of a fixed point multiplication or division (Etype =
3767 -- universal fixed)
3768
3769 -- The exapander will expand first the operand of the conversion, then
3770 -- the conversion, and finally the round attribute itself, since we
3771 -- always work inside out. But we cannot simply process naively in this
3772 -- order. In the semantic world where universal fixed and real really
3773 -- exist and have infinite precision, there is no problem, but in the
3774 -- implementation world, where universal real is a floating-point type,
3775 -- we would get the wrong result.
3776
3777 -- So the approach is as follows. First, when expanding a multiply or
3778 -- divide whose type is universal fixed, we do nothing at all, instead
3779 -- deferring the operation till later.
ee6ba406 3780
3781 -- The actual processing is done in Expand_N_Type_Conversion which
aad6babd 3782 -- handles the special case of Round by looking at its parent to see if
3783 -- it is a Round attribute, and if it is, handling the conversion (or
3784 -- its fixed multiply/divide child) in an appropriate manner.
ee6ba406 3785
3786 -- This means that by the time we get to expanding the Round attribute
3787 -- itself, the Round is nothing more than a type conversion (and will
3788 -- often be a null type conversion), so we just replace it with the
3789 -- appropriate conversion operation.
3790
3791 when Attribute_Round =>
3792 Rewrite (N,
3793 Convert_To (Etype (N), Relocate_Node (First (Exprs))));
3794 Analyze_And_Resolve (N);
3795
3796 --------------
3797 -- Rounding --
3798 --------------
3799
3800 -- Transforms 'Rounding into a call to the floating-point attribute
3801 -- function Rounding in Fat_xxx (where xxx is the root type)
3802
3803 when Attribute_Rounding =>
3804 Expand_Fpt_Attribute_R (N);
3805
3806 -------------
3807 -- Scaling --
3808 -------------
3809
3810 -- Transforms 'Scaling into a call to the floating-point attribute
3811 -- function Scaling in Fat_xxx (where xxx is the root type)
3812
3813 when Attribute_Scaling =>
3814 Expand_Fpt_Attribute_RI (N);
3815
3816 ----------
3817 -- Size --
3818 ----------
3819
3820 when Attribute_Size |
3821 Attribute_Object_Size |
3822 Attribute_Value_Size |
3823 Attribute_VADS_Size => Size :
3824
3825 declare
ee6ba406 3826 Siz : Uint;
9dfe12ae 3827 New_Node : Node_Id;
ee6ba406 3828
3829 begin
3830 -- Processing for VADS_Size case. Note that this processing removes
3831 -- all traces of VADS_Size from the tree, and completes all required
3832 -- processing for VADS_Size by translating the attribute reference
3833 -- to an appropriate Size or Object_Size reference.
3834
3835 if Id = Attribute_VADS_Size
3836 or else (Use_VADS_Size and then Id = Attribute_Size)
3837 then
3838 -- If the size is specified, then we simply use the specified
3839 -- size. This applies to both types and objects. The size of an
3840 -- object can be specified in the following ways:
3841
3842 -- An explicit size object is given for an object
3843 -- A component size is specified for an indexed component
3844 -- A component clause is specified for a selected component
3845 -- The object is a component of a packed composite object
3846
3847 -- If the size is specified, then VADS_Size of an object
3848
3849 if (Is_Entity_Name (Pref)
3850 and then Present (Size_Clause (Entity (Pref))))
3851 or else
3852 (Nkind (Pref) = N_Component_Clause
3853 and then (Present (Component_Clause
3854 (Entity (Selector_Name (Pref))))
3855 or else Is_Packed (Etype (Prefix (Pref)))))
3856 or else
3857 (Nkind (Pref) = N_Indexed_Component
3858 and then (Component_Size (Etype (Prefix (Pref))) /= 0
3859 or else Is_Packed (Etype (Prefix (Pref)))))
3860 then
3861 Set_Attribute_Name (N, Name_Size);
3862
3863 -- Otherwise if we have an object rather than a type, then the
3864 -- VADS_Size attribute applies to the type of the object, rather
3865 -- than the object itself. This is one of the respects in which
3866 -- VADS_Size differs from Size.
3867
3868 else
3869 if (not Is_Entity_Name (Pref)
3870 or else not Is_Type (Entity (Pref)))
d55c93e0 3871 and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp))
ee6ba406 3872 then
d55c93e0 3873 Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
ee6ba406 3874 end if;
3875
aad6babd 3876 -- For a scalar type for which no size was explicitly given,
3877 -- VADS_Size means Object_Size. This is the other respect in
3878 -- which VADS_Size differs from Size.
ee6ba406 3879
d55c93e0 3880 if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then
ee6ba406 3881 Set_Attribute_Name (N, Name_Object_Size);
3882
3883 -- In all other cases, Size and VADS_Size are the sane
3884
3885 else
3886 Set_Attribute_Name (N, Name_Size);
3887 end if;
3888 end if;
3889 end if;
3890
d55c93e0 3891 -- For class-wide types, X'Class'Size is transformed into a direct
3892 -- reference to the Size of the class type, so that the back end does
3893 -- not have to deal with the X'Class'Size reference.
ee6ba406 3894
9dfe12ae 3895 if Is_Entity_Name (Pref)
3896 and then Is_Class_Wide_Type (Entity (Pref))
3897 then
3898 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
3899 return;
3900
1550b445 3901 -- For X'Size applied to an object of a class-wide type, transform
9dfe12ae 3902 -- X'Size into a call to the primitive operation _Size applied to X.
3903
3904 elsif Is_Class_Wide_Type (Ptyp) then
99f2248e 3905
3906 -- No need to do anything else compiling under restriction
3907 -- No_Dispatching_Calls. During the semantic analysis we
3908 -- already notified such violation.
3909
3910 if Restriction_Active (No_Dispatching_Calls) then
3911 return;
3912 end if;
3913
ee6ba406 3914 New_Node :=
3915 Make_Function_Call (Loc,
3916 Name => New_Reference_To
3917 (Find_Prim_Op (Ptyp, Name_uSize), Loc),
3918 Parameter_Associations => New_List (Pref));
3919
3920 if Typ /= Standard_Long_Long_Integer then
3921
3922 -- The context is a specific integer type with which the
3923 -- original attribute was compatible. The function has a
3924 -- specific type as well, so to preserve the compatibility
3925 -- we must convert explicitly.
3926
3927 New_Node := Convert_To (Typ, New_Node);
3928 end if;
3929
3930 Rewrite (N, New_Node);
3931 Analyze_And_Resolve (N, Typ);
83aa52b6 3932 return;
3933
3934 -- Case of known RM_Size of a type
3935
3936 elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
3937 and then Is_Entity_Name (Pref)
3938 and then Is_Type (Entity (Pref))
3939 and then Known_Static_RM_Size (Entity (Pref))
3940 then
3941 Siz := RM_Size (Entity (Pref));
3942
3943 -- Case of known Esize of a type
3944
3945 elsif Id = Attribute_Object_Size
3946 and then Is_Entity_Name (Pref)
3947 and then Is_Type (Entity (Pref))
3948 and then Known_Static_Esize (Entity (Pref))
3949 then
3950 Siz := Esize (Entity (Pref));
3951
3952 -- Case of known size of object
3953
3954 elsif Id = Attribute_Size
3955 and then Is_Entity_Name (Pref)
3956 and then Is_Object (Entity (Pref))
3957 and then Known_Esize (Entity (Pref))
3958 and then Known_Static_Esize (Entity (Pref))
3959 then
3960 Siz := Esize (Entity (Pref));
ee6ba406 3961
3962 -- For an array component, we can do Size in the front end
3963 -- if the component_size of the array is set.
3964
3965 elsif Nkind (Pref) = N_Indexed_Component then
3966 Siz := Component_Size (Etype (Prefix (Pref)));
3967
aad6babd 3968 -- For a record component, we can do Size in the front end if there
3969 -- is a component clause, or if the record is packed and the
3970 -- component's size is known at compile time.
ee6ba406 3971
3972 elsif Nkind (Pref) = N_Selected_Component then
3973 declare
3974 Rec : constant Entity_Id := Etype (Prefix (Pref));
3975 Comp : constant Entity_Id := Entity (Selector_Name (Pref));
3976
3977 begin
3978 if Present (Component_Clause (Comp)) then
3979 Siz := Esize (Comp);
3980
3981 elsif Is_Packed (Rec) then
3982 Siz := RM_Size (Ptyp);
3983
3984 else
3985 Apply_Universal_Integer_Attribute_Checks (N);
3986 return;
3987 end if;
3988 end;
3989
d55c93e0 3990 -- All other cases are handled by the back end
ee6ba406 3991
3992 else
3993 Apply_Universal_Integer_Attribute_Checks (N);
3994
1550b445 3995 -- If Size is applied to a formal parameter that is of a packed
3996 -- array subtype, then apply Size to the actual subtype.
ee6ba406 3997
3998 if Is_Entity_Name (Pref)
3999 and then Is_Formal (Entity (Pref))
d55c93e0 4000 and then Is_Array_Type (Ptyp)
4001 and then Is_Packed (Ptyp)
ee6ba406 4002 then
4003 Rewrite (N,
4004 Make_Attribute_Reference (Loc,
4005 Prefix =>
4006 New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
4007 Attribute_Name => Name_Size));
4008 Analyze_And_Resolve (N, Typ);
4009 end if;
4010
83aa52b6 4011 -- If Size applies to a dereference of an access to unconstrained
d55c93e0 4012 -- packed array, the back end needs to see its unconstrained
4013 -- nominal type, but also a hint to the actual constrained type.
1550b445 4014
4015 if Nkind (Pref) = N_Explicit_Dereference
d55c93e0 4016 and then Is_Array_Type (Ptyp)
4017 and then not Is_Constrained (Ptyp)
4018 and then Is_Packed (Ptyp)
1550b445 4019 then
4020 Set_Actual_Designated_Subtype (Pref,
4021 Get_Actual_Subtype (Pref));
4022 end if;
4023
ee6ba406 4024 return;
4025 end if;
4026
4027 -- Common processing for record and array component case
4028
83aa52b6 4029 if Siz /= No_Uint and then Siz /= 0 then
6deeca1d 4030 declare
4031 CS : constant Boolean := Comes_From_Source (N);
ee6ba406 4032
6deeca1d 4033 begin
4034 Rewrite (N, Make_Integer_Literal (Loc, Siz));
4035
4036 -- This integer literal is not a static expression. We do not
4037 -- call Analyze_And_Resolve here, because this would activate
4038 -- the circuit for deciding that a static value was out of
4039 -- range, and we don't want that.
ee6ba406 4040
6deeca1d 4041 -- So just manually set the type, mark the expression as non-
4042 -- static, and then ensure that the result is checked properly
4043 -- if the attribute comes from source (if it was internally
4044 -- generated, we never need a constraint check).
ee6ba406 4045
6deeca1d 4046 Set_Etype (N, Typ);
4047 Set_Is_Static_Expression (N, False);
4048
4049 if CS then
4050 Apply_Constraint_Check (N, Typ);
4051 end if;
4052 end;
ee6ba406 4053 end if;
4054 end Size;
4055
4056 ------------------
4057 -- Storage_Pool --
4058 ------------------
4059
4060 when Attribute_Storage_Pool =>
4061 Rewrite (N,
4062 Make_Type_Conversion (Loc,
4063 Subtype_Mark => New_Reference_To (Etype (N), Loc),
4064 Expression => New_Reference_To (Entity (N), Loc)));
4065 Analyze_And_Resolve (N, Typ);
4066
4067 ------------------
4068 -- Storage_Size --
4069 ------------------
4070
d55c93e0 4071 when Attribute_Storage_Size => Storage_Size : begin
ee6ba406 4072
ee6ba406 4073 -- Access type case, always go to the root type
4074
4075 -- The case of access types results in a value of zero for the case
4076 -- where no storage size attribute clause has been given. If a
4077 -- storage size has been given, then the attribute is converted
4078 -- to a reference to the variable used to hold this value.
4079
4080 if Is_Access_Type (Ptyp) then
4081 if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
4082 Rewrite (N,
4083 Make_Attribute_Reference (Loc,
4084 Prefix => New_Reference_To (Typ, Loc),
4085 Attribute_Name => Name_Max,
4086 Expressions => New_List (
4087 Make_Integer_Literal (Loc, 0),
4088 Convert_To (Typ,
4089 New_Reference_To
4090 (Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
4091
4092 elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
4093 Rewrite (N,
4094 OK_Convert_To (Typ,
4095 Make_Function_Call (Loc,
9dfe12ae 4096 Name =>
4097 New_Reference_To
7f8eb6ed 4098 (Find_Prim_Op
4099 (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
4100 Attribute_Name (N)),
4101 Loc),
4102
4103 Parameter_Associations => New_List (
4104 New_Reference_To
4105 (Associated_Storage_Pool (Root_Type (Ptyp)), Loc)))));
ee6ba406 4106
ee6ba406 4107 else
4108 Rewrite (N, Make_Integer_Literal (Loc, 0));
4109 end if;
4110
4111 Analyze_And_Resolve (N, Typ);
4112
7f8eb6ed 4113 -- For tasks, we retrieve the size directly from the TCB. The
4114 -- size may depend on a discriminant of the type, and therefore
4115 -- can be a per-object expression, so type-level information is
4116 -- not sufficient in general. There are four cases to consider:
ee6ba406 4117
7f8eb6ed 4118 -- a) If the attribute appears within a task body, the designated
4119 -- TCB is obtained by a call to Self.
ee6ba406 4120
7f8eb6ed 4121 -- b) If the prefix of the attribute is the name of a task object,
4122 -- the designated TCB is the one stored in the corresponding record.
ee6ba406 4123
7f8eb6ed 4124 -- c) If the prefix is a task type, the size is obtained from the
4125 -- size variable created for each task type
ee6ba406 4126
7f8eb6ed 4127 -- d) If no storage_size was specified for the type , there is no
4128 -- size variable, and the value is a system-specific default.
ee6ba406 4129
4130 else
7f8eb6ed 4131 if In_Open_Scopes (Ptyp) then
4132
4133 -- Storage_Size (Self)
4134
ee6ba406 4135 Rewrite (N,
4136 Convert_To (Typ,
4137 Make_Function_Call (Loc,
4138 Name =>
7f8eb6ed 4139 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
4140 Parameter_Associations =>
4141 New_List (
4142 Make_Function_Call (Loc,
4143 Name =>
4144 New_Reference_To (RTE (RE_Self), Loc))))));
ee6ba406 4145
7f8eb6ed 4146 elsif not Is_Entity_Name (Pref)
4147 or else not Is_Type (Entity (Pref))
4148 then
4149 -- Storage_Size (Rec (Obj).Size)
4150
4151 Rewrite (N,
4152 Convert_To (Typ,
4153 Make_Function_Call (Loc,
4154 Name =>
4155 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
4156 Parameter_Associations =>
ee6ba406 4157 New_List (
4158 Make_Selected_Component (Loc,
4159 Prefix =>
4160 Unchecked_Convert_To (
4161 Corresponding_Record_Type (Ptyp),
7f8eb6ed 4162 New_Copy_Tree (Pref)),
ee6ba406 4163 Selector_Name =>
7f8eb6ed 4164 Make_Identifier (Loc, Name_uTask_Id))))));
ee6ba406 4165
7f8eb6ed 4166 elsif Present (Storage_Size_Variable (Ptyp)) then
ee6ba406 4167
7f8eb6ed 4168 -- Static storage size pragma given for type: retrieve value
4169 -- from its allocated storage variable.
ee6ba406 4170
7f8eb6ed 4171 Rewrite (N,
4172 Convert_To (Typ,
4173 Make_Function_Call (Loc,
4174 Name => New_Occurrence_Of (
4175 RTE (RE_Adjust_Storage_Size), Loc),
4176 Parameter_Associations =>
4177 New_List (
4178 New_Reference_To (
4179 Storage_Size_Variable (Ptyp), Loc)))));
4180 else
4181 -- Get system default
4182
4183 Rewrite (N,
4184 Convert_To (Typ,
4185 Make_Function_Call (Loc,
4186 Name =>
4187 New_Occurrence_Of (
4188 RTE (RE_Default_Stack_Size), Loc))));
ee6ba406 4189 end if;
7f8eb6ed 4190
4191 Analyze_And_Resolve (N, Typ);
ee6ba406 4192 end if;
4193 end Storage_Size;
4194
7189d17f 4195 -----------------
4196 -- Stream_Size --
4197 -----------------
4198
4199 when Attribute_Stream_Size => Stream_Size : declare
7189d17f 4200 Size : Int;
4201
4202 begin
4203 -- If we have a Stream_Size clause for this type use it, otherwise
4204 -- the Stream_Size if the size of the type.
4205
4206 if Has_Stream_Size_Clause (Ptyp) then
7f8eb6ed 4207 Size :=
4208 UI_To_Int
4209 (Static_Integer (Expression (Stream_Size_Clause (Ptyp))));
7189d17f 4210 else
4211 Size := UI_To_Int (Esize (Ptyp));
4212 end if;
4213
4214 Rewrite (N, Make_Integer_Literal (Loc, Intval => Size));
4215 Analyze_And_Resolve (N, Typ);
4216 end Stream_Size;
4217
ee6ba406 4218 ----------
4219 -- Succ --
4220 ----------
4221
4222 -- 1. Deal with enumeration types with holes
4223 -- 2. For floating-point, generate call to attribute function
4224 -- 3. For other cases, deal with constraint checking
4225
4226 when Attribute_Succ => Succ :
4227 declare
d55c93e0 4228 Etyp : constant Entity_Id := Base_Type (Ptyp);
ee6ba406 4229
4230 begin
d55c93e0 4231
ee6ba406 4232 -- For enumeration types with non-standard representations, we
4233 -- expand typ'Succ (x) into
4234
4235 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
4236
9dfe12ae 4237 -- If the representation is contiguous, we compute instead
4238 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
4239
ee6ba406 4240 if Is_Enumeration_Type (Ptyp)
d55c93e0 4241 and then Present (Enum_Pos_To_Rep (Etyp))
ee6ba406 4242 then
d55c93e0 4243 if Has_Contiguous_Rep (Etyp) then
9dfe12ae 4244 Rewrite (N,
4245 Unchecked_Convert_To (Ptyp,
4246 Make_Op_Add (Loc,
4247 Left_Opnd =>
4248 Make_Integer_Literal (Loc,
4249 Enumeration_Rep (First_Literal (Ptyp))),
4250 Right_Opnd =>
4251 Make_Function_Call (Loc,
4252 Name =>
4253 New_Reference_To
d55c93e0 4254 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
9dfe12ae 4255
4256 Parameter_Associations =>
4257 New_List (
4258 Unchecked_Convert_To (Ptyp,
4259 Make_Op_Add (Loc,
4260 Left_Opnd =>
4261 Unchecked_Convert_To (Standard_Integer,
4262 Relocate_Node (First (Exprs))),
4263 Right_Opnd =>
4264 Make_Integer_Literal (Loc, 1))),
4265 Rep_To_Pos_Flag (Ptyp, Loc))))));
4266 else
4267 -- Add Boolean parameter True, to request program errror if
4268 -- we have a bad representation on our hands. Add False if
4269 -- checks are suppressed.
ee6ba406 4270
9dfe12ae 4271 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
4272 Rewrite (N,
4273 Make_Indexed_Component (Loc,
d55c93e0 4274 Prefix =>
4275 New_Reference_To
4276 (Enum_Pos_To_Rep (Etyp), Loc),
9dfe12ae 4277 Expressions => New_List (
4278 Make_Op_Add (Loc,
4279 Left_Opnd =>
4280 Make_Function_Call (Loc,
4281 Name =>
4282 New_Reference_To
d55c93e0 4283 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
9dfe12ae 4284 Parameter_Associations => Exprs),
4285 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
4286 end if;
ee6ba406 4287
4288 Analyze_And_Resolve (N, Typ);
4289
4290 -- For floating-point, we transform 'Succ into a call to the Succ
4291 -- floating-point attribute function in Fat_xxx (xxx is root type)
4292
4293 elsif Is_Floating_Point_Type (Ptyp) then
4294 Expand_Fpt_Attribute_R (N);
4295 Analyze_And_Resolve (N, Typ);
4296
4297 -- For modular types, nothing to do (no overflow, since wraps)
4298
4299 elsif Is_Modular_Integer_Type (Ptyp) then
4300 null;
4301
4302 -- For other types, if range checking is enabled, we must generate
4303 -- a check if overflow checking is enabled.
4304
4305 elsif not Overflow_Checks_Suppressed (Ptyp) then
4306 Expand_Pred_Succ (N);
4307 end if;
4308 end Succ;
4309
4310 ---------
4311 -- Tag --
4312 ---------
4313
4314 -- Transforms X'Tag into a direct reference to the tag of X
4315
4316 when Attribute_Tag => Tag :
4317 declare
4318 Ttyp : Entity_Id;
4319 Prefix_Is_Type : Boolean;
4320
4321 begin
4322 if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then
4323 Ttyp := Entity (Pref);
4324 Prefix_Is_Type := True;
4325 else
d55c93e0 4326 Ttyp := Ptyp;
ee6ba406 4327 Prefix_Is_Type := False;
4328 end if;
4329
4330 if Is_Class_Wide_Type (Ttyp) then
4331 Ttyp := Root_Type (Ttyp);
4332 end if;
4333
4334 Ttyp := Underlying_Type (Ttyp);
4335
4336 if Prefix_Is_Type then
1d7e0b5b 4337
83aa52b6 4338 -- For VMs we leave the type attribute unexpanded because
1d7e0b5b 4339 -- there's not a dispatching table to reference.
4340
83aa52b6 4341 if VM_Target = No_VM then
1d7e0b5b 4342 Rewrite (N,
4343 Unchecked_Convert_To (RTE (RE_Tag),
4660e715 4344 New_Reference_To
4345 (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc)));
1d7e0b5b 4346 Analyze_And_Resolve (N, RTE (RE_Tag));
4347 end if;
ee6ba406 4348
83aa52b6 4349 -- (Ada 2005 (AI-251): The use of 'Tag in the sources always
4350 -- references the primary tag of the actual object. If 'Tag is
4351 -- applied to class-wide interface objects we generate code that
4352 -- displaces "this" to reference the base of the object.
4353
4354 elsif Comes_From_Source (N)
4355 and then Is_Class_Wide_Type (Etype (Prefix (N)))
4356 and then Is_Interface (Etype (Prefix (N)))
4357 then
4358 -- Generate:
4359 -- (To_Tag_Ptr (Prefix'Address)).all
4360
4361 -- Note that Prefix'Address is recursively expanded into a call
4362 -- to Base_Address (Obj.Tag)
4363
f0bf2ff3 4364 -- Not needed for VM targets, since all handled by the VM
4365
4366 if VM_Target = No_VM then
4367 Rewrite (N,
4368 Make_Explicit_Dereference (Loc,
4369 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
4370 Make_Attribute_Reference (Loc,
4371 Prefix => Relocate_Node (Pref),
4372 Attribute_Name => Name_Address))));
4373 Analyze_And_Resolve (N, RTE (RE_Tag));
4374 end if;
83aa52b6 4375
ee6ba406 4376 else
4377 Rewrite (N,
4378 Make_Selected_Component (Loc,
4379 Prefix => Relocate_Node (Pref),
4380 Selector_Name =>
4660e715 4381 New_Reference_To (First_Tag_Component (Ttyp), Loc)));
1d7e0b5b 4382 Analyze_And_Resolve (N, RTE (RE_Tag));
ee6ba406 4383 end if;
ee6ba406 4384 end Tag;
4385
4386 ----------------
4387 -- Terminated --
4388 ----------------
4389
aad6babd 4390 -- Transforms 'Terminated attribute into a call to Terminated function
ee6ba406 4391
4392 when Attribute_Terminated => Terminated :
4393 begin
1550b445 4394 -- The prefix of Terminated is of a task interface class-wide type.
4395 -- Generate:
4396
83aa52b6 4397 -- terminated (Task_Id (Pref._disp_get_task_id));
1550b445 4398
4399 if Ada_Version >= Ada_05
d55c93e0 4400 and then Ekind (Ptyp) = E_Class_Wide_Type
4401 and then Is_Interface (Ptyp)
4402 and then Is_Task_Interface (Ptyp)
1550b445 4403 then
4404 Rewrite (N,
4405 Make_Function_Call (Loc,
4406 Name =>
4407 New_Reference_To (RTE (RE_Terminated), Loc),
4408 Parameter_Associations => New_List (
83aa52b6 4409 Make_Unchecked_Type_Conversion (Loc,
4410 Subtype_Mark =>
4411 New_Reference_To (RTE (RO_ST_Task_Id), Loc),
4412 Expression =>
4413 Make_Selected_Component (Loc,
4414 Prefix =>
4415 New_Copy_Tree (Pref),
4416 Selector_Name =>
4417 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
1550b445 4418
4419 elsif Restricted_Profile then
ee6ba406 4420 Rewrite (N,
4421 Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
4422
4423 else
4424 Rewrite (N,
4425 Build_Call_With_Task (Pref, RTE (RE_Terminated)));
4426 end if;
4427
4428 Analyze_And_Resolve (N, Standard_Boolean);
4429 end Terminated;
4430
4431 ----------------
4432 -- To_Address --
4433 ----------------
4434
4435 -- Transforms System'To_Address (X) into unchecked conversion
4436 -- from (integral) type of X to type address.
4437
4438 when Attribute_To_Address =>
4439 Rewrite (N,
4440 Unchecked_Convert_To (RTE (RE_Address),
4441 Relocate_Node (First (Exprs))));
4442 Analyze_And_Resolve (N, RTE (RE_Address));
4443
5690e662 4444 ------------
4445 -- To_Any --
4446 ------------
4447
4448 when Attribute_To_Any => To_Any : declare
4449 P_Type : constant Entity_Id := Etype (Pref);
4450 Decls : constant List_Id := New_List;
4451 begin
4452 Rewrite (N,
4453 Build_To_Any_Call
4454 (Convert_To (P_Type,
4455 Relocate_Node (First (Exprs))), Decls));
4456 Insert_Actions (N, Decls);
4457 Analyze_And_Resolve (N, RTE (RE_Any));
4458 end To_Any;
4459
ee6ba406 4460 ----------------
4461 -- Truncation --
4462 ----------------
4463
4464 -- Transforms 'Truncation into a call to the floating-point attribute
99f2248e 4465 -- function Truncation in Fat_xxx (where xxx is the root type).
4466 -- Expansion is avoided for cases the back end can handle directly.
ee6ba406 4467
4468 when Attribute_Truncation =>
99f2248e 4469 if not Is_Inline_Floating_Point_Attribute (N) then
4470 Expand_Fpt_Attribute_R (N);
4471 end if;
ee6ba406 4472
5690e662 4473 --------------
4474 -- TypeCode --
4475 --------------
4476
4477 when Attribute_TypeCode => TypeCode : declare
4478 P_Type : constant Entity_Id := Etype (Pref);
4479 Decls : constant List_Id := New_List;
4480 begin
4481 Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls));
4482 Insert_Actions (N, Decls);
4483 Analyze_And_Resolve (N, RTE (RE_TypeCode));
4484 end TypeCode;
4485
ee6ba406 4486 -----------------------
4487 -- Unbiased_Rounding --
4488 -----------------------
4489
4490 -- Transforms 'Unbiased_Rounding into a call to the floating-point
4491 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
99f2248e 4492 -- root type). Expansion is avoided for cases the back end can handle
4493 -- directly.
ee6ba406 4494
4495 when Attribute_Unbiased_Rounding =>
99f2248e 4496 if not Is_Inline_Floating_Point_Attribute (N) then
4497 Expand_Fpt_Attribute_R (N);
4498 end if;
ee6ba406 4499
ee6ba406 4500 -----------------
4501 -- UET_Address --
4502 -----------------
4503
4504 when Attribute_UET_Address => UET_Address : declare
4505 Ent : constant Entity_Id :=
4506 Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
4507
4508 begin
4509 Insert_Action (N,
4510 Make_Object_Declaration (Loc,
4511 Defining_Identifier => Ent,
4512 Aliased_Present => True,
4513 Object_Definition =>
4514 New_Occurrence_Of (RTE (RE_Address), Loc)));
4515
4516 -- Construct name __gnat_xxx__SDP, where xxx is the unit name
4517 -- in normal external form.
4518
4519 Get_External_Unit_Name_String (Get_Unit_Name (Pref));
4520 Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
4521 Name_Len := Name_Len + 7;
4522 Name_Buffer (1 .. 7) := "__gnat_";
4523 Name_Buffer (Name_Len + 1 .. Name_Len + 5) := "__SDP";
4524 Name_Len := Name_Len + 5;
4525
4526 Set_Is_Imported (Ent);
4527 Set_Interface_Name (Ent,
4528 Make_String_Literal (Loc,
4529 Strval => String_From_Name_Buffer));
4530
f947f061 4531 -- Set entity as internal to ensure proper Sprint output of its
4532 -- implicit importation.
4533
4534 Set_Is_Internal (Ent);
4535
ee6ba406 4536 Rewrite (N,
4537 Make_Attribute_Reference (Loc,
4538 Prefix => New_Occurrence_Of (Ent, Loc),
4539 Attribute_Name => Name_Address));
4540
4541 Analyze_And_Resolve (N, Typ);
4542 end UET_Address;
4543
ee6ba406 4544 ---------------
4545 -- VADS_Size --
4546 ---------------
4547
4548 -- The processing for VADS_Size is shared with Size
4549
4550 ---------
4551 -- Val --
4552 ---------
4553
4554 -- For enumeration types with a standard representation, and for all
d55c93e0 4555 -- other types, Val is handled by the back end. For enumeration types
4556 -- with a non-standard representation we use the _Pos_To_Rep array that
ee6ba406 4557 -- was created when the type was frozen.
4558
4559 when Attribute_Val => Val :
4560 declare
4561 Etyp : constant Entity_Id := Base_Type (Entity (Pref));
4562
4563 begin
4564 if Is_Enumeration_Type (Etyp)
4565 and then Present (Enum_Pos_To_Rep (Etyp))
4566 then
9dfe12ae 4567 if Has_Contiguous_Rep (Etyp) then
4568 declare
4569 Rep_Node : constant Node_Id :=
4570 Unchecked_Convert_To (Etyp,
4571 Make_Op_Add (Loc,
4572 Left_Opnd =>
4573 Make_Integer_Literal (Loc,
4574 Enumeration_Rep (First_Literal (Etyp))),
4575 Right_Opnd =>
4576 (Convert_To (Standard_Integer,
4577 Relocate_Node (First (Exprs))))));
4578
4579 begin
4580 Rewrite (N,
4581 Unchecked_Convert_To (Etyp,
4582 Make_Op_Add (Loc,
4583 Left_Opnd =>
4584 Make_Integer_Literal (Loc,
4585 Enumeration_Rep (First_Literal (Etyp))),
4586 Right_Opnd =>
4587 Make_Function_Call (Loc,
4588 Name =>
4589 New_Reference_To
4590 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4591 Parameter_Associations => New_List (
4592 Rep_Node,
4593 Rep_To_Pos_Flag (Etyp, Loc))))));
4594 end;
4595
4596 else
4597 Rewrite (N,
4598 Make_Indexed_Component (Loc,
4599 Prefix => New_Reference_To (Enum_Pos_To_Rep (Etyp), Loc),
4600 Expressions => New_List (
4601 Convert_To (Standard_Integer,
4602 Relocate_Node (First (Exprs))))));
4603 end if;
ee6ba406 4604
4605 Analyze_And_Resolve (N, Typ);
4606 end if;
4607 end Val;
4608
4609 -----------
4610 -- Valid --
4611 -----------
4612
4613 -- The code for valid is dependent on the particular types involved.
4614 -- See separate sections below for the generated code in each case.
4615
4616 when Attribute_Valid => Valid :
4617 declare
d55c93e0 4618 Btyp : Entity_Id := Base_Type (Ptyp);
ee6ba406 4619 Tst : Node_Id;
4620
9dfe12ae 4621 Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
4622 -- Save the validity checking mode. We always turn off validity
4623 -- checking during process of 'Valid since this is one place
4624 -- where we do not want the implicit validity checks to intefere
4625 -- with the explicit validity check that the programmer is doing.
4626
ee6ba406 4627 function Make_Range_Test return Node_Id;
4628 -- Build the code for a range test of the form
4629 -- Btyp!(Pref) >= Btyp!(Ptyp'First)
4630 -- and then
4631 -- Btyp!(Pref) <= Btyp!(Ptyp'Last)
4632
9dfe12ae 4633 ---------------------
4634 -- Make_Range_Test --
4635 ---------------------
4636
ee6ba406 4637 function Make_Range_Test return Node_Id is
4638 begin
4639 return
4640 Make_And_Then (Loc,
4641 Left_Opnd =>
4642 Make_Op_Ge (Loc,
4643 Left_Opnd =>
4644 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
4645
4646 Right_Opnd =>
4647 Unchecked_Convert_To (Btyp,
4648 Make_Attribute_Reference (Loc,
4649 Prefix => New_Occurrence_Of (Ptyp, Loc),
4650 Attribute_Name => Name_First))),
4651
4652 Right_Opnd =>
4653 Make_Op_Le (Loc,
4654 Left_Opnd =>
9dfe12ae 4655 Unchecked_Convert_To (Btyp,
4656 Duplicate_Subexpr_No_Checks (Pref)),
ee6ba406 4657
4658 Right_Opnd =>
4659 Unchecked_Convert_To (Btyp,
4660 Make_Attribute_Reference (Loc,
4661 Prefix => New_Occurrence_Of (Ptyp, Loc),
4662 Attribute_Name => Name_Last))));
4663 end Make_Range_Test;
4664
4665 -- Start of processing for Attribute_Valid
4666
4667 begin
9dfe12ae 4668 -- Turn off validity checks. We do not want any implicit validity
4669 -- checks to intefere with the explicit check from the attribute
4670
4671 Validity_Checks_On := False;
4672
ee6ba406 4673 -- Floating-point case. This case is handled by the Valid attribute
4674 -- code in the floating-point attribute run-time library.
4675
4676 if Is_Floating_Point_Type (Ptyp) then
4677 declare
1550b445 4678 Pkg : RE_Id;
4679 Ftp : Entity_Id;
ee6ba406 4680
4681 begin
6e62b6c3 4682 -- For vax fpt types, call appropriate routine in special vax
4683 -- floating point unit. We do not have to worry about loads in
4684 -- this case, since these types have no signalling NaN's.
4685
1550b445 4686 if Vax_Float (Btyp) then
6e62b6c3 4687 Expand_Vax_Valid (N);
4688
7f8eb6ed 4689 -- The AAMP back end handles Valid for floating-point types
4690
4691 elsif Is_AAMP_Float (Btyp) then
4692 Analyze_And_Resolve (Pref, Ptyp);
4693 Set_Etype (N, Standard_Boolean);
4694 Set_Analyzed (N);
4695
1550b445 4696 -- Non VAX float case
9dfe12ae 4697
1550b445 4698 else
d55c93e0 4699 Find_Fat_Info (Ptyp, Ftp, Pkg);
1550b445 4700
4701 -- If the floating-point object might be unaligned, we need
4702 -- to call the special routine Unaligned_Valid, which makes
4703 -- the needed copy, being careful not to load the value into
4704 -- any floating-point register. The argument in this case is
99f2248e 4705 -- obj'Address (see Unaligned_Valid routine in Fat_Gen).
1550b445 4706
4707 if Is_Possibly_Unaligned_Object (Pref) then
1550b445 4708 Expand_Fpt_Attribute
4709 (N, Pkg, Name_Unaligned_Valid,
4710 New_List (
4711 Make_Attribute_Reference (Loc,
4712 Prefix => Relocate_Node (Pref),
4713 Attribute_Name => Name_Address)));
9dfe12ae 4714
1550b445 4715 -- In the normal case where we are sure the object is
4716 -- aligned, we generate a call to Valid, and the argument in
4717 -- this case is obj'Unrestricted_Access (after converting
4718 -- obj to the right floating-point type).
9dfe12ae 4719
1550b445 4720 else
4721 Expand_Fpt_Attribute
4722 (N, Pkg, Name_Valid,
4723 New_List (
4724 Make_Attribute_Reference (Loc,
4725 Prefix => Unchecked_Convert_To (Ftp, Pref),
4726 Attribute_Name => Name_Unrestricted_Access)));
4727 end if;
9dfe12ae 4728 end if;
ee6ba406 4729
4730 -- One more task, we still need a range check. Required
4731 -- only if we have a constraint, since the Valid routine
4732 -- catches infinities properly (infinities are never valid).
4733
4734 -- The way we do the range check is simply to create the
4735 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
4736
4737 if not Subtypes_Statically_Match (Ptyp, Btyp) then
4738 Rewrite (N,
4739 Make_And_Then (Loc,
4740 Left_Opnd => Relocate_Node (N),
4741 Right_Opnd =>
4742 Make_In (Loc,
4743 Left_Opnd => Convert_To (Btyp, Pref),
4744 Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
4745 end if;
4746 end;
4747
4748 -- Enumeration type with holes
4749
4750 -- For enumeration types with holes, the Pos value constructed by
4751 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
4752 -- second argument of False returns minus one for an invalid value,
4753 -- and the non-negative pos value for a valid value, so the
4754 -- expansion of X'Valid is simply:
4755
4756 -- type(X)'Pos (X) >= 0
4757
4758 -- We can't quite generate it that way because of the requirement
5329ca64 4759 -- for the non-standard second argument of False in the resulting
4760 -- rep_to_pos call, so we have to explicitly create:
ee6ba406 4761
4762 -- _rep_to_pos (X, False) >= 0
4763
4764 -- If we have an enumeration subtype, we also check that the
4765 -- value is in range:
4766
4767 -- _rep_to_pos (X, False) >= 0
4768 -- and then
5329ca64 4769 -- (X >= type(X)'First and then type(X)'Last <= X)
ee6ba406 4770
4771 elsif Is_Enumeration_Type (Ptyp)
4772 and then Present (Enum_Pos_To_Rep (Base_Type (Ptyp)))
4773 then
4774 Tst :=
4775 Make_Op_Ge (Loc,
4776 Left_Opnd =>
4777 Make_Function_Call (Loc,
4778 Name =>
4779 New_Reference_To
9dfe12ae 4780 (TSS (Base_Type (Ptyp), TSS_Rep_To_Pos), Loc),
ee6ba406 4781 Parameter_Associations => New_List (
4782 Pref,
4783 New_Occurrence_Of (Standard_False, Loc))),
4784 Right_Opnd => Make_Integer_Literal (Loc, 0));
4785
4786 if Ptyp /= Btyp
4787 and then
4788 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
4789 or else
4790 Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
4791 then
4792 -- The call to Make_Range_Test will create declarations
4793 -- that need a proper insertion point, but Pref is now
4794 -- attached to a node with no ancestor. Attach to tree
4795 -- even if it is to be rewritten below.
4796
4797 Set_Parent (Tst, Parent (N));
4798
4799 Tst :=
4800 Make_And_Then (Loc,
4801 Left_Opnd => Make_Range_Test,
4802 Right_Opnd => Tst);
4803 end if;
4804
4805 Rewrite (N, Tst);
4806
4807 -- Fortran convention booleans
4808
4809 -- For the very special case of Fortran convention booleans, the
4810 -- value is always valid, since it is an integer with the semantics
4811 -- that non-zero is true, and any value is permissible.
4812
4813 elsif Is_Boolean_Type (Ptyp)
4814 and then Convention (Ptyp) = Convention_Fortran
4815 then
4816 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
4817
4818 -- For biased representations, we will be doing an unchecked
aad6babd 4819 -- conversion without unbiasing the result. That means that the range
4820 -- test has to take this into account, and the proper form of the
4821 -- test is:
ee6ba406 4822
4823 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
4824
4825 elsif Has_Biased_Representation (Ptyp) then
4826 Btyp := RTE (RE_Unsigned_32);
4827 Rewrite (N,
4828 Make_Op_Lt (Loc,
4829 Left_Opnd =>
4830 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
4831 Right_Opnd =>
4832 Unchecked_Convert_To (Btyp,
4833 Make_Attribute_Reference (Loc,
4834 Prefix => New_Occurrence_Of (Ptyp, Loc),
4835 Attribute_Name => Name_Range_Length))));
4836
4837 -- For all other scalar types, what we want logically is a
4838 -- range test:
4839
4840 -- X in type(X)'First .. type(X)'Last
4841
4842 -- But that's precisely what won't work because of possible
4843 -- unwanted optimization (and indeed the basic motivation for
5329ca64 4844 -- the Valid attribute is exactly that this test does not work!)
ee6ba406 4845 -- What will work is:
4846
4847 -- Btyp!(X) >= Btyp!(type(X)'First)
4848 -- and then
4849 -- Btyp!(X) <= Btyp!(type(X)'Last)
4850
4851 -- where Btyp is an integer type large enough to cover the full
4852 -- range of possible stored values (i.e. it is chosen on the basis
4853 -- of the size of the type, not the range of the values). We write
4854 -- this as two tests, rather than a range check, so that static
4855 -- evaluation will easily remove either or both of the checks if
4856 -- they can be -statically determined to be true (this happens
4857 -- when the type of X is static and the range extends to the full
4858 -- range of stored values).
4859
4860 -- Unsigned types. Note: it is safe to consider only whether the
4861 -- subtype is unsigned, since we will in that case be doing all
aad6babd 4862 -- unsigned comparisons based on the subtype range. Since we use the
4863 -- actual subtype object size, this is appropriate.
ee6ba406 4864
4865 -- For example, if we have
4866
4867 -- subtype x is integer range 1 .. 200;
4868 -- for x'Object_Size use 8;
4869
aad6babd 4870 -- Now the base type is signed, but objects of this type are bits
4871 -- unsigned, and doing an unsigned test of the range 1 to 200 is
4872 -- correct, even though a value greater than 127 looks signed to a
4873 -- signed comparison.
ee6ba406 4874
4875 elsif Is_Unsigned_Type (Ptyp) then
4876 if Esize (Ptyp) <= 32 then
4877 Btyp := RTE (RE_Unsigned_32);
4878 else
4879 Btyp := RTE (RE_Unsigned_64);
4880 end if;
4881
4882 Rewrite (N, Make_Range_Test);
4883
4884 -- Signed types
4885
4886 else
4887 if Esize (Ptyp) <= Esize (Standard_Integer) then
4888 Btyp := Standard_Integer;
4889 else
4890 Btyp := Universal_Integer;
4891 end if;
4892
4893 Rewrite (N, Make_Range_Test);
4894 end if;
4895
4896 Analyze_And_Resolve (N, Standard_Boolean);
9dfe12ae 4897 Validity_Checks_On := Save_Validity_Checks_On;
ee6ba406 4898 end Valid;
4899
4900 -----------
4901 -- Value --
4902 -----------
4903
4904 -- Value attribute is handled in separate unti Exp_Imgv
4905
4906 when Attribute_Value =>
4907 Exp_Imgv.Expand_Value_Attribute (N);
4908
4909 -----------------
4910 -- Value_Size --
4911 -----------------
4912
4913 -- The processing for Value_Size shares the processing for Size
4914
4915 -------------
4916 -- Version --
4917 -------------
4918
4919 -- The processing for Version shares the processing for Body_Version
4920
4921 ----------------
4922 -- Wide_Image --
4923 ----------------
4924
f0bf2ff3 4925 -- Wide_Image attribute is handled in separate unit Exp_Imgv
ee6ba406 4926
f0bf2ff3 4927 when Attribute_Wide_Image =>
4928 Exp_Imgv.Expand_Wide_Image_Attribute (N);
ee6ba406 4929
7189d17f 4930 ---------------------
4931 -- Wide_Wide_Image --
4932 ---------------------
4933
f0bf2ff3 4934 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
7189d17f 4935
f0bf2ff3 4936 when Attribute_Wide_Wide_Image =>
4937 Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N);
7189d17f 4938
ee6ba406 4939 ----------------
4940 -- Wide_Value --
4941 ----------------
4942
4943 -- We expand typ'Wide_Value (X) into
4944
4945 -- typ'Value
4946 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
4947
4948 -- Wide_String_To_String is a runtime function that converts its wide
4949 -- string argument to String, converting any non-translatable characters
4950 -- into appropriate escape sequences. This preserves the required
4951 -- semantics of Wide_Value in all cases, and results in a very simple
4952 -- implementation approach.
4953
7f8eb6ed 4954 -- Note: for this approach to be fully standard compliant for the cases
4955 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
4956 -- method must cover the entire character range (e.g. UTF-8). But that
4957 -- is a reasonable requirement when dealing with encoded character
4958 -- sequences. Presumably if one of the restrictive encoding mechanisms
4959 -- is in use such as Shift-JIS, then characters that cannot be
4960 -- represented using this encoding will not appear in any case.
ee6ba406 4961
4962 when Attribute_Wide_Value => Wide_Value :
4963 begin
4964 Rewrite (N,
4965 Make_Attribute_Reference (Loc,
4966 Prefix => Pref,
4967 Attribute_Name => Name_Value,
4968
4969 Expressions => New_List (
4970 Make_Function_Call (Loc,
4971 Name =>
4972 New_Reference_To (RTE (RE_Wide_String_To_String), Loc),
4973
4974 Parameter_Associations => New_List (
4975 Relocate_Node (First (Exprs)),
4976 Make_Integer_Literal (Loc,
4977 Intval => Int (Wide_Character_Encoding_Method)))))));
4978
4979 Analyze_And_Resolve (N, Typ);
4980 end Wide_Value;
4981
7189d17f 4982 ---------------------
4983 -- Wide_Wide_Value --
4984 ---------------------
4985
4986 -- We expand typ'Wide_Value_Value (X) into
4987
4988 -- typ'Value
4989 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
4990
4991 -- Wide_Wide_String_To_String is a runtime function that converts its
4992 -- wide string argument to String, converting any non-translatable
4993 -- characters into appropriate escape sequences. This preserves the
4994 -- required semantics of Wide_Wide_Value in all cases, and results in a
4995 -- very simple implementation approach.
4996
4997 -- It's not quite right where typ = Wide_Wide_Character, because the
4998 -- encoding method may not cover the whole character type ???
4999
5000 when Attribute_Wide_Wide_Value => Wide_Wide_Value :
5001 begin
5002 Rewrite (N,
5003 Make_Attribute_Reference (Loc,
5004 Prefix => Pref,
5005 Attribute_Name => Name_Value,
5006
5007 Expressions => New_List (
5008 Make_Function_Call (Loc,
5009 Name =>
5010 New_Reference_To (RTE (RE_Wide_Wide_String_To_String), Loc),
5011
5012 Parameter_Associations => New_List (
5013 Relocate_Node (First (Exprs)),
5014 Make_Integer_Literal (Loc,
5015 Intval => Int (Wide_Character_Encoding_Method)))))));
5016
5017 Analyze_And_Resolve (N, Typ);
5018 end Wide_Wide_Value;
5019
5020 ---------------------
5021 -- Wide_Wide_Width --
5022 ---------------------
5023
5024 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
5025
5026 when Attribute_Wide_Wide_Width =>
5027 Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide);
5028
ee6ba406 5029 ----------------
5030 -- Wide_Width --
5031 ----------------
5032
5033 -- Wide_Width attribute is handled in separate unit Exp_Imgv
5034
5035 when Attribute_Wide_Width =>
7189d17f 5036 Exp_Imgv.Expand_Width_Attribute (N, Wide);
ee6ba406 5037
5038 -----------
5039 -- Width --
5040 -----------
5041
5042 -- Width attribute is handled in separate unit Exp_Imgv
5043
5044 when Attribute_Width =>
7189d17f 5045 Exp_Imgv.Expand_Width_Attribute (N, Normal);
ee6ba406 5046
5047 -----------
5048 -- Write --
5049 -----------
5050
5051 when Attribute_Write => Write : declare
5052 P_Type : constant Entity_Id := Entity (Pref);
5053 U_Type : constant Entity_Id := Underlying_Type (P_Type);
5054 Pname : Entity_Id;
5055 Decl : Node_Id;
5056 Prag : Node_Id;
5057 Arg3 : Node_Id;
5058 Wfunc : Node_Id;
5059
5060 begin
5061 -- If no underlying type, we have an error that will be diagnosed
5062 -- elsewhere, so here we just completely ignore the expansion.
5063
5064 if No (U_Type) then
5065 return;
5066 end if;
5067
5068 -- The simple case, if there is a TSS for Write, just call it
5069
9dfe12ae 5070 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
ee6ba406 5071
5072 if Present (Pname) then
5073 null;
5074
5075 else
5076 -- If there is a Stream_Convert pragma, use it, we rewrite
5077
5078 -- sourcetyp'Output (stream, Item)
5079
5080 -- as
5081
5082 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
5083
aad6babd 5084 -- where strmwrite is the given Write function that converts an
5085 -- argument of type sourcetyp or a type acctyp, from which it is
5086 -- derived to type strmtyp. The conversion to acttyp is required
5087 -- for the derived case.
ee6ba406 5088
5245b786 5089 Prag := Get_Stream_Convert_Pragma (P_Type);
ee6ba406 5090
5091 if Present (Prag) then
5092 Arg3 :=
5093 Next (Next (First (Pragma_Argument_Associations (Prag))));
5094 Wfunc := Entity (Expression (Arg3));
5095
5096 Rewrite (N,
5097 Make_Attribute_Reference (Loc,
5098 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
5099 Attribute_Name => Name_Output,
5100 Expressions => New_List (
5101 Relocate_Node (First (Exprs)),
5102 Make_Function_Call (Loc,
5103 Name => New_Occurrence_Of (Wfunc, Loc),
5104 Parameter_Associations => New_List (
83aa52b6 5105 OK_Convert_To (Etype (First_Formal (Wfunc)),
ee6ba406 5106 Relocate_Node (Next (First (Exprs)))))))));
5107
5108 Analyze (N);
5109 return;
5110
5111 -- For elementary types, we call the W_xxx routine directly
5112
5113 elsif Is_Elementary_Type (U_Type) then
5114 Rewrite (N, Build_Elementary_Write_Call (N));
5115 Analyze (N);
5116 return;
5117
5118 -- Array type case
5119
5120 elsif Is_Array_Type (U_Type) then
5121 Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
5122 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
5123
5124 -- Tagged type case, use the primitive Write function. Note that
5125 -- this will dispatch in the class-wide case which is what we want
5126
5127 elsif Is_Tagged_Type (U_Type) then
9dfe12ae 5128 Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
ee6ba406 5129
5130 -- All other record type cases, including protected records.
5131 -- The latter only arise for expander generated code for
5132 -- handling shared passive partition access.
5133
5134 else
5135 pragma Assert
5136 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
5137
00f91aef 5138 -- Ada 2005 (AI-216): Program_Error is raised when executing
5139 -- the default implementation of the Write attribute of an
99f2248e 5140 -- Unchecked_Union type. However, if the 'Write reference is
5141 -- within the generated Output stream procedure, Write outputs
5142 -- the components, and the default values of the discriminant
5143 -- are streamed by the Output procedure itself.
00f91aef 5144
99f2248e 5145 if Is_Unchecked_Union (Base_Type (U_Type))
5146 and not Is_TSS (Current_Scope, TSS_Stream_Output)
5147 then
00f91aef 5148 Insert_Action (N,
5149 Make_Raise_Program_Error (Loc,
5150 Reason => PE_Unchecked_Union_Restriction));
5151 end if;
5152
ee6ba406 5153 if Has_Discriminants (U_Type)
5154 and then Present
5155 (Discriminant_Default_Value (First_Discriminant (U_Type)))
5156 then
5157 Build_Mutable_Record_Write_Procedure
5158 (Loc, Base_Type (U_Type), Decl, Pname);
ee6ba406 5159 else
5160 Build_Record_Write_Procedure
5161 (Loc, Base_Type (U_Type), Decl, Pname);
5162 end if;
5163
5164 Insert_Action (N, Decl);
5165 end if;
5166 end if;
5167
5168 -- If we fall through, Pname is the procedure to be called
5169
5170 Rewrite_Stream_Proc_Call (Pname);
5171 end Write;
5172
d55c93e0 5173 -- Component_Size is handled by the back end, unless the component size
5174 -- is known at compile time, which is always true in the packed array
5175 -- case. It is important that the packed array case is handled in the
5176 -- front end (see Eval_Attribute) since the back end would otherwise get
5177 -- confused by the equivalent packed array type.
ee6ba406 5178
5179 when Attribute_Component_Size =>
5180 null;
5181
18a40e97 5182 -- The following attributes are handled by the back end (except that
5183 -- static cases have already been evaluated during semantic processing,
5184 -- but in any case the back end should not count on this). The one bit
5185 -- of special processing required is that these attributes typically
5186 -- generate conditionals in the code, so we need to check the relevant
5187 -- restriction.
5188
5189 when Attribute_Max |
5190 Attribute_Min =>
5191 Check_Restriction (No_Implicit_Conditionals, N);
ee6ba406 5192
18a40e97 5193 -- The following attributes are handled by the back end (except that
5194 -- static cases have already been evaluated during semantic processing,
5195 -- but in any case the back end should not count on this).
ee6ba406 5196
d55c93e0 5197 -- The back end also handles the non-class-wide cases of Size
ee6ba406 5198
5199 when Attribute_Bit_Order |
5200 Attribute_Code_Address |
5201 Attribute_Definite |
ee6ba406 5202 Attribute_Null_Parameter |
9dfe12ae 5203 Attribute_Passed_By_Reference |
5204 Attribute_Pool_Address =>
ee6ba406 5205 null;
5206
d55c93e0 5207 -- The following attributes are also handled by the back end, but return
5208 -- a universal integer result, so may need a conversion for checking
ee6ba406 5209 -- that the result is in range.
5210
5211 when Attribute_Aft |
ee6ba406 5212 Attribute_Bit |
5213 Attribute_Max_Size_In_Storage_Elements
5214 =>
5215 Apply_Universal_Integer_Attribute_Checks (N);
5216
5217 -- The following attributes should not appear at this stage, since they
5218 -- have already been handled by the analyzer (and properly rewritten
5219 -- with corresponding values or entities to represent the right values)
5220
5221 when Attribute_Abort_Signal |
5222 Attribute_Address_Size |
5223 Attribute_Base |
5224 Attribute_Class |
5225 Attribute_Default_Bit_Order |
5226 Attribute_Delta |
5227 Attribute_Denorm |
5228 Attribute_Digits |
5229 Attribute_Emax |
f947f061 5230 Attribute_Enabled |
ee6ba406 5231 Attribute_Epsilon |
f0bf2ff3 5232 Attribute_Fast_Math |
5c99c290 5233 Attribute_Has_Access_Values |
ee6ba406 5234 Attribute_Has_Discriminants |
d55c93e0 5235 Attribute_Has_Tagged_Values |
ee6ba406 5236 Attribute_Large |
5237 Attribute_Machine_Emax |
5238 Attribute_Machine_Emin |
5239 Attribute_Machine_Mantissa |
5240 Attribute_Machine_Overflows |
5241 Attribute_Machine_Radix |
5242 Attribute_Machine_Rounds |
ee6ba406 5243 Attribute_Maximum_Alignment |
5244 Attribute_Model_Emin |
5245 Attribute_Model_Epsilon |
5246 Attribute_Model_Mantissa |
5247 Attribute_Model_Small |
5248 Attribute_Modulus |
5249 Attribute_Partition_ID |
5250 Attribute_Range |
5251 Attribute_Safe_Emax |
5252 Attribute_Safe_First |
5253 Attribute_Safe_Large |
5254 Attribute_Safe_Last |
5255 Attribute_Safe_Small |
5256 Attribute_Scale |
5257 Attribute_Signed_Zeros |
5258 Attribute_Small |
5259 Attribute_Storage_Unit |
7f8eb6ed 5260 Attribute_Stub_Type |
9dfe12ae 5261 Attribute_Target_Name |
ee6ba406 5262 Attribute_Type_Class |
9dfe12ae 5263 Attribute_Unconstrained_Array |
ee6ba406 5264 Attribute_Universal_Literal_String |
5265 Attribute_Wchar_T_Size |
5266 Attribute_Word_Size =>
5267
5268 raise Program_Error;
5269
5270 -- The Asm_Input and Asm_Output attributes are not expanded at this
d55c93e0 5271 -- stage, but will be eliminated in the expansion of the Asm call, see
5272 -- Exp_Intr for details. So the back end will never see these either.
ee6ba406 5273
5274 when Attribute_Asm_Input |
5275 Attribute_Asm_Output =>
5276
5277 null;
5278
5279 end case;
5280
9dfe12ae 5281 exception
5282 when RE_Not_Available =>
5283 return;
ee6ba406 5284 end Expand_N_Attribute_Reference;
5285
5286 ----------------------
5287 -- Expand_Pred_Succ --
5288 ----------------------
5289
5290 -- For typ'Pred (exp), we generate the check
5291
5292 -- [constraint_error when exp = typ'Base'First]
5293
5294 -- Similarly, for typ'Succ (exp), we generate the check
5295
5296 -- [constraint_error when exp = typ'Base'Last]
5297
5298 -- These checks are not generated for modular types, since the proper
5299 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
5300
5301 procedure Expand_Pred_Succ (N : Node_Id) is
5302 Loc : constant Source_Ptr := Sloc (N);
5303 Cnam : Name_Id;
5304
5305 begin
5306 if Attribute_Name (N) = Name_Pred then
5307 Cnam := Name_First;
5308 else
5309 Cnam := Name_Last;
5310 end if;
5311
5312 Insert_Action (N,
5313 Make_Raise_Constraint_Error (Loc,
5314 Condition =>
5315 Make_Op_Eq (Loc,
9dfe12ae 5316 Left_Opnd =>
5317 Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
ee6ba406 5318 Right_Opnd =>
5319 Make_Attribute_Reference (Loc,
5320 Prefix =>
5321 New_Reference_To (Base_Type (Etype (Prefix (N))), Loc),
f15731c4 5322 Attribute_Name => Cnam)),
5323 Reason => CE_Overflow_Check_Failed));
ee6ba406 5324 end Expand_Pred_Succ;
5325
1550b445 5326 -------------------
5327 -- Find_Fat_Info --
5328 -------------------
5329
5330 procedure Find_Fat_Info
5331 (T : Entity_Id;
5332 Fat_Type : out Entity_Id;
5333 Fat_Pkg : out RE_Id)
5334 is
5335 Btyp : constant Entity_Id := Base_Type (T);
5336 Rtyp : constant Entity_Id := Root_Type (T);
5337 Digs : constant Nat := UI_To_Int (Digits_Value (Btyp));
5338
5339 begin
5340 -- If the base type is VAX float, then get appropriate VAX float type
5341
5342 if Vax_Float (Btyp) then
5343 case Digs is
5344 when 6 =>
5345 Fat_Type := RTE (RE_Fat_VAX_F);
5346 Fat_Pkg := RE_Attr_VAX_F_Float;
5347
5348 when 9 =>
5349 Fat_Type := RTE (RE_Fat_VAX_D);
5350 Fat_Pkg := RE_Attr_VAX_D_Float;
5351
5352 when 15 =>
5353 Fat_Type := RTE (RE_Fat_VAX_G);
5354 Fat_Pkg := RE_Attr_VAX_G_Float;
5355
5356 when others =>
5357 raise Program_Error;
5358 end case;
5359
5360 -- If root type is VAX float, this is the case where the library has
5361 -- been recompiled in VAX float mode, and we have an IEEE float type.
5362 -- This is when we use the special IEEE Fat packages.
5363
5364 elsif Vax_Float (Rtyp) then
5365 case Digs is
5366 when 6 =>
5367 Fat_Type := RTE (RE_Fat_IEEE_Short);
5368 Fat_Pkg := RE_Attr_IEEE_Short;
5369
5370 when 15 =>
5371 Fat_Type := RTE (RE_Fat_IEEE_Long);
5372 Fat_Pkg := RE_Attr_IEEE_Long;
5373
5374 when others =>
5375 raise Program_Error;
5376 end case;
5377
5378 -- If neither the base type nor the root type is VAX_Float then VAX
5379 -- float is out of the picture, and we can just use the root type.
5380
5381 else
5382 Fat_Type := Rtyp;
5383
5384 if Fat_Type = Standard_Short_Float then
5385 Fat_Pkg := RE_Attr_Short_Float;
7f8eb6ed 5386
1550b445 5387 elsif Fat_Type = Standard_Float then
5388 Fat_Pkg := RE_Attr_Float;
7f8eb6ed 5389
1550b445 5390 elsif Fat_Type = Standard_Long_Float then
5391 Fat_Pkg := RE_Attr_Long_Float;
7f8eb6ed 5392
1550b445 5393 elsif Fat_Type = Standard_Long_Long_Float then
5394 Fat_Pkg := RE_Attr_Long_Long_Float;
7f8eb6ed 5395
5396 -- Universal real (which is its own root type) is treated as being
5397 -- equivalent to Standard.Long_Long_Float, since it is defined to
5398 -- have the same precision as the longest Float type.
5399
5400 elsif Fat_Type = Universal_Real then
5401 Fat_Type := Standard_Long_Long_Float;
5402 Fat_Pkg := RE_Attr_Long_Long_Float;
5403
1550b445 5404 else
5405 raise Program_Error;
5406 end if;
5407 end if;
5408 end Find_Fat_Info;
5409
9dfe12ae 5410 ----------------------------
5411 -- Find_Stream_Subprogram --
5412 ----------------------------
5413
5414 function Find_Stream_Subprogram
5415 (Typ : Entity_Id;
aad6babd 5416 Nam : TSS_Name_Type) return Entity_Id
5417 is
8667b0b2 5418 Base_Typ : constant Entity_Id := Base_Type (Typ);
5419 Ent : constant Entity_Id := TSS (Typ, Nam);
d55c93e0 5420
9dfe12ae 5421 begin
aad6babd 5422 if Present (Ent) then
5423 return Ent;
5424 end if;
5425
d55c93e0 5426 -- Stream attributes for strings are expanded into library calls. The
5427 -- following checks are disabled when the run-time is not available or
5428 -- when compiling predefined types due to bootstrap issues. As a result,
5429 -- the compiler will generate in-place stream routines for string types
5430 -- that appear in GNAT's library, but will generate calls via rtsfind
5431 -- to library routines for user code.
5432 -- ??? For now, disable this code for JVM, since this generates a
5433 -- VerifyError exception at run-time on e.g. c330001.
5434 -- This is disabled for AAMP, to avoid making dependences on files not
5435 -- supported in the AAMP library (such as s-fileio.adb).
5436
5437 if VM_Target /= JVM_Target
5438 and then not AAMP_On_Target
5439 and then
5440 not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
5441 then
d55c93e0 5442 -- String as defined in package Ada
5443
8667b0b2 5444 if Base_Typ = Standard_String then
b9f24e67 5445 if Restriction_Active (No_Stream_Optimizations) then
5446 if Nam = TSS_Stream_Input then
5447 return RTE (RE_String_Input);
5448
5449 elsif Nam = TSS_Stream_Output then
5450 return RTE (RE_String_Output);
5451
5452 elsif Nam = TSS_Stream_Read then
5453 return RTE (RE_String_Read);
d55c93e0 5454
b9f24e67 5455 else pragma Assert (Nam = TSS_Stream_Write);
5456 return RTE (RE_String_Write);
5457 end if;
5458
5459 else
5460 if Nam = TSS_Stream_Input then
5461 return RTE (RE_String_Input_Blk_IO);
d55c93e0 5462
b9f24e67 5463 elsif Nam = TSS_Stream_Output then
5464 return RTE (RE_String_Output_Blk_IO);
d55c93e0 5465
b9f24e67 5466 elsif Nam = TSS_Stream_Read then
5467 return RTE (RE_String_Read_Blk_IO);
5468
5469 else pragma Assert (Nam = TSS_Stream_Write);
5470 return RTE (RE_String_Write_Blk_IO);
5471 end if;
d55c93e0 5472 end if;
5473
5474 -- Wide_String as defined in package Ada
5475
8667b0b2 5476 elsif Base_Typ = Standard_Wide_String then
b9f24e67 5477 if Restriction_Active (No_Stream_Optimizations) then
5478 if Nam = TSS_Stream_Input then
5479 return RTE (RE_Wide_String_Input);
5480
5481 elsif Nam = TSS_Stream_Output then
5482 return RTE (RE_Wide_String_Output);
5483
5484 elsif Nam = TSS_Stream_Read then
5485 return RTE (RE_Wide_String_Read);
5486
5487 else pragma Assert (Nam = TSS_Stream_Write);
5488 return RTE (RE_Wide_String_Write);
5489 end if;
5490
5491 else
5492 if Nam = TSS_Stream_Input then
5493 return RTE (RE_Wide_String_Input_Blk_IO);
d55c93e0 5494
b9f24e67 5495 elsif Nam = TSS_Stream_Output then
5496 return RTE (RE_Wide_String_Output_Blk_IO);
d55c93e0 5497
b9f24e67 5498 elsif Nam = TSS_Stream_Read then
5499 return RTE (RE_Wide_String_Read_Blk_IO);
d55c93e0 5500
b9f24e67 5501 else pragma Assert (Nam = TSS_Stream_Write);
5502 return RTE (RE_Wide_String_Write_Blk_IO);
5503 end if;
d55c93e0 5504 end if;
5505
5506 -- Wide_Wide_String as defined in package Ada
5507
8667b0b2 5508 elsif Base_Typ = Standard_Wide_Wide_String then
b9f24e67 5509 if Restriction_Active (No_Stream_Optimizations) then
5510 if Nam = TSS_Stream_Input then
5511 return RTE (RE_Wide_Wide_String_Input);
5512
5513 elsif Nam = TSS_Stream_Output then
5514 return RTE (RE_Wide_Wide_String_Output);
d55c93e0 5515
b9f24e67 5516 elsif Nam = TSS_Stream_Read then
5517 return RTE (RE_Wide_Wide_String_Read);
d55c93e0 5518
b9f24e67 5519 else pragma Assert (Nam = TSS_Stream_Write);
5520 return RTE (RE_Wide_Wide_String_Write);
5521 end if;
d55c93e0 5522
b9f24e67 5523 else
5524 if Nam = TSS_Stream_Input then
5525 return RTE (RE_Wide_Wide_String_Input_Blk_IO);
5526
5527 elsif Nam = TSS_Stream_Output then
5528 return RTE (RE_Wide_Wide_String_Output_Blk_IO);
5529
5530 elsif Nam = TSS_Stream_Read then
5531 return RTE (RE_Wide_Wide_String_Read_Blk_IO);
5532
5533 else pragma Assert (Nam = TSS_Stream_Write);
5534 return RTE (RE_Wide_Wide_String_Write_Blk_IO);
5535 end if;
d55c93e0 5536 end if;
5537 end if;
5538 end if;
5539
9dfe12ae 5540 if Is_Tagged_Type (Typ)
5541 and then Is_Derived_Type (Typ)
5542 then
5543 return Find_Prim_Op (Typ, Nam);
5544 else
5545 return Find_Inherited_TSS (Typ, Nam);
5546 end if;
5547 end Find_Stream_Subprogram;
5548
ee6ba406 5549 -----------------------
5550 -- Get_Index_Subtype --
5551 -----------------------
5552
5553 function Get_Index_Subtype (N : Node_Id) return Node_Id is
5554 P_Type : Entity_Id := Etype (Prefix (N));
5555 Indx : Node_Id;
5556 J : Int;
5557
5558 begin
5559 if Is_Access_Type (P_Type) then
5560 P_Type := Designated_Type (P_Type);
5561 end if;
5562
5563 if No (Expressions (N)) then
5564 J := 1;
5565 else
5566 J := UI_To_Int (Expr_Value (First (Expressions (N))));
5567 end if;
5568
5569 Indx := First_Index (P_Type);
5570 while J > 1 loop
5571 Next_Index (Indx);
5572 J := J - 1;
5573 end loop;
5574
5575 return Etype (Indx);
5576 end Get_Index_Subtype;
5577
5245b786 5578 -------------------------------
5579 -- Get_Stream_Convert_Pragma --
5580 -------------------------------
5581
5582 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is
5583 Typ : Entity_Id;
5584 N : Node_Id;
5585
5586 begin
5587 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
5588 -- that a stream convert pragma for a tagged type is not inherited from
5589 -- its parent. Probably what is wrong here is that it is basically
5590 -- incorrect to consider a stream convert pragma to be a representation
5591 -- pragma at all ???
5592
5593 N := First_Rep_Item (Implementation_Base_Type (T));
5594 while Present (N) loop
4c06b9d2 5595 if Nkind (N) = N_Pragma
5596 and then Pragma_Name (N) = Name_Stream_Convert
5597 then
5245b786 5598 -- For tagged types this pragma is not inherited, so we
5599 -- must verify that it is defined for the given type and
5600 -- not an ancestor.
5601
5602 Typ :=
5603 Entity (Expression (First (Pragma_Argument_Associations (N))));
5604
5605 if not Is_Tagged_Type (T)
5606 or else T = Typ
5607 or else (Is_Private_Type (Typ) and then T = Full_View (Typ))
5608 then
5609 return N;
5610 end if;
5611 end if;
5612
5613 Next_Rep_Item (N);
5614 end loop;
5615
5616 return Empty;
5617 end Get_Stream_Convert_Pragma;
5618
ee6ba406 5619 ---------------------------------
5620 -- Is_Constrained_Packed_Array --
5621 ---------------------------------
5622
5623 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is
5624 Arr : Entity_Id := Typ;
5625
5626 begin
5627 if Is_Access_Type (Arr) then
5628 Arr := Designated_Type (Arr);
5629 end if;
5630
5631 return Is_Array_Type (Arr)
5632 and then Is_Constrained (Arr)
5633 and then Present (Packed_Array_Type (Arr));
5634 end Is_Constrained_Packed_Array;
5635
99f2248e 5636 ----------------------------------------
5637 -- Is_Inline_Floating_Point_Attribute --
5638 ----------------------------------------
5639
5640 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is
5641 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
5642
5643 begin
5644 if Nkind (Parent (N)) /= N_Type_Conversion
5645 or else not Is_Integer_Type (Etype (Parent (N)))
5646 then
5647 return False;
5648 end if;
5649
5650 -- Should also support 'Machine_Rounding and 'Unbiased_Rounding, but
5651 -- required back end support has not been implemented yet ???
5652
5653 return Id = Attribute_Truncation;
5654 end Is_Inline_Floating_Point_Attribute;
5655
ee6ba406 5656end Exp_Attr;
Mirror of https://gcc.gnu.org/git/gcc.git