* gimplify.c (find_single_pointer_decl_1): New static function.
[official-gcc.git] / gcc / ada / exp_attr.adb
blobb9d7ee1f1dfabd02c609e50fb8c988b8c991471f
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ A T T R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
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 --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Exp_Ch2; use Exp_Ch2;
32 with Exp_Ch9; use Exp_Ch9;
33 with Exp_Imgv; use Exp_Imgv;
34 with Exp_Pakd; use Exp_Pakd;
35 with Exp_Strm; use Exp_Strm;
36 with Exp_Tss; use Exp_Tss;
37 with Exp_Util; use Exp_Util;
38 with Exp_VFpt; use Exp_VFpt;
39 with Gnatvsn; use Gnatvsn;
40 with Hostparm; use Hostparm;
41 with Lib; use Lib;
42 with Namet; use Namet;
43 with Nmake; use Nmake;
44 with Nlists; use Nlists;
45 with Opt; use Opt;
46 with Restrict; use Restrict;
47 with Rident; use Rident;
48 with Rtsfind; use Rtsfind;
49 with Sem; use Sem;
50 with Sem_Ch7; use Sem_Ch7;
51 with Sem_Ch8; use Sem_Ch8;
52 with Sem_Eval; use Sem_Eval;
53 with Sem_Res; use Sem_Res;
54 with Sem_Util; use Sem_Util;
55 with Sinfo; use Sinfo;
56 with Snames; use Snames;
57 with Stand; use Stand;
58 with Stringt; use Stringt;
59 with Tbuild; use Tbuild;
60 with Ttypes; use Ttypes;
61 with Uintp; use Uintp;
62 with Uname; use Uname;
63 with Validsw; use Validsw;
65 package body Exp_Attr is
67 -----------------------
68 -- Local Subprograms --
69 -----------------------
71 procedure Compile_Stream_Body_In_Scope
72 (N : Node_Id;
73 Decl : Node_Id;
74 Arr : Entity_Id;
75 Check : Boolean);
76 -- The body for a stream subprogram may be generated outside of the scope
77 -- of the type. If the type is fully private, it may depend on the full
78 -- view of other types (e.g. indices) that are currently private as well.
79 -- We install the declarations of the package in which the type is declared
80 -- before compiling the body in what is its proper environment. The Check
81 -- parameter indicates if checks are to be suppressed for the stream body.
82 -- We suppress checks for array/record reads, since the rule is that these
83 -- are like assignments, out of range values due to uninitialized storage,
84 -- or other invalid values do NOT cause a Constraint_Error to be raised.
86 procedure Expand_Fpt_Attribute
87 (N : Node_Id;
88 Rtp : Entity_Id;
89 Nam : Name_Id;
90 Args : List_Id);
91 -- This procedure expands a call to a floating-point attribute function.
92 -- N is the attribute reference node, and Args is a list of arguments to
93 -- be passed to the function call. Rtp is the root type of the floating
94 -- point type involved (used to select the proper generic instantiation
95 -- of the package containing the attribute routines). The Nam argument
96 -- is the attribute processing routine to be called. This is normally
97 -- the same as the attribute name, except in the Unaligned_Valid case.
99 procedure Expand_Fpt_Attribute_R (N : Node_Id);
100 -- This procedure expands a call to a floating-point attribute function
101 -- that takes a single floating-point argument. The function to be called
102 -- is always the same as the attribute name.
104 procedure Expand_Fpt_Attribute_RI (N : Node_Id);
105 -- This procedure expands a call to a floating-point attribute function
106 -- that takes one floating-point argument and one integer argument. The
107 -- function to be called is always the same as the attribute name.
109 procedure Expand_Fpt_Attribute_RR (N : Node_Id);
110 -- This procedure expands a call to a floating-point attribute function
111 -- that takes two floating-point arguments. The function to be called
112 -- is always the same as the attribute name.
114 procedure Expand_Pred_Succ (N : Node_Id);
115 -- Handles expansion of Pred or Succ attributes for case of non-real
116 -- operand with overflow checking required.
118 function Get_Index_Subtype (N : Node_Id) return Entity_Id;
119 -- Used for Last, Last, and Length, when the prefix is an array type,
120 -- Obtains the corresponding index subtype.
122 procedure Expand_Access_To_Type (N : Node_Id);
123 -- A reference to a type within its own scope is resolved to a reference
124 -- to the current instance of the type in its initialization procedure.
126 function Find_Stream_Subprogram
127 (Typ : Entity_Id;
128 Nam : TSS_Name_Type) return Entity_Id;
129 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
130 -- types, the corresponding primitive operation is looked up, else the
131 -- appropriate TSS from the type itself, or from its closest ancestor
132 -- defining it, is returned. In both cases, inheritance of representation
133 -- aspects is thus taken into account.
135 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id;
136 -- Given a type, find a corresponding stream convert pragma that applies to
137 -- the implementation base type of this type (Typ). If found, return the
138 -- pragma node, otherwise return Empty if no pragma is found.
140 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
141 -- Utility for array attributes, returns true on packed constrained
142 -- arrays, and on access to same.
144 ----------------------------------
145 -- Compile_Stream_Body_In_Scope --
146 ----------------------------------
148 procedure Compile_Stream_Body_In_Scope
149 (N : Node_Id;
150 Decl : Node_Id;
151 Arr : Entity_Id;
152 Check : Boolean)
154 Installed : Boolean := False;
155 Scop : constant Entity_Id := Scope (Arr);
156 Curr : constant Entity_Id := Current_Scope;
158 begin
159 if Is_Hidden (Arr)
160 and then not In_Open_Scopes (Scop)
161 and then Ekind (Scop) = E_Package
162 then
163 New_Scope (Scop);
164 Install_Visible_Declarations (Scop);
165 Install_Private_Declarations (Scop);
166 Installed := True;
168 -- The entities in the package are now visible, but the generated
169 -- stream entity must appear in the current scope (usually an
170 -- enclosing stream function) so that itypes all have their proper
171 -- scopes.
173 New_Scope (Curr);
174 end if;
176 if Check then
177 Insert_Action (N, Decl);
178 else
179 Insert_Action (N, Decl, All_Checks);
180 end if;
182 if Installed then
184 -- Remove extra copy of current scope, and package itself
186 Pop_Scope;
187 End_Package_Scope (Scop);
188 end if;
189 end Compile_Stream_Body_In_Scope;
191 ---------------------------
192 -- Expand_Access_To_Type --
193 ---------------------------
195 procedure Expand_Access_To_Type (N : Node_Id) is
196 Loc : constant Source_Ptr := Sloc (N);
197 Typ : constant Entity_Id := Etype (N);
198 Pref : constant Node_Id := Prefix (N);
199 Par : Node_Id;
200 Formal : Entity_Id;
202 begin
203 if Is_Entity_Name (Pref)
204 and then Is_Type (Entity (Pref))
205 then
206 -- If the current instance name denotes a task type,
207 -- then the access attribute is rewritten to be the
208 -- name of the "_task" parameter associated with the
209 -- task type's task body procedure. An unchecked
210 -- conversion is applied to ensure a type match in
211 -- cases of expander-generated calls (e.g., init procs).
213 if Is_Task_Type (Entity (Pref)) then
214 Formal :=
215 First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
217 while Present (Formal) loop
218 exit when Chars (Formal) = Name_uTask;
219 Next_Entity (Formal);
220 end loop;
222 pragma Assert (Present (Formal));
224 Rewrite (N,
225 Unchecked_Convert_To (Typ, New_Occurrence_Of (Formal, Loc)));
226 Set_Etype (N, Typ);
228 -- The expression must appear in a default expression,
229 -- (which in the initialization procedure is the rhs of
230 -- an assignment), and not in a discriminant constraint.
232 else
233 Par := Parent (N);
235 while Present (Par) loop
236 exit when Nkind (Par) = N_Assignment_Statement;
238 if Nkind (Par) = N_Component_Declaration then
239 return;
240 end if;
242 Par := Parent (Par);
243 end loop;
245 if Present (Par) then
246 Rewrite (N,
247 Make_Attribute_Reference (Loc,
248 Prefix => Make_Identifier (Loc, Name_uInit),
249 Attribute_Name => Attribute_Name (N)));
251 Analyze_And_Resolve (N, Typ);
252 end if;
253 end if;
254 end if;
255 end Expand_Access_To_Type;
257 --------------------------
258 -- Expand_Fpt_Attribute --
259 --------------------------
261 procedure Expand_Fpt_Attribute
262 (N : Node_Id;
263 Rtp : Entity_Id;
264 Nam : Name_Id;
265 Args : List_Id)
267 Loc : constant Source_Ptr := Sloc (N);
268 Typ : constant Entity_Id := Etype (N);
269 Pkg : RE_Id;
270 Fnm : Node_Id;
272 begin
273 -- The function name is the selected component Fat_xxx.yyy where xxx
274 -- is the floating-point root type, and yyy is the argument Nam.
276 -- Note: it would be more usual to have separate RE entries for each
277 -- of the entities in the Fat packages, but first they have identical
278 -- names (so we would have to have lots of renaming declarations to
279 -- meet the normal RE rule of separate names for all runtime entities),
280 -- and second there would be an awful lot of them!
282 if Rtp = Standard_Short_Float then
283 Pkg := RE_Fat_Short_Float;
284 elsif Rtp = Standard_Float then
285 Pkg := RE_Fat_Float;
286 elsif Rtp = Standard_Long_Float then
287 Pkg := RE_Fat_Long_Float;
288 else
289 Pkg := RE_Fat_Long_Long_Float;
290 end if;
292 Fnm :=
293 Make_Selected_Component (Loc,
294 Prefix => New_Reference_To (RTE (Pkg), Loc),
295 Selector_Name => Make_Identifier (Loc, Nam));
297 -- The generated call is given the provided set of parameters, and then
298 -- wrapped in a conversion which converts the result to the target type
299 -- We use the base type as the target because a range check may be
300 -- required.
302 Rewrite (N,
303 Unchecked_Convert_To (Base_Type (Etype (N)),
304 Make_Function_Call (Loc,
305 Name => Fnm,
306 Parameter_Associations => Args)));
308 Analyze_And_Resolve (N, Typ);
309 end Expand_Fpt_Attribute;
311 ----------------------------
312 -- Expand_Fpt_Attribute_R --
313 ----------------------------
315 -- The single argument is converted to its root type to call the
316 -- appropriate runtime function, with the actual call being built
317 -- by Expand_Fpt_Attribute
319 procedure Expand_Fpt_Attribute_R (N : Node_Id) is
320 E1 : constant Node_Id := First (Expressions (N));
321 Rtp : constant Entity_Id := Root_Type (Etype (E1));
323 begin
324 Expand_Fpt_Attribute
325 (N, Rtp, Attribute_Name (N),
326 New_List (Unchecked_Convert_To (Rtp, Relocate_Node (E1))));
327 end Expand_Fpt_Attribute_R;
329 -----------------------------
330 -- Expand_Fpt_Attribute_RI --
331 -----------------------------
333 -- The first argument is converted to its root type and the second
334 -- argument is converted to standard long long integer to call the
335 -- appropriate runtime function, with the actual call being built
336 -- by Expand_Fpt_Attribute
338 procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
339 E1 : constant Node_Id := First (Expressions (N));
340 Rtp : constant Entity_Id := Root_Type (Etype (E1));
341 E2 : constant Node_Id := Next (E1);
343 begin
344 Expand_Fpt_Attribute
345 (N, Rtp, Attribute_Name (N),
346 New_List (
347 Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
348 Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
349 end Expand_Fpt_Attribute_RI;
351 -----------------------------
352 -- Expand_Fpt_Attribute_RR --
353 -----------------------------
355 -- The two arguments is converted to their root types to call the
356 -- appropriate runtime function, with the actual call being built
357 -- by Expand_Fpt_Attribute
359 procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
360 E1 : constant Node_Id := First (Expressions (N));
361 Rtp : constant Entity_Id := Root_Type (Etype (E1));
362 E2 : constant Node_Id := Next (E1);
364 begin
365 Expand_Fpt_Attribute
366 (N, Rtp, Attribute_Name (N),
367 New_List (
368 Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
369 Unchecked_Convert_To (Rtp, Relocate_Node (E2))));
370 end Expand_Fpt_Attribute_RR;
372 ----------------------------------
373 -- Expand_N_Attribute_Reference --
374 ----------------------------------
376 procedure Expand_N_Attribute_Reference (N : Node_Id) is
377 Loc : constant Source_Ptr := Sloc (N);
378 Typ : constant Entity_Id := Etype (N);
379 Btyp : constant Entity_Id := Base_Type (Typ);
380 Pref : constant Node_Id := Prefix (N);
381 Exprs : constant List_Id := Expressions (N);
382 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
384 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
385 -- Rewrites a stream attribute for Read, Write or Output with the
386 -- procedure call. Pname is the entity for the procedure to call.
388 ------------------------------
389 -- Rewrite_Stream_Proc_Call --
390 ------------------------------
392 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
393 Item : constant Node_Id := Next (First (Exprs));
394 Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
395 Formal_Typ : constant Entity_Id := Etype (Formal);
396 Is_Written : constant Boolean := (Ekind (Formal) /= E_In_Parameter);
398 begin
399 -- The expansion depends on Item, the second actual, which is
400 -- the object being streamed in or out.
402 -- If the item is a component of a packed array type, and
403 -- a conversion is needed on exit, we introduce a temporary to
404 -- hold the value, because otherwise the packed reference will
405 -- not be properly expanded.
407 if Nkind (Item) = N_Indexed_Component
408 and then Is_Packed (Base_Type (Etype (Prefix (Item))))
409 and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
410 and then Is_Written
411 then
412 declare
413 Temp : constant Entity_Id :=
414 Make_Defining_Identifier
415 (Loc, New_Internal_Name ('V'));
416 Decl : Node_Id;
417 Assn : Node_Id;
419 begin
420 Decl :=
421 Make_Object_Declaration (Loc,
422 Defining_Identifier => Temp,
423 Object_Definition =>
424 New_Occurrence_Of (Formal_Typ, Loc));
425 Set_Etype (Temp, Formal_Typ);
427 Assn :=
428 Make_Assignment_Statement (Loc,
429 Name => New_Copy_Tree (Item),
430 Expression =>
431 Unchecked_Convert_To
432 (Etype (Item), New_Occurrence_Of (Temp, Loc)));
434 Rewrite (Item, New_Occurrence_Of (Temp, Loc));
435 Insert_Actions (N,
436 New_List (
437 Decl,
438 Make_Procedure_Call_Statement (Loc,
439 Name => New_Occurrence_Of (Pname, Loc),
440 Parameter_Associations => Exprs),
441 Assn));
443 Rewrite (N, Make_Null_Statement (Loc));
444 return;
445 end;
446 end if;
448 -- For the class-wide dispatching cases, and for cases in which
449 -- the base type of the second argument matches the base type of
450 -- the corresponding formal parameter (that is to say the stream
451 -- operation is not inherited), we are all set, and can use the
452 -- argument unchanged.
454 -- For all other cases we do an unchecked conversion of the second
455 -- parameter to the type of the formal of the procedure we are
456 -- calling. This deals with the private type cases, and with going
457 -- to the root type as required in elementary type case.
459 if not Is_Class_Wide_Type (Entity (Pref))
460 and then not Is_Class_Wide_Type (Etype (Item))
461 and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
462 then
463 Rewrite (Item,
464 Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
466 -- For untagged derived types set Assignment_OK, to prevent
467 -- copies from being created when the unchecked conversion
468 -- is expanded (which would happen in Remove_Side_Effects
469 -- if Expand_N_Unchecked_Conversion were allowed to call
470 -- Force_Evaluation). The copy could violate Ada semantics
471 -- in cases such as an actual that is an out parameter.
472 -- Note that this approach is also used in exp_ch7 for calls
473 -- to controlled type operations to prevent problems with
474 -- actuals wrapped in unchecked conversions.
476 if Is_Untagged_Derivation (Etype (Expression (Item))) then
477 Set_Assignment_OK (Item);
478 end if;
479 end if;
481 -- And now rewrite the call
483 Rewrite (N,
484 Make_Procedure_Call_Statement (Loc,
485 Name => New_Occurrence_Of (Pname, Loc),
486 Parameter_Associations => Exprs));
488 Analyze (N);
489 end Rewrite_Stream_Proc_Call;
491 -- Start of processing for Expand_N_Attribute_Reference
493 begin
494 -- Do required validity checking, if enabled. Do not apply check to
495 -- output parameters of an Asm instruction, since the value of this
496 -- is not set till after the attribute has been elaborated.
498 if Validity_Checks_On and then Validity_Check_Operands
499 and then Id /= Attribute_Asm_Output
500 then
501 declare
502 Expr : Node_Id;
503 begin
504 Expr := First (Expressions (N));
505 while Present (Expr) loop
506 Ensure_Valid (Expr);
507 Next (Expr);
508 end loop;
509 end;
510 end if;
512 -- Remaining processing depends on specific attribute
514 case Id is
516 ------------
517 -- Access --
518 ------------
520 when Attribute_Access =>
522 if Ekind (Btyp) = E_Access_Protected_Subprogram_Type then
524 -- The value of the attribute_reference is a record containing
525 -- two fields: an access to the protected object, and an access
526 -- to the subprogram itself. The prefix is a selected component.
528 declare
529 Agg : Node_Id;
530 Sub : Entity_Id;
531 E_T : constant Entity_Id := Equivalent_Type (Btyp);
532 Acc : constant Entity_Id :=
533 Etype (Next_Component (First_Component (E_T)));
534 Obj_Ref : Node_Id;
535 Curr : Entity_Id;
537 begin
538 -- Within the body of the protected type, the prefix
539 -- designates a local operation, and the object is the first
540 -- parameter of the corresponding protected body of the
541 -- current enclosing operation.
543 if Is_Entity_Name (Pref) then
544 pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
545 Sub :=
546 New_Occurrence_Of
547 (Protected_Body_Subprogram (Entity (Pref)), Loc);
548 Curr := Current_Scope;
550 while Scope (Curr) /= Scope (Entity (Pref)) loop
551 Curr := Scope (Curr);
552 end loop;
554 Obj_Ref :=
555 Make_Attribute_Reference (Loc,
556 Prefix =>
557 New_Occurrence_Of
558 (First_Formal
559 (Protected_Body_Subprogram (Curr)), Loc),
560 Attribute_Name => Name_Address);
562 -- Case where the prefix is not an entity name. Find the
563 -- version of the protected operation to be called from
564 -- outside the protected object.
566 else
567 Sub :=
568 New_Occurrence_Of
569 (External_Subprogram
570 (Entity (Selector_Name (Pref))), Loc);
572 Obj_Ref :=
573 Make_Attribute_Reference (Loc,
574 Prefix => Relocate_Node (Prefix (Pref)),
575 Attribute_Name => Name_Address);
576 end if;
578 Agg :=
579 Make_Aggregate (Loc,
580 Expressions =>
581 New_List (
582 Obj_Ref,
583 Unchecked_Convert_To (Acc,
584 Make_Attribute_Reference (Loc,
585 Prefix => Sub,
586 Attribute_Name => Name_Address))));
588 Rewrite (N, Agg);
590 Analyze_And_Resolve (N, E_T);
592 -- For subsequent analysis, the node must retain its type.
593 -- The backend will replace it with the equivalent type where
594 -- needed.
596 Set_Etype (N, Typ);
597 end;
599 elsif Ekind (Btyp) = E_General_Access_Type then
600 declare
601 Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
602 Parm_Ent : Entity_Id;
603 Conversion : Node_Id;
605 begin
606 -- If the prefix of an Access attribute is a dereference of an
607 -- access parameter (or a renaming of such a dereference) and
608 -- the context is a general access type (but not an anonymous
609 -- access type), then rewrite the attribute as a conversion of
610 -- the access parameter to the context access type. This will
611 -- result in an accessibility check being performed, if needed.
613 -- (X.all'Access => Acc_Type (X))
615 if Nkind (Ref_Object) = N_Explicit_Dereference
616 and then Is_Entity_Name (Prefix (Ref_Object))
617 then
618 Parm_Ent := Entity (Prefix (Ref_Object));
620 if Ekind (Parm_Ent) in Formal_Kind
621 and then Ekind (Etype (Parm_Ent)) = E_Anonymous_Access_Type
622 and then Present (Extra_Accessibility (Parm_Ent))
623 then
624 Conversion :=
625 Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object)));
627 Rewrite (N, Conversion);
628 Analyze_And_Resolve (N, Typ);
629 end if;
631 -- Ada 2005 (AI-251): If the designated type is an interface,
632 -- then rewrite the referenced object as a conversion to force
633 -- the displacement of the pointer to the secondary dispatch
634 -- table.
636 elsif Is_Interface (Directly_Designated_Type (Btyp)) then
637 Conversion := Convert_To (Typ, New_Copy_Tree (Ref_Object));
638 Rewrite (N, Conversion);
639 Analyze_And_Resolve (N, Typ);
640 end if;
641 end;
643 -- If the prefix is a type name, this is a reference to the current
644 -- instance of the type, within its initialization procedure.
646 else
647 Expand_Access_To_Type (N);
648 end if;
650 --------------
651 -- Adjacent --
652 --------------
654 -- Transforms 'Adjacent into a call to the floating-point attribute
655 -- function Adjacent in Fat_xxx (where xxx is the root type)
657 when Attribute_Adjacent =>
658 Expand_Fpt_Attribute_RR (N);
660 -------------
661 -- Address --
662 -------------
664 when Attribute_Address => Address : declare
665 Task_Proc : Entity_Id;
667 begin
668 -- If the prefix is a task or a task type, the useful address
669 -- is that of the procedure for the task body, i.e. the actual
670 -- program unit. We replace the original entity with that of
671 -- the procedure.
673 if Is_Entity_Name (Pref)
674 and then Is_Task_Type (Entity (Pref))
675 then
676 Task_Proc := Next_Entity (Root_Type (Etype (Pref)));
678 while Present (Task_Proc) loop
679 exit when Ekind (Task_Proc) = E_Procedure
680 and then Etype (First_Formal (Task_Proc)) =
681 Corresponding_Record_Type (Etype (Pref));
682 Next_Entity (Task_Proc);
683 end loop;
685 if Present (Task_Proc) then
686 Set_Entity (Pref, Task_Proc);
687 Set_Etype (Pref, Etype (Task_Proc));
688 end if;
690 -- Similarly, the address of a protected operation is the address
691 -- of the corresponding protected body, regardless of the protected
692 -- object from which it is selected.
694 elsif Nkind (Pref) = N_Selected_Component
695 and then Is_Subprogram (Entity (Selector_Name (Pref)))
696 and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref))))
697 then
698 Rewrite (Pref,
699 New_Occurrence_Of (
700 External_Subprogram (Entity (Selector_Name (Pref))), Loc));
702 elsif Nkind (Pref) = N_Explicit_Dereference
703 and then Ekind (Etype (Pref)) = E_Subprogram_Type
704 and then Convention (Etype (Pref)) = Convention_Protected
705 then
706 -- The prefix is be a dereference of an access_to_protected_
707 -- subprogram. The desired address is the second component of
708 -- the record that represents the access.
710 declare
711 Addr : constant Entity_Id := Etype (N);
712 Ptr : constant Node_Id := Prefix (Pref);
713 T : constant Entity_Id :=
714 Equivalent_Type (Base_Type (Etype (Ptr)));
716 begin
717 Rewrite (N,
718 Unchecked_Convert_To (Addr,
719 Make_Selected_Component (Loc,
720 Prefix => Unchecked_Convert_To (T, Ptr),
721 Selector_Name => New_Occurrence_Of (
722 Next_Entity (First_Entity (T)), Loc))));
724 Analyze_And_Resolve (N, Addr);
725 end;
726 end if;
728 -- Deal with packed array reference, other cases are handled by gigi
730 if Involves_Packed_Array_Reference (Pref) then
731 Expand_Packed_Address_Reference (N);
732 end if;
733 end Address;
735 ---------------
736 -- Alignment --
737 ---------------
739 when Attribute_Alignment => Alignment : declare
740 Ptyp : constant Entity_Id := Etype (Pref);
741 New_Node : Node_Id;
743 begin
744 -- For class-wide types, X'Class'Alignment is transformed into a
745 -- direct reference to the Alignment of the class type, so that the
746 -- back end does not have to deal with the X'Class'Alignment
747 -- reference.
749 if Is_Entity_Name (Pref)
750 and then Is_Class_Wide_Type (Entity (Pref))
751 then
752 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
753 return;
755 -- For x'Alignment applied to an object of a class wide type,
756 -- transform X'Alignment into a call to the predefined primitive
757 -- operation _Alignment applied to X.
759 elsif Is_Class_Wide_Type (Ptyp) then
760 New_Node :=
761 Make_Function_Call (Loc,
762 Name => New_Reference_To
763 (Find_Prim_Op (Ptyp, Name_uAlignment), Loc),
764 Parameter_Associations => New_List (Pref));
766 if Typ /= Standard_Integer then
768 -- The context is a specific integer type with which the
769 -- original attribute was compatible. The function has a
770 -- specific type as well, so to preserve the compatibility
771 -- we must convert explicitly.
773 New_Node := Convert_To (Typ, New_Node);
774 end if;
776 Rewrite (N, New_Node);
777 Analyze_And_Resolve (N, Typ);
778 return;
780 -- For all other cases, we just have to deal with the case of
781 -- the fact that the result can be universal.
783 else
784 Apply_Universal_Integer_Attribute_Checks (N);
785 end if;
786 end Alignment;
788 ---------------
789 -- AST_Entry --
790 ---------------
792 when Attribute_AST_Entry => AST_Entry : declare
793 Ttyp : Entity_Id;
794 T_Id : Node_Id;
795 Eent : Entity_Id;
797 Entry_Ref : Node_Id;
798 -- The reference to the entry or entry family
800 Index : Node_Id;
801 -- The index expression for an entry family reference, or
802 -- the Empty if Entry_Ref references a simple entry.
804 begin
805 if Nkind (Pref) = N_Indexed_Component then
806 Entry_Ref := Prefix (Pref);
807 Index := First (Expressions (Pref));
808 else
809 Entry_Ref := Pref;
810 Index := Empty;
811 end if;
813 -- Get expression for Task_Id and the entry entity
815 if Nkind (Entry_Ref) = N_Selected_Component then
816 T_Id :=
817 Make_Attribute_Reference (Loc,
818 Attribute_Name => Name_Identity,
819 Prefix => Prefix (Entry_Ref));
821 Ttyp := Etype (Prefix (Entry_Ref));
822 Eent := Entity (Selector_Name (Entry_Ref));
824 else
825 T_Id :=
826 Make_Function_Call (Loc,
827 Name => New_Occurrence_Of (RTE (RE_Current_Task), Loc));
829 Eent := Entity (Entry_Ref);
831 -- We have to find the enclosing task to get the task type
832 -- There must be one, since we already validated this earlier
834 Ttyp := Current_Scope;
835 while not Is_Task_Type (Ttyp) loop
836 Ttyp := Scope (Ttyp);
837 end loop;
838 end if;
840 -- Now rewrite the attribute with a call to Create_AST_Handler
842 Rewrite (N,
843 Make_Function_Call (Loc,
844 Name => New_Occurrence_Of (RTE (RE_Create_AST_Handler), Loc),
845 Parameter_Associations => New_List (
846 T_Id,
847 Entry_Index_Expression (Loc, Eent, Index, Ttyp))));
849 Analyze_And_Resolve (N, RTE (RE_AST_Handler));
850 end AST_Entry;
852 ------------------
853 -- Bit_Position --
854 ------------------
856 -- We compute this if a component clause was present, otherwise
857 -- we leave the computation up to Gigi, since we don't know what
858 -- layout will be chosen.
860 -- Note that the attribute can apply to a naked record component
861 -- in generated code (i.e. the prefix is an identifier that
862 -- references the component or discriminant entity).
864 when Attribute_Bit_Position => Bit_Position :
865 declare
866 CE : Entity_Id;
868 begin
869 if Nkind (Pref) = N_Identifier then
870 CE := Entity (Pref);
871 else
872 CE := Entity (Selector_Name (Pref));
873 end if;
875 if Known_Static_Component_Bit_Offset (CE) then
876 Rewrite (N,
877 Make_Integer_Literal (Loc,
878 Intval => Component_Bit_Offset (CE)));
879 Analyze_And_Resolve (N, Typ);
881 else
882 Apply_Universal_Integer_Attribute_Checks (N);
883 end if;
884 end Bit_Position;
886 ------------------
887 -- Body_Version --
888 ------------------
890 -- A reference to P'Body_Version or P'Version is expanded to
892 -- Vnn : Unsigned;
893 -- pragma Import (C, Vnn, "uuuuT";
894 -- ...
895 -- Get_Version_String (Vnn)
897 -- where uuuu is the unit name (dots replaced by double underscore)
898 -- and T is B for the cases of Body_Version, or Version applied to a
899 -- subprogram acting as its own spec, and S for Version applied to a
900 -- subprogram spec or package. This sequence of code references the
901 -- the unsigned constant created in the main program by the binder.
903 -- A special exception occurs for Standard, where the string
904 -- returned is a copy of the library string in gnatvsn.ads.
906 when Attribute_Body_Version | Attribute_Version => Version : declare
907 E : constant Entity_Id :=
908 Make_Defining_Identifier (Loc, New_Internal_Name ('V'));
909 Pent : Entity_Id := Entity (Pref);
910 S : String_Id;
912 begin
913 -- If not library unit, get to containing library unit
915 while Pent /= Standard_Standard
916 and then Scope (Pent) /= Standard_Standard
917 loop
918 Pent := Scope (Pent);
919 end loop;
921 -- Special case Standard
923 if Pent = Standard_Standard
924 or else Pent = Standard_ASCII
925 then
926 Rewrite (N,
927 Make_String_Literal (Loc,
928 Strval => Verbose_Library_Version));
930 -- All other cases
932 else
933 -- Build required string constant
935 Get_Name_String (Get_Unit_Name (Pent));
937 Start_String;
938 for J in 1 .. Name_Len - 2 loop
939 if Name_Buffer (J) = '.' then
940 Store_String_Chars ("__");
941 else
942 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
943 end if;
944 end loop;
946 -- Case of subprogram acting as its own spec, always use body
948 if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
949 and then Nkind (Parent (Declaration_Node (Pent))) =
950 N_Subprogram_Body
951 and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
952 then
953 Store_String_Chars ("B");
955 -- Case of no body present, always use spec
957 elsif not Unit_Requires_Body (Pent) then
958 Store_String_Chars ("S");
960 -- Otherwise use B for Body_Version, S for spec
962 elsif Id = Attribute_Body_Version then
963 Store_String_Chars ("B");
964 else
965 Store_String_Chars ("S");
966 end if;
968 S := End_String;
969 Lib.Version_Referenced (S);
971 -- Insert the object declaration
973 Insert_Actions (N, New_List (
974 Make_Object_Declaration (Loc,
975 Defining_Identifier => E,
976 Object_Definition =>
977 New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
979 -- Set entity as imported with correct external name
981 Set_Is_Imported (E);
982 Set_Interface_Name (E, Make_String_Literal (Loc, S));
984 -- And now rewrite original reference
986 Rewrite (N,
987 Make_Function_Call (Loc,
988 Name => New_Reference_To (RTE (RE_Get_Version_String), Loc),
989 Parameter_Associations => New_List (
990 New_Occurrence_Of (E, Loc))));
991 end if;
993 Analyze_And_Resolve (N, RTE (RE_Version_String));
994 end Version;
996 -------------
997 -- Ceiling --
998 -------------
1000 -- Transforms 'Ceiling into a call to the floating-point attribute
1001 -- function Ceiling in Fat_xxx (where xxx is the root type)
1003 when Attribute_Ceiling =>
1004 Expand_Fpt_Attribute_R (N);
1006 --------------
1007 -- Callable --
1008 --------------
1010 -- Transforms 'Callable attribute into a call to the Callable function
1012 when Attribute_Callable => Callable :
1013 begin
1014 Rewrite (N,
1015 Build_Call_With_Task (Pref, RTE (RE_Callable)));
1016 Analyze_And_Resolve (N, Standard_Boolean);
1017 end Callable;
1019 ------------
1020 -- Caller --
1021 ------------
1023 -- Transforms 'Caller attribute into a call to either the
1024 -- Task_Entry_Caller or the Protected_Entry_Caller function.
1026 when Attribute_Caller => Caller : declare
1027 Id_Kind : constant Entity_Id := RTE (RO_AT_Task_Id);
1028 Ent : constant Entity_Id := Entity (Pref);
1029 Conctype : constant Entity_Id := Scope (Ent);
1030 Nest_Depth : Integer := 0;
1031 Name : Node_Id;
1032 S : Entity_Id;
1034 begin
1035 -- Protected case
1037 if Is_Protected_Type (Conctype) then
1038 if Abort_Allowed
1039 or else Restriction_Active (No_Entry_Queue) = False
1040 or else Number_Entries (Conctype) > 1
1041 then
1042 Name :=
1043 New_Reference_To
1044 (RTE (RE_Protected_Entry_Caller), Loc);
1045 else
1046 Name :=
1047 New_Reference_To
1048 (RTE (RE_Protected_Single_Entry_Caller), Loc);
1049 end if;
1051 Rewrite (N,
1052 Unchecked_Convert_To (Id_Kind,
1053 Make_Function_Call (Loc,
1054 Name => Name,
1055 Parameter_Associations => New_List
1056 (New_Reference_To (
1057 Object_Ref
1058 (Corresponding_Body (Parent (Conctype))), Loc)))));
1060 -- Task case
1062 else
1063 -- Determine the nesting depth of the E'Caller attribute, that
1064 -- is, how many accept statements are nested within the accept
1065 -- statement for E at the point of E'Caller. The runtime uses
1066 -- this depth to find the specified entry call.
1068 for J in reverse 0 .. Scope_Stack.Last loop
1069 S := Scope_Stack.Table (J).Entity;
1071 -- We should not reach the scope of the entry, as it should
1072 -- already have been checked in Sem_Attr that this attribute
1073 -- reference is within a matching accept statement.
1075 pragma Assert (S /= Conctype);
1077 if S = Ent then
1078 exit;
1080 elsif Is_Entry (S) then
1081 Nest_Depth := Nest_Depth + 1;
1082 end if;
1083 end loop;
1085 Rewrite (N,
1086 Unchecked_Convert_To (Id_Kind,
1087 Make_Function_Call (Loc,
1088 Name => New_Reference_To (
1089 RTE (RE_Task_Entry_Caller), Loc),
1090 Parameter_Associations => New_List (
1091 Make_Integer_Literal (Loc,
1092 Intval => Int (Nest_Depth))))));
1093 end if;
1095 Analyze_And_Resolve (N, Id_Kind);
1096 end Caller;
1098 -------------
1099 -- Compose --
1100 -------------
1102 -- Transforms 'Compose into a call to the floating-point attribute
1103 -- function Compose in Fat_xxx (where xxx is the root type)
1105 -- Note: we strictly should have special code here to deal with the
1106 -- case of absurdly negative arguments (less than Integer'First)
1107 -- which will return a (signed) zero value, but it hardly seems
1108 -- worth the effort. Absurdly large positive arguments will raise
1109 -- constraint error which is fine.
1111 when Attribute_Compose =>
1112 Expand_Fpt_Attribute_RI (N);
1114 -----------------
1115 -- Constrained --
1116 -----------------
1118 when Attribute_Constrained => Constrained : declare
1119 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
1120 Typ : constant Entity_Id := Etype (Pref);
1122 begin
1123 -- Reference to a parameter where the value is passed as an extra
1124 -- actual, corresponding to the extra formal referenced by the
1125 -- Extra_Constrained field of the corresponding formal. If this
1126 -- is an entry in-parameter, it is replaced by a constant renaming
1127 -- for which Extra_Constrained is never created.
1129 if Present (Formal_Ent)
1130 and then Ekind (Formal_Ent) /= E_Constant
1131 and then Present (Extra_Constrained (Formal_Ent))
1132 then
1133 Rewrite (N,
1134 New_Occurrence_Of
1135 (Extra_Constrained (Formal_Ent), Sloc (N)));
1137 -- For variables with a Extra_Constrained field, we use the
1138 -- corresponding entity.
1140 elsif Nkind (Pref) = N_Identifier
1141 and then Ekind (Entity (Pref)) = E_Variable
1142 and then Present (Extra_Constrained (Entity (Pref)))
1143 then
1144 Rewrite (N,
1145 New_Occurrence_Of
1146 (Extra_Constrained (Entity (Pref)), Sloc (N)));
1148 -- For all other entity names, we can tell at compile time
1150 elsif Is_Entity_Name (Pref) then
1151 declare
1152 Ent : constant Entity_Id := Entity (Pref);
1153 Res : Boolean;
1155 begin
1156 -- (RM J.4) obsolescent cases
1158 if Is_Type (Ent) then
1160 -- Private type
1162 if Is_Private_Type (Ent) then
1163 Res := not Has_Discriminants (Ent)
1164 or else Is_Constrained (Ent);
1166 -- It not a private type, must be a generic actual type
1167 -- that corresponded to a private type. We know that this
1168 -- correspondence holds, since otherwise the reference
1169 -- within the generic template would have been illegal.
1171 else
1172 if Is_Composite_Type (Underlying_Type (Ent)) then
1173 Res := Is_Constrained (Ent);
1174 else
1175 Res := True;
1176 end if;
1177 end if;
1179 -- If the prefix is not a variable or is aliased, then
1180 -- definitely true; if it's a formal parameter without
1181 -- an associated extra formal, then treat it as constrained.
1183 elsif not Is_Variable (Pref)
1184 or else Present (Formal_Ent)
1185 or else Is_Aliased_View (Pref)
1186 then
1187 Res := True;
1189 -- Variable case, just look at type to see if it is
1190 -- constrained. Note that the one case where this is
1191 -- not accurate (the procedure formal case), has been
1192 -- handled above.
1194 else
1195 Res := Is_Constrained (Etype (Ent));
1196 end if;
1198 Rewrite (N,
1199 New_Reference_To (Boolean_Literals (Res), Loc));
1200 end;
1202 -- Prefix is not an entity name. These are also cases where
1203 -- we can always tell at compile time by looking at the form
1204 -- and type of the prefix. If an explicit dereference of an
1205 -- object with constrained partial view, this is unconstrained
1206 -- (Ada 2005 AI-363).
1208 else
1209 Rewrite (N,
1210 New_Reference_To (
1211 Boolean_Literals (
1212 not Is_Variable (Pref)
1213 or else
1214 (Nkind (Pref) = N_Explicit_Dereference
1215 and then
1216 not Has_Constrained_Partial_View (Base_Type (Typ)))
1217 or else Is_Constrained (Typ)),
1218 Loc));
1219 end if;
1221 Analyze_And_Resolve (N, Standard_Boolean);
1222 end Constrained;
1224 ---------------
1225 -- Copy_Sign --
1226 ---------------
1228 -- Transforms 'Copy_Sign into a call to the floating-point attribute
1229 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
1231 when Attribute_Copy_Sign =>
1232 Expand_Fpt_Attribute_RR (N);
1234 -----------
1235 -- Count --
1236 -----------
1238 -- Transforms 'Count attribute into a call to the Count function
1240 when Attribute_Count => Count :
1241 declare
1242 Entnam : Node_Id;
1243 Index : Node_Id;
1244 Name : Node_Id;
1245 Call : Node_Id;
1246 Conctyp : Entity_Id;
1248 begin
1249 -- If the prefix is a member of an entry family, retrieve both
1250 -- entry name and index. For a simple entry there is no index.
1252 if Nkind (Pref) = N_Indexed_Component then
1253 Entnam := Prefix (Pref);
1254 Index := First (Expressions (Pref));
1255 else
1256 Entnam := Pref;
1257 Index := Empty;
1258 end if;
1260 -- Find the concurrent type in which this attribute is referenced
1261 -- (there had better be one).
1263 Conctyp := Current_Scope;
1264 while not Is_Concurrent_Type (Conctyp) loop
1265 Conctyp := Scope (Conctyp);
1266 end loop;
1268 -- Protected case
1270 if Is_Protected_Type (Conctyp) then
1272 if Abort_Allowed
1273 or else Restriction_Active (No_Entry_Queue) = False
1274 or else Number_Entries (Conctyp) > 1
1275 then
1276 Name := New_Reference_To (RTE (RE_Protected_Count), Loc);
1278 Call :=
1279 Make_Function_Call (Loc,
1280 Name => Name,
1281 Parameter_Associations => New_List (
1282 New_Reference_To (
1283 Object_Ref (
1284 Corresponding_Body (Parent (Conctyp))), Loc),
1285 Entry_Index_Expression (
1286 Loc, Entity (Entnam), Index, Scope (Entity (Entnam)))));
1287 else
1288 Name := New_Reference_To (RTE (RE_Protected_Count_Entry), Loc);
1290 Call := Make_Function_Call (Loc,
1291 Name => Name,
1292 Parameter_Associations => New_List (
1293 New_Reference_To (
1294 Object_Ref (
1295 Corresponding_Body (Parent (Conctyp))), Loc)));
1296 end if;
1298 -- Task case
1300 else
1301 Call :=
1302 Make_Function_Call (Loc,
1303 Name => New_Reference_To (RTE (RE_Task_Count), Loc),
1304 Parameter_Associations => New_List (
1305 Entry_Index_Expression
1306 (Loc, Entity (Entnam), Index, Scope (Entity (Entnam)))));
1307 end if;
1309 -- The call returns type Natural but the context is universal integer
1310 -- so any integer type is allowed. The attribute was already resolved
1311 -- so its Etype is the required result type. If the base type of the
1312 -- context type is other than Standard.Integer we put in a conversion
1313 -- to the required type. This can be a normal typed conversion since
1314 -- both input and output types of the conversion are integer types
1316 if Base_Type (Typ) /= Base_Type (Standard_Integer) then
1317 Rewrite (N, Convert_To (Typ, Call));
1318 else
1319 Rewrite (N, Call);
1320 end if;
1322 Analyze_And_Resolve (N, Typ);
1323 end Count;
1325 ---------------
1326 -- Elab_Body --
1327 ---------------
1329 -- This processing is shared by Elab_Spec
1331 -- What we do is to insert the following declarations
1333 -- procedure tnn;
1334 -- pragma Import (C, enn, "name___elabb/s");
1336 -- and then the Elab_Body/Spec attribute is replaced by a reference
1337 -- to this defining identifier.
1339 when Attribute_Elab_Body |
1340 Attribute_Elab_Spec =>
1342 Elab_Body : declare
1343 Ent : constant Entity_Id :=
1344 Make_Defining_Identifier (Loc,
1345 New_Internal_Name ('E'));
1346 Str : String_Id;
1347 Lang : Node_Id;
1349 procedure Make_Elab_String (Nod : Node_Id);
1350 -- Given Nod, an identifier, or a selected component, put the
1351 -- image into the current string literal, with double underline
1352 -- between components.
1354 procedure Make_Elab_String (Nod : Node_Id) is
1355 begin
1356 if Nkind (Nod) = N_Selected_Component then
1357 Make_Elab_String (Prefix (Nod));
1358 if Java_VM then
1359 Store_String_Char ('$');
1360 else
1361 Store_String_Char ('_');
1362 Store_String_Char ('_');
1363 end if;
1365 Get_Name_String (Chars (Selector_Name (Nod)));
1367 else
1368 pragma Assert (Nkind (Nod) = N_Identifier);
1369 Get_Name_String (Chars (Nod));
1370 end if;
1372 Store_String_Chars (Name_Buffer (1 .. Name_Len));
1373 end Make_Elab_String;
1375 -- Start of processing for Elab_Body/Elab_Spec
1377 begin
1378 -- First we need to prepare the string literal for the name of
1379 -- the elaboration routine to be referenced.
1381 Start_String;
1382 Make_Elab_String (Pref);
1384 if Java_VM then
1385 Store_String_Chars ("._elab");
1386 Lang := Make_Identifier (Loc, Name_Ada);
1387 else
1388 Store_String_Chars ("___elab");
1389 Lang := Make_Identifier (Loc, Name_C);
1390 end if;
1392 if Id = Attribute_Elab_Body then
1393 Store_String_Char ('b');
1394 else
1395 Store_String_Char ('s');
1396 end if;
1398 Str := End_String;
1400 Insert_Actions (N, New_List (
1401 Make_Subprogram_Declaration (Loc,
1402 Specification =>
1403 Make_Procedure_Specification (Loc,
1404 Defining_Unit_Name => Ent)),
1406 Make_Pragma (Loc,
1407 Chars => Name_Import,
1408 Pragma_Argument_Associations => New_List (
1409 Make_Pragma_Argument_Association (Loc,
1410 Expression => Lang),
1412 Make_Pragma_Argument_Association (Loc,
1413 Expression =>
1414 Make_Identifier (Loc, Chars (Ent))),
1416 Make_Pragma_Argument_Association (Loc,
1417 Expression =>
1418 Make_String_Literal (Loc, Str))))));
1420 Set_Entity (N, Ent);
1421 Rewrite (N, New_Occurrence_Of (Ent, Loc));
1422 end Elab_Body;
1424 ----------------
1425 -- Elaborated --
1426 ----------------
1428 -- Elaborated is always True for preelaborated units, predefined
1429 -- units, pure units and units which have Elaborate_Body pragmas.
1430 -- These units have no elaboration entity.
1432 -- Note: The Elaborated attribute is never passed through to Gigi
1434 when Attribute_Elaborated => Elaborated : declare
1435 Ent : constant Entity_Id := Entity (Pref);
1437 begin
1438 if Present (Elaboration_Entity (Ent)) then
1439 Rewrite (N,
1440 New_Occurrence_Of (Elaboration_Entity (Ent), Loc));
1441 else
1442 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
1443 end if;
1444 end Elaborated;
1446 --------------
1447 -- Enum_Rep --
1448 --------------
1450 when Attribute_Enum_Rep => Enum_Rep :
1451 begin
1452 -- X'Enum_Rep (Y) expands to
1454 -- target-type (Y)
1456 -- This is simply a direct conversion from the enumeration type
1457 -- to the target integer type, which is treated by Gigi as a normal
1458 -- integer conversion, treating the enumeration type as an integer,
1459 -- which is exactly what we want! We set Conversion_OK to make sure
1460 -- that the analyzer does not complain about what otherwise might
1461 -- be an illegal conversion.
1463 if Is_Non_Empty_List (Exprs) then
1464 Rewrite (N,
1465 OK_Convert_To (Typ, Relocate_Node (First (Exprs))));
1467 -- X'Enum_Rep where X is an enumeration literal is replaced by
1468 -- the literal value.
1470 elsif Ekind (Entity (Pref)) = E_Enumeration_Literal then
1471 Rewrite (N,
1472 Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref))));
1474 -- If this is a renaming of a literal, recover the representation
1475 -- of the original.
1477 elsif Ekind (Entity (Pref)) = E_Constant
1478 and then Present (Renamed_Object (Entity (Pref)))
1479 and then
1480 Ekind (Entity (Renamed_Object (Entity (Pref))))
1481 = E_Enumeration_Literal
1482 then
1483 Rewrite (N,
1484 Make_Integer_Literal (Loc,
1485 Enumeration_Rep (Entity (Renamed_Object (Entity (Pref))))));
1487 -- X'Enum_Rep where X is an object does a direct unchecked conversion
1488 -- of the object value, as described for the type case above.
1490 else
1491 Rewrite (N,
1492 OK_Convert_To (Typ, Relocate_Node (Pref)));
1493 end if;
1495 Set_Etype (N, Typ);
1496 Analyze_And_Resolve (N, Typ);
1498 end Enum_Rep;
1500 --------------
1501 -- Exponent --
1502 --------------
1504 -- Transforms 'Exponent into a call to the floating-point attribute
1505 -- function Exponent in Fat_xxx (where xxx is the root type)
1507 when Attribute_Exponent =>
1508 Expand_Fpt_Attribute_R (N);
1510 ------------------
1511 -- External_Tag --
1512 ------------------
1514 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
1516 when Attribute_External_Tag => External_Tag :
1517 begin
1518 Rewrite (N,
1519 Make_Function_Call (Loc,
1520 Name => New_Reference_To (RTE (RE_External_Tag), Loc),
1521 Parameter_Associations => New_List (
1522 Make_Attribute_Reference (Loc,
1523 Attribute_Name => Name_Tag,
1524 Prefix => Prefix (N)))));
1526 Analyze_And_Resolve (N, Standard_String);
1527 end External_Tag;
1529 -----------
1530 -- First --
1531 -----------
1533 when Attribute_First => declare
1534 Ptyp : constant Entity_Id := Etype (Pref);
1536 begin
1537 -- If the prefix type is a constrained packed array type which
1538 -- already has a Packed_Array_Type representation defined, then
1539 -- replace this attribute with a direct reference to 'First of the
1540 -- appropriate index subtype (since otherwise Gigi will try to give
1541 -- us the value of 'First for this implementation type).
1543 if Is_Constrained_Packed_Array (Ptyp) then
1544 Rewrite (N,
1545 Make_Attribute_Reference (Loc,
1546 Attribute_Name => Name_First,
1547 Prefix => New_Reference_To (Get_Index_Subtype (N), Loc)));
1548 Analyze_And_Resolve (N, Typ);
1550 elsif Is_Access_Type (Ptyp) then
1551 Apply_Access_Check (N);
1552 end if;
1553 end;
1555 ---------------
1556 -- First_Bit --
1557 ---------------
1559 -- We compute this if a component clause was present, otherwise
1560 -- we leave the computation up to Gigi, since we don't know what
1561 -- layout will be chosen.
1563 when Attribute_First_Bit => First_Bit :
1564 declare
1565 CE : constant Entity_Id := Entity (Selector_Name (Pref));
1567 begin
1568 if Known_Static_Component_Bit_Offset (CE) then
1569 Rewrite (N,
1570 Make_Integer_Literal (Loc,
1571 Component_Bit_Offset (CE) mod System_Storage_Unit));
1573 Analyze_And_Resolve (N, Typ);
1575 else
1576 Apply_Universal_Integer_Attribute_Checks (N);
1577 end if;
1578 end First_Bit;
1580 -----------------
1581 -- Fixed_Value --
1582 -----------------
1584 -- We transform:
1586 -- fixtype'Fixed_Value (integer-value)
1588 -- into
1590 -- fixtype(integer-value)
1592 -- we do all the required analysis of the conversion here, because
1593 -- we do not want this to go through the fixed-point conversion
1594 -- circuits. Note that gigi always treats fixed-point as equivalent
1595 -- to the corresponding integer type anyway.
1597 when Attribute_Fixed_Value => Fixed_Value :
1598 begin
1599 Rewrite (N,
1600 Make_Type_Conversion (Loc,
1601 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
1602 Expression => Relocate_Node (First (Exprs))));
1603 Set_Etype (N, Entity (Pref));
1604 Set_Analyzed (N);
1606 -- Note: it might appear that a properly analyzed unchecked conversion
1607 -- would be just fine here, but that's not the case, since the full
1608 -- range checks performed by the following call are critical!
1610 Apply_Type_Conversion_Checks (N);
1611 end Fixed_Value;
1613 -----------
1614 -- Floor --
1615 -----------
1617 -- Transforms 'Floor into a call to the floating-point attribute
1618 -- function Floor in Fat_xxx (where xxx is the root type)
1620 when Attribute_Floor =>
1621 Expand_Fpt_Attribute_R (N);
1623 ----------
1624 -- Fore --
1625 ----------
1627 -- For the fixed-point type Typ:
1629 -- Typ'Fore
1631 -- expands into
1633 -- Result_Type (System.Fore (Long_Long_Float (Type'First)),
1634 -- Long_Long_Float (Type'Last))
1636 -- Note that we know that the type is a non-static subtype, or Fore
1637 -- would have itself been computed dynamically in Eval_Attribute.
1639 when Attribute_Fore => Fore :
1640 declare
1641 Ptyp : constant Entity_Id := Etype (Pref);
1643 begin
1644 Rewrite (N,
1645 Convert_To (Typ,
1646 Make_Function_Call (Loc,
1647 Name => New_Reference_To (RTE (RE_Fore), Loc),
1649 Parameter_Associations => New_List (
1650 Convert_To (Standard_Long_Long_Float,
1651 Make_Attribute_Reference (Loc,
1652 Prefix => New_Reference_To (Ptyp, Loc),
1653 Attribute_Name => Name_First)),
1655 Convert_To (Standard_Long_Long_Float,
1656 Make_Attribute_Reference (Loc,
1657 Prefix => New_Reference_To (Ptyp, Loc),
1658 Attribute_Name => Name_Last))))));
1660 Analyze_And_Resolve (N, Typ);
1661 end Fore;
1663 --------------
1664 -- Fraction --
1665 --------------
1667 -- Transforms 'Fraction into a call to the floating-point attribute
1668 -- function Fraction in Fat_xxx (where xxx is the root type)
1670 when Attribute_Fraction =>
1671 Expand_Fpt_Attribute_R (N);
1673 --------------
1674 -- Identity --
1675 --------------
1677 -- For an exception returns a reference to the exception data:
1678 -- Exception_Id!(Prefix'Reference)
1680 -- For a task it returns a reference to the _task_id component of
1681 -- corresponding record:
1683 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
1685 -- in Ada.Task_Identification
1687 when Attribute_Identity => Identity : declare
1688 Id_Kind : Entity_Id;
1690 begin
1691 if Etype (Pref) = Standard_Exception_Type then
1692 Id_Kind := RTE (RE_Exception_Id);
1694 if Present (Renamed_Object (Entity (Pref))) then
1695 Set_Entity (Pref, Renamed_Object (Entity (Pref)));
1696 end if;
1698 Rewrite (N,
1699 Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref)));
1700 else
1701 Id_Kind := RTE (RO_AT_Task_Id);
1703 Rewrite (N,
1704 Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
1705 end if;
1707 Analyze_And_Resolve (N, Id_Kind);
1708 end Identity;
1710 -----------
1711 -- Image --
1712 -----------
1714 -- Image attribute is handled in separate unit Exp_Imgv
1716 when Attribute_Image =>
1717 Exp_Imgv.Expand_Image_Attribute (N);
1719 ---------
1720 -- Img --
1721 ---------
1723 -- X'Img is expanded to typ'Image (X), where typ is the type of X
1725 when Attribute_Img => Img :
1726 begin
1727 Rewrite (N,
1728 Make_Attribute_Reference (Loc,
1729 Prefix => New_Reference_To (Etype (Pref), Loc),
1730 Attribute_Name => Name_Image,
1731 Expressions => New_List (Relocate_Node (Pref))));
1733 Analyze_And_Resolve (N, Standard_String);
1734 end Img;
1736 -----------
1737 -- Input --
1738 -----------
1740 when Attribute_Input => Input : declare
1741 P_Type : constant Entity_Id := Entity (Pref);
1742 B_Type : constant Entity_Id := Base_Type (P_Type);
1743 U_Type : constant Entity_Id := Underlying_Type (P_Type);
1744 Strm : constant Node_Id := First (Exprs);
1745 Fname : Entity_Id;
1746 Decl : Node_Id;
1747 Call : Node_Id;
1748 Prag : Node_Id;
1749 Arg2 : Node_Id;
1750 Rfunc : Node_Id;
1752 Cntrl : Node_Id := Empty;
1753 -- Value for controlling argument in call. Always Empty except in
1754 -- the dispatching (class-wide type) case, where it is a reference
1755 -- to the dummy object initialized to the right internal tag.
1757 procedure Freeze_Stream_Subprogram (F : Entity_Id);
1758 -- The expansion of the attribute reference may generate a call to
1759 -- a user-defined stream subprogram that is frozen by the call. This
1760 -- can lead to access-before-elaboration problem if the reference
1761 -- appears in an object declaration and the subprogram body has not
1762 -- been seen. The freezing of the subprogram requires special code
1763 -- because it appears in an expanded context where expressions do
1764 -- not freeze their constituents.
1766 ------------------------------
1767 -- Freeze_Stream_Subprogram --
1768 ------------------------------
1770 procedure Freeze_Stream_Subprogram (F : Entity_Id) is
1771 Decl : constant Node_Id := Unit_Declaration_Node (F);
1772 Bod : Node_Id;
1774 begin
1775 -- If this is user-defined subprogram, the corresponding
1776 -- stream function appears as a renaming-as-body, and the
1777 -- user subprogram must be retrieved by tree traversal.
1779 if Present (Decl)
1780 and then Nkind (Decl) = N_Subprogram_Declaration
1781 and then Present (Corresponding_Body (Decl))
1782 then
1783 Bod := Corresponding_Body (Decl);
1785 if Nkind (Unit_Declaration_Node (Bod)) =
1786 N_Subprogram_Renaming_Declaration
1787 then
1788 Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod))));
1789 end if;
1790 end if;
1791 end Freeze_Stream_Subprogram;
1793 -- Start of processing for Input
1795 begin
1796 -- If no underlying type, we have an error that will be diagnosed
1797 -- elsewhere, so here we just completely ignore the expansion.
1799 if No (U_Type) then
1800 return;
1801 end if;
1803 -- If there is a TSS for Input, just call it
1805 Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
1807 if Present (Fname) then
1808 null;
1810 else
1811 -- If there is a Stream_Convert pragma, use it, we rewrite
1813 -- sourcetyp'Input (stream)
1815 -- as
1817 -- sourcetyp (streamread (strmtyp'Input (stream)));
1819 -- where stmrearead is the given Read function that converts
1820 -- an argument of type strmtyp to type sourcetyp or a type
1821 -- from which it is derived. The extra conversion is required
1822 -- for the derived case.
1824 Prag := Get_Stream_Convert_Pragma (P_Type);
1826 if Present (Prag) then
1827 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
1828 Rfunc := Entity (Expression (Arg2));
1830 Rewrite (N,
1831 Convert_To (B_Type,
1832 Make_Function_Call (Loc,
1833 Name => New_Occurrence_Of (Rfunc, Loc),
1834 Parameter_Associations => New_List (
1835 Make_Attribute_Reference (Loc,
1836 Prefix =>
1837 New_Occurrence_Of
1838 (Etype (First_Formal (Rfunc)), Loc),
1839 Attribute_Name => Name_Input,
1840 Expressions => Exprs)))));
1842 Analyze_And_Resolve (N, B_Type);
1843 return;
1845 -- Elementary types
1847 elsif Is_Elementary_Type (U_Type) then
1849 -- A special case arises if we have a defined _Read routine,
1850 -- since in this case we are required to call this routine.
1852 if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then
1853 Build_Record_Or_Elementary_Input_Function
1854 (Loc, U_Type, Decl, Fname);
1855 Insert_Action (N, Decl);
1857 -- For normal cases, we call the I_xxx routine directly
1859 else
1860 Rewrite (N, Build_Elementary_Input_Call (N));
1861 Analyze_And_Resolve (N, P_Type);
1862 return;
1863 end if;
1865 -- Array type case
1867 elsif Is_Array_Type (U_Type) then
1868 Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
1869 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
1871 -- Dispatching case with class-wide type
1873 elsif Is_Class_Wide_Type (P_Type) then
1875 declare
1876 Rtyp : constant Entity_Id := Root_Type (P_Type);
1877 Dnn : Entity_Id;
1878 Decl : Node_Id;
1880 begin
1881 -- Read the internal tag (RM 13.13.2(34)) and use it to
1882 -- initialize a dummy tag object:
1884 -- Dnn : Ada.Tags.Tag
1885 -- := Descendant_Tag (String'Input (Strm), P_Type);
1887 -- This dummy object is used only to provide a controlling
1888 -- argument for the eventual _Input call. Descendant_Tag is
1889 -- called rather than Internal_Tag to ensure that we have a
1890 -- tag for a type that is descended from the prefix type and
1891 -- declared at the same accessibility level (the exception
1892 -- Tag_Error will be raised otherwise). The level check is
1893 -- required for Ada 2005 because tagged types can be
1894 -- extended in nested scopes (AI-344).
1896 Dnn :=
1897 Make_Defining_Identifier (Loc,
1898 Chars => New_Internal_Name ('D'));
1900 Decl :=
1901 Make_Object_Declaration (Loc,
1902 Defining_Identifier => Dnn,
1903 Object_Definition =>
1904 New_Occurrence_Of (RTE (RE_Tag), Loc),
1905 Expression =>
1906 Make_Function_Call (Loc,
1907 Name =>
1908 New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
1909 Parameter_Associations => New_List (
1910 Make_Attribute_Reference (Loc,
1911 Prefix =>
1912 New_Occurrence_Of (Standard_String, Loc),
1913 Attribute_Name => Name_Input,
1914 Expressions => New_List (
1915 Relocate_Node
1916 (Duplicate_Subexpr (Strm)))),
1917 Make_Attribute_Reference (Loc,
1918 Prefix => New_Reference_To (P_Type, Loc),
1919 Attribute_Name => Name_Tag))));
1921 Insert_Action (N, Decl);
1923 -- Now we need to get the entity for the call, and construct
1924 -- a function call node, where we preset a reference to Dnn
1925 -- as the controlling argument (doing an unchecked convert
1926 -- to the class-wide tagged type to make it look like a real
1927 -- tagged object).
1929 Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
1930 Cntrl := Unchecked_Convert_To (P_Type,
1931 New_Occurrence_Of (Dnn, Loc));
1932 Set_Etype (Cntrl, P_Type);
1933 Set_Parent (Cntrl, N);
1934 end;
1936 -- For tagged types, use the primitive Input function
1938 elsif Is_Tagged_Type (U_Type) then
1939 Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
1941 -- All other record type cases, including protected records. The
1942 -- latter only arise for expander generated code for handling
1943 -- shared passive partition access.
1945 else
1946 pragma Assert
1947 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
1949 -- Ada 2005 (AI-216): Program_Error is raised when executing
1950 -- the default implementation of the Input attribute of an
1951 -- unchecked union type if the type lacks default discriminant
1952 -- values.
1954 if Is_Unchecked_Union (Base_Type (U_Type))
1955 and then not Present (Discriminant_Constraint (U_Type))
1956 then
1957 Insert_Action (N,
1958 Make_Raise_Program_Error (Loc,
1959 Reason => PE_Unchecked_Union_Restriction));
1961 return;
1962 end if;
1964 Build_Record_Or_Elementary_Input_Function
1965 (Loc, Base_Type (U_Type), Decl, Fname);
1966 Insert_Action (N, Decl);
1968 if Nkind (Parent (N)) = N_Object_Declaration
1969 and then Is_Record_Type (U_Type)
1970 then
1971 -- The stream function may contain calls to user-defined
1972 -- Read procedures for individual components.
1974 declare
1975 Comp : Entity_Id;
1976 Func : Entity_Id;
1978 begin
1979 Comp := First_Component (U_Type);
1980 while Present (Comp) loop
1981 Func :=
1982 Find_Stream_Subprogram
1983 (Etype (Comp), TSS_Stream_Read);
1985 if Present (Func) then
1986 Freeze_Stream_Subprogram (Func);
1987 end if;
1989 Next_Component (Comp);
1990 end loop;
1991 end;
1992 end if;
1993 end if;
1994 end if;
1996 -- If we fall through, Fname is the function to be called. The result
1997 -- is obtained by calling the appropriate function, then converting
1998 -- the result. The conversion does a subtype check.
2000 Call :=
2001 Make_Function_Call (Loc,
2002 Name => New_Occurrence_Of (Fname, Loc),
2003 Parameter_Associations => New_List (
2004 Relocate_Node (Strm)));
2006 Set_Controlling_Argument (Call, Cntrl);
2007 Rewrite (N, Unchecked_Convert_To (P_Type, Call));
2008 Analyze_And_Resolve (N, P_Type);
2010 if Nkind (Parent (N)) = N_Object_Declaration then
2011 Freeze_Stream_Subprogram (Fname);
2012 end if;
2013 end Input;
2015 -------------------
2016 -- Integer_Value --
2017 -------------------
2019 -- We transform
2021 -- inttype'Fixed_Value (fixed-value)
2023 -- into
2025 -- inttype(integer-value))
2027 -- we do all the required analysis of the conversion here, because
2028 -- we do not want this to go through the fixed-point conversion
2029 -- circuits. Note that gigi always treats fixed-point as equivalent
2030 -- to the corresponding integer type anyway.
2032 when Attribute_Integer_Value => Integer_Value :
2033 begin
2034 Rewrite (N,
2035 Make_Type_Conversion (Loc,
2036 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
2037 Expression => Relocate_Node (First (Exprs))));
2038 Set_Etype (N, Entity (Pref));
2039 Set_Analyzed (N);
2041 -- Note: it might appear that a properly analyzed unchecked conversion
2042 -- would be just fine here, but that's not the case, since the full
2043 -- range checks performed by the following call are critical!
2045 Apply_Type_Conversion_Checks (N);
2046 end Integer_Value;
2048 ----------
2049 -- Last --
2050 ----------
2052 when Attribute_Last => declare
2053 Ptyp : constant Entity_Id := Etype (Pref);
2055 begin
2056 -- If the prefix type is a constrained packed array type which
2057 -- already has a Packed_Array_Type representation defined, then
2058 -- replace this attribute with a direct reference to 'Last of the
2059 -- appropriate index subtype (since otherwise Gigi will try to give
2060 -- us the value of 'Last for this implementation type).
2062 if Is_Constrained_Packed_Array (Ptyp) then
2063 Rewrite (N,
2064 Make_Attribute_Reference (Loc,
2065 Attribute_Name => Name_Last,
2066 Prefix => New_Reference_To (Get_Index_Subtype (N), Loc)));
2067 Analyze_And_Resolve (N, Typ);
2069 elsif Is_Access_Type (Ptyp) then
2070 Apply_Access_Check (N);
2071 end if;
2072 end;
2074 --------------
2075 -- Last_Bit --
2076 --------------
2078 -- We compute this if a component clause was present, otherwise
2079 -- we leave the computation up to Gigi, since we don't know what
2080 -- layout will be chosen.
2082 when Attribute_Last_Bit => Last_Bit :
2083 declare
2084 CE : constant Entity_Id := Entity (Selector_Name (Pref));
2086 begin
2087 if Known_Static_Component_Bit_Offset (CE)
2088 and then Known_Static_Esize (CE)
2089 then
2090 Rewrite (N,
2091 Make_Integer_Literal (Loc,
2092 Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
2093 + Esize (CE) - 1));
2095 Analyze_And_Resolve (N, Typ);
2097 else
2098 Apply_Universal_Integer_Attribute_Checks (N);
2099 end if;
2100 end Last_Bit;
2102 ------------------
2103 -- Leading_Part --
2104 ------------------
2106 -- Transforms 'Leading_Part into a call to the floating-point attribute
2107 -- function Leading_Part in Fat_xxx (where xxx is the root type)
2109 -- Note: strictly, we should have special case code to deal with
2110 -- absurdly large positive arguments (greater than Integer'Last), which
2111 -- result in returning the first argument unchanged, but it hardly seems
2112 -- worth the effort. We raise constraint error for absurdly negative
2113 -- arguments which is fine.
2115 when Attribute_Leading_Part =>
2116 Expand_Fpt_Attribute_RI (N);
2118 ------------
2119 -- Length --
2120 ------------
2122 when Attribute_Length => declare
2123 Ptyp : constant Entity_Id := Etype (Pref);
2124 Ityp : Entity_Id;
2125 Xnum : Uint;
2127 begin
2128 -- Processing for packed array types
2130 if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
2131 Ityp := Get_Index_Subtype (N);
2133 -- If the index type, Ityp, is an enumeration type with
2134 -- holes, then we calculate X'Length explicitly using
2136 -- Typ'Max
2137 -- (0, Ityp'Pos (X'Last (N)) -
2138 -- Ityp'Pos (X'First (N)) + 1);
2140 -- Since the bounds in the template are the representation
2141 -- values and gigi would get the wrong value.
2143 if Is_Enumeration_Type (Ityp)
2144 and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
2145 then
2146 if No (Exprs) then
2147 Xnum := Uint_1;
2148 else
2149 Xnum := Expr_Value (First (Expressions (N)));
2150 end if;
2152 Rewrite (N,
2153 Make_Attribute_Reference (Loc,
2154 Prefix => New_Occurrence_Of (Typ, Loc),
2155 Attribute_Name => Name_Max,
2156 Expressions => New_List
2157 (Make_Integer_Literal (Loc, 0),
2159 Make_Op_Add (Loc,
2160 Left_Opnd =>
2161 Make_Op_Subtract (Loc,
2162 Left_Opnd =>
2163 Make_Attribute_Reference (Loc,
2164 Prefix => New_Occurrence_Of (Ityp, Loc),
2165 Attribute_Name => Name_Pos,
2167 Expressions => New_List (
2168 Make_Attribute_Reference (Loc,
2169 Prefix => Duplicate_Subexpr (Pref),
2170 Attribute_Name => Name_Last,
2171 Expressions => New_List (
2172 Make_Integer_Literal (Loc, Xnum))))),
2174 Right_Opnd =>
2175 Make_Attribute_Reference (Loc,
2176 Prefix => New_Occurrence_Of (Ityp, Loc),
2177 Attribute_Name => Name_Pos,
2179 Expressions => New_List (
2180 Make_Attribute_Reference (Loc,
2181 Prefix =>
2182 Duplicate_Subexpr_No_Checks (Pref),
2183 Attribute_Name => Name_First,
2184 Expressions => New_List (
2185 Make_Integer_Literal (Loc, Xnum)))))),
2187 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
2189 Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
2190 return;
2192 -- If the prefix type is a constrained packed array type which
2193 -- already has a Packed_Array_Type representation defined, then
2194 -- replace this attribute with a direct reference to 'Range_Length
2195 -- of the appropriate index subtype (since otherwise Gigi will try
2196 -- to give us the value of 'Length for this implementation type).
2198 elsif Is_Constrained (Ptyp) then
2199 Rewrite (N,
2200 Make_Attribute_Reference (Loc,
2201 Attribute_Name => Name_Range_Length,
2202 Prefix => New_Reference_To (Ityp, Loc)));
2203 Analyze_And_Resolve (N, Typ);
2204 end if;
2206 -- If we have a packed array that is not bit packed, which was
2208 -- Access type case
2210 elsif Is_Access_Type (Ptyp) then
2211 Apply_Access_Check (N);
2213 -- If the designated type is a packed array type, then we
2214 -- convert the reference to:
2216 -- typ'Max (0, 1 +
2217 -- xtyp'Pos (Pref'Last (Expr)) -
2218 -- xtyp'Pos (Pref'First (Expr)));
2220 -- This is a bit complex, but it is the easiest thing to do
2221 -- that works in all cases including enum types with holes
2222 -- xtyp here is the appropriate index type.
2224 declare
2225 Dtyp : constant Entity_Id := Designated_Type (Ptyp);
2226 Xtyp : Entity_Id;
2228 begin
2229 if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
2230 Xtyp := Get_Index_Subtype (N);
2232 Rewrite (N,
2233 Make_Attribute_Reference (Loc,
2234 Prefix => New_Occurrence_Of (Typ, Loc),
2235 Attribute_Name => Name_Max,
2236 Expressions => New_List (
2237 Make_Integer_Literal (Loc, 0),
2239 Make_Op_Add (Loc,
2240 Make_Integer_Literal (Loc, 1),
2241 Make_Op_Subtract (Loc,
2242 Left_Opnd =>
2243 Make_Attribute_Reference (Loc,
2244 Prefix => New_Occurrence_Of (Xtyp, Loc),
2245 Attribute_Name => Name_Pos,
2246 Expressions => New_List (
2247 Make_Attribute_Reference (Loc,
2248 Prefix => Duplicate_Subexpr (Pref),
2249 Attribute_Name => Name_Last,
2250 Expressions =>
2251 New_Copy_List (Exprs)))),
2253 Right_Opnd =>
2254 Make_Attribute_Reference (Loc,
2255 Prefix => New_Occurrence_Of (Xtyp, Loc),
2256 Attribute_Name => Name_Pos,
2257 Expressions => New_List (
2258 Make_Attribute_Reference (Loc,
2259 Prefix =>
2260 Duplicate_Subexpr_No_Checks (Pref),
2261 Attribute_Name => Name_First,
2262 Expressions =>
2263 New_Copy_List (Exprs)))))))));
2265 Analyze_And_Resolve (N, Typ);
2266 end if;
2267 end;
2269 -- Otherwise leave it to gigi
2271 else
2272 Apply_Universal_Integer_Attribute_Checks (N);
2273 end if;
2274 end;
2276 -------------
2277 -- Machine --
2278 -------------
2280 -- Transforms 'Machine into a call to the floating-point attribute
2281 -- function Machine in Fat_xxx (where xxx is the root type)
2283 when Attribute_Machine =>
2284 Expand_Fpt_Attribute_R (N);
2286 ------------------
2287 -- Machine_Size --
2288 ------------------
2290 -- Machine_Size is equivalent to Object_Size, so transform it into
2291 -- Object_Size and that way Gigi never sees Machine_Size.
2293 when Attribute_Machine_Size =>
2294 Rewrite (N,
2295 Make_Attribute_Reference (Loc,
2296 Prefix => Prefix (N),
2297 Attribute_Name => Name_Object_Size));
2299 Analyze_And_Resolve (N, Typ);
2301 --------------
2302 -- Mantissa --
2303 --------------
2305 -- The only case that can get this far is the dynamic case of the old
2306 -- Ada 83 Mantissa attribute for the fixed-point case. For this case, we
2307 -- expand:
2309 -- typ'Mantissa
2311 -- into
2313 -- ityp (System.Mantissa.Mantissa_Value
2314 -- (Integer'Integer_Value (typ'First),
2315 -- Integer'Integer_Value (typ'Last)));
2317 when Attribute_Mantissa => Mantissa : declare
2318 Ptyp : constant Entity_Id := Etype (Pref);
2320 begin
2321 Rewrite (N,
2322 Convert_To (Typ,
2323 Make_Function_Call (Loc,
2324 Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
2326 Parameter_Associations => New_List (
2328 Make_Attribute_Reference (Loc,
2329 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2330 Attribute_Name => Name_Integer_Value,
2331 Expressions => New_List (
2333 Make_Attribute_Reference (Loc,
2334 Prefix => New_Occurrence_Of (Ptyp, Loc),
2335 Attribute_Name => Name_First))),
2337 Make_Attribute_Reference (Loc,
2338 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2339 Attribute_Name => Name_Integer_Value,
2340 Expressions => New_List (
2342 Make_Attribute_Reference (Loc,
2343 Prefix => New_Occurrence_Of (Ptyp, Loc),
2344 Attribute_Name => Name_Last)))))));
2346 Analyze_And_Resolve (N, Typ);
2347 end Mantissa;
2349 ---------
2350 -- Mod --
2351 ---------
2353 when Attribute_Mod => Mod_Case : declare
2354 Arg : constant Node_Id := Relocate_Node (First (Exprs));
2355 Hi : constant Node_Id := Type_High_Bound (Etype (Arg));
2356 Modv : constant Uint := Modulus (Btyp);
2358 begin
2360 -- This is not so simple. The issue is what type to use for the
2361 -- computation of the modular value.
2363 -- The easy case is when the modulus value is within the bounds
2364 -- of the signed integer type of the argument. In this case we can
2365 -- just do the computation in that signed integer type, and then
2366 -- do an ordinary conversion to the target type.
2368 if Modv <= Expr_Value (Hi) then
2369 Rewrite (N,
2370 Convert_To (Btyp,
2371 Make_Op_Mod (Loc,
2372 Left_Opnd => Arg,
2373 Right_Opnd => Make_Integer_Literal (Loc, Modv))));
2375 -- Here we know that the modulus is larger than type'Last of the
2376 -- integer type. There are two cases to consider:
2378 -- a) The integer value is non-negative. In this case, it is
2379 -- returned as the result (since it is less than the modulus).
2381 -- b) The integer value is negative. In this case, we know that the
2382 -- result is modulus + value, where the value might be as small as
2383 -- -modulus. The trouble is what type do we use to do the subtract.
2384 -- No type will do, since modulus can be as big as 2**64, and no
2385 -- integer type accomodates this value. Let's do bit of algebra
2387 -- modulus + value
2388 -- = modulus - (-value)
2389 -- = (modulus - 1) - (-value - 1)
2391 -- Now modulus - 1 is certainly in range of the modular type.
2392 -- -value is in the range 1 .. modulus, so -value -1 is in the
2393 -- range 0 .. modulus-1 which is in range of the modular type.
2394 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
2395 -- which we can compute using the integer base type.
2397 -- Once this is done we analyze the conditional expression without
2398 -- range checks, because we know everything is in range, and we
2399 -- want to prevent spurious warnings on either branch.
2401 else
2402 Rewrite (N,
2403 Make_Conditional_Expression (Loc,
2404 Expressions => New_List (
2405 Make_Op_Ge (Loc,
2406 Left_Opnd => Duplicate_Subexpr (Arg),
2407 Right_Opnd => Make_Integer_Literal (Loc, 0)),
2409 Convert_To (Btyp,
2410 Duplicate_Subexpr_No_Checks (Arg)),
2412 Make_Op_Subtract (Loc,
2413 Left_Opnd =>
2414 Make_Integer_Literal (Loc,
2415 Intval => Modv - 1),
2416 Right_Opnd =>
2417 Convert_To (Btyp,
2418 Make_Op_Minus (Loc,
2419 Right_Opnd =>
2420 Make_Op_Add (Loc,
2421 Left_Opnd => Duplicate_Subexpr_No_Checks (Arg),
2422 Right_Opnd =>
2423 Make_Integer_Literal (Loc,
2424 Intval => 1))))))));
2426 end if;
2428 Analyze_And_Resolve (N, Btyp, All_Checks);
2429 end Mod_Case;
2431 -----------
2432 -- Model --
2433 -----------
2435 -- Transforms 'Model into a call to the floating-point attribute
2436 -- function Model in Fat_xxx (where xxx is the root type)
2438 when Attribute_Model =>
2439 Expand_Fpt_Attribute_R (N);
2441 -----------------
2442 -- Object_Size --
2443 -----------------
2445 -- The processing for Object_Size shares the processing for Size
2447 ------------
2448 -- Output --
2449 ------------
2451 when Attribute_Output => Output : declare
2452 P_Type : constant Entity_Id := Entity (Pref);
2453 U_Type : constant Entity_Id := Underlying_Type (P_Type);
2454 Pname : Entity_Id;
2455 Decl : Node_Id;
2456 Prag : Node_Id;
2457 Arg3 : Node_Id;
2458 Wfunc : Node_Id;
2460 begin
2461 -- If no underlying type, we have an error that will be diagnosed
2462 -- elsewhere, so here we just completely ignore the expansion.
2464 if No (U_Type) then
2465 return;
2466 end if;
2468 -- If TSS for Output is present, just call it
2470 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
2472 if Present (Pname) then
2473 null;
2475 else
2476 -- If there is a Stream_Convert pragma, use it, we rewrite
2478 -- sourcetyp'Output (stream, Item)
2480 -- as
2482 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
2484 -- where strmwrite is the given Write function that converts an
2485 -- argument of type sourcetyp or a type acctyp, from which it is
2486 -- derived to type strmtyp. The conversion to acttyp is required
2487 -- for the derived case.
2489 Prag := Get_Stream_Convert_Pragma (P_Type);
2491 if Present (Prag) then
2492 Arg3 :=
2493 Next (Next (First (Pragma_Argument_Associations (Prag))));
2494 Wfunc := Entity (Expression (Arg3));
2496 Rewrite (N,
2497 Make_Attribute_Reference (Loc,
2498 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
2499 Attribute_Name => Name_Output,
2500 Expressions => New_List (
2501 Relocate_Node (First (Exprs)),
2502 Make_Function_Call (Loc,
2503 Name => New_Occurrence_Of (Wfunc, Loc),
2504 Parameter_Associations => New_List (
2505 Convert_To (Etype (First_Formal (Wfunc)),
2506 Relocate_Node (Next (First (Exprs)))))))));
2508 Analyze (N);
2509 return;
2511 -- For elementary types, we call the W_xxx routine directly.
2512 -- Note that the effect of Write and Output is identical for
2513 -- the case of an elementary type, since there are no
2514 -- discriminants or bounds.
2516 elsif Is_Elementary_Type (U_Type) then
2518 -- A special case arises if we have a defined _Write routine,
2519 -- since in this case we are required to call this routine.
2521 if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then
2522 Build_Record_Or_Elementary_Output_Procedure
2523 (Loc, U_Type, Decl, Pname);
2524 Insert_Action (N, Decl);
2526 -- For normal cases, we call the W_xxx routine directly
2528 else
2529 Rewrite (N, Build_Elementary_Write_Call (N));
2530 Analyze (N);
2531 return;
2532 end if;
2534 -- Array type case
2536 elsif Is_Array_Type (U_Type) then
2537 Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
2538 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
2540 -- Class-wide case, first output external tag, then dispatch
2541 -- to the appropriate primitive Output function (RM 13.13.2(31)).
2543 elsif Is_Class_Wide_Type (P_Type) then
2544 Tag_Write : declare
2545 Strm : constant Node_Id := First (Exprs);
2546 Item : constant Node_Id := Next (Strm);
2548 begin
2549 -- The code is:
2550 -- if Get_Access_Level (Item'Tag)
2551 -- /= Get_Access_Level (P_Type'Tag)
2552 -- then
2553 -- raise Tag_Error;
2554 -- end if;
2555 -- String'Output (Strm, External_Tag (Item'Tag));
2557 -- Ada 2005 (AI-344): Check that the accessibility level
2558 -- of the type of the output object is not deeper than
2559 -- that of the attribute's prefix type.
2561 if Ada_Version >= Ada_05 then
2562 Insert_Action (N,
2563 Make_Implicit_If_Statement (N,
2564 Condition =>
2565 Make_Op_Ne (Loc,
2566 Left_Opnd =>
2567 Make_Function_Call (Loc,
2568 Name =>
2569 New_Reference_To
2570 (RTE (RE_Get_Access_Level), Loc),
2571 Parameter_Associations =>
2572 New_List (Make_Attribute_Reference (Loc,
2573 Prefix =>
2574 Relocate_Node (
2575 Duplicate_Subexpr (Item,
2576 Name_Req => True)),
2577 Attribute_Name =>
2578 Name_Tag))),
2579 Right_Opnd =>
2580 Make_Integer_Literal
2581 (Loc, Type_Access_Level (P_Type))),
2582 Then_Statements =>
2583 New_List (Make_Raise_Statement (Loc,
2584 New_Occurrence_Of (
2585 RTE (RE_Tag_Error), Loc)))));
2586 end if;
2588 Insert_Action (N,
2589 Make_Attribute_Reference (Loc,
2590 Prefix => New_Occurrence_Of (Standard_String, Loc),
2591 Attribute_Name => Name_Output,
2592 Expressions => New_List (
2593 Relocate_Node (Duplicate_Subexpr (Strm)),
2594 Make_Function_Call (Loc,
2595 Name =>
2596 New_Occurrence_Of (RTE (RE_External_Tag), Loc),
2597 Parameter_Associations => New_List (
2598 Make_Attribute_Reference (Loc,
2599 Prefix =>
2600 Relocate_Node
2601 (Duplicate_Subexpr (Item, Name_Req => True)),
2602 Attribute_Name => Name_Tag))))));
2603 end Tag_Write;
2605 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
2607 -- Tagged type case, use the primitive Output function
2609 elsif Is_Tagged_Type (U_Type) then
2610 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
2612 -- -- All other record type cases, including protected records.
2613 -- -- The latter only arise for expander generated code for
2614 -- -- handling shared passive partition access.
2616 else
2617 pragma Assert
2618 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
2620 -- Ada 2005 (AI-216): Program_Error is raised when executing
2621 -- the default implementation of the Output attribute of an
2622 -- unchecked union type if the type lacks default discriminant
2623 -- values.
2625 if Is_Unchecked_Union (Base_Type (U_Type))
2626 and then not Present (Discriminant_Constraint (U_Type))
2627 then
2628 Insert_Action (N,
2629 Make_Raise_Program_Error (Loc,
2630 Reason => PE_Unchecked_Union_Restriction));
2632 return;
2633 end if;
2635 Build_Record_Or_Elementary_Output_Procedure
2636 (Loc, Base_Type (U_Type), Decl, Pname);
2637 Insert_Action (N, Decl);
2638 end if;
2639 end if;
2641 -- If we fall through, Pname is the name of the procedure to call
2643 Rewrite_Stream_Proc_Call (Pname);
2644 end Output;
2646 ---------
2647 -- Pos --
2648 ---------
2650 -- For enumeration types with a standard representation, Pos is
2651 -- handled by Gigi.
2653 -- For enumeration types, with a non-standard representation we
2654 -- generate a call to the _Rep_To_Pos function created when the
2655 -- type was frozen. The call has the form
2657 -- _rep_to_pos (expr, flag)
2659 -- The parameter flag is True if range checks are enabled, causing
2660 -- Program_Error to be raised if the expression has an invalid
2661 -- representation, and False if range checks are suppressed.
2663 -- For integer types, Pos is equivalent to a simple integer
2664 -- conversion and we rewrite it as such
2666 when Attribute_Pos => Pos :
2667 declare
2668 Etyp : Entity_Id := Base_Type (Entity (Pref));
2670 begin
2671 -- Deal with zero/non-zero boolean values
2673 if Is_Boolean_Type (Etyp) then
2674 Adjust_Condition (First (Exprs));
2675 Etyp := Standard_Boolean;
2676 Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
2677 end if;
2679 -- Case of enumeration type
2681 if Is_Enumeration_Type (Etyp) then
2683 -- Non-standard enumeration type (generate call)
2685 if Present (Enum_Pos_To_Rep (Etyp)) then
2686 Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
2687 Rewrite (N,
2688 Convert_To (Typ,
2689 Make_Function_Call (Loc,
2690 Name =>
2691 New_Reference_To (TSS (Etyp, TSS_Rep_To_Pos), Loc),
2692 Parameter_Associations => Exprs)));
2694 Analyze_And_Resolve (N, Typ);
2696 -- Standard enumeration type (do universal integer check)
2698 else
2699 Apply_Universal_Integer_Attribute_Checks (N);
2700 end if;
2702 -- Deal with integer types (replace by conversion)
2704 elsif Is_Integer_Type (Etyp) then
2705 Rewrite (N, Convert_To (Typ, First (Exprs)));
2706 Analyze_And_Resolve (N, Typ);
2707 end if;
2709 end Pos;
2711 --------------
2712 -- Position --
2713 --------------
2715 -- We compute this if a component clause was present, otherwise
2716 -- we leave the computation up to Gigi, since we don't know what
2717 -- layout will be chosen.
2719 when Attribute_Position => Position :
2720 declare
2721 CE : constant Entity_Id := Entity (Selector_Name (Pref));
2723 begin
2724 if Present (Component_Clause (CE)) then
2725 Rewrite (N,
2726 Make_Integer_Literal (Loc,
2727 Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
2728 Analyze_And_Resolve (N, Typ);
2730 else
2731 Apply_Universal_Integer_Attribute_Checks (N);
2732 end if;
2733 end Position;
2735 ----------
2736 -- Pred --
2737 ----------
2739 -- 1. Deal with enumeration types with holes
2740 -- 2. For floating-point, generate call to attribute function
2741 -- 3. For other cases, deal with constraint checking
2743 when Attribute_Pred => Pred :
2744 declare
2745 Ptyp : constant Entity_Id := Base_Type (Etype (Pref));
2747 begin
2748 -- For enumeration types with non-standard representations, we
2749 -- expand typ'Pred (x) into
2751 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
2753 -- If the representation is contiguous, we compute instead
2754 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
2756 if Is_Enumeration_Type (Ptyp)
2757 and then Present (Enum_Pos_To_Rep (Ptyp))
2758 then
2759 if Has_Contiguous_Rep (Ptyp) then
2760 Rewrite (N,
2761 Unchecked_Convert_To (Ptyp,
2762 Make_Op_Add (Loc,
2763 Left_Opnd =>
2764 Make_Integer_Literal (Loc,
2765 Enumeration_Rep (First_Literal (Ptyp))),
2766 Right_Opnd =>
2767 Make_Function_Call (Loc,
2768 Name =>
2769 New_Reference_To
2770 (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
2772 Parameter_Associations =>
2773 New_List (
2774 Unchecked_Convert_To (Ptyp,
2775 Make_Op_Subtract (Loc,
2776 Left_Opnd =>
2777 Unchecked_Convert_To (Standard_Integer,
2778 Relocate_Node (First (Exprs))),
2779 Right_Opnd =>
2780 Make_Integer_Literal (Loc, 1))),
2781 Rep_To_Pos_Flag (Ptyp, Loc))))));
2783 else
2784 -- Add Boolean parameter True, to request program errror if
2785 -- we have a bad representation on our hands. If checks are
2786 -- suppressed, then add False instead
2788 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
2789 Rewrite (N,
2790 Make_Indexed_Component (Loc,
2791 Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
2792 Expressions => New_List (
2793 Make_Op_Subtract (Loc,
2794 Left_Opnd =>
2795 Make_Function_Call (Loc,
2796 Name =>
2797 New_Reference_To (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
2798 Parameter_Associations => Exprs),
2799 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
2800 end if;
2802 Analyze_And_Resolve (N, Typ);
2804 -- For floating-point, we transform 'Pred into a call to the Pred
2805 -- floating-point attribute function in Fat_xxx (xxx is root type)
2807 elsif Is_Floating_Point_Type (Ptyp) then
2808 Expand_Fpt_Attribute_R (N);
2809 Analyze_And_Resolve (N, Typ);
2811 -- For modular types, nothing to do (no overflow, since wraps)
2813 elsif Is_Modular_Integer_Type (Ptyp) then
2814 null;
2816 -- For other types, if range checking is enabled, we must generate
2817 -- a check if overflow checking is enabled.
2819 elsif not Overflow_Checks_Suppressed (Ptyp) then
2820 Expand_Pred_Succ (N);
2821 end if;
2823 end Pred;
2825 ------------------
2826 -- Range_Length --
2827 ------------------
2829 when Attribute_Range_Length => Range_Length : declare
2830 P_Type : constant Entity_Id := Etype (Pref);
2832 begin
2833 -- The only special processing required is for the case where
2834 -- Range_Length is applied to an enumeration type with holes.
2835 -- In this case we transform
2837 -- X'Range_Length
2839 -- to
2841 -- X'Pos (X'Last) - X'Pos (X'First) + 1
2843 -- So that the result reflects the proper Pos values instead
2844 -- of the underlying representations.
2846 if Is_Enumeration_Type (P_Type)
2847 and then Has_Non_Standard_Rep (P_Type)
2848 then
2849 Rewrite (N,
2850 Make_Op_Add (Loc,
2851 Left_Opnd =>
2852 Make_Op_Subtract (Loc,
2853 Left_Opnd =>
2854 Make_Attribute_Reference (Loc,
2855 Attribute_Name => Name_Pos,
2856 Prefix => New_Occurrence_Of (P_Type, Loc),
2857 Expressions => New_List (
2858 Make_Attribute_Reference (Loc,
2859 Attribute_Name => Name_Last,
2860 Prefix => New_Occurrence_Of (P_Type, Loc)))),
2862 Right_Opnd =>
2863 Make_Attribute_Reference (Loc,
2864 Attribute_Name => Name_Pos,
2865 Prefix => New_Occurrence_Of (P_Type, Loc),
2866 Expressions => New_List (
2867 Make_Attribute_Reference (Loc,
2868 Attribute_Name => Name_First,
2869 Prefix => New_Occurrence_Of (P_Type, Loc))))),
2871 Right_Opnd =>
2872 Make_Integer_Literal (Loc, 1)));
2874 Analyze_And_Resolve (N, Typ);
2876 -- For all other cases, attribute is handled by Gigi, but we need
2877 -- to deal with the case of the range check on a universal integer.
2879 else
2880 Apply_Universal_Integer_Attribute_Checks (N);
2881 end if;
2883 end Range_Length;
2885 ----------
2886 -- Read --
2887 ----------
2889 when Attribute_Read => Read : declare
2890 P_Type : constant Entity_Id := Entity (Pref);
2891 B_Type : constant Entity_Id := Base_Type (P_Type);
2892 U_Type : constant Entity_Id := Underlying_Type (P_Type);
2893 Pname : Entity_Id;
2894 Decl : Node_Id;
2895 Prag : Node_Id;
2896 Arg2 : Node_Id;
2897 Rfunc : Node_Id;
2898 Lhs : Node_Id;
2899 Rhs : Node_Id;
2901 begin
2902 -- If no underlying type, we have an error that will be diagnosed
2903 -- elsewhere, so here we just completely ignore the expansion.
2905 if No (U_Type) then
2906 return;
2907 end if;
2909 -- The simple case, if there is a TSS for Read, just call it
2911 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
2913 if Present (Pname) then
2914 null;
2916 else
2917 -- If there is a Stream_Convert pragma, use it, we rewrite
2919 -- sourcetyp'Read (stream, Item)
2921 -- as
2923 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
2925 -- where strmread is the given Read function that converts an
2926 -- argument of type strmtyp to type sourcetyp or a type from which
2927 -- it is derived. The conversion to sourcetyp is required in the
2928 -- latter case.
2930 -- A special case arises if Item is a type conversion in which
2931 -- case, we have to expand to:
2933 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
2935 -- where Itemx is the expression of the type conversion (i.e.
2936 -- the actual object), and typex is the type of Itemx.
2938 Prag := Get_Stream_Convert_Pragma (P_Type);
2940 if Present (Prag) then
2941 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
2942 Rfunc := Entity (Expression (Arg2));
2943 Lhs := Relocate_Node (Next (First (Exprs)));
2944 Rhs :=
2945 Convert_To (B_Type,
2946 Make_Function_Call (Loc,
2947 Name => New_Occurrence_Of (Rfunc, Loc),
2948 Parameter_Associations => New_List (
2949 Make_Attribute_Reference (Loc,
2950 Prefix =>
2951 New_Occurrence_Of
2952 (Etype (First_Formal (Rfunc)), Loc),
2953 Attribute_Name => Name_Input,
2954 Expressions => New_List (
2955 Relocate_Node (First (Exprs)))))));
2957 if Nkind (Lhs) = N_Type_Conversion then
2958 Lhs := Expression (Lhs);
2959 Rhs := Convert_To (Etype (Lhs), Rhs);
2960 end if;
2962 Rewrite (N,
2963 Make_Assignment_Statement (Loc,
2964 Name => Lhs,
2965 Expression => Rhs));
2966 Set_Assignment_OK (Lhs);
2967 Analyze (N);
2968 return;
2970 -- For elementary types, we call the I_xxx routine using the first
2971 -- parameter and then assign the result into the second parameter.
2972 -- We set Assignment_OK to deal with the conversion case.
2974 elsif Is_Elementary_Type (U_Type) then
2975 declare
2976 Lhs : Node_Id;
2977 Rhs : Node_Id;
2979 begin
2980 Lhs := Relocate_Node (Next (First (Exprs)));
2981 Rhs := Build_Elementary_Input_Call (N);
2983 if Nkind (Lhs) = N_Type_Conversion then
2984 Lhs := Expression (Lhs);
2985 Rhs := Convert_To (Etype (Lhs), Rhs);
2986 end if;
2988 Set_Assignment_OK (Lhs);
2990 Rewrite (N,
2991 Make_Assignment_Statement (Loc,
2992 Name => Lhs,
2993 Expression => Rhs));
2995 Analyze (N);
2996 return;
2997 end;
2999 -- Array type case
3001 elsif Is_Array_Type (U_Type) then
3002 Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
3003 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3005 -- Tagged type case, use the primitive Read function. Note that
3006 -- this will dispatch in the class-wide case which is what we want
3008 elsif Is_Tagged_Type (U_Type) then
3009 Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
3011 -- All other record type cases, including protected records. The
3012 -- latter only arise for expander generated code for handling
3013 -- shared passive partition access.
3015 else
3016 pragma Assert
3017 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
3019 -- Ada 2005 (AI-216): Program_Error is raised when executing
3020 -- the default implementation of the Read attribute of an
3021 -- Unchecked_Union type.
3023 if Is_Unchecked_Union (Base_Type (U_Type)) then
3024 Insert_Action (N,
3025 Make_Raise_Program_Error (Loc,
3026 Reason => PE_Unchecked_Union_Restriction));
3027 end if;
3029 if Has_Discriminants (U_Type)
3030 and then Present
3031 (Discriminant_Default_Value (First_Discriminant (U_Type)))
3032 then
3033 Build_Mutable_Record_Read_Procedure
3034 (Loc, Base_Type (U_Type), Decl, Pname);
3035 else
3036 Build_Record_Read_Procedure
3037 (Loc, Base_Type (U_Type), Decl, Pname);
3038 end if;
3040 -- Suppress checks, uninitialized or otherwise invalid
3041 -- data does not cause constraint errors to be raised for
3042 -- a complete record read.
3044 Insert_Action (N, Decl, All_Checks);
3045 end if;
3046 end if;
3048 Rewrite_Stream_Proc_Call (Pname);
3049 end Read;
3051 ---------------
3052 -- Remainder --
3053 ---------------
3055 -- Transforms 'Remainder into a call to the floating-point attribute
3056 -- function Remainder in Fat_xxx (where xxx is the root type)
3058 when Attribute_Remainder =>
3059 Expand_Fpt_Attribute_RR (N);
3061 -----------
3062 -- Round --
3063 -----------
3065 -- The handling of the Round attribute is quite delicate. The processing
3066 -- in Sem_Attr introduced a conversion to universal real, reflecting the
3067 -- semantics of Round, but we do not want anything to do with universal
3068 -- real at runtime, since this corresponds to using floating-point
3069 -- arithmetic.
3071 -- What we have now is that the Etype of the Round attribute correctly
3072 -- indicates the final result type. The operand of the Round is the
3073 -- conversion to universal real, described above, and the operand of
3074 -- this conversion is the actual operand of Round, which may be the
3075 -- special case of a fixed point multiplication or division (Etype =
3076 -- universal fixed)
3078 -- The exapander will expand first the operand of the conversion, then
3079 -- the conversion, and finally the round attribute itself, since we
3080 -- always work inside out. But we cannot simply process naively in this
3081 -- order. In the semantic world where universal fixed and real really
3082 -- exist and have infinite precision, there is no problem, but in the
3083 -- implementation world, where universal real is a floating-point type,
3084 -- we would get the wrong result.
3086 -- So the approach is as follows. First, when expanding a multiply or
3087 -- divide whose type is universal fixed, we do nothing at all, instead
3088 -- deferring the operation till later.
3090 -- The actual processing is done in Expand_N_Type_Conversion which
3091 -- handles the special case of Round by looking at its parent to see if
3092 -- it is a Round attribute, and if it is, handling the conversion (or
3093 -- its fixed multiply/divide child) in an appropriate manner.
3095 -- This means that by the time we get to expanding the Round attribute
3096 -- itself, the Round is nothing more than a type conversion (and will
3097 -- often be a null type conversion), so we just replace it with the
3098 -- appropriate conversion operation.
3100 when Attribute_Round =>
3101 Rewrite (N,
3102 Convert_To (Etype (N), Relocate_Node (First (Exprs))));
3103 Analyze_And_Resolve (N);
3105 --------------
3106 -- Rounding --
3107 --------------
3109 -- Transforms 'Rounding into a call to the floating-point attribute
3110 -- function Rounding in Fat_xxx (where xxx is the root type)
3112 when Attribute_Rounding =>
3113 Expand_Fpt_Attribute_R (N);
3115 -------------
3116 -- Scaling --
3117 -------------
3119 -- Transforms 'Scaling into a call to the floating-point attribute
3120 -- function Scaling in Fat_xxx (where xxx is the root type)
3122 when Attribute_Scaling =>
3123 Expand_Fpt_Attribute_RI (N);
3125 ----------
3126 -- Size --
3127 ----------
3129 when Attribute_Size |
3130 Attribute_Object_Size |
3131 Attribute_Value_Size |
3132 Attribute_VADS_Size => Size :
3134 declare
3135 Ptyp : constant Entity_Id := Etype (Pref);
3136 Siz : Uint;
3137 New_Node : Node_Id;
3139 begin
3140 -- Processing for VADS_Size case. Note that this processing removes
3141 -- all traces of VADS_Size from the tree, and completes all required
3142 -- processing for VADS_Size by translating the attribute reference
3143 -- to an appropriate Size or Object_Size reference.
3145 if Id = Attribute_VADS_Size
3146 or else (Use_VADS_Size and then Id = Attribute_Size)
3147 then
3148 -- If the size is specified, then we simply use the specified
3149 -- size. This applies to both types and objects. The size of an
3150 -- object can be specified in the following ways:
3152 -- An explicit size object is given for an object
3153 -- A component size is specified for an indexed component
3154 -- A component clause is specified for a selected component
3155 -- The object is a component of a packed composite object
3157 -- If the size is specified, then VADS_Size of an object
3159 if (Is_Entity_Name (Pref)
3160 and then Present (Size_Clause (Entity (Pref))))
3161 or else
3162 (Nkind (Pref) = N_Component_Clause
3163 and then (Present (Component_Clause
3164 (Entity (Selector_Name (Pref))))
3165 or else Is_Packed (Etype (Prefix (Pref)))))
3166 or else
3167 (Nkind (Pref) = N_Indexed_Component
3168 and then (Component_Size (Etype (Prefix (Pref))) /= 0
3169 or else Is_Packed (Etype (Prefix (Pref)))))
3170 then
3171 Set_Attribute_Name (N, Name_Size);
3173 -- Otherwise if we have an object rather than a type, then the
3174 -- VADS_Size attribute applies to the type of the object, rather
3175 -- than the object itself. This is one of the respects in which
3176 -- VADS_Size differs from Size.
3178 else
3179 if (not Is_Entity_Name (Pref)
3180 or else not Is_Type (Entity (Pref)))
3181 and then (Is_Scalar_Type (Etype (Pref))
3182 or else Is_Constrained (Etype (Pref)))
3183 then
3184 Rewrite (Pref, New_Occurrence_Of (Etype (Pref), Loc));
3185 end if;
3187 -- For a scalar type for which no size was explicitly given,
3188 -- VADS_Size means Object_Size. This is the other respect in
3189 -- which VADS_Size differs from Size.
3191 if Is_Scalar_Type (Etype (Pref))
3192 and then No (Size_Clause (Etype (Pref)))
3193 then
3194 Set_Attribute_Name (N, Name_Object_Size);
3196 -- In all other cases, Size and VADS_Size are the sane
3198 else
3199 Set_Attribute_Name (N, Name_Size);
3200 end if;
3201 end if;
3202 end if;
3204 -- For class-wide types, X'Class'Size is transformed into a
3205 -- direct reference to the Size of the class type, so that gigi
3206 -- does not have to deal with the X'Class'Size reference.
3208 if Is_Entity_Name (Pref)
3209 and then Is_Class_Wide_Type (Entity (Pref))
3210 then
3211 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
3212 return;
3214 -- For x'Size applied to an object of a class-wide type, transform
3215 -- X'Size into a call to the primitive operation _Size applied to X.
3217 elsif Is_Class_Wide_Type (Ptyp) then
3218 New_Node :=
3219 Make_Function_Call (Loc,
3220 Name => New_Reference_To
3221 (Find_Prim_Op (Ptyp, Name_uSize), Loc),
3222 Parameter_Associations => New_List (Pref));
3224 if Typ /= Standard_Long_Long_Integer then
3226 -- The context is a specific integer type with which the
3227 -- original attribute was compatible. The function has a
3228 -- specific type as well, so to preserve the compatibility
3229 -- we must convert explicitly.
3231 New_Node := Convert_To (Typ, New_Node);
3232 end if;
3234 Rewrite (N, New_Node);
3235 Analyze_And_Resolve (N, Typ);
3236 return;
3238 -- For an array component, we can do Size in the front end
3239 -- if the component_size of the array is set.
3241 elsif Nkind (Pref) = N_Indexed_Component then
3242 Siz := Component_Size (Etype (Prefix (Pref)));
3244 -- For a record component, we can do Size in the front end if there
3245 -- is a component clause, or if the record is packed and the
3246 -- component's size is known at compile time.
3248 elsif Nkind (Pref) = N_Selected_Component then
3249 declare
3250 Rec : constant Entity_Id := Etype (Prefix (Pref));
3251 Comp : constant Entity_Id := Entity (Selector_Name (Pref));
3253 begin
3254 if Present (Component_Clause (Comp)) then
3255 Siz := Esize (Comp);
3257 elsif Is_Packed (Rec) then
3258 Siz := RM_Size (Ptyp);
3260 else
3261 Apply_Universal_Integer_Attribute_Checks (N);
3262 return;
3263 end if;
3264 end;
3266 -- All other cases are handled by Gigi
3268 else
3269 Apply_Universal_Integer_Attribute_Checks (N);
3271 -- If we have Size applied to a formal parameter, that is a
3272 -- packed array subtype, then apply size to the actual subtype.
3274 if Is_Entity_Name (Pref)
3275 and then Is_Formal (Entity (Pref))
3276 and then Is_Array_Type (Etype (Pref))
3277 and then Is_Packed (Etype (Pref))
3278 then
3279 Rewrite (N,
3280 Make_Attribute_Reference (Loc,
3281 Prefix =>
3282 New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
3283 Attribute_Name => Name_Size));
3284 Analyze_And_Resolve (N, Typ);
3285 end if;
3287 return;
3288 end if;
3290 -- Common processing for record and array component case
3292 if Siz /= 0 then
3293 Rewrite (N, Make_Integer_Literal (Loc, Siz));
3295 Analyze_And_Resolve (N, Typ);
3297 -- The result is not a static expression
3299 Set_Is_Static_Expression (N, False);
3300 end if;
3301 end Size;
3303 ------------------
3304 -- Storage_Pool --
3305 ------------------
3307 when Attribute_Storage_Pool =>
3308 Rewrite (N,
3309 Make_Type_Conversion (Loc,
3310 Subtype_Mark => New_Reference_To (Etype (N), Loc),
3311 Expression => New_Reference_To (Entity (N), Loc)));
3312 Analyze_And_Resolve (N, Typ);
3314 ------------------
3315 -- Storage_Size --
3316 ------------------
3318 when Attribute_Storage_Size => Storage_Size :
3319 declare
3320 Ptyp : constant Entity_Id := Etype (Pref);
3322 begin
3323 -- Access type case, always go to the root type
3325 -- The case of access types results in a value of zero for the case
3326 -- where no storage size attribute clause has been given. If a
3327 -- storage size has been given, then the attribute is converted
3328 -- to a reference to the variable used to hold this value.
3330 if Is_Access_Type (Ptyp) then
3331 if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
3332 Rewrite (N,
3333 Make_Attribute_Reference (Loc,
3334 Prefix => New_Reference_To (Typ, Loc),
3335 Attribute_Name => Name_Max,
3336 Expressions => New_List (
3337 Make_Integer_Literal (Loc, 0),
3338 Convert_To (Typ,
3339 New_Reference_To
3340 (Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
3342 elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
3343 Rewrite (N,
3344 OK_Convert_To (Typ,
3345 Make_Function_Call (Loc,
3346 Name =>
3347 New_Reference_To
3348 (Find_Prim_Op
3349 (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
3350 Attribute_Name (N)),
3351 Loc),
3353 Parameter_Associations => New_List (New_Reference_To (
3354 Associated_Storage_Pool (Root_Type (Ptyp)), Loc)))));
3355 else
3356 Rewrite (N, Make_Integer_Literal (Loc, 0));
3357 end if;
3359 Analyze_And_Resolve (N, Typ);
3361 -- The case of a task type (an obsolescent feature) is handled the
3362 -- same way, seems as reasonable as anything, and it is what the
3363 -- ACVC tests (e.g. CD1009K) seem to expect.
3365 -- If there is no Storage_Size variable, then we return the default
3366 -- task stack size, otherwise, expand a Storage_Size attribute as
3367 -- follows:
3369 -- Typ (Adjust_Storage_Size (taskZ))
3371 -- except for the case of a task object which has a Storage_Size
3372 -- pragma:
3374 -- Typ (Adjust_Storage_Size (taskV!(name)._Size))
3376 else
3377 if not Present (Storage_Size_Variable (Ptyp)) then
3378 Rewrite (N,
3379 Convert_To (Typ,
3380 Make_Function_Call (Loc,
3381 Name =>
3382 New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc))));
3384 else
3385 if not (Is_Entity_Name (Pref) and then
3386 Is_Task_Type (Entity (Pref))) and then
3387 Chars (Last_Entity (Corresponding_Record_Type (Ptyp))) =
3388 Name_uSize
3389 then
3390 Rewrite (N,
3391 Convert_To (Typ,
3392 Make_Function_Call (Loc,
3393 Name => New_Occurrence_Of (
3394 RTE (RE_Adjust_Storage_Size), Loc),
3395 Parameter_Associations =>
3396 New_List (
3397 Make_Selected_Component (Loc,
3398 Prefix =>
3399 Unchecked_Convert_To (
3400 Corresponding_Record_Type (Ptyp),
3401 New_Copy_Tree (Pref)),
3402 Selector_Name =>
3403 Make_Identifier (Loc, Name_uSize))))));
3405 -- Task not having Storage_Size pragma
3407 else
3408 Rewrite (N,
3409 Convert_To (Typ,
3410 Make_Function_Call (Loc,
3411 Name => New_Occurrence_Of (
3412 RTE (RE_Adjust_Storage_Size), Loc),
3413 Parameter_Associations =>
3414 New_List (
3415 New_Reference_To (
3416 Storage_Size_Variable (Ptyp), Loc)))));
3417 end if;
3419 Analyze_And_Resolve (N, Typ);
3420 end if;
3421 end if;
3422 end Storage_Size;
3424 -----------------
3425 -- Stream_Size --
3426 -----------------
3428 when Attribute_Stream_Size => Stream_Size : declare
3429 Ptyp : constant Entity_Id := Etype (Pref);
3430 Size : Int;
3432 begin
3433 -- If we have a Stream_Size clause for this type use it, otherwise
3434 -- the Stream_Size if the size of the type.
3436 if Has_Stream_Size_Clause (Ptyp) then
3437 Size := UI_To_Int
3438 (Static_Integer (Expression (Stream_Size_Clause (Ptyp))));
3439 else
3440 Size := UI_To_Int (Esize (Ptyp));
3441 end if;
3443 Rewrite (N, Make_Integer_Literal (Loc, Intval => Size));
3444 Analyze_And_Resolve (N, Typ);
3445 end Stream_Size;
3447 ----------
3448 -- Succ --
3449 ----------
3451 -- 1. Deal with enumeration types with holes
3452 -- 2. For floating-point, generate call to attribute function
3453 -- 3. For other cases, deal with constraint checking
3455 when Attribute_Succ => Succ :
3456 declare
3457 Ptyp : constant Entity_Id := Base_Type (Etype (Pref));
3459 begin
3460 -- For enumeration types with non-standard representations, we
3461 -- expand typ'Succ (x) into
3463 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
3465 -- If the representation is contiguous, we compute instead
3466 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
3468 if Is_Enumeration_Type (Ptyp)
3469 and then Present (Enum_Pos_To_Rep (Ptyp))
3470 then
3471 if Has_Contiguous_Rep (Ptyp) then
3472 Rewrite (N,
3473 Unchecked_Convert_To (Ptyp,
3474 Make_Op_Add (Loc,
3475 Left_Opnd =>
3476 Make_Integer_Literal (Loc,
3477 Enumeration_Rep (First_Literal (Ptyp))),
3478 Right_Opnd =>
3479 Make_Function_Call (Loc,
3480 Name =>
3481 New_Reference_To
3482 (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
3484 Parameter_Associations =>
3485 New_List (
3486 Unchecked_Convert_To (Ptyp,
3487 Make_Op_Add (Loc,
3488 Left_Opnd =>
3489 Unchecked_Convert_To (Standard_Integer,
3490 Relocate_Node (First (Exprs))),
3491 Right_Opnd =>
3492 Make_Integer_Literal (Loc, 1))),
3493 Rep_To_Pos_Flag (Ptyp, Loc))))));
3494 else
3495 -- Add Boolean parameter True, to request program errror if
3496 -- we have a bad representation on our hands. Add False if
3497 -- checks are suppressed.
3499 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
3500 Rewrite (N,
3501 Make_Indexed_Component (Loc,
3502 Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
3503 Expressions => New_List (
3504 Make_Op_Add (Loc,
3505 Left_Opnd =>
3506 Make_Function_Call (Loc,
3507 Name =>
3508 New_Reference_To
3509 (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
3510 Parameter_Associations => Exprs),
3511 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
3512 end if;
3514 Analyze_And_Resolve (N, Typ);
3516 -- For floating-point, we transform 'Succ into a call to the Succ
3517 -- floating-point attribute function in Fat_xxx (xxx is root type)
3519 elsif Is_Floating_Point_Type (Ptyp) then
3520 Expand_Fpt_Attribute_R (N);
3521 Analyze_And_Resolve (N, Typ);
3523 -- For modular types, nothing to do (no overflow, since wraps)
3525 elsif Is_Modular_Integer_Type (Ptyp) then
3526 null;
3528 -- For other types, if range checking is enabled, we must generate
3529 -- a check if overflow checking is enabled.
3531 elsif not Overflow_Checks_Suppressed (Ptyp) then
3532 Expand_Pred_Succ (N);
3533 end if;
3534 end Succ;
3536 ---------
3537 -- Tag --
3538 ---------
3540 -- Transforms X'Tag into a direct reference to the tag of X
3542 when Attribute_Tag => Tag :
3543 declare
3544 Ttyp : Entity_Id;
3545 Prefix_Is_Type : Boolean;
3547 begin
3548 if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then
3549 Ttyp := Entity (Pref);
3550 Prefix_Is_Type := True;
3551 else
3552 Ttyp := Etype (Pref);
3553 Prefix_Is_Type := False;
3554 end if;
3556 if Is_Class_Wide_Type (Ttyp) then
3557 Ttyp := Root_Type (Ttyp);
3558 end if;
3560 Ttyp := Underlying_Type (Ttyp);
3562 if Prefix_Is_Type then
3564 -- For JGNAT we leave the type attribute unexpanded because
3565 -- there's not a dispatching table to reference.
3567 if not Java_VM then
3568 Rewrite (N,
3569 Unchecked_Convert_To (RTE (RE_Tag),
3570 New_Reference_To
3571 (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc)));
3572 Analyze_And_Resolve (N, RTE (RE_Tag));
3573 end if;
3575 else
3576 Rewrite (N,
3577 Make_Selected_Component (Loc,
3578 Prefix => Relocate_Node (Pref),
3579 Selector_Name =>
3580 New_Reference_To (First_Tag_Component (Ttyp), Loc)));
3581 Analyze_And_Resolve (N, RTE (RE_Tag));
3582 end if;
3583 end Tag;
3585 ----------------
3586 -- Terminated --
3587 ----------------
3589 -- Transforms 'Terminated attribute into a call to Terminated function
3591 when Attribute_Terminated => Terminated :
3592 begin
3593 if Restricted_Profile then
3594 Rewrite (N,
3595 Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
3597 else
3598 Rewrite (N,
3599 Build_Call_With_Task (Pref, RTE (RE_Terminated)));
3600 end if;
3602 Analyze_And_Resolve (N, Standard_Boolean);
3603 end Terminated;
3605 ----------------
3606 -- To_Address --
3607 ----------------
3609 -- Transforms System'To_Address (X) into unchecked conversion
3610 -- from (integral) type of X to type address.
3612 when Attribute_To_Address =>
3613 Rewrite (N,
3614 Unchecked_Convert_To (RTE (RE_Address),
3615 Relocate_Node (First (Exprs))));
3616 Analyze_And_Resolve (N, RTE (RE_Address));
3618 ----------------
3619 -- Truncation --
3620 ----------------
3622 -- Transforms 'Truncation into a call to the floating-point attribute
3623 -- function Truncation in Fat_xxx (where xxx is the root type)
3625 when Attribute_Truncation =>
3626 Expand_Fpt_Attribute_R (N);
3628 -----------------------
3629 -- Unbiased_Rounding --
3630 -----------------------
3632 -- Transforms 'Unbiased_Rounding into a call to the floating-point
3633 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
3634 -- root type)
3636 when Attribute_Unbiased_Rounding =>
3637 Expand_Fpt_Attribute_R (N);
3639 ----------------------
3640 -- Unchecked_Access --
3641 ----------------------
3643 when Attribute_Unchecked_Access =>
3644 Expand_Access_To_Type (N);
3646 -----------------
3647 -- UET_Address --
3648 -----------------
3650 when Attribute_UET_Address => UET_Address : declare
3651 Ent : constant Entity_Id :=
3652 Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
3654 begin
3655 Insert_Action (N,
3656 Make_Object_Declaration (Loc,
3657 Defining_Identifier => Ent,
3658 Aliased_Present => True,
3659 Object_Definition =>
3660 New_Occurrence_Of (RTE (RE_Address), Loc)));
3662 -- Construct name __gnat_xxx__SDP, where xxx is the unit name
3663 -- in normal external form.
3665 Get_External_Unit_Name_String (Get_Unit_Name (Pref));
3666 Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
3667 Name_Len := Name_Len + 7;
3668 Name_Buffer (1 .. 7) := "__gnat_";
3669 Name_Buffer (Name_Len + 1 .. Name_Len + 5) := "__SDP";
3670 Name_Len := Name_Len + 5;
3672 Set_Is_Imported (Ent);
3673 Set_Interface_Name (Ent,
3674 Make_String_Literal (Loc,
3675 Strval => String_From_Name_Buffer));
3677 Rewrite (N,
3678 Make_Attribute_Reference (Loc,
3679 Prefix => New_Occurrence_Of (Ent, Loc),
3680 Attribute_Name => Name_Address));
3682 Analyze_And_Resolve (N, Typ);
3683 end UET_Address;
3685 -------------------------
3686 -- Unrestricted_Access --
3687 -------------------------
3689 when Attribute_Unrestricted_Access =>
3690 Expand_Access_To_Type (N);
3692 ---------------
3693 -- VADS_Size --
3694 ---------------
3696 -- The processing for VADS_Size is shared with Size
3698 ---------
3699 -- Val --
3700 ---------
3702 -- For enumeration types with a standard representation, and for all
3703 -- other types, Val is handled by Gigi. For enumeration types with
3704 -- a non-standard representation we use the _Pos_To_Rep array that
3705 -- was created when the type was frozen.
3707 when Attribute_Val => Val :
3708 declare
3709 Etyp : constant Entity_Id := Base_Type (Entity (Pref));
3711 begin
3712 if Is_Enumeration_Type (Etyp)
3713 and then Present (Enum_Pos_To_Rep (Etyp))
3714 then
3715 if Has_Contiguous_Rep (Etyp) then
3716 declare
3717 Rep_Node : constant Node_Id :=
3718 Unchecked_Convert_To (Etyp,
3719 Make_Op_Add (Loc,
3720 Left_Opnd =>
3721 Make_Integer_Literal (Loc,
3722 Enumeration_Rep (First_Literal (Etyp))),
3723 Right_Opnd =>
3724 (Convert_To (Standard_Integer,
3725 Relocate_Node (First (Exprs))))));
3727 begin
3728 Rewrite (N,
3729 Unchecked_Convert_To (Etyp,
3730 Make_Op_Add (Loc,
3731 Left_Opnd =>
3732 Make_Integer_Literal (Loc,
3733 Enumeration_Rep (First_Literal (Etyp))),
3734 Right_Opnd =>
3735 Make_Function_Call (Loc,
3736 Name =>
3737 New_Reference_To
3738 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
3739 Parameter_Associations => New_List (
3740 Rep_Node,
3741 Rep_To_Pos_Flag (Etyp, Loc))))));
3742 end;
3744 else
3745 Rewrite (N,
3746 Make_Indexed_Component (Loc,
3747 Prefix => New_Reference_To (Enum_Pos_To_Rep (Etyp), Loc),
3748 Expressions => New_List (
3749 Convert_To (Standard_Integer,
3750 Relocate_Node (First (Exprs))))));
3751 end if;
3753 Analyze_And_Resolve (N, Typ);
3754 end if;
3755 end Val;
3757 -----------
3758 -- Valid --
3759 -----------
3761 -- The code for valid is dependent on the particular types involved.
3762 -- See separate sections below for the generated code in each case.
3764 when Attribute_Valid => Valid :
3765 declare
3766 Ptyp : constant Entity_Id := Etype (Pref);
3767 Btyp : Entity_Id := Base_Type (Ptyp);
3768 Tst : Node_Id;
3770 Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
3771 -- Save the validity checking mode. We always turn off validity
3772 -- checking during process of 'Valid since this is one place
3773 -- where we do not want the implicit validity checks to intefere
3774 -- with the explicit validity check that the programmer is doing.
3776 function Make_Range_Test return Node_Id;
3777 -- Build the code for a range test of the form
3778 -- Btyp!(Pref) >= Btyp!(Ptyp'First)
3779 -- and then
3780 -- Btyp!(Pref) <= Btyp!(Ptyp'Last)
3782 ---------------------
3783 -- Make_Range_Test --
3784 ---------------------
3786 function Make_Range_Test return Node_Id is
3787 begin
3788 return
3789 Make_And_Then (Loc,
3790 Left_Opnd =>
3791 Make_Op_Ge (Loc,
3792 Left_Opnd =>
3793 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
3795 Right_Opnd =>
3796 Unchecked_Convert_To (Btyp,
3797 Make_Attribute_Reference (Loc,
3798 Prefix => New_Occurrence_Of (Ptyp, Loc),
3799 Attribute_Name => Name_First))),
3801 Right_Opnd =>
3802 Make_Op_Le (Loc,
3803 Left_Opnd =>
3804 Unchecked_Convert_To (Btyp,
3805 Duplicate_Subexpr_No_Checks (Pref)),
3807 Right_Opnd =>
3808 Unchecked_Convert_To (Btyp,
3809 Make_Attribute_Reference (Loc,
3810 Prefix => New_Occurrence_Of (Ptyp, Loc),
3811 Attribute_Name => Name_Last))));
3812 end Make_Range_Test;
3814 -- Start of processing for Attribute_Valid
3816 begin
3817 -- Turn off validity checks. We do not want any implicit validity
3818 -- checks to intefere with the explicit check from the attribute
3820 Validity_Checks_On := False;
3822 -- Floating-point case. This case is handled by the Valid attribute
3823 -- code in the floating-point attribute run-time library.
3825 if Is_Floating_Point_Type (Ptyp) then
3826 declare
3827 Rtp : constant Entity_Id := Root_Type (Etype (Pref));
3829 begin
3830 -- For vax fpt types, call appropriate routine in special vax
3831 -- floating point unit. We do not have to worry about loads in
3832 -- this case, since these types have no signalling NaN's.
3834 if Vax_Float (Rtp) then
3835 Expand_Vax_Valid (N);
3837 -- If the floating-point object might be unaligned, we need
3838 -- to call the special routine Unaligned_Valid, which makes
3839 -- the needed copy, being careful not to load the value into
3840 -- any floating-point register. The argument in this case is
3841 -- obj'Address (see Unchecked_Valid routine in s-fatgen.ads).
3843 elsif Is_Possibly_Unaligned_Object (Pref) then
3844 Set_Attribute_Name (N, Name_Unaligned_Valid);
3845 Expand_Fpt_Attribute
3846 (N, Rtp, Name_Unaligned_Valid,
3847 New_List (
3848 Make_Attribute_Reference (Loc,
3849 Prefix => Relocate_Node (Pref),
3850 Attribute_Name => Name_Address)));
3852 -- In the normal case where we are sure the object is aligned,
3853 -- we generate a call to Valid, and the argument in this case
3854 -- is obj'Unrestricted_Access (after converting obj to the
3855 -- right floating-point type).
3857 else
3858 Expand_Fpt_Attribute
3859 (N, Rtp, Name_Valid,
3860 New_List (
3861 Make_Attribute_Reference (Loc,
3862 Prefix => Unchecked_Convert_To (Rtp, Pref),
3863 Attribute_Name => Name_Unrestricted_Access)));
3864 end if;
3866 -- One more task, we still need a range check. Required
3867 -- only if we have a constraint, since the Valid routine
3868 -- catches infinities properly (infinities are never valid).
3870 -- The way we do the range check is simply to create the
3871 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
3873 if not Subtypes_Statically_Match (Ptyp, Btyp) then
3874 Rewrite (N,
3875 Make_And_Then (Loc,
3876 Left_Opnd => Relocate_Node (N),
3877 Right_Opnd =>
3878 Make_In (Loc,
3879 Left_Opnd => Convert_To (Btyp, Pref),
3880 Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
3881 end if;
3882 end;
3884 -- Enumeration type with holes
3886 -- For enumeration types with holes, the Pos value constructed by
3887 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
3888 -- second argument of False returns minus one for an invalid value,
3889 -- and the non-negative pos value for a valid value, so the
3890 -- expansion of X'Valid is simply:
3892 -- type(X)'Pos (X) >= 0
3894 -- We can't quite generate it that way because of the requirement
3895 -- for the non-standard second argument of False in the resulting
3896 -- rep_to_pos call, so we have to explicitly create:
3898 -- _rep_to_pos (X, False) >= 0
3900 -- If we have an enumeration subtype, we also check that the
3901 -- value is in range:
3903 -- _rep_to_pos (X, False) >= 0
3904 -- and then
3905 -- (X >= type(X)'First and then type(X)'Last <= X)
3907 elsif Is_Enumeration_Type (Ptyp)
3908 and then Present (Enum_Pos_To_Rep (Base_Type (Ptyp)))
3909 then
3910 Tst :=
3911 Make_Op_Ge (Loc,
3912 Left_Opnd =>
3913 Make_Function_Call (Loc,
3914 Name =>
3915 New_Reference_To
3916 (TSS (Base_Type (Ptyp), TSS_Rep_To_Pos), Loc),
3917 Parameter_Associations => New_List (
3918 Pref,
3919 New_Occurrence_Of (Standard_False, Loc))),
3920 Right_Opnd => Make_Integer_Literal (Loc, 0));
3922 if Ptyp /= Btyp
3923 and then
3924 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
3925 or else
3926 Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
3927 then
3928 -- The call to Make_Range_Test will create declarations
3929 -- that need a proper insertion point, but Pref is now
3930 -- attached to a node with no ancestor. Attach to tree
3931 -- even if it is to be rewritten below.
3933 Set_Parent (Tst, Parent (N));
3935 Tst :=
3936 Make_And_Then (Loc,
3937 Left_Opnd => Make_Range_Test,
3938 Right_Opnd => Tst);
3939 end if;
3941 Rewrite (N, Tst);
3943 -- Fortran convention booleans
3945 -- For the very special case of Fortran convention booleans, the
3946 -- value is always valid, since it is an integer with the semantics
3947 -- that non-zero is true, and any value is permissible.
3949 elsif Is_Boolean_Type (Ptyp)
3950 and then Convention (Ptyp) = Convention_Fortran
3951 then
3952 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
3954 -- For biased representations, we will be doing an unchecked
3955 -- conversion without unbiasing the result. That means that the range
3956 -- test has to take this into account, and the proper form of the
3957 -- test is:
3959 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
3961 elsif Has_Biased_Representation (Ptyp) then
3962 Btyp := RTE (RE_Unsigned_32);
3963 Rewrite (N,
3964 Make_Op_Lt (Loc,
3965 Left_Opnd =>
3966 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
3967 Right_Opnd =>
3968 Unchecked_Convert_To (Btyp,
3969 Make_Attribute_Reference (Loc,
3970 Prefix => New_Occurrence_Of (Ptyp, Loc),
3971 Attribute_Name => Name_Range_Length))));
3973 -- For all other scalar types, what we want logically is a
3974 -- range test:
3976 -- X in type(X)'First .. type(X)'Last
3978 -- But that's precisely what won't work because of possible
3979 -- unwanted optimization (and indeed the basic motivation for
3980 -- the Valid attribute is exactly that this test does not work!)
3981 -- What will work is:
3983 -- Btyp!(X) >= Btyp!(type(X)'First)
3984 -- and then
3985 -- Btyp!(X) <= Btyp!(type(X)'Last)
3987 -- where Btyp is an integer type large enough to cover the full
3988 -- range of possible stored values (i.e. it is chosen on the basis
3989 -- of the size of the type, not the range of the values). We write
3990 -- this as two tests, rather than a range check, so that static
3991 -- evaluation will easily remove either or both of the checks if
3992 -- they can be -statically determined to be true (this happens
3993 -- when the type of X is static and the range extends to the full
3994 -- range of stored values).
3996 -- Unsigned types. Note: it is safe to consider only whether the
3997 -- subtype is unsigned, since we will in that case be doing all
3998 -- unsigned comparisons based on the subtype range. Since we use the
3999 -- actual subtype object size, this is appropriate.
4001 -- For example, if we have
4003 -- subtype x is integer range 1 .. 200;
4004 -- for x'Object_Size use 8;
4006 -- Now the base type is signed, but objects of this type are bits
4007 -- unsigned, and doing an unsigned test of the range 1 to 200 is
4008 -- correct, even though a value greater than 127 looks signed to a
4009 -- signed comparison.
4011 elsif Is_Unsigned_Type (Ptyp) then
4012 if Esize (Ptyp) <= 32 then
4013 Btyp := RTE (RE_Unsigned_32);
4014 else
4015 Btyp := RTE (RE_Unsigned_64);
4016 end if;
4018 Rewrite (N, Make_Range_Test);
4020 -- Signed types
4022 else
4023 if Esize (Ptyp) <= Esize (Standard_Integer) then
4024 Btyp := Standard_Integer;
4025 else
4026 Btyp := Universal_Integer;
4027 end if;
4029 Rewrite (N, Make_Range_Test);
4030 end if;
4032 Analyze_And_Resolve (N, Standard_Boolean);
4033 Validity_Checks_On := Save_Validity_Checks_On;
4034 end Valid;
4036 -----------
4037 -- Value --
4038 -----------
4040 -- Value attribute is handled in separate unti Exp_Imgv
4042 when Attribute_Value =>
4043 Exp_Imgv.Expand_Value_Attribute (N);
4045 -----------------
4046 -- Value_Size --
4047 -----------------
4049 -- The processing for Value_Size shares the processing for Size
4051 -------------
4052 -- Version --
4053 -------------
4055 -- The processing for Version shares the processing for Body_Version
4057 ----------------
4058 -- Wide_Image --
4059 ----------------
4061 -- We expand typ'Wide_Image (X) into
4063 -- String_To_Wide_String
4064 -- (typ'Image (X), Wide_Character_Encoding_Method)
4066 -- This works in all cases because String_To_Wide_String converts any
4067 -- wide character escape sequences resulting from the Image call to the
4068 -- proper Wide_Character equivalent
4070 -- not quite right for typ = Wide_Character ???
4072 when Attribute_Wide_Image => Wide_Image :
4073 begin
4074 Rewrite (N,
4075 Make_Function_Call (Loc,
4076 Name => New_Reference_To (RTE (RE_String_To_Wide_String), Loc),
4077 Parameter_Associations => New_List (
4078 Make_Attribute_Reference (Loc,
4079 Prefix => Pref,
4080 Attribute_Name => Name_Image,
4081 Expressions => Exprs),
4083 Make_Integer_Literal (Loc,
4084 Intval => Int (Wide_Character_Encoding_Method)))));
4086 Analyze_And_Resolve (N, Standard_Wide_String);
4087 end Wide_Image;
4089 ---------------------
4090 -- Wide_Wide_Image --
4091 ---------------------
4093 -- We expand typ'Wide_Wide_Image (X) into
4095 -- String_To_Wide_Wide_String
4096 -- (typ'Image (X), Wide_Character_Encoding_Method)
4098 -- This works in all cases because String_To_Wide_Wide_String converts
4099 -- any wide character escape sequences resulting from the Image call to
4100 -- the proper Wide_Character equivalent
4102 -- not quite right for typ = Wide_Wide_Character ???
4104 when Attribute_Wide_Wide_Image => Wide_Wide_Image :
4105 begin
4106 Rewrite (N,
4107 Make_Function_Call (Loc,
4108 Name => New_Reference_To
4109 (RTE (RE_String_To_Wide_Wide_String), Loc),
4110 Parameter_Associations => New_List (
4111 Make_Attribute_Reference (Loc,
4112 Prefix => Pref,
4113 Attribute_Name => Name_Image,
4114 Expressions => Exprs),
4116 Make_Integer_Literal (Loc,
4117 Intval => Int (Wide_Character_Encoding_Method)))));
4119 Analyze_And_Resolve (N, Standard_Wide_Wide_String);
4120 end Wide_Wide_Image;
4122 ----------------
4123 -- Wide_Value --
4124 ----------------
4126 -- We expand typ'Wide_Value (X) into
4128 -- typ'Value
4129 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
4131 -- Wide_String_To_String is a runtime function that converts its wide
4132 -- string argument to String, converting any non-translatable characters
4133 -- into appropriate escape sequences. This preserves the required
4134 -- semantics of Wide_Value in all cases, and results in a very simple
4135 -- implementation approach.
4137 -- It's not quite right where typ = Wide_Character, because the encoding
4138 -- method may not cover the whole character type ???
4140 when Attribute_Wide_Value => Wide_Value :
4141 begin
4142 Rewrite (N,
4143 Make_Attribute_Reference (Loc,
4144 Prefix => Pref,
4145 Attribute_Name => Name_Value,
4147 Expressions => New_List (
4148 Make_Function_Call (Loc,
4149 Name =>
4150 New_Reference_To (RTE (RE_Wide_String_To_String), Loc),
4152 Parameter_Associations => New_List (
4153 Relocate_Node (First (Exprs)),
4154 Make_Integer_Literal (Loc,
4155 Intval => Int (Wide_Character_Encoding_Method)))))));
4157 Analyze_And_Resolve (N, Typ);
4158 end Wide_Value;
4160 ---------------------
4161 -- Wide_Wide_Value --
4162 ---------------------
4164 -- We expand typ'Wide_Value_Value (X) into
4166 -- typ'Value
4167 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
4169 -- Wide_Wide_String_To_String is a runtime function that converts its
4170 -- wide string argument to String, converting any non-translatable
4171 -- characters into appropriate escape sequences. This preserves the
4172 -- required semantics of Wide_Wide_Value in all cases, and results in a
4173 -- very simple implementation approach.
4175 -- It's not quite right where typ = Wide_Wide_Character, because the
4176 -- encoding method may not cover the whole character type ???
4178 when Attribute_Wide_Wide_Value => Wide_Wide_Value :
4179 begin
4180 Rewrite (N,
4181 Make_Attribute_Reference (Loc,
4182 Prefix => Pref,
4183 Attribute_Name => Name_Value,
4185 Expressions => New_List (
4186 Make_Function_Call (Loc,
4187 Name =>
4188 New_Reference_To (RTE (RE_Wide_Wide_String_To_String), Loc),
4190 Parameter_Associations => New_List (
4191 Relocate_Node (First (Exprs)),
4192 Make_Integer_Literal (Loc,
4193 Intval => Int (Wide_Character_Encoding_Method)))))));
4195 Analyze_And_Resolve (N, Typ);
4196 end Wide_Wide_Value;
4198 ---------------------
4199 -- Wide_Wide_Width --
4200 ---------------------
4202 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
4204 when Attribute_Wide_Wide_Width =>
4205 Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide);
4207 ----------------
4208 -- Wide_Width --
4209 ----------------
4211 -- Wide_Width attribute is handled in separate unit Exp_Imgv
4213 when Attribute_Wide_Width =>
4214 Exp_Imgv.Expand_Width_Attribute (N, Wide);
4216 -----------
4217 -- Width --
4218 -----------
4220 -- Width attribute is handled in separate unit Exp_Imgv
4222 when Attribute_Width =>
4223 Exp_Imgv.Expand_Width_Attribute (N, Normal);
4225 -----------
4226 -- Write --
4227 -----------
4229 when Attribute_Write => Write : declare
4230 P_Type : constant Entity_Id := Entity (Pref);
4231 U_Type : constant Entity_Id := Underlying_Type (P_Type);
4232 Pname : Entity_Id;
4233 Decl : Node_Id;
4234 Prag : Node_Id;
4235 Arg3 : Node_Id;
4236 Wfunc : Node_Id;
4238 begin
4239 -- If no underlying type, we have an error that will be diagnosed
4240 -- elsewhere, so here we just completely ignore the expansion.
4242 if No (U_Type) then
4243 return;
4244 end if;
4246 -- The simple case, if there is a TSS for Write, just call it
4248 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
4250 if Present (Pname) then
4251 null;
4253 else
4254 -- If there is a Stream_Convert pragma, use it, we rewrite
4256 -- sourcetyp'Output (stream, Item)
4258 -- as
4260 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
4262 -- where strmwrite is the given Write function that converts an
4263 -- argument of type sourcetyp or a type acctyp, from which it is
4264 -- derived to type strmtyp. The conversion to acttyp is required
4265 -- for the derived case.
4267 Prag := Get_Stream_Convert_Pragma (P_Type);
4269 if Present (Prag) then
4270 Arg3 :=
4271 Next (Next (First (Pragma_Argument_Associations (Prag))));
4272 Wfunc := Entity (Expression (Arg3));
4274 Rewrite (N,
4275 Make_Attribute_Reference (Loc,
4276 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
4277 Attribute_Name => Name_Output,
4278 Expressions => New_List (
4279 Relocate_Node (First (Exprs)),
4280 Make_Function_Call (Loc,
4281 Name => New_Occurrence_Of (Wfunc, Loc),
4282 Parameter_Associations => New_List (
4283 Convert_To (Etype (First_Formal (Wfunc)),
4284 Relocate_Node (Next (First (Exprs)))))))));
4286 Analyze (N);
4287 return;
4289 -- For elementary types, we call the W_xxx routine directly
4291 elsif Is_Elementary_Type (U_Type) then
4292 Rewrite (N, Build_Elementary_Write_Call (N));
4293 Analyze (N);
4294 return;
4296 -- Array type case
4298 elsif Is_Array_Type (U_Type) then
4299 Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
4300 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
4302 -- Tagged type case, use the primitive Write function. Note that
4303 -- this will dispatch in the class-wide case which is what we want
4305 elsif Is_Tagged_Type (U_Type) then
4306 Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
4308 -- All other record type cases, including protected records.
4309 -- The latter only arise for expander generated code for
4310 -- handling shared passive partition access.
4312 else
4313 pragma Assert
4314 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
4316 -- Ada 2005 (AI-216): Program_Error is raised when executing
4317 -- the default implementation of the Write attribute of an
4318 -- Unchecked_Union type.
4320 if Is_Unchecked_Union (Base_Type (U_Type)) then
4321 Insert_Action (N,
4322 Make_Raise_Program_Error (Loc,
4323 Reason => PE_Unchecked_Union_Restriction));
4324 end if;
4326 if Has_Discriminants (U_Type)
4327 and then Present
4328 (Discriminant_Default_Value (First_Discriminant (U_Type)))
4329 then
4330 Build_Mutable_Record_Write_Procedure
4331 (Loc, Base_Type (U_Type), Decl, Pname);
4332 else
4333 Build_Record_Write_Procedure
4334 (Loc, Base_Type (U_Type), Decl, Pname);
4335 end if;
4337 Insert_Action (N, Decl);
4338 end if;
4339 end if;
4341 -- If we fall through, Pname is the procedure to be called
4343 Rewrite_Stream_Proc_Call (Pname);
4344 end Write;
4346 -- Component_Size is handled by Gigi, unless the component size is known
4347 -- at compile time, which is always true in the packed array case. It is
4348 -- important that the packed array case is handled in the front end (see
4349 -- Eval_Attribute) since Gigi would otherwise get confused by the
4350 -- equivalent packed array type.
4352 when Attribute_Component_Size =>
4353 null;
4355 -- The following attributes are handled by Gigi (except that static
4356 -- cases have already been evaluated by the semantics, but in any case
4357 -- Gigi should not count on that).
4359 -- In addition Gigi handles the non-floating-point cases of Pred and
4360 -- Succ (including the fixed-point cases, which can just be treated as
4361 -- integer increment/decrement operations)
4363 -- Gigi also handles the non-class-wide cases of Size
4365 when Attribute_Bit_Order |
4366 Attribute_Code_Address |
4367 Attribute_Definite |
4368 Attribute_Max |
4369 Attribute_Mechanism_Code |
4370 Attribute_Min |
4371 Attribute_Null_Parameter |
4372 Attribute_Passed_By_Reference |
4373 Attribute_Pool_Address =>
4374 null;
4376 -- The following attributes are also handled by Gigi, but return a
4377 -- universal integer result, so may need a conversion for checking
4378 -- that the result is in range.
4380 when Attribute_Aft |
4381 Attribute_Bit |
4382 Attribute_Max_Size_In_Storage_Elements
4384 Apply_Universal_Integer_Attribute_Checks (N);
4386 -- The following attributes should not appear at this stage, since they
4387 -- have already been handled by the analyzer (and properly rewritten
4388 -- with corresponding values or entities to represent the right values)
4390 when Attribute_Abort_Signal |
4391 Attribute_Address_Size |
4392 Attribute_Base |
4393 Attribute_Class |
4394 Attribute_Default_Bit_Order |
4395 Attribute_Delta |
4396 Attribute_Denorm |
4397 Attribute_Digits |
4398 Attribute_Emax |
4399 Attribute_Epsilon |
4400 Attribute_Has_Access_Values |
4401 Attribute_Has_Discriminants |
4402 Attribute_Large |
4403 Attribute_Machine_Emax |
4404 Attribute_Machine_Emin |
4405 Attribute_Machine_Mantissa |
4406 Attribute_Machine_Overflows |
4407 Attribute_Machine_Radix |
4408 Attribute_Machine_Rounds |
4409 Attribute_Maximum_Alignment |
4410 Attribute_Model_Emin |
4411 Attribute_Model_Epsilon |
4412 Attribute_Model_Mantissa |
4413 Attribute_Model_Small |
4414 Attribute_Modulus |
4415 Attribute_Partition_ID |
4416 Attribute_Range |
4417 Attribute_Safe_Emax |
4418 Attribute_Safe_First |
4419 Attribute_Safe_Large |
4420 Attribute_Safe_Last |
4421 Attribute_Safe_Small |
4422 Attribute_Scale |
4423 Attribute_Signed_Zeros |
4424 Attribute_Small |
4425 Attribute_Storage_Unit |
4426 Attribute_Target_Name |
4427 Attribute_Type_Class |
4428 Attribute_Unconstrained_Array |
4429 Attribute_Universal_Literal_String |
4430 Attribute_Wchar_T_Size |
4431 Attribute_Word_Size =>
4433 raise Program_Error;
4435 -- The Asm_Input and Asm_Output attributes are not expanded at this
4436 -- stage, but will be eliminated in the expansion of the Asm call,
4437 -- see Exp_Intr for details. So Gigi will never see these either.
4439 when Attribute_Asm_Input |
4440 Attribute_Asm_Output =>
4442 null;
4444 end case;
4446 exception
4447 when RE_Not_Available =>
4448 return;
4449 end Expand_N_Attribute_Reference;
4451 ----------------------
4452 -- Expand_Pred_Succ --
4453 ----------------------
4455 -- For typ'Pred (exp), we generate the check
4457 -- [constraint_error when exp = typ'Base'First]
4459 -- Similarly, for typ'Succ (exp), we generate the check
4461 -- [constraint_error when exp = typ'Base'Last]
4463 -- These checks are not generated for modular types, since the proper
4464 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
4466 procedure Expand_Pred_Succ (N : Node_Id) is
4467 Loc : constant Source_Ptr := Sloc (N);
4468 Cnam : Name_Id;
4470 begin
4471 if Attribute_Name (N) = Name_Pred then
4472 Cnam := Name_First;
4473 else
4474 Cnam := Name_Last;
4475 end if;
4477 Insert_Action (N,
4478 Make_Raise_Constraint_Error (Loc,
4479 Condition =>
4480 Make_Op_Eq (Loc,
4481 Left_Opnd =>
4482 Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
4483 Right_Opnd =>
4484 Make_Attribute_Reference (Loc,
4485 Prefix =>
4486 New_Reference_To (Base_Type (Etype (Prefix (N))), Loc),
4487 Attribute_Name => Cnam)),
4488 Reason => CE_Overflow_Check_Failed));
4489 end Expand_Pred_Succ;
4491 ----------------------------
4492 -- Find_Stream_Subprogram --
4493 ----------------------------
4495 function Find_Stream_Subprogram
4496 (Typ : Entity_Id;
4497 Nam : TSS_Name_Type) return Entity_Id
4499 Ent : constant Entity_Id := TSS (Typ, Nam);
4500 begin
4501 if Present (Ent) then
4502 return Ent;
4503 end if;
4505 if Is_Tagged_Type (Typ)
4506 and then Is_Derived_Type (Typ)
4507 then
4508 return Find_Prim_Op (Typ, Nam);
4509 else
4510 return Find_Inherited_TSS (Typ, Nam);
4511 end if;
4512 end Find_Stream_Subprogram;
4514 -----------------------
4515 -- Get_Index_Subtype --
4516 -----------------------
4518 function Get_Index_Subtype (N : Node_Id) return Node_Id is
4519 P_Type : Entity_Id := Etype (Prefix (N));
4520 Indx : Node_Id;
4521 J : Int;
4523 begin
4524 if Is_Access_Type (P_Type) then
4525 P_Type := Designated_Type (P_Type);
4526 end if;
4528 if No (Expressions (N)) then
4529 J := 1;
4530 else
4531 J := UI_To_Int (Expr_Value (First (Expressions (N))));
4532 end if;
4534 Indx := First_Index (P_Type);
4535 while J > 1 loop
4536 Next_Index (Indx);
4537 J := J - 1;
4538 end loop;
4540 return Etype (Indx);
4541 end Get_Index_Subtype;
4543 -------------------------------
4544 -- Get_Stream_Convert_Pragma --
4545 -------------------------------
4547 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is
4548 Typ : Entity_Id;
4549 N : Node_Id;
4551 begin
4552 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
4553 -- that a stream convert pragma for a tagged type is not inherited from
4554 -- its parent. Probably what is wrong here is that it is basically
4555 -- incorrect to consider a stream convert pragma to be a representation
4556 -- pragma at all ???
4558 N := First_Rep_Item (Implementation_Base_Type (T));
4559 while Present (N) loop
4560 if Nkind (N) = N_Pragma and then Chars (N) = Name_Stream_Convert then
4562 -- For tagged types this pragma is not inherited, so we
4563 -- must verify that it is defined for the given type and
4564 -- not an ancestor.
4566 Typ :=
4567 Entity (Expression (First (Pragma_Argument_Associations (N))));
4569 if not Is_Tagged_Type (T)
4570 or else T = Typ
4571 or else (Is_Private_Type (Typ) and then T = Full_View (Typ))
4572 then
4573 return N;
4574 end if;
4575 end if;
4577 Next_Rep_Item (N);
4578 end loop;
4580 return Empty;
4581 end Get_Stream_Convert_Pragma;
4583 ---------------------------------
4584 -- Is_Constrained_Packed_Array --
4585 ---------------------------------
4587 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is
4588 Arr : Entity_Id := Typ;
4590 begin
4591 if Is_Access_Type (Arr) then
4592 Arr := Designated_Type (Arr);
4593 end if;
4595 return Is_Array_Type (Arr)
4596 and then Is_Constrained (Arr)
4597 and then Present (Packed_Array_Type (Arr));
4598 end Is_Constrained_Packed_Array;
4600 end Exp_Attr;