]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/ada/exp_attr.adb
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Daily bump.
[thirdparty/gcc.git] / gcc / ada / exp_attr.adb
CommitLineData
ee6ba406 1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- E X P _ A T T R --
6-- --
7-- B o d y --
8-- --
ee6ba406 9-- --
f15731c4 10-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
ee6ba406 11-- --
12-- GNAT is free software; you can redistribute it and/or modify it under --
13-- terms of the GNU General Public License as published by the Free Soft- --
14-- ware Foundation; either version 2, or (at your option) any later ver- --
15-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18-- for more details. You should have received a copy of the GNU General --
19-- Public License distributed with GNAT; see file COPYING. If not, write --
20-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21-- MA 02111-1307, USA. --
22-- --
23-- GNAT was originally developed by the GNAT team at New York University. --
24-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
25-- --
26------------------------------------------------------------------------------
27
28with Atree; use Atree;
29with Checks; use Checks;
30with Einfo; use Einfo;
31with Exp_Ch2; use Exp_Ch2;
32with Exp_Ch9; use Exp_Ch9;
33with Exp_Imgv; use Exp_Imgv;
34with Exp_Pakd; use Exp_Pakd;
35with Exp_Strm; use Exp_Strm;
36with Exp_Tss; use Exp_Tss;
37with Exp_Util; use Exp_Util;
38with Gnatvsn; use Gnatvsn;
39with Hostparm; use Hostparm;
40with Lib; use Lib;
41with Namet; use Namet;
42with Nmake; use Nmake;
43with Nlists; use Nlists;
44with Opt; use Opt;
45with Restrict; use Restrict;
46with Rtsfind; use Rtsfind;
47with Sem; use Sem;
48with Sem_Ch7; use Sem_Ch7;
49with Sem_Ch8; use Sem_Ch8;
ee6ba406 50with Sem_Eval; use Sem_Eval;
51with Sem_Res; use Sem_Res;
52with Sem_Util; use Sem_Util;
53with Sinfo; use Sinfo;
54with Snames; use Snames;
55with Stand; use Stand;
56with Stringt; use Stringt;
57with Tbuild; use Tbuild;
58with Ttypes; use Ttypes;
59with Uintp; use Uintp;
60with Uname; use Uname;
61with Validsw; use Validsw;
62
63package body Exp_Attr is
64
65 -----------------------
66 -- Local Subprograms --
67 -----------------------
68
69 procedure Compile_Stream_Body_In_Scope
70 (N : Node_Id;
71 Decl : Node_Id;
72 Arr : Entity_Id;
73 Check : Boolean);
74 -- The body for a stream subprogram may be generated outside of the scope
75 -- of the type. If the type is fully private, it may depend on the full
76 -- view of other types (e.g. indices) that are currently private as well.
77 -- We install the declarations of the package in which the type is declared
78 -- before compiling the body in what is its proper environment. The Check
79 -- parameter indicates if checks are to be suppressed for the stream body.
80 -- We suppress checks for array/record reads, since the rule is that these
81 -- are like assignments, out of range values due to uninitialized storage,
82 -- or other invalid values do NOT cause a Constraint_Error to be raised.
83
84 procedure Expand_Fpt_Attribute
85 (N : Node_Id;
86 Rtp : Entity_Id;
87 Args : List_Id);
88 -- This procedure expands a call to a floating-point attribute function.
89 -- N is the attribute reference node, and Args is a list of arguments to
90 -- be passed to the function call. Rtp is the root type of the floating
91 -- point type involved (used to select the proper generic instantiation
92 -- of the package containing the attribute routines).
93
94 procedure Expand_Fpt_Attribute_R (N : Node_Id);
95 -- This procedure expands a call to a floating-point attribute function
96 -- that takes a single floating-point argument.
97
98 procedure Expand_Fpt_Attribute_RI (N : Node_Id);
99 -- This procedure expands a call to a floating-point attribute function
100 -- that takes one floating-point argument and one integer argument.
101
102 procedure Expand_Fpt_Attribute_RR (N : Node_Id);
103 -- This procedure expands a call to a floating-point attribute function
104 -- that takes two floating-point arguments.
105
106 procedure Expand_Pred_Succ (N : Node_Id);
107 -- Handles expansion of Pred or Succ attributes for case of non-real
108 -- operand with overflow checking required.
109
110 function Get_Index_Subtype (N : Node_Id) return Entity_Id;
111 -- Used for Last, Last, and Length, when the prefix is an array type,
112 -- Obtains the corresponding index subtype.
113
114 procedure Expand_Access_To_Type (N : Node_Id);
115 -- A reference to a type within its own scope is resolved to a reference
116 -- to the current instance of the type in its initialization procedure.
117
118 function Find_Inherited_TSS
119 (Typ : Entity_Id;
120 Nam : Name_Id) return Entity_Id;
121
122 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
123 -- Utility for array attributes, returns true on packed constrained
124 -- arrays, and on access to same.
125
126 ----------------------------------
127 -- Compile_Stream_Body_In_Scope --
128 ----------------------------------
129
130 procedure Compile_Stream_Body_In_Scope
131 (N : Node_Id;
132 Decl : Node_Id;
133 Arr : Entity_Id;
134 Check : Boolean)
135 is
136 Installed : Boolean := False;
137 Scop : constant Entity_Id := Scope (Arr);
138 Curr : constant Entity_Id := Current_Scope;
139
140 begin
141 if Is_Hidden (Arr)
142 and then not In_Open_Scopes (Scop)
143 and then Ekind (Scop) = E_Package
144 then
145 New_Scope (Scop);
146 Install_Visible_Declarations (Scop);
147 Install_Private_Declarations (Scop);
148 Installed := True;
149
150 -- The entities in the package are now visible, but the generated
151 -- stream entity must appear in the current scope (usually an
152 -- enclosing stream function) so that itypes all have their proper
153 -- scopes.
154
155 New_Scope (Curr);
156 end if;
157
158 if Check then
159 Insert_Action (N, Decl);
160 else
161 Insert_Action (N, Decl, All_Checks);
162 end if;
163
164 if Installed then
165
166 -- Remove extra copy of current scope, and package itself
167
168 Pop_Scope;
169 End_Package_Scope (Scop);
170 end if;
171 end Compile_Stream_Body_In_Scope;
172
173 ---------------------------
174 -- Expand_Access_To_Type --
175 ---------------------------
176
177 procedure Expand_Access_To_Type (N : Node_Id) is
178 Loc : constant Source_Ptr := Sloc (N);
179 Typ : constant Entity_Id := Etype (N);
180 Pref : constant Node_Id := Prefix (N);
181 Par : Node_Id;
182 Formal : Entity_Id;
183
184 begin
185 if Is_Entity_Name (Pref)
186 and then Is_Type (Entity (Pref))
187 then
188 -- If the current instance name denotes a task type,
189 -- then the access attribute is rewritten to be the
190 -- name of the "_task" parameter associated with the
191 -- task type's task body procedure. An unchecked
192 -- conversion is applied to ensure a type match in
193 -- cases of expander-generated calls (e.g., init procs).
194
195 if Is_Task_Type (Entity (Pref)) then
196 Formal :=
197 First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
198
199 while Present (Formal) loop
200 exit when Chars (Formal) = Name_uTask;
201 Next_Entity (Formal);
202 end loop;
203
204 pragma Assert (Present (Formal));
205
206 Rewrite (N,
207 Unchecked_Convert_To (Typ, New_Occurrence_Of (Formal, Loc)));
208 Set_Etype (N, Typ);
209
210 -- The expression must appear in a default expression,
211 -- (which in the initialization procedure is the rhs of
212 -- an assignment), and not in a discriminant constraint.
213
214 else
215 Par := Parent (N);
216
217 while Present (Par) loop
218 exit when Nkind (Par) = N_Assignment_Statement;
219
220 if Nkind (Par) = N_Component_Declaration then
221 return;
222 end if;
223
224 Par := Parent (Par);
225 end loop;
226
227 if Present (Par) then
228 Rewrite (N,
229 Make_Attribute_Reference (Loc,
230 Prefix => Make_Identifier (Loc, Name_uInit),
231 Attribute_Name => Attribute_Name (N)));
232
233 Analyze_And_Resolve (N, Typ);
234 end if;
235 end if;
236 end if;
237 end Expand_Access_To_Type;
238
239 --------------------------
240 -- Expand_Fpt_Attribute --
241 --------------------------
242
243 procedure Expand_Fpt_Attribute
244 (N : Node_Id;
245 Rtp : Entity_Id;
246 Args : List_Id)
247 is
248 Loc : constant Source_Ptr := Sloc (N);
249 Typ : constant Entity_Id := Etype (N);
250 Pkg : RE_Id;
251 Fnm : Node_Id;
252
253 begin
254 -- The function name is the selected component Fat_xxx.yyy where xxx
255 -- is the floating-point root type, and yyy is the attribute name
256
257 -- Note: it would be more usual to have separate RE entries for each
258 -- of the entities in the Fat packages, but first they have identical
259 -- names (so we would have to have lots of renaming declarations to
260 -- meet the normal RE rule of separate names for all runtime entities),
261 -- and second there would be an awful lot of them!
262
263 if Rtp = Standard_Short_Float then
264 Pkg := RE_Fat_Short_Float;
265 elsif Rtp = Standard_Float then
266 Pkg := RE_Fat_Float;
267 elsif Rtp = Standard_Long_Float then
268 Pkg := RE_Fat_Long_Float;
269 else
270 Pkg := RE_Fat_Long_Long_Float;
271 end if;
272
273 Fnm :=
274 Make_Selected_Component (Loc,
275 Prefix => New_Reference_To (RTE (Pkg), Loc),
276 Selector_Name => Make_Identifier (Loc, Attribute_Name (N)));
277
278 -- The generated call is given the provided set of parameters, and then
279 -- wrapped in a conversion which converts the result to the target type
280
281 Rewrite (N,
282 Unchecked_Convert_To (Etype (N),
283 Make_Function_Call (Loc,
284 Name => Fnm,
285 Parameter_Associations => Args)));
286
287 Analyze_And_Resolve (N, Typ);
288
289 end Expand_Fpt_Attribute;
290
291 ----------------------------
292 -- Expand_Fpt_Attribute_R --
293 ----------------------------
294
295 -- The single argument is converted to its root type to call the
296 -- appropriate runtime function, with the actual call being built
297 -- by Expand_Fpt_Attribute
298
299 procedure Expand_Fpt_Attribute_R (N : Node_Id) is
300 E1 : constant Node_Id := First (Expressions (N));
301 Rtp : constant Entity_Id := Root_Type (Etype (E1));
302
303 begin
304 Expand_Fpt_Attribute (N, Rtp, New_List (
305 Unchecked_Convert_To (Rtp, Relocate_Node (E1))));
306 end Expand_Fpt_Attribute_R;
307
308 -----------------------------
309 -- Expand_Fpt_Attribute_RI --
310 -----------------------------
311
312 -- The first argument is converted to its root type and the second
313 -- argument is converted to standard long long integer to call the
314 -- appropriate runtime function, with the actual call being built
315 -- by Expand_Fpt_Attribute
316
317 procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
318 E1 : constant Node_Id := First (Expressions (N));
319 Rtp : constant Entity_Id := Root_Type (Etype (E1));
320 E2 : constant Node_Id := Next (E1);
321
322 begin
323 Expand_Fpt_Attribute (N, Rtp, New_List (
324 Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
325 Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
326 end Expand_Fpt_Attribute_RI;
327
328 -----------------------------
329 -- Expand_Fpt_Attribute_RR --
330 -----------------------------
331
332 -- The two arguments is converted to their root types to call the
333 -- appropriate runtime function, with the actual call being built
334 -- by Expand_Fpt_Attribute
335
336 procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
337 E1 : constant Node_Id := First (Expressions (N));
338 Rtp : constant Entity_Id := Root_Type (Etype (E1));
339 E2 : constant Node_Id := Next (E1);
340
341 begin
342 Expand_Fpt_Attribute (N, Rtp, New_List (
343 Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
344 Unchecked_Convert_To (Rtp, Relocate_Node (E2))));
345 end Expand_Fpt_Attribute_RR;
346
347 ----------------------------------
348 -- Expand_N_Attribute_Reference --
349 ----------------------------------
350
351 procedure Expand_N_Attribute_Reference (N : Node_Id) is
352 Loc : constant Source_Ptr := Sloc (N);
353 Typ : constant Entity_Id := Etype (N);
354 Btyp : constant Entity_Id := Base_Type (Typ);
355 Pref : constant Node_Id := Prefix (N);
356 Exprs : constant List_Id := Expressions (N);
357 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
358
359 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
360 -- Rewrites a stream attribute for Read, Write or Output with the
361 -- procedure call. Pname is the entity for the procedure to call.
362
363 ------------------------------
364 -- Rewrite_Stream_Proc_Call --
365 ------------------------------
366
367 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
368 Item : constant Node_Id := Next (First (Exprs));
369 Formal_Typ : constant Entity_Id :=
370 Etype (Next_Formal (First_Formal (Pname)));
371
372 begin
373 -- We have to worry about the type of the second argument
374
375 -- For the class-wide dispatching cases, and for cases in which
376 -- the base type of the second argument matches the base type of
377 -- the corresponding formal parameter, we are all set, and can use
378 -- the argument unchanged.
379
380 -- For all other cases we do an unchecked conversion of the second
381 -- parameter to the type of the formal of the procedure we are
382 -- calling. This deals with the private type cases, and with going
383 -- to the root type as required in elementary type case.
384
385 if not Is_Class_Wide_Type (Entity (Pref))
386 and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
387 then
388 Rewrite (Item,
389 Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
390
391 -- For untagged derived types set Assignment_OK, to prevent
392 -- copies from being created when the unchecked conversion
393 -- is expanded (which would happen in Remove_Side_Effects
394 -- if Expand_N_Unchecked_Conversion were allowed to call
395 -- Force_Evaluation). The copy could violate Ada semantics
396 -- in cases such as an actual that is an out parameter.
397 -- Note that this approach is also used in exp_ch7 for calls
398 -- to controlled type operations to prevent problems with
399 -- actuals wrapped in unchecked conversions.
400
401 if Is_Untagged_Derivation (Etype (Expression (Item))) then
402 Set_Assignment_OK (Item);
403 end if;
404 end if;
405
406 -- And now rewrite the call
407
408 Rewrite (N,
409 Make_Procedure_Call_Statement (Loc,
410 Name => New_Occurrence_Of (Pname, Loc),
411 Parameter_Associations => Exprs));
412
413 Analyze (N);
414 end Rewrite_Stream_Proc_Call;
415
416 -- Start of processing for Expand_N_Attribute_Reference
417
418 begin
419 -- Do required validity checking
420
421 if Validity_Checks_On and Validity_Check_Operands then
422 declare
423 Expr : Node_Id;
424
425 begin
426 Expr := First (Expressions (N));
427 while Present (Expr) loop
428 Ensure_Valid (Expr);
429 Next (Expr);
430 end loop;
431 end;
432 end if;
433
434 -- Remaining processing depends on specific attribute
435
436 case Id is
437
438 ------------
439 -- Access --
440 ------------
441
442 when Attribute_Access =>
443
444 if Ekind (Btyp) = E_Access_Protected_Subprogram_Type then
445
446 -- The value of the attribute_reference is a record containing
447 -- two fields: an access to the protected object, and an access
448 -- to the subprogram itself. The prefix is a selected component.
449
450 declare
451 Agg : Node_Id;
452 Sub : Entity_Id;
f15731c4 453 E_T : constant Entity_Id := Equivalent_Type (Btyp);
ee6ba406 454 Acc : constant Entity_Id :=
455 Etype (Next_Component (First_Component (E_T)));
456 Obj_Ref : Node_Id;
457 Curr : Entity_Id;
458
459 begin
460 -- Within the body of the protected type, the prefix
461 -- designates a local operation, and the object is the first
462 -- parameter of the corresponding protected body of the
463 -- current enclosing operation.
464
465 if Is_Entity_Name (Pref) then
466 pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
467 Sub :=
468 New_Occurrence_Of
469 (Protected_Body_Subprogram (Entity (Pref)), Loc);
470 Curr := Current_Scope;
471
472 while Scope (Curr) /= Scope (Entity (Pref)) loop
473 Curr := Scope (Curr);
474 end loop;
475
476 Obj_Ref :=
477 Make_Attribute_Reference (Loc,
478 Prefix =>
479 New_Occurrence_Of
480 (First_Formal
481 (Protected_Body_Subprogram (Curr)), Loc),
482 Attribute_Name => Name_Address);
483
484 -- Case where the prefix is not an entity name. Find the
485 -- version of the protected operation to be called from
486 -- outside the protected object.
487
488 else
489 Sub :=
490 New_Occurrence_Of
491 (External_Subprogram
492 (Entity (Selector_Name (Pref))), Loc);
493
494 Obj_Ref :=
495 Make_Attribute_Reference (Loc,
496 Prefix => Relocate_Node (Prefix (Pref)),
497 Attribute_Name => Name_Address);
498 end if;
499
500 Agg :=
501 Make_Aggregate (Loc,
502 Expressions =>
503 New_List (
504 Obj_Ref,
505 Unchecked_Convert_To (Acc,
506 Make_Attribute_Reference (Loc,
507 Prefix => Sub,
508 Attribute_Name => Name_Address))));
509
510 Rewrite (N, Agg);
511
f15731c4 512 Analyze_And_Resolve (N, E_T);
ee6ba406 513
514 -- For subsequent analysis, the node must retain its type.
515 -- The backend will replace it with the equivalent type where
516 -- needed.
517
518 Set_Etype (N, Typ);
519 end;
520
521 elsif Ekind (Btyp) = E_General_Access_Type then
522 declare
523 Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
524 Parm_Ent : Entity_Id;
525 Conversion : Node_Id;
526
527 begin
528 -- If the prefix of an Access attribute is a dereference of an
529 -- access parameter (or a renaming of such a dereference) and
530 -- the context is a general access type (but not an anonymous
531 -- access type), then rewrite the attribute as a conversion of
532 -- the access parameter to the context access type. This will
533 -- result in an accessibility check being performed, if needed.
534
535 -- (X.all'Access => Acc_Type (X))
536
537 if Nkind (Ref_Object) = N_Explicit_Dereference
538 and then Is_Entity_Name (Prefix (Ref_Object))
539 then
540 Parm_Ent := Entity (Prefix (Ref_Object));
541
542 if Ekind (Parm_Ent) in Formal_Kind
543 and then Ekind (Etype (Parm_Ent)) = E_Anonymous_Access_Type
544 and then Present (Extra_Accessibility (Parm_Ent))
545 then
546 Conversion :=
547 Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object)));
548
549 Rewrite (N, Conversion);
550 Analyze_And_Resolve (N, Typ);
551 end if;
552 end if;
553 end;
554
555 -- If the prefix is a type name, this is a reference to the current
556 -- instance of the type, within its initialization procedure.
557
558 else
559 Expand_Access_To_Type (N);
560 end if;
561
562 --------------
563 -- Adjacent --
564 --------------
565
566 -- Transforms 'Adjacent into a call to the floating-point attribute
567 -- function Adjacent in Fat_xxx (where xxx is the root type)
568
569 when Attribute_Adjacent =>
570 Expand_Fpt_Attribute_RR (N);
571
572 -------------
573 -- Address --
574 -------------
575
576 when Attribute_Address => Address : declare
577 Task_Proc : Entity_Id;
578
579 begin
580 -- If the prefix is a task or a task type, the useful address
581 -- is that of the procedure for the task body, i.e. the actual
582 -- program unit. We replace the original entity with that of
583 -- the procedure.
584
585 if Is_Entity_Name (Pref)
586 and then Is_Task_Type (Entity (Pref))
587 then
588 Task_Proc := Next_Entity (Root_Type (Etype (Pref)));
589
590 while Present (Task_Proc) loop
591 exit when Ekind (Task_Proc) = E_Procedure
592 and then Etype (First_Formal (Task_Proc)) =
593 Corresponding_Record_Type (Etype (Pref));
594 Next_Entity (Task_Proc);
595 end loop;
596
597 if Present (Task_Proc) then
598 Set_Entity (Pref, Task_Proc);
599 Set_Etype (Pref, Etype (Task_Proc));
600 end if;
601
602 -- Similarly, the address of a protected operation is the address
603 -- of the corresponding protected body, regardless of the protected
604 -- object from which it is selected.
605
606 elsif Nkind (Pref) = N_Selected_Component
607 and then Is_Subprogram (Entity (Selector_Name (Pref)))
608 and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref))))
609 then
610 Rewrite (Pref,
611 New_Occurrence_Of (
612 External_Subprogram (Entity (Selector_Name (Pref))), Loc));
613
614 elsif Nkind (Pref) = N_Explicit_Dereference
615 and then Ekind (Etype (Pref)) = E_Subprogram_Type
616 and then Convention (Etype (Pref)) = Convention_Protected
617 then
618 -- The prefix is be a dereference of an access_to_protected_
619 -- subprogram. The desired address is the second component of
620 -- the record that represents the access.
621
622 declare
623 Addr : constant Entity_Id := Etype (N);
624 Ptr : constant Node_Id := Prefix (Pref);
625 T : constant Entity_Id :=
626 Equivalent_Type (Base_Type (Etype (Ptr)));
627
628 begin
629 Rewrite (N,
630 Unchecked_Convert_To (Addr,
631 Make_Selected_Component (Loc,
632 Prefix => Unchecked_Convert_To (T, Ptr),
633 Selector_Name => New_Occurrence_Of (
634 Next_Entity (First_Entity (T)), Loc))));
635
636 Analyze_And_Resolve (N, Addr);
637 end;
638 end if;
639
640 -- Deal with packed array reference, other cases are handled by gigi
641
642 if Involves_Packed_Array_Reference (Pref) then
643 Expand_Packed_Address_Reference (N);
644 end if;
645 end Address;
646
647 ---------------
648 -- AST_Entry --
649 ---------------
650
651 when Attribute_AST_Entry => AST_Entry : declare
652 Ttyp : Entity_Id;
653 T_Id : Node_Id;
654 Eent : Entity_Id;
655
656 Entry_Ref : Node_Id;
657 -- The reference to the entry or entry family
658
659 Index : Node_Id;
660 -- The index expression for an entry family reference, or
661 -- the Empty if Entry_Ref references a simple entry.
662
663 begin
664 if Nkind (Pref) = N_Indexed_Component then
665 Entry_Ref := Prefix (Pref);
666 Index := First (Expressions (Pref));
667 else
668 Entry_Ref := Pref;
669 Index := Empty;
670 end if;
671
672 -- Get expression for Task_Id and the entry entity
673
674 if Nkind (Entry_Ref) = N_Selected_Component then
675 T_Id :=
676 Make_Attribute_Reference (Loc,
677 Attribute_Name => Name_Identity,
678 Prefix => Prefix (Entry_Ref));
679
680 Ttyp := Etype (Prefix (Entry_Ref));
681 Eent := Entity (Selector_Name (Entry_Ref));
682
683 else
684 T_Id :=
685 Make_Function_Call (Loc,
686 Name => New_Occurrence_Of (RTE (RE_Current_Task), Loc));
687
688 Eent := Entity (Entry_Ref);
689
690 -- We have to find the enclosing task to get the task type
691 -- There must be one, since we already validated this earlier
692
693 Ttyp := Current_Scope;
694 while not Is_Task_Type (Ttyp) loop
695 Ttyp := Scope (Ttyp);
696 end loop;
697 end if;
698
699 -- Now rewrite the attribute with a call to Create_AST_Handler
700
701 Rewrite (N,
702 Make_Function_Call (Loc,
703 Name => New_Occurrence_Of (RTE (RE_Create_AST_Handler), Loc),
704 Parameter_Associations => New_List (
705 T_Id,
706 Entry_Index_Expression (Loc, Eent, Index, Ttyp))));
707
708 Analyze_And_Resolve (N, RTE (RE_AST_Handler));
709 end AST_Entry;
710
711 ------------------
712 -- Bit_Position --
713 ------------------
714
715 -- We compute this if a component clause was present, otherwise
716 -- we leave the computation up to Gigi, since we don't know what
717 -- layout will be chosen.
718
719 -- Note that the attribute can apply to a naked record component
720 -- in generated code (i.e. the prefix is an identifier that
721 -- references the component or discriminant entity).
722
723 when Attribute_Bit_Position => Bit_Position :
724 declare
725 CE : Entity_Id;
726
727 begin
728 if Nkind (Pref) = N_Identifier then
729 CE := Entity (Pref);
730 else
731 CE := Entity (Selector_Name (Pref));
732 end if;
733
734 if Known_Static_Component_Bit_Offset (CE) then
735 Rewrite (N,
736 Make_Integer_Literal (Loc,
737 Intval => Component_Bit_Offset (CE)));
738 Analyze_And_Resolve (N, Typ);
739
740 else
741 Apply_Universal_Integer_Attribute_Checks (N);
742 end if;
743 end Bit_Position;
744
745 ------------------
746 -- Body_Version --
747 ------------------
748
749 -- A reference to P'Body_Version or P'Version is expanded to
750
751 -- Vnn : Unsigned;
752 -- pragma Import (C, Vnn, "uuuuT";
753 -- ...
754 -- Get_Version_String (Vnn)
755
756 -- where uuuu is the unit name (dots replaced by double underscore)
757 -- and T is B for the cases of Body_Version, or Version applied to a
758 -- subprogram acting as its own spec, and S for Version applied to a
759 -- subprogram spec or package. This sequence of code references the
760 -- the unsigned constant created in the main program by the binder.
761
762 -- A special exception occurs for Standard, where the string
763 -- returned is a copy of the library string in gnatvsn.ads.
764
765 when Attribute_Body_Version | Attribute_Version => Version : declare
766 E : constant Entity_Id :=
767 Make_Defining_Identifier (Loc, New_Internal_Name ('V'));
768 Pent : Entity_Id := Entity (Pref);
769 S : String_Id;
770
771 begin
772 -- If not library unit, get to containing library unit
773
774 while Pent /= Standard_Standard
775 and then Scope (Pent) /= Standard_Standard
776 loop
777 Pent := Scope (Pent);
778 end loop;
779
780 -- Special case Standard
781
782 if Pent = Standard_Standard
783 or else Pent = Standard_ASCII
784 then
785 Name_Buffer (1 .. Library_Version'Length) := Library_Version;
786 Name_Len := Library_Version'Length;
787 Rewrite (N,
788 Make_String_Literal (Loc,
789 Strval => String_From_Name_Buffer));
790
791 -- All other cases
792
793 else
794 -- Build required string constant
795
796 Get_Name_String (Get_Unit_Name (Pent));
797
798 Start_String;
799 for J in 1 .. Name_Len - 2 loop
800 if Name_Buffer (J) = '.' then
801 Store_String_Chars ("__");
802 else
803 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
804 end if;
805 end loop;
806
807 -- Case of subprogram acting as its own spec, always use body
808
809 if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
810 and then Nkind (Parent (Declaration_Node (Pent))) =
811 N_Subprogram_Body
812 and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
813 then
814 Store_String_Chars ("B");
815
816 -- Case of no body present, always use spec
817
818 elsif not Unit_Requires_Body (Pent) then
819 Store_String_Chars ("S");
820
821 -- Otherwise use B for Body_Version, S for spec
822
823 elsif Id = Attribute_Body_Version then
824 Store_String_Chars ("B");
825 else
826 Store_String_Chars ("S");
827 end if;
828
829 S := End_String;
830 Lib.Version_Referenced (S);
831
832 -- Insert the object declaration
833
834 Insert_Actions (N, New_List (
835 Make_Object_Declaration (Loc,
836 Defining_Identifier => E,
837 Object_Definition =>
838 New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
839
840 -- Set entity as imported with correct external name
841
842 Set_Is_Imported (E);
843 Set_Interface_Name (E, Make_String_Literal (Loc, S));
844
845 -- And now rewrite original reference
846
847 Rewrite (N,
848 Make_Function_Call (Loc,
849 Name => New_Reference_To (RTE (RE_Get_Version_String), Loc),
850 Parameter_Associations => New_List (
851 New_Occurrence_Of (E, Loc))));
852 end if;
853
854 Analyze_And_Resolve (N, RTE (RE_Version_String));
855 end Version;
856
857 -------------
858 -- Ceiling --
859 -------------
860
861 -- Transforms 'Ceiling into a call to the floating-point attribute
862 -- function Ceiling in Fat_xxx (where xxx is the root type)
863
864 when Attribute_Ceiling =>
865 Expand_Fpt_Attribute_R (N);
866
867 --------------
868 -- Callable --
869 --------------
870
871 -- Transforms 'Callable attribute into a call to the Callable function.
872
873 when Attribute_Callable => Callable :
874 begin
875 Rewrite (N,
876 Build_Call_With_Task (Pref, RTE (RE_Callable)));
877 Analyze_And_Resolve (N, Standard_Boolean);
878 end Callable;
879
880 ------------
881 -- Caller --
882 ------------
883
884 -- Transforms 'Caller attribute into a call to either the
885 -- Task_Entry_Caller or the Protected_Entry_Caller function.
886
887 when Attribute_Caller => Caller : declare
888 Id_Kind : Entity_Id := RTE (RO_AT_Task_ID);
889 Ent : Entity_Id := Entity (Pref);
890 Conctype : Entity_Id := Scope (Ent);
891 Nest_Depth : Integer := 0;
892 Name : Node_Id;
893 S : Entity_Id;
894
895 begin
896 -- Protected case
897
898 if Is_Protected_Type (Conctype) then
899 if Abort_Allowed
900 or else Restrictions (No_Entry_Queue) = False
901 or else Number_Entries (Conctype) > 1
902 then
903 Name :=
904 New_Reference_To
905 (RTE (RE_Protected_Entry_Caller), Loc);
906 else
907 Name :=
908 New_Reference_To
909 (RTE (RE_Protected_Single_Entry_Caller), Loc);
910 end if;
911
912 Rewrite (N,
913 Unchecked_Convert_To (Id_Kind,
914 Make_Function_Call (Loc,
915 Name => Name,
916 Parameter_Associations => New_List
917 (New_Reference_To (
918 Object_Ref
919 (Corresponding_Body (Parent (Conctype))), Loc)))));
920
921 -- Task case
922
923 else
924 -- Determine the nesting depth of the E'Caller attribute, that
925 -- is, how many accept statements are nested within the accept
926 -- statement for E at the point of E'Caller. The runtime uses
927 -- this depth to find the specified entry call.
928
929 for J in reverse 0 .. Scope_Stack.Last loop
930 S := Scope_Stack.Table (J).Entity;
931
932 -- We should not reach the scope of the entry, as it should
933 -- already have been checked in Sem_Attr that this attribute
934 -- reference is within a matching accept statement.
935
936 pragma Assert (S /= Conctype);
937
938 if S = Ent then
939 exit;
940
941 elsif Is_Entry (S) then
942 Nest_Depth := Nest_Depth + 1;
943 end if;
944 end loop;
945
946 Rewrite (N,
947 Unchecked_Convert_To (Id_Kind,
948 Make_Function_Call (Loc,
949 Name => New_Reference_To (
950 RTE (RE_Task_Entry_Caller), Loc),
951 Parameter_Associations => New_List (
952 Make_Integer_Literal (Loc,
953 Intval => Int (Nest_Depth))))));
954 end if;
955
956 Analyze_And_Resolve (N, Id_Kind);
957 end Caller;
958
959 -------------
960 -- Compose --
961 -------------
962
963 -- Transforms 'Compose into a call to the floating-point attribute
964 -- function Compose in Fat_xxx (where xxx is the root type)
965
966 -- Note: we strictly should have special code here to deal with the
967 -- case of absurdly negative arguments (less than Integer'First)
968 -- which will return a (signed) zero value, but it hardly seems
969 -- worth the effort. Absurdly large positive arguments will raise
970 -- constraint error which is fine.
971
972 when Attribute_Compose =>
973 Expand_Fpt_Attribute_RI (N);
974
975 -----------------
976 -- Constrained --
977 -----------------
978
979 when Attribute_Constrained => Constrained : declare
980 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
981
982 begin
983 -- Reference to a parameter where the value is passed as an extra
984 -- actual, corresponding to the extra formal referenced by the
985 -- Extra_Constrained field of the corresponding formal.
986
987 if Present (Formal_Ent)
988 and then Present (Extra_Constrained (Formal_Ent))
989 then
990 Rewrite (N,
991 New_Occurrence_Of
992 (Extra_Constrained (Formal_Ent), Sloc (N)));
993
994 -- For variables with a Extra_Constrained field, we use the
995 -- corresponding entity.
996
997 elsif Nkind (Pref) = N_Identifier
998 and then Ekind (Entity (Pref)) = E_Variable
999 and then Present (Extra_Constrained (Entity (Pref)))
1000 then
1001 Rewrite (N,
1002 New_Occurrence_Of
1003 (Extra_Constrained (Entity (Pref)), Sloc (N)));
1004
1005 -- For all other entity names, we can tell at compile time
1006
1007 elsif Is_Entity_Name (Pref) then
1008 declare
1009 Ent : constant Entity_Id := Entity (Pref);
1010 Res : Boolean;
1011
1012 begin
1013 -- (RM J.4) obsolescent cases
1014
1015 if Is_Type (Ent) then
1016
1017 -- Private type
1018
1019 if Is_Private_Type (Ent) then
1020 Res := not Has_Discriminants (Ent)
1021 or else Is_Constrained (Ent);
1022
1023 -- It not a private type, must be a generic actual type
1024 -- that corresponded to a private type. We know that this
1025 -- correspondence holds, since otherwise the reference
1026 -- within the generic template would have been illegal.
1027
1028 else
1029 declare
1030 UT : Entity_Id := Underlying_Type (Ent);
1031
1032 begin
1033 if Is_Composite_Type (UT) then
1034 Res := Is_Constrained (Ent);
1035 else
1036 Res := True;
1037 end if;
1038 end;
1039 end if;
1040
1041 -- If the prefix is not a variable or is aliased, then
1042 -- definitely true; if it's a formal parameter without
1043 -- an associated extra formal, then treat it as constrained.
1044
1045 elsif not Is_Variable (Pref)
1046 or else Present (Formal_Ent)
1047 or else Is_Aliased_View (Pref)
1048 then
1049 Res := True;
1050
1051 -- Variable case, just look at type to see if it is
1052 -- constrained. Note that the one case where this is
1053 -- not accurate (the procedure formal case), has been
1054 -- handled above.
1055
1056 else
1057 Res := Is_Constrained (Etype (Ent));
1058 end if;
1059
1060 if Res then
1061 Rewrite (N,
1062 New_Reference_To (Standard_True, Loc));
1063 else
1064 Rewrite (N,
1065 New_Reference_To (Standard_False, Loc));
1066 end if;
1067 end;
1068
1069 -- Prefix is not an entity name. These are also cases where
1070 -- we can always tell at compile time by looking at the form
1071 -- and type of the prefix.
1072
1073 else
1074 if not Is_Variable (Pref)
1075 or else Nkind (Pref) = N_Explicit_Dereference
1076 or else Is_Constrained (Etype (Pref))
1077 then
1078 Rewrite (N,
1079 New_Reference_To (Standard_True, Loc));
1080 else
1081 Rewrite (N,
1082 New_Reference_To (Standard_False, Loc));
1083 end if;
1084 end if;
1085
1086 Analyze_And_Resolve (N, Standard_Boolean);
1087 end Constrained;
1088
1089 ---------------
1090 -- Copy_Sign --
1091 ---------------
1092
1093 -- Transforms 'Copy_Sign into a call to the floating-point attribute
1094 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
1095
1096 when Attribute_Copy_Sign =>
1097 Expand_Fpt_Attribute_RR (N);
1098
1099 -----------
1100 -- Count --
1101 -----------
1102
1103 -- Transforms 'Count attribute into a call to the Count function
1104
1105 when Attribute_Count => Count :
1106 declare
1107 Entnam : Node_Id;
1108 Index : Node_Id;
1109 Name : Node_Id;
1110 Call : Node_Id;
1111 Conctyp : Entity_Id;
1112
1113 begin
1114 -- If the prefix is a member of an entry family, retrieve both
1115 -- entry name and index. For a simple entry there is no index.
1116
1117 if Nkind (Pref) = N_Indexed_Component then
1118 Entnam := Prefix (Pref);
1119 Index := First (Expressions (Pref));
1120 else
1121 Entnam := Pref;
1122 Index := Empty;
1123 end if;
1124
1125 -- Find the concurrent type in which this attribute is referenced
1126 -- (there had better be one).
1127
1128 Conctyp := Current_Scope;
1129 while not Is_Concurrent_Type (Conctyp) loop
1130 Conctyp := Scope (Conctyp);
1131 end loop;
1132
1133 -- Protected case
1134
1135 if Is_Protected_Type (Conctyp) then
1136
1137 if Abort_Allowed
1138 or else Restrictions (No_Entry_Queue) = False
1139 or else Number_Entries (Conctyp) > 1
1140 then
1141 Name := New_Reference_To (RTE (RE_Protected_Count), Loc);
1142
1143 Call :=
1144 Make_Function_Call (Loc,
1145 Name => Name,
1146 Parameter_Associations => New_List (
1147 New_Reference_To (
1148 Object_Ref (
1149 Corresponding_Body (Parent (Conctyp))), Loc),
1150 Entry_Index_Expression (
1151 Loc, Entity (Entnam), Index, Scope (Entity (Entnam)))));
1152 else
1153 Name := New_Reference_To (RTE (RE_Protected_Count_Entry), Loc);
1154
1155 Call := Make_Function_Call (Loc,
1156 Name => Name,
1157 Parameter_Associations => New_List (
1158 New_Reference_To (
1159 Object_Ref (
1160 Corresponding_Body (Parent (Conctyp))), Loc)));
1161 end if;
1162
1163 -- Task case
1164
1165 else
1166 Call :=
1167 Make_Function_Call (Loc,
1168 Name => New_Reference_To (RTE (RE_Task_Count), Loc),
1169 Parameter_Associations => New_List (
1170 Entry_Index_Expression
1171 (Loc, Entity (Entnam), Index, Scope (Entity (Entnam)))));
1172 end if;
1173
1174 -- The call returns type Natural but the context is universal integer
1175 -- so any integer type is allowed. The attribute was already resolved
1176 -- so its Etype is the required result type. If the base type of the
1177 -- context type is other than Standard.Integer we put in a conversion
1178 -- to the required type. This can be a normal typed conversion since
1179 -- both input and output types of the conversion are integer types
1180
1181 if Base_Type (Typ) /= Base_Type (Standard_Integer) then
1182 Rewrite (N, Convert_To (Typ, Call));
1183 else
1184 Rewrite (N, Call);
1185 end if;
1186
1187 Analyze_And_Resolve (N, Typ);
1188 end Count;
1189
1190 ---------------
1191 -- Elab_Body --
1192 ---------------
1193
1194 -- This processing is shared by Elab_Spec
1195
1196 -- What we do is to insert the following declarations
1197
1198 -- procedure tnn;
1199 -- pragma Import (C, enn, "name___elabb/s");
1200
1201 -- and then the Elab_Body/Spec attribute is replaced by a reference
1202 -- to this defining identifier.
1203
1204 when Attribute_Elab_Body |
1205 Attribute_Elab_Spec =>
1206
1207 Elab_Body : declare
1208 Ent : constant Entity_Id :=
1209 Make_Defining_Identifier (Loc,
1210 New_Internal_Name ('E'));
1211 Str : String_Id;
1212 Lang : Node_Id;
1213
1214 procedure Make_Elab_String (Nod : Node_Id);
1215 -- Given Nod, an identifier, or a selected component, put the
1216 -- image into the current string literal, with double underline
1217 -- between components.
1218
1219 procedure Make_Elab_String (Nod : Node_Id) is
1220 begin
1221 if Nkind (Nod) = N_Selected_Component then
1222 Make_Elab_String (Prefix (Nod));
1223 if Java_VM then
1224 Store_String_Char ('$');
1225 else
1226 Store_String_Char ('_');
1227 Store_String_Char ('_');
1228 end if;
1229
1230 Get_Name_String (Chars (Selector_Name (Nod)));
1231
1232 else
1233 pragma Assert (Nkind (Nod) = N_Identifier);
1234 Get_Name_String (Chars (Nod));
1235 end if;
1236
1237 Store_String_Chars (Name_Buffer (1 .. Name_Len));
1238 end Make_Elab_String;
1239
1240 -- Start of processing for Elab_Body/Elab_Spec
1241
1242 begin
1243 -- First we need to prepare the string literal for the name of
1244 -- the elaboration routine to be referenced.
1245
1246 Start_String;
1247 Make_Elab_String (Pref);
1248
1249 if Java_VM then
1250 Store_String_Chars ("._elab");
1251 Lang := Make_Identifier (Loc, Name_Ada);
1252 else
1253 Store_String_Chars ("___elab");
1254 Lang := Make_Identifier (Loc, Name_C);
1255 end if;
1256
1257 if Id = Attribute_Elab_Body then
1258 Store_String_Char ('b');
1259 else
1260 Store_String_Char ('s');
1261 end if;
1262
1263 Str := End_String;
1264
1265 Insert_Actions (N, New_List (
1266 Make_Subprogram_Declaration (Loc,
1267 Specification =>
1268 Make_Procedure_Specification (Loc,
1269 Defining_Unit_Name => Ent)),
1270
1271 Make_Pragma (Loc,
1272 Chars => Name_Import,
1273 Pragma_Argument_Associations => New_List (
1274 Make_Pragma_Argument_Association (Loc,
1275 Expression => Lang),
1276
1277 Make_Pragma_Argument_Association (Loc,
1278 Expression =>
1279 Make_Identifier (Loc, Chars (Ent))),
1280
1281 Make_Pragma_Argument_Association (Loc,
1282 Expression =>
1283 Make_String_Literal (Loc, Str))))));
1284
1285 Set_Entity (N, Ent);
1286 Rewrite (N, New_Occurrence_Of (Ent, Loc));
1287 end Elab_Body;
1288
1289 ----------------
1290 -- Elaborated --
1291 ----------------
1292
1293 -- Elaborated is always True for preelaborated units, predefined
1294 -- units, pure units and units which have Elaborate_Body pragmas.
1295 -- These units have no elaboration entity.
1296
1297 -- Note: The Elaborated attribute is never passed through to Gigi
1298
1299 when Attribute_Elaborated => Elaborated : declare
1300 Ent : constant Entity_Id := Entity (Pref);
1301
1302 begin
1303 if Present (Elaboration_Entity (Ent)) then
1304 Rewrite (N,
1305 New_Occurrence_Of (Elaboration_Entity (Ent), Loc));
1306 else
1307 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
1308 end if;
1309 end Elaborated;
1310
1311 --------------
1312 -- Enum_Rep --
1313 --------------
1314
1315 when Attribute_Enum_Rep => Enum_Rep :
1316 begin
1317 -- X'Enum_Rep (Y) expands to
1318
1319 -- target-type (Y)
1320
1321 -- This is simply a direct conversion from the enumeration type
1322 -- to the target integer type, which is treated by Gigi as a normal
1323 -- integer conversion, treating the enumeration type as an integer,
1324 -- which is exactly what we want! We set Conversion_OK to make sure
1325 -- that the analyzer does not complain about what otherwise might
1326 -- be an illegal conversion.
1327
1328 if Is_Non_Empty_List (Exprs) then
1329 Rewrite (N,
1330 OK_Convert_To (Typ, Relocate_Node (First (Exprs))));
1331
1332 -- X'Enum_Rep where X is an enumeration literal is replaced by
1333 -- the literal value.
1334
1335 elsif Ekind (Entity (Pref)) = E_Enumeration_Literal then
1336 Rewrite (N,
1337 Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref))));
1338
1339 -- X'Enum_Rep where X is an object does a direct unchecked conversion
1340 -- of the object value, as described for the type case above.
1341
1342 else
1343 Rewrite (N,
1344 OK_Convert_To (Typ, Relocate_Node (Pref)));
1345 end if;
1346
1347 Set_Etype (N, Typ);
1348 Analyze_And_Resolve (N, Typ);
1349
1350 end Enum_Rep;
1351
1352 --------------
1353 -- Exponent --
1354 --------------
1355
1356 -- Transforms 'Exponent into a call to the floating-point attribute
1357 -- function Exponent in Fat_xxx (where xxx is the root type)
1358
1359 when Attribute_Exponent =>
1360 Expand_Fpt_Attribute_R (N);
1361
1362 ------------------
1363 -- External_Tag --
1364 ------------------
1365
1366 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
1367
1368 when Attribute_External_Tag => External_Tag :
1369 begin
1370 Rewrite (N,
1371 Make_Function_Call (Loc,
1372 Name => New_Reference_To (RTE (RE_External_Tag), Loc),
1373 Parameter_Associations => New_List (
1374 Make_Attribute_Reference (Loc,
1375 Attribute_Name => Name_Tag,
1376 Prefix => Prefix (N)))));
1377
1378 Analyze_And_Resolve (N, Standard_String);
1379 end External_Tag;
1380
1381 -----------
1382 -- First --
1383 -----------
1384
1385 when Attribute_First => declare
1386 Ptyp : constant Entity_Id := Etype (Pref);
1387
1388 begin
1389 -- If the prefix type is a constrained packed array type which
1390 -- already has a Packed_Array_Type representation defined, then
1391 -- replace this attribute with a direct reference to 'First of the
1392 -- appropriate index subtype (since otherwise Gigi will try to give
1393 -- us the value of 'First for this implementation type).
1394
1395 if Is_Constrained_Packed_Array (Ptyp) then
1396 Rewrite (N,
1397 Make_Attribute_Reference (Loc,
1398 Attribute_Name => Name_First,
1399 Prefix => New_Reference_To (Get_Index_Subtype (N), Loc)));
1400 Analyze_And_Resolve (N, Typ);
1401
1402 elsif Is_Access_Type (Ptyp) then
1403 Apply_Access_Check (N);
1404 end if;
1405 end;
1406
1407 ---------------
1408 -- First_Bit --
1409 ---------------
1410
1411 -- We compute this if a component clause was present, otherwise
1412 -- we leave the computation up to Gigi, since we don't know what
1413 -- layout will be chosen.
1414
1415 when Attribute_First_Bit => First_Bit :
1416 declare
1417 CE : constant Entity_Id := Entity (Selector_Name (Pref));
1418
1419 begin
1420 if Known_Static_Component_Bit_Offset (CE) then
1421 Rewrite (N,
1422 Make_Integer_Literal (Loc,
1423 Component_Bit_Offset (CE) mod System_Storage_Unit));
1424
1425 Analyze_And_Resolve (N, Typ);
1426
1427 else
1428 Apply_Universal_Integer_Attribute_Checks (N);
1429 end if;
1430 end First_Bit;
1431
1432 -----------------
1433 -- Fixed_Value --
1434 -----------------
1435
1436 -- We transform:
1437
1438 -- fixtype'Fixed_Value (integer-value)
1439
1440 -- into
1441
1442 -- fixtype(integer-value)
1443
1444 -- we do all the required analysis of the conversion here, because
1445 -- we do not want this to go through the fixed-point conversion
1446 -- circuits. Note that gigi always treats fixed-point as equivalent
1447 -- to the corresponding integer type anyway.
1448
1449 when Attribute_Fixed_Value => Fixed_Value :
1450 begin
1451 Rewrite (N,
1452 Make_Type_Conversion (Loc,
1453 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
1454 Expression => Relocate_Node (First (Exprs))));
1455 Set_Etype (N, Entity (Pref));
1456 Set_Analyzed (N);
1457 Apply_Type_Conversion_Checks (N);
1458 end Fixed_Value;
1459
1460 -----------
1461 -- Floor --
1462 -----------
1463
1464 -- Transforms 'Floor into a call to the floating-point attribute
1465 -- function Floor in Fat_xxx (where xxx is the root type)
1466
1467 when Attribute_Floor =>
1468 Expand_Fpt_Attribute_R (N);
1469
1470 ----------
1471 -- Fore --
1472 ----------
1473
1474 -- For the fixed-point type Typ:
1475
1476 -- Typ'Fore
1477
1478 -- expands into
1479
1480 -- Result_Type (System.Fore (Long_Long_Float (Type'First)),
1481 -- Long_Long_Float (Type'Last))
1482
1483 -- Note that we know that the type is a non-static subtype, or Fore
1484 -- would have itself been computed dynamically in Eval_Attribute.
1485
1486 when Attribute_Fore => Fore :
1487 declare
1488 Ptyp : constant Entity_Id := Etype (Pref);
1489
1490 begin
1491 Rewrite (N,
1492 Convert_To (Typ,
1493 Make_Function_Call (Loc,
1494 Name => New_Reference_To (RTE (RE_Fore), Loc),
1495
1496 Parameter_Associations => New_List (
1497 Convert_To (Standard_Long_Long_Float,
1498 Make_Attribute_Reference (Loc,
1499 Prefix => New_Reference_To (Ptyp, Loc),
1500 Attribute_Name => Name_First)),
1501
1502 Convert_To (Standard_Long_Long_Float,
1503 Make_Attribute_Reference (Loc,
1504 Prefix => New_Reference_To (Ptyp, Loc),
1505 Attribute_Name => Name_Last))))));
1506
1507 Analyze_And_Resolve (N, Typ);
1508 end Fore;
1509
1510 --------------
1511 -- Fraction --
1512 --------------
1513
1514 -- Transforms 'Fraction into a call to the floating-point attribute
1515 -- function Fraction in Fat_xxx (where xxx is the root type)
1516
1517 when Attribute_Fraction =>
1518 Expand_Fpt_Attribute_R (N);
1519
1520 --------------
1521 -- Identity --
1522 --------------
1523
1524 -- For an exception returns a reference to the exception data:
1525 -- Exception_Id!(Prefix'Reference)
1526
1527 -- For a task it returns a reference to the _task_id component of
1528 -- corresponding record:
1529
1530 -- taskV!(Prefix)._Task_Id, converted to the type Task_ID defined
1531
1532 -- in Ada.Task_Identification.
1533
1534 when Attribute_Identity => Identity : declare
1535 Id_Kind : Entity_Id;
1536
1537 begin
1538 if Etype (Pref) = Standard_Exception_Type then
1539 Id_Kind := RTE (RE_Exception_Id);
1540
1541 if Present (Renamed_Object (Entity (Pref))) then
1542 Set_Entity (Pref, Renamed_Object (Entity (Pref)));
1543 end if;
1544
1545 Rewrite (N,
1546 Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref)));
1547 else
1548 Id_Kind := RTE (RO_AT_Task_ID);
1549
1550 Rewrite (N,
1551 Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
1552 end if;
1553
1554 Analyze_And_Resolve (N, Id_Kind);
1555 end Identity;
1556
1557 -----------
1558 -- Image --
1559 -----------
1560
1561 -- Image attribute is handled in separate unit Exp_Imgv
1562
1563 when Attribute_Image =>
1564 Exp_Imgv.Expand_Image_Attribute (N);
1565
1566 ---------
1567 -- Img --
1568 ---------
1569
1570 -- X'Img is expanded to typ'Image (X), where typ is the type of X
1571
1572 when Attribute_Img => Img :
1573 begin
1574 Rewrite (N,
1575 Make_Attribute_Reference (Loc,
1576 Prefix => New_Reference_To (Etype (Pref), Loc),
1577 Attribute_Name => Name_Image,
1578 Expressions => New_List (Relocate_Node (Pref))));
1579
1580 Analyze_And_Resolve (N, Standard_String);
1581 end Img;
1582
1583 -----------
1584 -- Input --
1585 -----------
1586
1587 when Attribute_Input => Input : declare
1588 P_Type : constant Entity_Id := Entity (Pref);
1589 B_Type : constant Entity_Id := Base_Type (P_Type);
1590 U_Type : constant Entity_Id := Underlying_Type (P_Type);
1591 Strm : constant Node_Id := First (Exprs);
1592 Fname : Entity_Id;
1593 Decl : Node_Id;
1594 Call : Node_Id;
1595 Prag : Node_Id;
1596 Arg2 : Node_Id;
1597 Rfunc : Node_Id;
1598
1599 Cntrl : Node_Id := Empty;
1600 -- Value for controlling argument in call. Always Empty except in
1601 -- the dispatching (class-wide type) case, where it is a reference
1602 -- to the dummy object initialized to the right internal tag.
1603
1604 begin
1605 -- If no underlying type, we have an error that will be diagnosed
1606 -- elsewhere, so here we just completely ignore the expansion.
1607
1608 if No (U_Type) then
1609 return;
1610 end if;
1611
1612 -- If there is a TSS for Input, just call it
1613
1614 Fname := Find_Inherited_TSS (P_Type, Name_uInput);
1615
1616 if Present (Fname) then
1617 null;
1618
1619 else
1620 -- If there is a Stream_Convert pragma, use it, we rewrite
1621
1622 -- sourcetyp'Input (stream)
1623
1624 -- as
1625
1626 -- sourcetyp (streamread (strmtyp'Input (stream)));
1627
1628 -- where stmrearead is the given Read function that converts
1629 -- an argument of type strmtyp to type sourcetyp or a type
1630 -- from which it is derived. The extra conversion is required
1631 -- for the derived case.
1632
1633 Prag :=
1634 Get_Rep_Pragma
1635 (Implementation_Base_Type (P_Type), Name_Stream_Convert);
1636
1637 if Present (Prag) then
1638 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
1639 Rfunc := Entity (Expression (Arg2));
1640
1641 Rewrite (N,
1642 Convert_To (B_Type,
1643 Make_Function_Call (Loc,
1644 Name => New_Occurrence_Of (Rfunc, Loc),
1645 Parameter_Associations => New_List (
1646 Make_Attribute_Reference (Loc,
1647 Prefix =>
1648 New_Occurrence_Of
1649 (Etype (First_Formal (Rfunc)), Loc),
1650 Attribute_Name => Name_Input,
1651 Expressions => Exprs)))));
1652
1653 Analyze_And_Resolve (N, B_Type);
1654 return;
1655
1656 -- Elementary types
1657
1658 elsif Is_Elementary_Type (U_Type) then
1659
1660 -- A special case arises if we have a defined _Read routine,
1661 -- since in this case we are required to call this routine.
1662
1663 if Present (TSS (B_Type, Name_uRead)) then
1664 Build_Record_Or_Elementary_Input_Function
1665 (Loc, U_Type, Decl, Fname);
1666 Insert_Action (N, Decl);
1667
1668 -- For normal cases, we call the I_xxx routine directly
1669
1670 else
1671 Rewrite (N, Build_Elementary_Input_Call (N));
1672 Analyze_And_Resolve (N, P_Type);
1673 return;
1674 end if;
1675
1676 -- Array type case
1677
1678 elsif Is_Array_Type (U_Type) then
1679 Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
1680 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
1681
1682 -- Dispatching case with class-wide type
1683
1684 elsif Is_Class_Wide_Type (P_Type) then
1685
1686 declare
1687 Rtyp : constant Entity_Id := Root_Type (P_Type);
1688 Dnn : Entity_Id;
1689 Decl : Node_Id;
1690
1691 begin
1692 -- Read the internal tag (RM 13.13.2(34)) and use it to
1693 -- initialize a dummy tag object:
1694
1695 -- Dnn : Ada.Tags.Tag
1696 -- := Internal_Tag (String'Input (Strm));
1697
1698 -- This dummy object is used only to provide a controlling
1699 -- argument for the eventual _Input call.
1700
1701 Dnn :=
1702 Make_Defining_Identifier (Loc,
1703 Chars => New_Internal_Name ('D'));
1704
1705 Decl :=
1706 Make_Object_Declaration (Loc,
1707 Defining_Identifier => Dnn,
1708 Object_Definition =>
1709 New_Occurrence_Of (RTE (RE_Tag), Loc),
1710 Expression =>
1711 Make_Function_Call (Loc,
1712 Name =>
1713 New_Occurrence_Of (RTE (RE_Internal_Tag), Loc),
1714 Parameter_Associations => New_List (
1715 Make_Attribute_Reference (Loc,
1716 Prefix =>
1717 New_Occurrence_Of (Standard_String, Loc),
1718 Attribute_Name => Name_Input,
1719 Expressions => New_List (
1720 Relocate_Node
1721 (Duplicate_Subexpr (Strm)))))));
1722
1723 Insert_Action (N, Decl);
1724
1725 -- Now we need to get the entity for the call, and construct
1726 -- a function call node, where we preset a reference to Dnn
1727 -- as the controlling argument (doing an unchecked
1728 -- conversion to the tagged type to make it look like
1729 -- a real tagged object).
1730
1731 Fname := Find_Prim_Op (Rtyp, Name_uInput);
1732 Cntrl := Unchecked_Convert_To (Rtyp,
1733 New_Occurrence_Of (Dnn, Loc));
1734 Set_Etype (Cntrl, Rtyp);
1735 Set_Parent (Cntrl, N);
1736 end;
1737
1738 -- For tagged types, use the primitive Input function
1739
1740 elsif Is_Tagged_Type (U_Type) then
1741 Fname := Find_Prim_Op (U_Type, Name_uInput);
1742
1743 -- All other record type cases, including protected records.
1744 -- The latter only arise for expander generated code for
1745 -- handling shared passive partition access.
1746
1747 else
1748 pragma Assert
1749 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
1750
1751 Build_Record_Or_Elementary_Input_Function
1752 (Loc, Base_Type (U_Type), Decl, Fname);
1753 Insert_Action (N, Decl);
1754 end if;
1755 end if;
1756
1757 -- If we fall through, Fname is the function to be called. The
1758 -- result is obtained by calling the appropriate function, then
1759 -- converting the result. The conversion does a subtype check.
1760
1761 Call :=
1762 Make_Function_Call (Loc,
1763 Name => New_Occurrence_Of (Fname, Loc),
1764 Parameter_Associations => New_List (
1765 Relocate_Node (Strm)));
1766
1767 Set_Controlling_Argument (Call, Cntrl);
1768 Rewrite (N, Unchecked_Convert_To (P_Type, Call));
1769 Analyze_And_Resolve (N, P_Type);
1770 end Input;
1771
1772 -------------------
1773 -- Integer_Value --
1774 -------------------
1775
1776 -- We transform
1777
1778 -- inttype'Fixed_Value (fixed-value)
1779
1780 -- into
1781
1782 -- inttype(integer-value))
1783
1784 -- we do all the required analysis of the conversion here, because
1785 -- we do not want this to go through the fixed-point conversion
1786 -- circuits. Note that gigi always treats fixed-point as equivalent
1787 -- to the corresponding integer type anyway.
1788
1789 when Attribute_Integer_Value => Integer_Value :
1790 begin
1791 Rewrite (N,
1792 Make_Type_Conversion (Loc,
1793 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
1794 Expression => Relocate_Node (First (Exprs))));
1795 Set_Etype (N, Entity (Pref));
1796 Set_Analyzed (N);
1797 Apply_Type_Conversion_Checks (N);
1798 end Integer_Value;
1799
1800 ----------
1801 -- Last --
1802 ----------
1803
1804 when Attribute_Last => declare
1805 Ptyp : constant Entity_Id := Etype (Pref);
1806
1807 begin
1808 -- If the prefix type is a constrained packed array type which
1809 -- already has a Packed_Array_Type representation defined, then
1810 -- replace this attribute with a direct reference to 'Last of the
1811 -- appropriate index subtype (since otherwise Gigi will try to give
1812 -- us the value of 'Last for this implementation type).
1813
1814 if Is_Constrained_Packed_Array (Ptyp) then
1815 Rewrite (N,
1816 Make_Attribute_Reference (Loc,
1817 Attribute_Name => Name_Last,
1818 Prefix => New_Reference_To (Get_Index_Subtype (N), Loc)));
1819 Analyze_And_Resolve (N, Typ);
1820
1821 elsif Is_Access_Type (Ptyp) then
1822 Apply_Access_Check (N);
1823 end if;
1824 end;
1825
1826 --------------
1827 -- Last_Bit --
1828 --------------
1829
1830 -- We compute this if a component clause was present, otherwise
1831 -- we leave the computation up to Gigi, since we don't know what
1832 -- layout will be chosen.
1833
1834 when Attribute_Last_Bit => Last_Bit :
1835 declare
1836 CE : constant Entity_Id := Entity (Selector_Name (Pref));
1837
1838 begin
1839 if Known_Static_Component_Bit_Offset (CE)
1840 and then Known_Static_Esize (CE)
1841 then
1842 Rewrite (N,
1843 Make_Integer_Literal (Loc,
1844 Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
1845 + Esize (CE) - 1));
1846
1847 Analyze_And_Resolve (N, Typ);
1848
1849 else
1850 Apply_Universal_Integer_Attribute_Checks (N);
1851 end if;
1852 end Last_Bit;
1853
1854 ------------------
1855 -- Leading_Part --
1856 ------------------
1857
1858 -- Transforms 'Leading_Part into a call to the floating-point attribute
1859 -- function Leading_Part in Fat_xxx (where xxx is the root type)
1860
1861 -- Note: strictly, we should have special case code to deal with
1862 -- absurdly large positive arguments (greater than Integer'Last),
1863 -- which result in returning the first argument unchanged, but it
1864 -- hardly seems worth the effort. We raise constraint error for
1865 -- absurdly negative arguments which is fine.
1866
1867 when Attribute_Leading_Part =>
1868 Expand_Fpt_Attribute_RI (N);
1869
1870 ------------
1871 -- Length --
1872 ------------
1873
1874 when Attribute_Length => declare
1875 Ptyp : constant Entity_Id := Etype (Pref);
1876 Ityp : Entity_Id;
1877 Xnum : Uint;
1878
1879 begin
1880 -- Processing for packed array types
1881
1882 if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
1883 Ityp := Get_Index_Subtype (N);
1884
1885 -- If the index type, Ityp, is an enumeration type with
1886 -- holes, then we calculate X'Length explicitly using
1887
1888 -- Typ'Max
1889 -- (0, Ityp'Pos (X'Last (N)) -
1890 -- Ityp'Pos (X'First (N)) + 1);
1891
1892 -- Since the bounds in the template are the representation
1893 -- values and gigi would get the wrong value.
1894
1895 if Is_Enumeration_Type (Ityp)
1896 and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
1897 then
1898 if No (Exprs) then
1899 Xnum := Uint_1;
1900 else
1901 Xnum := Expr_Value (First (Expressions (N)));
1902 end if;
1903
1904 Rewrite (N,
1905 Make_Attribute_Reference (Loc,
1906 Prefix => New_Occurrence_Of (Typ, Loc),
1907 Attribute_Name => Name_Max,
1908 Expressions => New_List
1909 (Make_Integer_Literal (Loc, 0),
1910
1911 Make_Op_Add (Loc,
1912 Left_Opnd =>
1913 Make_Op_Subtract (Loc,
1914 Left_Opnd =>
1915 Make_Attribute_Reference (Loc,
1916 Prefix => New_Occurrence_Of (Ityp, Loc),
1917 Attribute_Name => Name_Pos,
1918
1919 Expressions => New_List (
1920 Make_Attribute_Reference (Loc,
1921 Prefix => Duplicate_Subexpr (Pref),
1922 Attribute_Name => Name_Last,
1923 Expressions => New_List (
1924 Make_Integer_Literal (Loc, Xnum))))),
1925
1926 Right_Opnd =>
1927 Make_Attribute_Reference (Loc,
1928 Prefix => New_Occurrence_Of (Ityp, Loc),
1929 Attribute_Name => Name_Pos,
1930
1931 Expressions => New_List (
1932 Make_Attribute_Reference (Loc,
1933 Prefix => Duplicate_Subexpr (Pref),
1934 Attribute_Name => Name_First,
1935 Expressions => New_List (
1936 Make_Integer_Literal (Loc, Xnum)))))),
1937
1938 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
1939
1940 Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
1941 return;
1942
1943 -- If the prefix type is a constrained packed array type which
1944 -- already has a Packed_Array_Type representation defined, then
1945 -- replace this attribute with a direct reference to 'Range_Length
1946 -- of the appropriate index subtype (since otherwise Gigi will try
1947 -- to give us the value of 'Length for this implementation type).
1948
1949 elsif Is_Constrained (Ptyp) then
1950 Rewrite (N,
1951 Make_Attribute_Reference (Loc,
1952 Attribute_Name => Name_Range_Length,
1953 Prefix => New_Reference_To (Ityp, Loc)));
1954 Analyze_And_Resolve (N, Typ);
1955 end if;
1956
1957 -- If we have a packed array that is not bit packed, which was
1958
1959 -- Access type case
1960
1961 elsif Is_Access_Type (Ptyp) then
1962 Apply_Access_Check (N);
1963
1964 -- If the designated type is a packed array type, then we
1965 -- convert the reference to:
1966
1967 -- typ'Max (0, 1 +
1968 -- xtyp'Pos (Pref'Last (Expr)) -
1969 -- xtyp'Pos (Pref'First (Expr)));
1970
1971 -- This is a bit complex, but it is the easiest thing to do
1972 -- that works in all cases including enum types with holes
1973 -- xtyp here is the appropriate index type.
1974
1975 declare
1976 Dtyp : constant Entity_Id := Designated_Type (Ptyp);
1977 Xtyp : Entity_Id;
1978
1979 begin
1980 if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
1981 Xtyp := Get_Index_Subtype (N);
1982
1983 Rewrite (N,
1984 Make_Attribute_Reference (Loc,
1985 Prefix => New_Occurrence_Of (Typ, Loc),
1986 Attribute_Name => Name_Max,
1987 Expressions => New_List (
1988 Make_Integer_Literal (Loc, 0),
1989
1990 Make_Op_Add (Loc,
1991 Make_Integer_Literal (Loc, 1),
1992 Make_Op_Subtract (Loc,
1993 Left_Opnd =>
1994 Make_Attribute_Reference (Loc,
1995 Prefix => New_Occurrence_Of (Xtyp, Loc),
1996 Attribute_Name => Name_Pos,
1997 Expressions => New_List (
1998 Make_Attribute_Reference (Loc,
1999 Prefix => Duplicate_Subexpr (Pref),
2000 Attribute_Name => Name_Last,
2001 Expressions =>
2002 New_Copy_List (Exprs)))),
2003
2004 Right_Opnd =>
2005 Make_Attribute_Reference (Loc,
2006 Prefix => New_Occurrence_Of (Xtyp, Loc),
2007 Attribute_Name => Name_Pos,
2008 Expressions => New_List (
2009 Make_Attribute_Reference (Loc,
2010 Prefix => Duplicate_Subexpr (Pref),
2011 Attribute_Name => Name_First,
2012 Expressions =>
2013 New_Copy_List (Exprs)))))))));
2014
2015 Analyze_And_Resolve (N, Typ);
2016 end if;
2017 end;
2018
2019 -- Otherwise leave it to gigi
2020
2021 else
2022 Apply_Universal_Integer_Attribute_Checks (N);
2023 end if;
2024 end;
2025
2026 -------------
2027 -- Machine --
2028 -------------
2029
2030 -- Transforms 'Machine into a call to the floating-point attribute
2031 -- function Machine in Fat_xxx (where xxx is the root type)
2032
2033 when Attribute_Machine =>
2034 Expand_Fpt_Attribute_R (N);
2035
2036 ------------------
2037 -- Machine_Size --
2038 ------------------
2039
2040 -- Machine_Size is equivalent to Object_Size, so transform it into
2041 -- Object_Size and that way Gigi never sees Machine_Size.
2042
2043 when Attribute_Machine_Size =>
2044 Rewrite (N,
2045 Make_Attribute_Reference (Loc,
2046 Prefix => Prefix (N),
2047 Attribute_Name => Name_Object_Size));
2048
2049 Analyze_And_Resolve (N, Typ);
2050
2051 --------------
2052 -- Mantissa --
2053 --------------
2054
2055 -- The only case that can get this far is the dynamic case of the
2056 -- old Ada 83 Mantissa attribute for the fixed-point case. For this
2057 -- case, we expand:
2058
2059 -- typ'Mantissa
2060
2061 -- into
2062
2063 -- ityp (System.Mantissa.Mantissa_Value
2064 -- (Integer'Integer_Value (typ'First),
2065 -- Integer'Integer_Value (typ'Last)));
2066
2067 when Attribute_Mantissa => Mantissa : declare
2068 Ptyp : constant Entity_Id := Etype (Pref);
2069
2070 begin
2071 Rewrite (N,
2072 Convert_To (Typ,
2073 Make_Function_Call (Loc,
2074 Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
2075
2076 Parameter_Associations => New_List (
2077
2078 Make_Attribute_Reference (Loc,
2079 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2080 Attribute_Name => Name_Integer_Value,
2081 Expressions => New_List (
2082
2083 Make_Attribute_Reference (Loc,
2084 Prefix => New_Occurrence_Of (Ptyp, Loc),
2085 Attribute_Name => Name_First))),
2086
2087 Make_Attribute_Reference (Loc,
2088 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2089 Attribute_Name => Name_Integer_Value,
2090 Expressions => New_List (
2091
2092 Make_Attribute_Reference (Loc,
2093 Prefix => New_Occurrence_Of (Ptyp, Loc),
2094 Attribute_Name => Name_Last)))))));
2095
2096 Analyze_And_Resolve (N, Typ);
2097 end Mantissa;
2098
2099 -----------
2100 -- Model --
2101 -----------
2102
2103 -- Transforms 'Model into a call to the floating-point attribute
2104 -- function Model in Fat_xxx (where xxx is the root type)
2105
2106 when Attribute_Model =>
2107 Expand_Fpt_Attribute_R (N);
2108
2109 -----------------
2110 -- Object_Size --
2111 -----------------
2112
2113 -- The processing for Object_Size shares the processing for Size
2114
2115 ------------
2116 -- Output --
2117 ------------
2118
2119 when Attribute_Output => Output : declare
2120 P_Type : constant Entity_Id := Entity (Pref);
2121 B_Type : constant Entity_Id := Base_Type (P_Type);
2122 U_Type : constant Entity_Id := Underlying_Type (P_Type);
2123 Pname : Entity_Id;
2124 Decl : Node_Id;
2125 Prag : Node_Id;
2126 Arg3 : Node_Id;
2127 Wfunc : Node_Id;
2128
2129 begin
2130 -- If no underlying type, we have an error that will be diagnosed
2131 -- elsewhere, so here we just completely ignore the expansion.
2132
2133 if No (U_Type) then
2134 return;
2135 end if;
2136
2137 -- If TSS for Output is present, just call it
2138
2139 Pname := Find_Inherited_TSS (P_Type, Name_uOutput);
2140
2141 if Present (Pname) then
2142 null;
2143
2144 else
2145 -- If there is a Stream_Convert pragma, use it, we rewrite
2146
2147 -- sourcetyp'Output (stream, Item)
2148
2149 -- as
2150
2151 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
2152
2153 -- where strmwrite is the given Write function that converts
2154 -- an argument of type sourcetyp or a type acctyp, from which
2155 -- it is derived to type strmtyp. The conversion to acttyp is
2156 -- required for the derived case.
2157
2158 Prag :=
2159 Get_Rep_Pragma
2160 (Implementation_Base_Type (P_Type), Name_Stream_Convert);
2161
2162 if Present (Prag) then
2163 Arg3 :=
2164 Next (Next (First (Pragma_Argument_Associations (Prag))));
2165 Wfunc := Entity (Expression (Arg3));
2166
2167 Rewrite (N,
2168 Make_Attribute_Reference (Loc,
2169 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
2170 Attribute_Name => Name_Output,
2171 Expressions => New_List (
2172 Relocate_Node (First (Exprs)),
2173 Make_Function_Call (Loc,
2174 Name => New_Occurrence_Of (Wfunc, Loc),
2175 Parameter_Associations => New_List (
2176 Convert_To (Etype (First_Formal (Wfunc)),
2177 Relocate_Node (Next (First (Exprs)))))))));
2178
2179 Analyze (N);
2180 return;
2181
2182 -- For elementary types, we call the W_xxx routine directly.
2183 -- Note that the effect of Write and Output is identical for
2184 -- the case of an elementary type, since there are no
2185 -- discriminants or bounds.
2186
2187 elsif Is_Elementary_Type (U_Type) then
2188
2189 -- A special case arises if we have a defined _Write routine,
2190 -- since in this case we are required to call this routine.
2191
2192 if Present (TSS (B_Type, Name_uWrite)) then
2193 Build_Record_Or_Elementary_Output_Procedure
2194 (Loc, U_Type, Decl, Pname);
2195 Insert_Action (N, Decl);
2196
2197 -- For normal cases, we call the W_xxx routine directly
2198
2199 else
2200 Rewrite (N, Build_Elementary_Write_Call (N));
2201 Analyze (N);
2202 return;
2203 end if;
2204
2205 -- Array type case
2206
2207 elsif Is_Array_Type (U_Type) then
2208 Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
2209 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
2210
2211 -- Class-wide case, first output external tag, then dispatch
2212 -- to the appropriate primitive Output function (RM 13.13.2(31)).
2213
2214 elsif Is_Class_Wide_Type (P_Type) then
2215 Tag_Write : declare
2216 Strm : constant Node_Id := First (Exprs);
2217 Item : constant Node_Id := Next (Strm);
2218
2219 begin
2220 -- The code is:
2221 -- String'Output (Strm, External_Tag (Item'Tag))
2222
2223 Insert_Action (N,
2224 Make_Attribute_Reference (Loc,
2225 Prefix => New_Occurrence_Of (Standard_String, Loc),
2226 Attribute_Name => Name_Output,
2227 Expressions => New_List (
2228 Relocate_Node (Duplicate_Subexpr (Strm)),
2229 Make_Function_Call (Loc,
2230 Name =>
2231 New_Occurrence_Of (RTE (RE_External_Tag), Loc),
2232 Parameter_Associations => New_List (
2233 Make_Attribute_Reference (Loc,
2234 Prefix =>
2235 Relocate_Node
2236 (Duplicate_Subexpr (Item, Name_Req => True)),
2237 Attribute_Name => Name_Tag))))));
2238 end Tag_Write;
2239
2240 Pname := Find_Prim_Op (U_Type, Name_uOutput);
2241
2242 -- Tagged type case, use the primitive Output function
2243
2244 elsif Is_Tagged_Type (U_Type) then
2245 Pname := Find_Prim_Op (U_Type, Name_uOutput);
2246
2247 -- All other record type cases, including protected records.
2248 -- The latter only arise for expander generated code for
2249 -- handling shared passive partition access.
2250
2251 else
2252 pragma Assert
2253 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
2254
2255 Build_Record_Or_Elementary_Output_Procedure
2256 (Loc, Base_Type (U_Type), Decl, Pname);
2257 Insert_Action (N, Decl);
2258 end if;
2259 end if;
2260
2261 -- If we fall through, Pname is the name of the procedure to call
2262
2263 Rewrite_Stream_Proc_Call (Pname);
2264 end Output;
2265
2266 ---------
2267 -- Pos --
2268 ---------
2269
2270 -- For enumeration types with a standard representation, Pos is
2271 -- handled by Gigi.
2272
2273 -- For enumeration types, with a non-standard representation we
2274 -- generate a call to the _Rep_To_Pos function created when the
2275 -- type was frozen. The call has the form
2276
2277 -- _rep_to_pos (expr, True)
2278
2279 -- The parameter True causes Program_Error to be raised if the
2280 -- expression has an invalid representation.
2281
2282 -- For integer types, Pos is equivalent to a simple integer
2283 -- conversion and we rewrite it as such
2284
2285 when Attribute_Pos => Pos :
2286 declare
2287 Etyp : Entity_Id := Base_Type (Entity (Pref));
2288
2289 begin
2290 -- Deal with zero/non-zero boolean values
2291
2292 if Is_Boolean_Type (Etyp) then
2293 Adjust_Condition (First (Exprs));
2294 Etyp := Standard_Boolean;
2295 Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
2296 end if;
2297
2298 -- Case of enumeration type
2299
2300 if Is_Enumeration_Type (Etyp) then
2301
2302 -- Non-standard enumeration type (generate call)
2303
2304 if Present (Enum_Pos_To_Rep (Etyp)) then
2305 Append_To (Exprs, New_Occurrence_Of (Standard_True, Loc));
2306
2307 Rewrite (N,
2308 Convert_To (Typ,
2309 Make_Function_Call (Loc,
2310 Name =>
2311 New_Reference_To (TSS (Etyp, Name_uRep_To_Pos), Loc),
2312 Parameter_Associations => Exprs)));
2313
2314 Analyze_And_Resolve (N, Typ);
2315
2316 -- Standard enumeration type (do universal integer check)
2317
2318 else
2319 Apply_Universal_Integer_Attribute_Checks (N);
2320 end if;
2321
2322 -- Deal with integer types (replace by conversion)
2323
2324 elsif Is_Integer_Type (Etyp) then
2325 Rewrite (N, Convert_To (Typ, First (Exprs)));
2326 Analyze_And_Resolve (N, Typ);
2327 end if;
2328
2329 end Pos;
2330
2331 --------------
2332 -- Position --
2333 --------------
2334
2335 -- We compute this if a component clause was present, otherwise
2336 -- we leave the computation up to Gigi, since we don't know what
2337 -- layout will be chosen.
2338
2339 when Attribute_Position => Position :
2340 declare
2341 CE : constant Entity_Id := Entity (Selector_Name (Pref));
2342
2343 begin
2344 if Present (Component_Clause (CE)) then
2345 Rewrite (N,
2346 Make_Integer_Literal (Loc,
2347 Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
2348 Analyze_And_Resolve (N, Typ);
2349
2350 else
2351 Apply_Universal_Integer_Attribute_Checks (N);
2352 end if;
2353 end Position;
2354
2355 ----------
2356 -- Pred --
2357 ----------
2358
2359 -- 1. Deal with enumeration types with holes
2360 -- 2. For floating-point, generate call to attribute function
2361 -- 3. For other cases, deal with constraint checking
2362
2363 when Attribute_Pred => Pred :
2364 declare
2365 Ptyp : constant Entity_Id := Base_Type (Etype (Pref));
2366
2367 begin
2368 -- For enumeration types with non-standard representations, we
2369 -- expand typ'Pred (x) into
2370
2371 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
2372
2373 if Is_Enumeration_Type (Ptyp)
2374 and then Present (Enum_Pos_To_Rep (Ptyp))
2375 then
2376 -- Add Boolean parameter True, to request program errror if
2377 -- we have a bad representation on our hands.
2378
2379 Append_To (Exprs, New_Occurrence_Of (Standard_True, Loc));
2380
2381 Rewrite (N,
2382 Make_Indexed_Component (Loc,
2383 Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
2384 Expressions => New_List (
2385 Make_Op_Subtract (Loc,
2386 Left_Opnd =>
2387 Make_Function_Call (Loc,
2388 Name =>
2389 New_Reference_To (TSS (Ptyp, Name_uRep_To_Pos), Loc),
2390 Parameter_Associations => Exprs),
2391 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
2392
2393 Analyze_And_Resolve (N, Typ);
2394
2395 -- For floating-point, we transform 'Pred into a call to the Pred
2396 -- floating-point attribute function in Fat_xxx (xxx is root type)
2397
2398 elsif Is_Floating_Point_Type (Ptyp) then
2399 Expand_Fpt_Attribute_R (N);
2400 Analyze_And_Resolve (N, Typ);
2401
2402 -- For modular types, nothing to do (no overflow, since wraps)
2403
2404 elsif Is_Modular_Integer_Type (Ptyp) then
2405 null;
2406
2407 -- For other types, if range checking is enabled, we must generate
2408 -- a check if overflow checking is enabled.
2409
2410 elsif not Overflow_Checks_Suppressed (Ptyp) then
2411 Expand_Pred_Succ (N);
2412 end if;
2413
2414 end Pred;
2415
2416 ------------------
2417 -- Range_Length --
2418 ------------------
2419
2420 when Attribute_Range_Length => Range_Length : declare
2421 P_Type : constant Entity_Id := Etype (Pref);
2422
2423 begin
2424 -- The only special processing required is for the case where
2425 -- Range_Length is applied to an enumeration type with holes.
2426 -- In this case we transform
2427
2428 -- X'Range_Length
2429
2430 -- to
2431
2432 -- X'Pos (X'Last) - X'Pos (X'First) + 1
2433
2434 -- So that the result reflects the proper Pos values instead
2435 -- of the underlying representations.
2436
2437 if Is_Enumeration_Type (P_Type)
2438 and then Has_Non_Standard_Rep (P_Type)
2439 then
2440 Rewrite (N,
2441 Make_Op_Add (Loc,
2442 Left_Opnd =>
2443 Make_Op_Subtract (Loc,
2444 Left_Opnd =>
2445 Make_Attribute_Reference (Loc,
2446 Attribute_Name => Name_Pos,
2447 Prefix => New_Occurrence_Of (P_Type, Loc),
2448 Expressions => New_List (
2449 Make_Attribute_Reference (Loc,
2450 Attribute_Name => Name_Last,
2451 Prefix => New_Occurrence_Of (P_Type, Loc)))),
2452
2453 Right_Opnd =>
2454 Make_Attribute_Reference (Loc,
2455 Attribute_Name => Name_Pos,
2456 Prefix => New_Occurrence_Of (P_Type, Loc),
2457 Expressions => New_List (
2458 Make_Attribute_Reference (Loc,
2459 Attribute_Name => Name_First,
2460 Prefix => New_Occurrence_Of (P_Type, Loc))))),
2461
2462 Right_Opnd =>
2463 Make_Integer_Literal (Loc, 1)));
2464
2465 Analyze_And_Resolve (N, Typ);
2466
2467 -- For all other cases, attribute is handled by Gigi, but we need
2468 -- to deal with the case of the range check on a universal integer.
2469
2470 else
2471 Apply_Universal_Integer_Attribute_Checks (N);
2472 end if;
2473
2474 end Range_Length;
2475
2476 ----------
2477 -- Read --
2478 ----------
2479
2480 when Attribute_Read => Read : declare
2481 P_Type : constant Entity_Id := Entity (Pref);
2482 B_Type : constant Entity_Id := Base_Type (P_Type);
2483 U_Type : constant Entity_Id := Underlying_Type (P_Type);
2484 Pname : Entity_Id;
2485 Decl : Node_Id;
2486 Prag : Node_Id;
2487 Arg2 : Node_Id;
2488 Rfunc : Node_Id;
2489 Lhs : Node_Id;
2490 Rhs : Node_Id;
2491
2492 begin
2493 -- If no underlying type, we have an error that will be diagnosed
2494 -- elsewhere, so here we just completely ignore the expansion.
2495
2496 if No (U_Type) then
2497 return;
2498 end if;
2499
2500 -- The simple case, if there is a TSS for Read, just call it
2501
2502 Pname := Find_Inherited_TSS (P_Type, Name_uRead);
2503
2504 if Present (Pname) then
2505 null;
2506
2507 else
2508 -- If there is a Stream_Convert pragma, use it, we rewrite
2509
2510 -- sourcetyp'Read (stream, Item)
2511
2512 -- as
2513
2514 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
2515
2516 -- where strmread is the given Read function that converts
2517 -- an argument of type strmtyp to type sourcetyp or a type
2518 -- from which it is derived. The conversion to sourcetyp
2519 -- is required in the latter case.
2520
2521 -- A special case arises if Item is a type conversion in which
2522 -- case, we have to expand to:
2523
2524 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
2525
2526 -- where Itemx is the expression of the type conversion (i.e.
2527 -- the actual object), and typex is the type of Itemx.
2528
2529 Prag :=
2530 Get_Rep_Pragma
2531 (Implementation_Base_Type (P_Type), Name_Stream_Convert);
2532
2533 if Present (Prag) then
2534 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
2535 Rfunc := Entity (Expression (Arg2));
2536 Lhs := Relocate_Node (Next (First (Exprs)));
2537 Rhs :=
2538 Convert_To (B_Type,
2539 Make_Function_Call (Loc,
2540 Name => New_Occurrence_Of (Rfunc, Loc),
2541 Parameter_Associations => New_List (
2542 Make_Attribute_Reference (Loc,
2543 Prefix =>
2544 New_Occurrence_Of
2545 (Etype (First_Formal (Rfunc)), Loc),
2546 Attribute_Name => Name_Input,
2547 Expressions => New_List (
2548 Relocate_Node (First (Exprs)))))));
2549
2550 if Nkind (Lhs) = N_Type_Conversion then
2551 Lhs := Expression (Lhs);
2552 Rhs := Convert_To (Etype (Lhs), Rhs);
2553 end if;
2554
2555 Rewrite (N,
2556 Make_Assignment_Statement (Loc,
2557 Name => Lhs,
2558 Expression => Rhs));
2559 Set_Assignment_OK (Lhs);
2560 Analyze (N);
2561 return;
2562
2563 -- For elementary types, we call the I_xxx routine using the first
2564 -- parameter and then assign the result into the second parameter.
2565 -- We set Assignment_OK to deal with the conversion case.
2566
2567 elsif Is_Elementary_Type (U_Type) then
2568 declare
2569 Lhs : Node_Id;
2570 Rhs : Node_Id;
2571
2572 begin
2573 Lhs := Relocate_Node (Next (First (Exprs)));
2574 Rhs := Build_Elementary_Input_Call (N);
2575
2576 if Nkind (Lhs) = N_Type_Conversion then
2577 Lhs := Expression (Lhs);
2578 Rhs := Convert_To (Etype (Lhs), Rhs);
2579 end if;
2580
2581 Set_Assignment_OK (Lhs);
2582
2583 Rewrite (N,
2584 Make_Assignment_Statement (Loc,
2585 Name => Lhs,
2586 Expression => Rhs));
2587
2588 Analyze (N);
2589 return;
2590 end;
2591
2592 -- Array type case
2593
2594 elsif Is_Array_Type (U_Type) then
2595 Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
2596 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
2597
2598 -- Tagged type case, use the primitive Read function. Note that
2599 -- this will dispatch in the class-wide case which is what we want
2600
2601 elsif Is_Tagged_Type (U_Type) then
2602 Pname := Find_Prim_Op (U_Type, Name_uRead);
2603
2604 -- All other record type cases, including protected records.
2605 -- The latter only arise for expander generated code for
2606 -- handling shared passive partition access.
2607
2608 else
2609 pragma Assert
2610 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
2611
2612 if Has_Discriminants (U_Type)
2613 and then Present
2614 (Discriminant_Default_Value (First_Discriminant (U_Type)))
2615 then
2616 Build_Mutable_Record_Read_Procedure
2617 (Loc, Base_Type (U_Type), Decl, Pname);
2618
2619 else
2620 Build_Record_Read_Procedure
2621 (Loc, Base_Type (U_Type), Decl, Pname);
2622 end if;
2623
2624 -- Suppress checks, uninitialized or otherwise invalid
2625 -- data does not cause constraint errors to be raised for
2626 -- a complete record read.
2627
2628 Insert_Action (N, Decl, All_Checks);
2629 end if;
2630 end if;
2631
2632 Rewrite_Stream_Proc_Call (Pname);
2633 end Read;
2634
2635 ---------------
2636 -- Remainder --
2637 ---------------
2638
2639 -- Transforms 'Remainder into a call to the floating-point attribute
2640 -- function Remainder in Fat_xxx (where xxx is the root type)
2641
2642 when Attribute_Remainder =>
2643 Expand_Fpt_Attribute_RR (N);
2644
2645 -----------
2646 -- Round --
2647 -----------
2648
2649 -- The handling of the Round attribute is quite delicate. The
2650 -- processing in Sem_Attr introduced a conversion to universal
2651 -- real, reflecting the semantics of Round, but we do not want
2652 -- anything to do with universal real at runtime, since this
2653 -- corresponds to using floating-point arithmetic.
2654
2655 -- What we have now is that the Etype of the Round attribute
2656 -- correctly indicates the final result type. The operand of
2657 -- the Round is the conversion to universal real, described
2658 -- above, and the operand of this conversion is the actual
2659 -- operand of Round, which may be the special case of a fixed
2660 -- point multiplication or division (Etype = universal fixed)
2661
2662 -- The exapander will expand first the operand of the conversion,
2663 -- then the conversion, and finally the round attribute itself,
2664 -- since we always work inside out. But we cannot simply process
2665 -- naively in this order. In the semantic world where universal
2666 -- fixed and real really exist and have infinite precision, there
2667 -- is no problem, but in the implementation world, where universal
2668 -- real is a floating-point type, we would get the wrong result.
2669
2670 -- So the approach is as follows. First, when expanding a multiply
2671 -- or divide whose type is universal fixed, we do nothing at all,
2672 -- instead deferring the operation till later.
2673
2674 -- The actual processing is done in Expand_N_Type_Conversion which
2675 -- handles the special case of Round by looking at its parent to
2676 -- see if it is a Round attribute, and if it is, handling the
2677 -- conversion (or its fixed multiply/divide child) in an appropriate
2678 -- manner.
2679
2680 -- This means that by the time we get to expanding the Round attribute
2681 -- itself, the Round is nothing more than a type conversion (and will
2682 -- often be a null type conversion), so we just replace it with the
2683 -- appropriate conversion operation.
2684
2685 when Attribute_Round =>
2686 Rewrite (N,
2687 Convert_To (Etype (N), Relocate_Node (First (Exprs))));
2688 Analyze_And_Resolve (N);
2689
2690 --------------
2691 -- Rounding --
2692 --------------
2693
2694 -- Transforms 'Rounding into a call to the floating-point attribute
2695 -- function Rounding in Fat_xxx (where xxx is the root type)
2696
2697 when Attribute_Rounding =>
2698 Expand_Fpt_Attribute_R (N);
2699
2700 -------------
2701 -- Scaling --
2702 -------------
2703
2704 -- Transforms 'Scaling into a call to the floating-point attribute
2705 -- function Scaling in Fat_xxx (where xxx is the root type)
2706
2707 when Attribute_Scaling =>
2708 Expand_Fpt_Attribute_RI (N);
2709
2710 ----------
2711 -- Size --
2712 ----------
2713
2714 when Attribute_Size |
2715 Attribute_Object_Size |
2716 Attribute_Value_Size |
2717 Attribute_VADS_Size => Size :
2718
2719 declare
2720 Ptyp : constant Entity_Id := Etype (Pref);
2721 New_Node : Node_Id;
2722 Siz : Uint;
2723
2724 begin
2725 -- Processing for VADS_Size case. Note that this processing removes
2726 -- all traces of VADS_Size from the tree, and completes all required
2727 -- processing for VADS_Size by translating the attribute reference
2728 -- to an appropriate Size or Object_Size reference.
2729
2730 if Id = Attribute_VADS_Size
2731 or else (Use_VADS_Size and then Id = Attribute_Size)
2732 then
2733 -- If the size is specified, then we simply use the specified
2734 -- size. This applies to both types and objects. The size of an
2735 -- object can be specified in the following ways:
2736
2737 -- An explicit size object is given for an object
2738 -- A component size is specified for an indexed component
2739 -- A component clause is specified for a selected component
2740 -- The object is a component of a packed composite object
2741
2742 -- If the size is specified, then VADS_Size of an object
2743
2744 if (Is_Entity_Name (Pref)
2745 and then Present (Size_Clause (Entity (Pref))))
2746 or else
2747 (Nkind (Pref) = N_Component_Clause
2748 and then (Present (Component_Clause
2749 (Entity (Selector_Name (Pref))))
2750 or else Is_Packed (Etype (Prefix (Pref)))))
2751 or else
2752 (Nkind (Pref) = N_Indexed_Component
2753 and then (Component_Size (Etype (Prefix (Pref))) /= 0
2754 or else Is_Packed (Etype (Prefix (Pref)))))
2755 then
2756 Set_Attribute_Name (N, Name_Size);
2757
2758 -- Otherwise if we have an object rather than a type, then the
2759 -- VADS_Size attribute applies to the type of the object, rather
2760 -- than the object itself. This is one of the respects in which
2761 -- VADS_Size differs from Size.
2762
2763 else
2764 if (not Is_Entity_Name (Pref)
2765 or else not Is_Type (Entity (Pref)))
2766 and then (Is_Scalar_Type (Etype (Pref))
2767 or else Is_Constrained (Etype (Pref)))
2768 then
2769 Rewrite (Pref, New_Occurrence_Of (Etype (Pref), Loc));
2770 end if;
2771
2772 -- For a scalar type for which no size was
2773 -- explicitly given, VADS_Size means Object_Size. This is the
2774 -- other respect in which VADS_Size differs from Size.
2775
2776 if Is_Scalar_Type (Etype (Pref))
2777 and then No (Size_Clause (Etype (Pref)))
2778 then
2779 Set_Attribute_Name (N, Name_Object_Size);
2780
2781 -- In all other cases, Size and VADS_Size are the sane
2782
2783 else
2784 Set_Attribute_Name (N, Name_Size);
2785 end if;
2786 end if;
2787 end if;
2788
2789 -- For class-wide types, transform X'Size into a call to
2790 -- the primitive operation _Size
2791
2792 if Is_Class_Wide_Type (Ptyp) then
2793 New_Node :=
2794 Make_Function_Call (Loc,
2795 Name => New_Reference_To
2796 (Find_Prim_Op (Ptyp, Name_uSize), Loc),
2797 Parameter_Associations => New_List (Pref));
2798
2799 if Typ /= Standard_Long_Long_Integer then
2800
2801 -- The context is a specific integer type with which the
2802 -- original attribute was compatible. The function has a
2803 -- specific type as well, so to preserve the compatibility
2804 -- we must convert explicitly.
2805
2806 New_Node := Convert_To (Typ, New_Node);
2807 end if;
2808
2809 Rewrite (N, New_Node);
2810 Analyze_And_Resolve (N, Typ);
2811 return;
2812
2813 -- For an array component, we can do Size in the front end
2814 -- if the component_size of the array is set.
2815
2816 elsif Nkind (Pref) = N_Indexed_Component then
2817 Siz := Component_Size (Etype (Prefix (Pref)));
2818
2819 -- For a record component, we can do Size in the front end
2820 -- if there is a component clause, or if the record is packed
2821 -- and the component's size is known at compile time.
2822
2823 elsif Nkind (Pref) = N_Selected_Component then
2824 declare
2825 Rec : constant Entity_Id := Etype (Prefix (Pref));
2826 Comp : constant Entity_Id := Entity (Selector_Name (Pref));
2827
2828 begin
2829 if Present (Component_Clause (Comp)) then
2830 Siz := Esize (Comp);
2831
2832 elsif Is_Packed (Rec) then
2833 Siz := RM_Size (Ptyp);
2834
2835 else
2836 Apply_Universal_Integer_Attribute_Checks (N);
2837 return;
2838 end if;
2839 end;
2840
2841 -- All other cases are handled by Gigi
2842
2843 else
2844 Apply_Universal_Integer_Attribute_Checks (N);
2845
2846 -- If we have Size applied to a formal parameter, that is a
2847 -- packed array subtype, then apply size to the actual subtype.
2848
2849 if Is_Entity_Name (Pref)
2850 and then Is_Formal (Entity (Pref))
2851 and then Is_Array_Type (Etype (Pref))
2852 and then Is_Packed (Etype (Pref))
2853 then
2854 Rewrite (N,
2855 Make_Attribute_Reference (Loc,
2856 Prefix =>
2857 New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
2858 Attribute_Name => Name_Size));
2859 Analyze_And_Resolve (N, Typ);
2860 end if;
2861
2862 return;
2863 end if;
2864
2865 -- Common processing for record and array component case
2866
2867 if Siz /= 0 then
2868 Rewrite (N,
2869 Make_Integer_Literal (Loc, Siz));
2870
2871 Analyze_And_Resolve (N, Typ);
2872
2873 -- The result is not a static expression
2874
2875 Set_Is_Static_Expression (N, False);
2876 end if;
2877 end Size;
2878
2879 ------------------
2880 -- Storage_Pool --
2881 ------------------
2882
2883 when Attribute_Storage_Pool =>
2884 Rewrite (N,
2885 Make_Type_Conversion (Loc,
2886 Subtype_Mark => New_Reference_To (Etype (N), Loc),
2887 Expression => New_Reference_To (Entity (N), Loc)));
2888 Analyze_And_Resolve (N, Typ);
2889
2890 ------------------
2891 -- Storage_Size --
2892 ------------------
2893
2894 when Attribute_Storage_Size => Storage_Size :
2895 declare
2896 Ptyp : constant Entity_Id := Etype (Pref);
2897
2898 begin
2899 -- Access type case, always go to the root type
2900
2901 -- The case of access types results in a value of zero for the case
2902 -- where no storage size attribute clause has been given. If a
2903 -- storage size has been given, then the attribute is converted
2904 -- to a reference to the variable used to hold this value.
2905
2906 if Is_Access_Type (Ptyp) then
2907 if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
2908 Rewrite (N,
2909 Make_Attribute_Reference (Loc,
2910 Prefix => New_Reference_To (Typ, Loc),
2911 Attribute_Name => Name_Max,
2912 Expressions => New_List (
2913 Make_Integer_Literal (Loc, 0),
2914 Convert_To (Typ,
2915 New_Reference_To
2916 (Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
2917
2918 elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
2919 Rewrite (N,
2920 OK_Convert_To (Typ,
2921 Make_Function_Call (Loc,
2922 Name => New_Reference_To (Find_Prim_Op (Etype (
2923 Associated_Storage_Pool (Root_Type (Ptyp))),
2924 Attribute_Name (N)), Loc),
2925
2926 Parameter_Associations => New_List (New_Reference_To (
2927 Associated_Storage_Pool (Root_Type (Ptyp)), Loc)))));
2928 else
2929 Rewrite (N, Make_Integer_Literal (Loc, 0));
2930 end if;
2931
2932 Analyze_And_Resolve (N, Typ);
2933
2934 -- The case of a task type (an obsolescent feature) is handled the
2935 -- same way, seems as reasonable as anything, and it is what the
2936 -- ACVC tests (e.g. CD1009K) seem to expect.
2937
2938 -- If there is no Storage_Size variable, then we return the default
2939 -- task stack size, otherwise, expand a Storage_Size attribute as
2940 -- follows:
2941
2942 -- Typ (Adjust_Storage_Size (taskZ))
2943
2944 -- except for the case of a task object which has a Storage_Size
2945 -- pragma:
2946
2947 -- Typ (Adjust_Storage_Size (taskV!(name)._Size))
2948
2949 else
2950 if not Present (Storage_Size_Variable (Ptyp)) then
2951 Rewrite (N,
2952 Convert_To (Typ,
2953 Make_Function_Call (Loc,
2954 Name =>
2955 New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc))));
2956
2957 else
2958 if not (Is_Entity_Name (Pref) and then
2959 Is_Task_Type (Entity (Pref))) and then
2960 Chars (Last_Entity (Corresponding_Record_Type (Ptyp))) =
2961 Name_uSize
2962 then
2963 Rewrite (N,
2964 Convert_To (Typ,
2965 Make_Function_Call (Loc,
2966 Name => New_Occurrence_Of (
2967 RTE (RE_Adjust_Storage_Size), Loc),
2968 Parameter_Associations =>
2969 New_List (
2970 Make_Selected_Component (Loc,
2971 Prefix =>
2972 Unchecked_Convert_To (
2973 Corresponding_Record_Type (Ptyp),
2974 New_Copy_Tree (Pref)),
2975 Selector_Name =>
2976 Make_Identifier (Loc, Name_uSize))))));
2977
2978 -- Task not having Storage_Size pragma
2979
2980 else
2981 Rewrite (N,
2982 Convert_To (Typ,
2983 Make_Function_Call (Loc,
2984 Name => New_Occurrence_Of (
2985 RTE (RE_Adjust_Storage_Size), Loc),
2986 Parameter_Associations =>
2987 New_List (
2988 New_Reference_To (
2989 Storage_Size_Variable (Ptyp), Loc)))));
2990 end if;
2991
2992 Analyze_And_Resolve (N, Typ);
2993 end if;
2994 end if;
2995 end Storage_Size;
2996
2997 ----------
2998 -- Succ --
2999 ----------
3000
3001 -- 1. Deal with enumeration types with holes
3002 -- 2. For floating-point, generate call to attribute function
3003 -- 3. For other cases, deal with constraint checking
3004
3005 when Attribute_Succ => Succ :
3006 declare
3007 Ptyp : constant Entity_Id := Base_Type (Etype (Pref));
3008
3009 begin
3010 -- For enumeration types with non-standard representations, we
3011 -- expand typ'Succ (x) into
3012
3013 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
3014
3015 if Is_Enumeration_Type (Ptyp)
3016 and then Present (Enum_Pos_To_Rep (Ptyp))
3017 then
3018 -- Add Boolean parameter True, to request program errror if
3019 -- we have a bad representation on our hands.
3020
3021 Append_To (Exprs, New_Occurrence_Of (Standard_True, Loc));
3022
3023 Rewrite (N,
3024 Make_Indexed_Component (Loc,
3025 Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
3026 Expressions => New_List (
3027 Make_Op_Add (Loc,
3028 Left_Opnd =>
3029 Make_Function_Call (Loc,
3030 Name =>
3031 New_Reference_To (TSS (Ptyp, Name_uRep_To_Pos), Loc),
3032 Parameter_Associations => Exprs),
3033 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
3034
3035 Analyze_And_Resolve (N, Typ);
3036
3037 -- For floating-point, we transform 'Succ into a call to the Succ
3038 -- floating-point attribute function in Fat_xxx (xxx is root type)
3039
3040 elsif Is_Floating_Point_Type (Ptyp) then
3041 Expand_Fpt_Attribute_R (N);
3042 Analyze_And_Resolve (N, Typ);
3043
3044 -- For modular types, nothing to do (no overflow, since wraps)
3045
3046 elsif Is_Modular_Integer_Type (Ptyp) then
3047 null;
3048
3049 -- For other types, if range checking is enabled, we must generate
3050 -- a check if overflow checking is enabled.
3051
3052 elsif not Overflow_Checks_Suppressed (Ptyp) then
3053 Expand_Pred_Succ (N);
3054 end if;
3055 end Succ;
3056
3057 ---------
3058 -- Tag --
3059 ---------
3060
3061 -- Transforms X'Tag into a direct reference to the tag of X
3062
3063 when Attribute_Tag => Tag :
3064 declare
3065 Ttyp : Entity_Id;
3066 Prefix_Is_Type : Boolean;
3067
3068 begin
3069 if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then
3070 Ttyp := Entity (Pref);
3071 Prefix_Is_Type := True;
3072 else
3073 Ttyp := Etype (Pref);
3074 Prefix_Is_Type := False;
3075 end if;
3076
3077 if Is_Class_Wide_Type (Ttyp) then
3078 Ttyp := Root_Type (Ttyp);
3079 end if;
3080
3081 Ttyp := Underlying_Type (Ttyp);
3082
3083 if Prefix_Is_Type then
1d7e0b5b 3084
3085 -- For JGNAT we leave the type attribute unexpanded because
3086 -- there's not a dispatching table to reference.
3087
3088 if not Java_VM then
3089 Rewrite (N,
3090 Unchecked_Convert_To (RTE (RE_Tag),
3091 New_Reference_To (Access_Disp_Table (Ttyp), Loc)));
3092 Analyze_And_Resolve (N, RTE (RE_Tag));
3093 end if;
ee6ba406 3094
3095 else
3096 Rewrite (N,
3097 Make_Selected_Component (Loc,
3098 Prefix => Relocate_Node (Pref),
3099 Selector_Name =>
3100 New_Reference_To (Tag_Component (Ttyp), Loc)));
1d7e0b5b 3101 Analyze_And_Resolve (N, RTE (RE_Tag));
ee6ba406 3102 end if;
ee6ba406 3103 end Tag;
3104
3105 ----------------
3106 -- Terminated --
3107 ----------------
3108
3109 -- Transforms 'Terminated attribute into a call to Terminated function.
3110
3111 when Attribute_Terminated => Terminated :
3112 begin
3113 if Restricted_Profile then
3114 Rewrite (N,
3115 Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
3116
3117 else
3118 Rewrite (N,
3119 Build_Call_With_Task (Pref, RTE (RE_Terminated)));
3120 end if;
3121
3122 Analyze_And_Resolve (N, Standard_Boolean);
3123 end Terminated;
3124
3125 ----------------
3126 -- To_Address --
3127 ----------------
3128
3129 -- Transforms System'To_Address (X) into unchecked conversion
3130 -- from (integral) type of X to type address.
3131
3132 when Attribute_To_Address =>
3133 Rewrite (N,
3134 Unchecked_Convert_To (RTE (RE_Address),
3135 Relocate_Node (First (Exprs))));
3136 Analyze_And_Resolve (N, RTE (RE_Address));
3137
3138 ----------------
3139 -- Truncation --
3140 ----------------
3141
3142 -- Transforms 'Truncation into a call to the floating-point attribute
3143 -- function Truncation in Fat_xxx (where xxx is the root type)
3144
3145 when Attribute_Truncation =>
3146 Expand_Fpt_Attribute_R (N);
3147
3148 -----------------------
3149 -- Unbiased_Rounding --
3150 -----------------------
3151
3152 -- Transforms 'Unbiased_Rounding into a call to the floating-point
3153 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
3154 -- root type)
3155
3156 when Attribute_Unbiased_Rounding =>
3157 Expand_Fpt_Attribute_R (N);
3158
3159 ----------------------
3160 -- Unchecked_Access --
3161 ----------------------
3162
3163 when Attribute_Unchecked_Access =>
3164 Expand_Access_To_Type (N);
3165
3166 -----------------
3167 -- UET_Address --
3168 -----------------
3169
3170 when Attribute_UET_Address => UET_Address : declare
3171 Ent : constant Entity_Id :=
3172 Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
3173
3174 begin
3175 Insert_Action (N,
3176 Make_Object_Declaration (Loc,
3177 Defining_Identifier => Ent,
3178 Aliased_Present => True,
3179 Object_Definition =>
3180 New_Occurrence_Of (RTE (RE_Address), Loc)));
3181
3182 -- Construct name __gnat_xxx__SDP, where xxx is the unit name
3183 -- in normal external form.
3184
3185 Get_External_Unit_Name_String (Get_Unit_Name (Pref));
3186 Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
3187 Name_Len := Name_Len + 7;
3188 Name_Buffer (1 .. 7) := "__gnat_";
3189 Name_Buffer (Name_Len + 1 .. Name_Len + 5) := "__SDP";
3190 Name_Len := Name_Len + 5;
3191
3192 Set_Is_Imported (Ent);
3193 Set_Interface_Name (Ent,
3194 Make_String_Literal (Loc,
3195 Strval => String_From_Name_Buffer));
3196
3197 Rewrite (N,
3198 Make_Attribute_Reference (Loc,
3199 Prefix => New_Occurrence_Of (Ent, Loc),
3200 Attribute_Name => Name_Address));
3201
3202 Analyze_And_Resolve (N, Typ);
3203 end UET_Address;
3204
3205 -------------------------
3206 -- Unrestricted_Access --
3207 -------------------------
3208
3209 when Attribute_Unrestricted_Access =>
3210 Expand_Access_To_Type (N);
3211
3212 ---------------
3213 -- VADS_Size --
3214 ---------------
3215
3216 -- The processing for VADS_Size is shared with Size
3217
3218 ---------
3219 -- Val --
3220 ---------
3221
3222 -- For enumeration types with a standard representation, and for all
3223 -- other types, Val is handled by Gigi. For enumeration types with
3224 -- a non-standard representation we use the _Pos_To_Rep array that
3225 -- was created when the type was frozen.
3226
3227 when Attribute_Val => Val :
3228 declare
3229 Etyp : constant Entity_Id := Base_Type (Entity (Pref));
3230
3231 begin
3232 if Is_Enumeration_Type (Etyp)
3233 and then Present (Enum_Pos_To_Rep (Etyp))
3234 then
3235 Rewrite (N,
3236 Make_Indexed_Component (Loc,
3237 Prefix => New_Reference_To (Enum_Pos_To_Rep (Etyp), Loc),
3238 Expressions => New_List (
3239 Convert_To (Standard_Integer,
3240 Relocate_Node (First (Exprs))))));
3241
3242 Analyze_And_Resolve (N, Typ);
3243 end if;
3244 end Val;
3245
3246 -----------
3247 -- Valid --
3248 -----------
3249
3250 -- The code for valid is dependent on the particular types involved.
3251 -- See separate sections below for the generated code in each case.
3252
3253 when Attribute_Valid => Valid :
3254 declare
3255 Ptyp : constant Entity_Id := Etype (Pref);
3256 Btyp : Entity_Id := Base_Type (Ptyp);
3257 Tst : Node_Id;
3258
3259 function Make_Range_Test return Node_Id;
3260 -- Build the code for a range test of the form
3261 -- Btyp!(Pref) >= Btyp!(Ptyp'First)
3262 -- and then
3263 -- Btyp!(Pref) <= Btyp!(Ptyp'Last)
3264
3265 function Make_Range_Test return Node_Id is
3266 begin
3267 return
3268 Make_And_Then (Loc,
3269 Left_Opnd =>
3270 Make_Op_Ge (Loc,
3271 Left_Opnd =>
3272 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
3273
3274 Right_Opnd =>
3275 Unchecked_Convert_To (Btyp,
3276 Make_Attribute_Reference (Loc,
3277 Prefix => New_Occurrence_Of (Ptyp, Loc),
3278 Attribute_Name => Name_First))),
3279
3280 Right_Opnd =>
3281 Make_Op_Le (Loc,
3282 Left_Opnd =>
3283 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
3284
3285 Right_Opnd =>
3286 Unchecked_Convert_To (Btyp,
3287 Make_Attribute_Reference (Loc,
3288 Prefix => New_Occurrence_Of (Ptyp, Loc),
3289 Attribute_Name => Name_Last))));
3290 end Make_Range_Test;
3291
3292 -- Start of processing for Attribute_Valid
3293
3294 begin
3295 -- Floating-point case. This case is handled by the Valid attribute
3296 -- code in the floating-point attribute run-time library.
3297
3298 if Is_Floating_Point_Type (Ptyp) then
3299 declare
3300 Rtp : constant Entity_Id := Root_Type (Etype (Pref));
3301
3302 begin
3303 Expand_Fpt_Attribute (N, Rtp, New_List (
3304 Make_Attribute_Reference (Loc,
3305 Prefix => Unchecked_Convert_To (Rtp, Pref),
3306 Attribute_Name => Name_Unrestricted_Access)));
3307
3308 -- One more task, we still need a range check. Required
3309 -- only if we have a constraint, since the Valid routine
3310 -- catches infinities properly (infinities are never valid).
3311
3312 -- The way we do the range check is simply to create the
3313 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
3314
3315 if not Subtypes_Statically_Match (Ptyp, Btyp) then
3316 Rewrite (N,
3317 Make_And_Then (Loc,
3318 Left_Opnd => Relocate_Node (N),
3319 Right_Opnd =>
3320 Make_In (Loc,
3321 Left_Opnd => Convert_To (Btyp, Pref),
3322 Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
3323 end if;
3324 end;
3325
3326 -- Enumeration type with holes
3327
3328 -- For enumeration types with holes, the Pos value constructed by
3329 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
3330 -- second argument of False returns minus one for an invalid value,
3331 -- and the non-negative pos value for a valid value, so the
3332 -- expansion of X'Valid is simply:
3333
3334 -- type(X)'Pos (X) >= 0
3335
3336 -- We can't quite generate it that way because of the requirement
3337 -- for the non-standard second argument of False, so we have to
3338 -- explicitly create:
3339
3340 -- _rep_to_pos (X, False) >= 0
3341
3342 -- If we have an enumeration subtype, we also check that the
3343 -- value is in range:
3344
3345 -- _rep_to_pos (X, False) >= 0
3346 -- and then
3347 -- (X >= type(X)'First and then type(X)'Last <= X)
3348
3349 elsif Is_Enumeration_Type (Ptyp)
3350 and then Present (Enum_Pos_To_Rep (Base_Type (Ptyp)))
3351 then
3352 Tst :=
3353 Make_Op_Ge (Loc,
3354 Left_Opnd =>
3355 Make_Function_Call (Loc,
3356 Name =>
3357 New_Reference_To
3358 (TSS (Base_Type (Ptyp), Name_uRep_To_Pos), Loc),
3359 Parameter_Associations => New_List (
3360 Pref,
3361 New_Occurrence_Of (Standard_False, Loc))),
3362 Right_Opnd => Make_Integer_Literal (Loc, 0));
3363
3364 if Ptyp /= Btyp
3365 and then
3366 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
3367 or else
3368 Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
3369 then
3370 -- The call to Make_Range_Test will create declarations
3371 -- that need a proper insertion point, but Pref is now
3372 -- attached to a node with no ancestor. Attach to tree
3373 -- even if it is to be rewritten below.
3374
3375 Set_Parent (Tst, Parent (N));
3376
3377 Tst :=
3378 Make_And_Then (Loc,
3379 Left_Opnd => Make_Range_Test,
3380 Right_Opnd => Tst);
3381 end if;
3382
3383 Rewrite (N, Tst);
3384
3385 -- Fortran convention booleans
3386
3387 -- For the very special case of Fortran convention booleans, the
3388 -- value is always valid, since it is an integer with the semantics
3389 -- that non-zero is true, and any value is permissible.
3390
3391 elsif Is_Boolean_Type (Ptyp)
3392 and then Convention (Ptyp) = Convention_Fortran
3393 then
3394 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
3395
3396 -- For biased representations, we will be doing an unchecked
3397 -- conversion without unbiasing the result. That means that
3398 -- the range test has to take this into account, and the
3399 -- proper form of the test is:
3400
3401 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
3402
3403 elsif Has_Biased_Representation (Ptyp) then
3404 Btyp := RTE (RE_Unsigned_32);
3405 Rewrite (N,
3406 Make_Op_Lt (Loc,
3407 Left_Opnd =>
3408 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
3409 Right_Opnd =>
3410 Unchecked_Convert_To (Btyp,
3411 Make_Attribute_Reference (Loc,
3412 Prefix => New_Occurrence_Of (Ptyp, Loc),
3413 Attribute_Name => Name_Range_Length))));
3414
3415 -- For all other scalar types, what we want logically is a
3416 -- range test:
3417
3418 -- X in type(X)'First .. type(X)'Last
3419
3420 -- But that's precisely what won't work because of possible
3421 -- unwanted optimization (and indeed the basic motivation for
3422 -- the Valid attribute -is exactly that this test does not work.
3423 -- What will work is:
3424
3425 -- Btyp!(X) >= Btyp!(type(X)'First)
3426 -- and then
3427 -- Btyp!(X) <= Btyp!(type(X)'Last)
3428
3429 -- where Btyp is an integer type large enough to cover the full
3430 -- range of possible stored values (i.e. it is chosen on the basis
3431 -- of the size of the type, not the range of the values). We write
3432 -- this as two tests, rather than a range check, so that static
3433 -- evaluation will easily remove either or both of the checks if
3434 -- they can be -statically determined to be true (this happens
3435 -- when the type of X is static and the range extends to the full
3436 -- range of stored values).
3437
3438 -- Unsigned types. Note: it is safe to consider only whether the
3439 -- subtype is unsigned, since we will in that case be doing all
3440 -- unsigned comparisons based on the subtype range. Since we use
3441 -- the actual subtype object size, this is appropriate.
3442
3443 -- For example, if we have
3444
3445 -- subtype x is integer range 1 .. 200;
3446 -- for x'Object_Size use 8;
3447
3448 -- Now the base type is signed, but objects of this type are 8
3449 -- bits unsigned, and doing an unsigned test of the range 1 to
3450 -- 200 is correct, even though a value greater than 127 looks
3451 -- signed to a signed comparison.
3452
3453 elsif Is_Unsigned_Type (Ptyp) then
3454 if Esize (Ptyp) <= 32 then
3455 Btyp := RTE (RE_Unsigned_32);
3456 else
3457 Btyp := RTE (RE_Unsigned_64);
3458 end if;
3459
3460 Rewrite (N, Make_Range_Test);
3461
3462 -- Signed types
3463
3464 else
3465 if Esize (Ptyp) <= Esize (Standard_Integer) then
3466 Btyp := Standard_Integer;
3467 else
3468 Btyp := Universal_Integer;
3469 end if;
3470
3471 Rewrite (N, Make_Range_Test);
3472 end if;
3473
3474 Analyze_And_Resolve (N, Standard_Boolean);
3475 end Valid;
3476
3477 -----------
3478 -- Value --
3479 -----------
3480
3481 -- Value attribute is handled in separate unti Exp_Imgv
3482
3483 when Attribute_Value =>
3484 Exp_Imgv.Expand_Value_Attribute (N);
3485
3486 -----------------
3487 -- Value_Size --
3488 -----------------
3489
3490 -- The processing for Value_Size shares the processing for Size
3491
3492 -------------
3493 -- Version --
3494 -------------
3495
3496 -- The processing for Version shares the processing for Body_Version
3497
3498 ----------------
3499 -- Wide_Image --
3500 ----------------
3501
3502 -- We expand typ'Wide_Image (X) into
3503
3504 -- String_To_Wide_String
3505 -- (typ'Image (X), Wide_Character_Encoding_Method)
3506
3507 -- This works in all cases because String_To_Wide_String converts any
3508 -- wide character escape sequences resulting from the Image call to the
3509 -- proper Wide_Character equivalent
3510
3511 -- not quite right for typ = Wide_Character ???
3512
3513 when Attribute_Wide_Image => Wide_Image :
3514 begin
3515 Rewrite (N,
3516 Make_Function_Call (Loc,
3517 Name => New_Reference_To (RTE (RE_String_To_Wide_String), Loc),
3518 Parameter_Associations => New_List (
3519 Make_Attribute_Reference (Loc,
3520 Prefix => Pref,
3521 Attribute_Name => Name_Image,
3522 Expressions => Exprs),
3523
3524 Make_Integer_Literal (Loc,
3525 Intval => Int (Wide_Character_Encoding_Method)))));
3526
3527 Analyze_And_Resolve (N, Standard_Wide_String);
3528 end Wide_Image;
3529
3530 ----------------
3531 -- Wide_Value --
3532 ----------------
3533
3534 -- We expand typ'Wide_Value (X) into
3535
3536 -- typ'Value
3537 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
3538
3539 -- Wide_String_To_String is a runtime function that converts its wide
3540 -- string argument to String, converting any non-translatable characters
3541 -- into appropriate escape sequences. This preserves the required
3542 -- semantics of Wide_Value in all cases, and results in a very simple
3543 -- implementation approach.
3544
3545 -- It's not quite right where typ = Wide_Character, because the encoding
3546 -- method may not cover the whole character type ???
3547
3548 when Attribute_Wide_Value => Wide_Value :
3549 begin
3550 Rewrite (N,
3551 Make_Attribute_Reference (Loc,
3552 Prefix => Pref,
3553 Attribute_Name => Name_Value,
3554
3555 Expressions => New_List (
3556 Make_Function_Call (Loc,
3557 Name =>
3558 New_Reference_To (RTE (RE_Wide_String_To_String), Loc),
3559
3560 Parameter_Associations => New_List (
3561 Relocate_Node (First (Exprs)),
3562 Make_Integer_Literal (Loc,
3563 Intval => Int (Wide_Character_Encoding_Method)))))));
3564
3565 Analyze_And_Resolve (N, Typ);
3566 end Wide_Value;
3567
3568 ----------------
3569 -- Wide_Width --
3570 ----------------
3571
3572 -- Wide_Width attribute is handled in separate unit Exp_Imgv
3573
3574 when Attribute_Wide_Width =>
3575 Exp_Imgv.Expand_Width_Attribute (N, Wide => True);
3576
3577 -----------
3578 -- Width --
3579 -----------
3580
3581 -- Width attribute is handled in separate unit Exp_Imgv
3582
3583 when Attribute_Width =>
3584 Exp_Imgv.Expand_Width_Attribute (N, Wide => False);
3585
3586 -----------
3587 -- Write --
3588 -----------
3589
3590 when Attribute_Write => Write : declare
3591 P_Type : constant Entity_Id := Entity (Pref);
3592 U_Type : constant Entity_Id := Underlying_Type (P_Type);
3593 Pname : Entity_Id;
3594 Decl : Node_Id;
3595 Prag : Node_Id;
3596 Arg3 : Node_Id;
3597 Wfunc : Node_Id;
3598
3599 begin
3600 -- If no underlying type, we have an error that will be diagnosed
3601 -- elsewhere, so here we just completely ignore the expansion.
3602
3603 if No (U_Type) then
3604 return;
3605 end if;
3606
3607 -- The simple case, if there is a TSS for Write, just call it
3608
3609 Pname := Find_Inherited_TSS (P_Type, Name_uWrite);
3610
3611 if Present (Pname) then
3612 null;
3613
3614 else
3615 -- If there is a Stream_Convert pragma, use it, we rewrite
3616
3617 -- sourcetyp'Output (stream, Item)
3618
3619 -- as
3620
3621 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
3622
3623 -- where strmwrite is the given Write function that converts
3624 -- an argument of type sourcetyp or a type acctyp, from which
3625 -- it is derived to type strmtyp. The conversion to acttyp is
3626 -- required for the derived case.
3627
3628 Prag :=
3629 Get_Rep_Pragma
3630 (Implementation_Base_Type (P_Type), Name_Stream_Convert);
3631
3632 if Present (Prag) then
3633 Arg3 :=
3634 Next (Next (First (Pragma_Argument_Associations (Prag))));
3635 Wfunc := Entity (Expression (Arg3));
3636
3637 Rewrite (N,
3638 Make_Attribute_Reference (Loc,
3639 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
3640 Attribute_Name => Name_Output,
3641 Expressions => New_List (
3642 Relocate_Node (First (Exprs)),
3643 Make_Function_Call (Loc,
3644 Name => New_Occurrence_Of (Wfunc, Loc),
3645 Parameter_Associations => New_List (
3646 Convert_To (Etype (First_Formal (Wfunc)),
3647 Relocate_Node (Next (First (Exprs)))))))));
3648
3649 Analyze (N);
3650 return;
3651
3652 -- For elementary types, we call the W_xxx routine directly
3653
3654 elsif Is_Elementary_Type (U_Type) then
3655 Rewrite (N, Build_Elementary_Write_Call (N));
3656 Analyze (N);
3657 return;
3658
3659 -- Array type case
3660
3661 elsif Is_Array_Type (U_Type) then
3662 Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
3663 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3664
3665 -- Tagged type case, use the primitive Write function. Note that
3666 -- this will dispatch in the class-wide case which is what we want
3667
3668 elsif Is_Tagged_Type (U_Type) then
3669 Pname := Find_Prim_Op (U_Type, Name_uWrite);
3670
3671 -- All other record type cases, including protected records.
3672 -- The latter only arise for expander generated code for
3673 -- handling shared passive partition access.
3674
3675 else
3676 pragma Assert
3677 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
3678
3679 if Has_Discriminants (U_Type)
3680 and then Present
3681 (Discriminant_Default_Value (First_Discriminant (U_Type)))
3682 then
3683 Build_Mutable_Record_Write_Procedure
3684 (Loc, Base_Type (U_Type), Decl, Pname);
3685
3686 else
3687 Build_Record_Write_Procedure
3688 (Loc, Base_Type (U_Type), Decl, Pname);
3689 end if;
3690
3691 Insert_Action (N, Decl);
3692 end if;
3693 end if;
3694
3695 -- If we fall through, Pname is the procedure to be called
3696
3697 Rewrite_Stream_Proc_Call (Pname);
3698 end Write;
3699
3700 -- Component_Size is handled by Gigi, unless the component size is
3701 -- known at compile time, which is always true in the packed array
3702 -- case. It is important that the packed array case is handled in
3703 -- the front end (see Eval_Attribute) since Gigi would otherwise
3704 -- get confused by the equivalent packed array type.
3705
3706 when Attribute_Component_Size =>
3707 null;
3708
3709 -- The following attributes are handled by Gigi (except that static
3710 -- cases have already been evaluated by the semantics, but in any
3711 -- case Gigi should not count on that).
3712
3713 -- In addition Gigi handles the non-floating-point cases of Pred
3714 -- and Succ (including the fixed-point cases, which can just be
3715 -- treated as integer increment/decrement operations)
3716
3717 -- Gigi also handles the non-class-wide cases of Size
3718
3719 when Attribute_Bit_Order |
3720 Attribute_Code_Address |
3721 Attribute_Definite |
3722 Attribute_Max |
3723 Attribute_Mechanism_Code |
3724 Attribute_Min |
3725 Attribute_Null_Parameter |
3726 Attribute_Passed_By_Reference =>
3727 null;
3728
3729 -- The following attributes are also handled by Gigi, but return a
3730 -- universal integer result, so may need a conversion for checking
3731 -- that the result is in range.
3732
3733 when Attribute_Aft |
3734 Attribute_Alignment |
3735 Attribute_Bit |
3736 Attribute_Max_Size_In_Storage_Elements
3737 =>
3738 Apply_Universal_Integer_Attribute_Checks (N);
3739
3740 -- The following attributes should not appear at this stage, since they
3741 -- have already been handled by the analyzer (and properly rewritten
3742 -- with corresponding values or entities to represent the right values)
3743
3744 when Attribute_Abort_Signal |
3745 Attribute_Address_Size |
3746 Attribute_Base |
3747 Attribute_Class |
3748 Attribute_Default_Bit_Order |
3749 Attribute_Delta |
3750 Attribute_Denorm |
3751 Attribute_Digits |
3752 Attribute_Emax |
3753 Attribute_Epsilon |
3754 Attribute_Has_Discriminants |
3755 Attribute_Large |
3756 Attribute_Machine_Emax |
3757 Attribute_Machine_Emin |
3758 Attribute_Machine_Mantissa |
3759 Attribute_Machine_Overflows |
3760 Attribute_Machine_Radix |
3761 Attribute_Machine_Rounds |
ee6ba406 3762 Attribute_Maximum_Alignment |
3763 Attribute_Model_Emin |
3764 Attribute_Model_Epsilon |
3765 Attribute_Model_Mantissa |
3766 Attribute_Model_Small |
3767 Attribute_Modulus |
3768 Attribute_Partition_ID |
3769 Attribute_Range |
3770 Attribute_Safe_Emax |
3771 Attribute_Safe_First |
3772 Attribute_Safe_Large |
3773 Attribute_Safe_Last |
3774 Attribute_Safe_Small |
3775 Attribute_Scale |
3776 Attribute_Signed_Zeros |
3777 Attribute_Small |
3778 Attribute_Storage_Unit |
ee6ba406 3779 Attribute_Type_Class |
3780 Attribute_Universal_Literal_String |
3781 Attribute_Wchar_T_Size |
3782 Attribute_Word_Size =>
3783
3784 raise Program_Error;
3785
3786 -- The Asm_Input and Asm_Output attributes are not expanded at this
3787 -- stage, but will be eliminated in the expansion of the Asm call,
3788 -- see Exp_Intr for details. So Gigi will never see these either.
3789
3790 when Attribute_Asm_Input |
3791 Attribute_Asm_Output =>
3792
3793 null;
3794
3795 end case;
3796
3797 end Expand_N_Attribute_Reference;
3798
3799 ----------------------
3800 -- Expand_Pred_Succ --
3801 ----------------------
3802
3803 -- For typ'Pred (exp), we generate the check
3804
3805 -- [constraint_error when exp = typ'Base'First]
3806
3807 -- Similarly, for typ'Succ (exp), we generate the check
3808
3809 -- [constraint_error when exp = typ'Base'Last]
3810
3811 -- These checks are not generated for modular types, since the proper
3812 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
3813
3814 procedure Expand_Pred_Succ (N : Node_Id) is
3815 Loc : constant Source_Ptr := Sloc (N);
3816 Cnam : Name_Id;
3817
3818 begin
3819 if Attribute_Name (N) = Name_Pred then
3820 Cnam := Name_First;
3821 else
3822 Cnam := Name_Last;
3823 end if;
3824
3825 Insert_Action (N,
3826 Make_Raise_Constraint_Error (Loc,
3827 Condition =>
3828 Make_Op_Eq (Loc,
3829 Left_Opnd => Duplicate_Subexpr (First (Expressions (N))),
3830 Right_Opnd =>
3831 Make_Attribute_Reference (Loc,
3832 Prefix =>
3833 New_Reference_To (Base_Type (Etype (Prefix (N))), Loc),
f15731c4 3834 Attribute_Name => Cnam)),
3835 Reason => CE_Overflow_Check_Failed));
ee6ba406 3836
3837 end Expand_Pred_Succ;
3838
3839 ------------------------
3840 -- Find_Inherited_TSS --
3841 ------------------------
3842
3843 function Find_Inherited_TSS
3844 (Typ : Entity_Id;
3845 Nam : Name_Id) return Entity_Id
3846 is
3847 P_Type : Entity_Id := Typ;
3848 Proc : Entity_Id;
3849
3850 begin
3851 Proc := TSS (Base_Type (Typ), Nam);
3852
3853 -- Check first if there is a TSS given for the type itself.
3854
3855 if Present (Proc) then
3856 return Proc;
3857 end if;
3858
3859 -- If Typ is a derived type, it may inherit attributes from some
3860 -- ancestor which is not the ultimate underlying one.
f15731c4 3861 -- If Typ is a derived tagged type, the corresponding primitive
3862 -- operation has been created explicitly.
ee6ba406 3863
3864 if Is_Derived_Type (P_Type) then
f15731c4 3865 if Is_Tagged_Type (P_Type) then
3866 return Find_Prim_Op (P_Type, Nam);
3867 else
3868 while Is_Derived_Type (P_Type) loop
3869 Proc := TSS (Base_Type (Etype (Typ)), Nam);
ee6ba406 3870
f15731c4 3871 if Present (Proc) then
3872 return Proc;
3873 else
3874 P_Type := Base_Type (Etype (P_Type));
3875 end if;
3876 end loop;
3877 end if;
ee6ba406 3878 end if;
3879
3880 -- If nothing else, use the TSS of the root type.
3881
3882 return TSS (Base_Type (Underlying_Type (Typ)), Nam);
3883 end Find_Inherited_TSS;
3884
3885 -----------------------
3886 -- Get_Index_Subtype --
3887 -----------------------
3888
3889 function Get_Index_Subtype (N : Node_Id) return Node_Id is
3890 P_Type : Entity_Id := Etype (Prefix (N));
3891 Indx : Node_Id;
3892 J : Int;
3893
3894 begin
3895 if Is_Access_Type (P_Type) then
3896 P_Type := Designated_Type (P_Type);
3897 end if;
3898
3899 if No (Expressions (N)) then
3900 J := 1;
3901 else
3902 J := UI_To_Int (Expr_Value (First (Expressions (N))));
3903 end if;
3904
3905 Indx := First_Index (P_Type);
3906 while J > 1 loop
3907 Next_Index (Indx);
3908 J := J - 1;
3909 end loop;
3910
3911 return Etype (Indx);
3912 end Get_Index_Subtype;
3913
3914 ---------------------------------
3915 -- Is_Constrained_Packed_Array --
3916 ---------------------------------
3917
3918 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is
3919 Arr : Entity_Id := Typ;
3920
3921 begin
3922 if Is_Access_Type (Arr) then
3923 Arr := Designated_Type (Arr);
3924 end if;
3925
3926 return Is_Array_Type (Arr)
3927 and then Is_Constrained (Arr)
3928 and then Present (Packed_Array_Type (Arr));
3929 end Is_Constrained_Packed_Array;
3930
3931end Exp_Attr;
Mirror of https://gcc.gnu.org/git/gcc.git