]> gcc.gnu.org Git - gcc.git/blame - gcc/ada/exp_attr.adb
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
[Ada] Ensure meaningless digits in a string are discarded
[gcc.git] / gcc / ada / exp_attr.adb
CommitLineData
70482933
RK		 1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- E X P _ A T T R --
6-- --
7-- B o d y --
8-- --
1d005acc 9-- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
70482933
RK		 10-- --
11-- GNAT is free software; you can redistribute it and/or modify it under --
12-- terms of the GNU General Public License as published by the Free Soft- --
748086b7 13-- ware Foundation; either version 3, or (at your option) any later ver- --
70482933
RK		 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
9eea4346
GB		 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17-- for more details. You should have received a copy of the GNU General --
18-- Public License distributed with GNAT; see file COPYING3. If not, go to --
19-- http://www.gnu.org/licenses for a complete copy of the license. --
70482933
RK		 20-- --
21-- GNAT was originally developed by the GNAT team at New York University. --
71ff80dc 22-- Extensive contributions were provided by Ada Core Technologies Inc. --
70482933
RK		 23-- --
24------------------------------------------------------------------------------
25
8575023c 26with Aspects; use Aspects;
70482933
RK		 27with Atree; use Atree;
28with Checks; use Checks;
29with Einfo; use Einfo;
5d09245e 30with Elists; use Elists;
0669bebe 31with Exp_Atag; use Exp_Atag;
70482933 32with Exp_Ch2; use Exp_Ch2;
21d27997
RD		 33with Exp_Ch3; use Exp_Ch3;
34with Exp_Ch6; use Exp_Ch6;
70482933 35with Exp_Ch9; use Exp_Ch9;
54838d1f 36with Exp_Dist; use Exp_Dist;
70482933
RK		 37with Exp_Imgv; use Exp_Imgv;
38with Exp_Pakd; use Exp_Pakd;
39with Exp_Strm; use Exp_Strm;
40with Exp_Tss; use Exp_Tss;
41with Exp_Util; use Exp_Util;
16f67b79 42with Freeze; use Freeze;
70482933 43with Gnatvsn; use Gnatvsn;
16f67b79 44with Itypes; use Itypes;
70482933
RK		 45with Lib; use Lib;
46with Namet; use Namet;
47with Nmake; use Nmake;
48with Nlists; use Nlists;
49with Opt; use Opt;
50with Restrict; use Restrict;
6e937c1c 51with Rident; use Rident;
70482933
RK		 52with Rtsfind; use Rtsfind;
53with Sem; use Sem;
a4100e55 54with Sem_Aux; use Sem_Aux;
e10dab7f 55with Sem_Ch6; use Sem_Ch6;
70482933
RK		 56with Sem_Ch7; use Sem_Ch7;
57with Sem_Ch8; use Sem_Ch8;
70482933
RK		 58with Sem_Eval; use Sem_Eval;
59with Sem_Res; use Sem_Res;
60with Sem_Util; use Sem_Util;
61with Sinfo; use Sinfo;
62with Snames; use Snames;
63with Stand; use Stand;
64with Stringt; use Stringt;
65with Tbuild; use Tbuild;
66with Ttypes; use Ttypes;
67with Uintp; use Uintp;
68with Uname; use Uname;
69with Validsw; use Validsw;
70
71package body Exp_Attr is
72
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
76
99fc068e 77 function Build_Array_VS_Func
f16cb8df
HK		 78 (Attr : Node_Id;
79 Formal_Typ : Entity_Id;
80 Array_Typ : Entity_Id;
81 Comp_Typ : Entity_Id) return Entity_Id;
82 -- Validate the components of an array type by means of a function. Return
83 -- the entity of the validation function. The parameters are as follows:
84 --
85 -- * Attr - the 'Valid_Scalars attribute for which the function is
86 -- generated.
87 --
88 -- * Formal_Typ - the type of the generated function's only formal
89 -- parameter.
90 --
91 -- * Array_Typ - the array type whose components are to be validated
92 --
93 -- * Comp_Typ - the component type of the array
99fc068e 94
99bba92c
AC		 95 function Build_Disp_Get_Task_Id_Call (Actual : Node_Id) return Node_Id;
96 -- Build a call to Disp_Get_Task_Id, passing Actual as actual parameter
97
45ec05e1 98 function Build_Record_VS_Func
f16cb8df
HK		 99 (Attr : Node_Id;
100 Formal_Typ : Entity_Id;
101 Rec_Typ : Entity_Id) return Entity_Id;
102 -- Validate the components, discriminants, and variants of a record type by
103 -- means of a function. Return the entity of the validation function. The
104 -- parameters are as follows:
105 --
106 -- * Attr - the 'Valid_Scalars attribute for which the function is
107 -- generated.
108 --
109 -- * Formal_Typ - the type of the generated function's only formal
110 -- parameter.
111 --
112 -- * Rec_Typ - the record type whose internals are to be validated
45ec05e1 113
70482933
RK		 114 procedure Compile_Stream_Body_In_Scope
115 (N : Node_Id;
116 Decl : Node_Id;
117 Arr : Entity_Id;
118 Check : Boolean);
119 -- The body for a stream subprogram may be generated outside of the scope
120 -- of the type. If the type is fully private, it may depend on the full
3b42c566 121 -- view of other types (e.g. indexes) that are currently private as well.
70482933
RK		 122 -- We install the declarations of the package in which the type is declared
123 -- before compiling the body in what is its proper environment. The Check
124 -- parameter indicates if checks are to be suppressed for the stream body.
125 -- We suppress checks for array/record reads, since the rule is that these
126 -- are like assignments, out of range values due to uninitialized storage,
127 -- or other invalid values do NOT cause a Constraint_Error to be raised.
3dddb11e
ES		 128 -- If we are within an instance body all visibility has been established
129 -- already and there is no need to install the package.
70482933 130
73f05f9f
ES		 131 -- This mechanism is now extended to the component types of the array type,
132 -- when the component type is not in scope and is private, to handle
133 -- properly the case when the full view has defaulted discriminants.
134
135 -- This special processing is ultimately caused by the fact that the
136 -- compiler lacks a well-defined phase when full views are visible
137 -- everywhere. Having such a separate pass would remove much of the
138 -- special-case code that shuffles partial and full views in the middle
139 -- of semantic analysis and expansion.
140
7ce611e2
ES		 141 procedure Expand_Access_To_Protected_Op
142 (N : Node_Id;
143 Pref : Node_Id;
144 Typ : Entity_Id);
7ce611e2
ES		 145 -- An attribute reference to a protected subprogram is transformed into
146 -- a pair of pointers: one to the object, and one to the operations.
147 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
148
70482933 149 procedure Expand_Fpt_Attribute
fbf5a39b 150 (N : Node_Id;
65f01153 151 Pkg : RE_Id;
fbf5a39b 152 Nam : Name_Id;
70482933
RK		 153 Args : List_Id);
154 -- This procedure expands a call to a floating-point attribute function.
155 -- N is the attribute reference node, and Args is a list of arguments to
65f01153
RD		 156 -- be passed to the function call. Pkg identifies the package containing
157 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
158 -- have already been converted to the floating-point type for which Pkg was
159 -- instantiated. The Nam argument is the relevant attribute processing
160 -- routine to be called. This is the same as the attribute name, except in
161 -- the Unaligned_Valid case.
70482933
RK		 162
163 procedure Expand_Fpt_Attribute_R (N : Node_Id);
164 -- This procedure expands a call to a floating-point attribute function
fbf5a39b
AC		 165 -- that takes a single floating-point argument. The function to be called
166 -- is always the same as the attribute name.
70482933
RK		 167
168 procedure Expand_Fpt_Attribute_RI (N : Node_Id);
169 -- This procedure expands a call to a floating-point attribute function
fbf5a39b
AC		 170 -- that takes one floating-point argument and one integer argument. The
171 -- function to be called is always the same as the attribute name.
70482933
RK		 172
173 procedure Expand_Fpt_Attribute_RR (N : Node_Id);
174 -- This procedure expands a call to a floating-point attribute function
fbf5a39b
AC		 175 -- that takes two floating-point arguments. The function to be called
176 -- is always the same as the attribute name.
70482933 177
aa9b151a 178 procedure Expand_Loop_Entry_Attribute (N : Node_Id);
d436b30d
AC		 179 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
180 -- loop may be converted into a conditional block. See body for details.
181
e0f63680
AC		 182 procedure Expand_Min_Max_Attribute (N : Node_Id);
183 -- Handle the expansion of attributes 'Max and 'Min, including expanding
184 -- then out if we are in Modify_Tree_For_C mode.
185
aa9b151a 186 procedure Expand_Pred_Succ_Attribute (N : Node_Id);
70482933
RK		 187 -- Handles expansion of Pred or Succ attributes for case of non-real
188 -- operand with overflow checking required.
189
18a2ad5d
AC		 190 procedure Expand_Update_Attribute (N : Node_Id);
191 -- Handle the expansion of attribute Update
192
70482933 193 function Get_Index_Subtype (N : Node_Id) return Entity_Id;
470cd9e9 194 -- Used for Last, Last, and Length, when the prefix is an array type.
70482933
RK		 195 -- Obtains the corresponding index subtype.
196
65f01153
RD		 197 procedure Find_Fat_Info
198 (T : Entity_Id;
199 Fat_Type : out Entity_Id;
200 Fat_Pkg : out RE_Id);
201 -- Given a floating-point type T, identifies the package containing the
202 -- attributes for this type (returned in Fat_Pkg), and the corresponding
203 -- type for which this package was instantiated from Fat_Gen. Error if T
204 -- is not a floating-point type.
205
fbf5a39b
AC		 206 function Find_Stream_Subprogram
207 (Typ : Entity_Id;
208 Nam : TSS_Name_Type) return Entity_Id;
209 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
210 -- types, the corresponding primitive operation is looked up, else the
211 -- appropriate TSS from the type itself, or from its closest ancestor
212 -- defining it, is returned. In both cases, inheritance of representation
213 -- aspects is thus taken into account.
70482933 214
96d2756f
AC		 215 function Full_Base (T : Entity_Id) return Entity_Id;
216 -- The stream functions need to examine the underlying representation of
217 -- composite types. In some cases T may be non-private but its base type
218 -- is, in which case the function returns the corresponding full view.
219
1d571f3b
AC		 220 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id;
221 -- Given a type, find a corresponding stream convert pragma that applies to
222 -- the implementation base type of this type (Typ). If found, return the
223 -- pragma node, otherwise return Empty if no pragma is found.
224
70482933
RK		 225 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
226 -- Utility for array attributes, returns true on packed constrained
227 -- arrays, and on access to same.
228
0669bebe
GB		 229 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean;
230 -- Returns true iff the given node refers to an attribute call that
231 -- can be expanded directly by the back end and does not need front end
232 -- expansion. Typically used for rounding and truncation attributes that
233 -- appear directly inside a conversion to integer.
234
99fc068e
RD		 235 -------------------------
236 -- Build_Array_VS_Func --
237 -------------------------
238
239 function Build_Array_VS_Func
f16cb8df
HK		 240 (Attr : Node_Id;
241 Formal_Typ : Entity_Id;
242 Array_Typ : Entity_Id;
243 Comp_Typ : Entity_Id) return Entity_Id
99fc068e 244 is
f16cb8df
HK		 245 Loc : constant Source_Ptr := Sloc (Attr);
246
247 function Validate_Component
248 (Obj_Id : Entity_Id;
249 Indexes : List_Id) return Node_Id;
250 -- Process a single component denoted by indexes Indexes. Obj_Id denotes
251 -- the entity of the validation parameter. Return the check associated
252 -- with the component.
253
254 function Validate_Dimension
255 (Obj_Id : Entity_Id;
256 Dim : Int;
257 Indexes : List_Id) return Node_Id;
258 -- Process dimension Dim of the array type. Obj_Id denotes the entity
259 -- of the validation parameter. Indexes is a list where each dimension
260 -- deposits its loop variable, which will later identify a component.
261 -- Return the loop associated with the current dimension.
99fc068e 262
f16cb8df
HK		 263 ------------------------
264 -- Validate_Component --
265 ------------------------
99fc068e 266
f16cb8df
HK		 267 function Validate_Component
268 (Obj_Id : Entity_Id;
269 Indexes : List_Id) return Node_Id
270 is
271 Attr_Nam : Name_Id;
99fc068e
RD		 272
273 begin
f16cb8df
HK		 274 if Is_Scalar_Type (Comp_Typ) then
275 Attr_Nam := Name_Valid;
99fc068e 276 else
f16cb8df 277 Attr_Nam := Name_Valid_Scalars;
99fc068e
RD		 278 end if;
279
f16cb8df
HK		 280 -- Generate:
281 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars] then
282 -- return False;
283 -- end if;
284
285 return
99fc068e
RD		 286 Make_If_Statement (Loc,
287 Condition =>
288 Make_Op_Not (Loc,
289 Right_Opnd =>
290 Make_Attribute_Reference (Loc,
f16cb8df
HK		 291 Prefix =>
292 Make_Indexed_Component (Loc,
293 Prefix =>
294 Unchecked_Convert_To (Array_Typ,
295 New_Occurrence_Of (Obj_Id, Loc)),
296 Expressions => Indexes),
297 Attribute_Name => Attr_Nam)),
298
99fc068e
RD		 299 Then_Statements => New_List (
300 Make_Simple_Return_Statement (Loc,
f16cb8df
HK		 301 Expression => New_Occurrence_Of (Standard_False, Loc))));
302 end Validate_Component;
99fc068e
RD		 303
304 ------------------------
f16cb8df 305 -- Validate_Dimension --
99fc068e
RD		 306 ------------------------
307
f16cb8df
HK		 308 function Validate_Dimension
309 (Obj_Id : Entity_Id;
310 Dim : Int;
311 Indexes : List_Id) return Node_Id
312 is
99fc068e
RD		 313 Index : Entity_Id;
314
315 begin
f16cb8df
HK		 316 -- Validate the component once all dimensions have produced their
317 -- individual loops.
99fc068e 318
f16cb8df
HK		 319 if Dim > Number_Dimensions (Array_Typ) then
320 return Validate_Component (Obj_Id, Indexes);
99fc068e 321
f16cb8df 322 -- Process the current dimension
99fc068e
RD		 323
324 else
325 Index :=
f16cb8df 326 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim));
99fc068e 327
f16cb8df 328 Append_To (Indexes, New_Occurrence_Of (Index, Loc));
99fc068e 329
f16cb8df
HK		 330 -- Generate:
331 -- for J1 in Array_Typ (Obj_Id)'Range (1) loop
332 -- for JN in Array_Typ (Obj_Id)'Range (N) loop
333 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars]
334 -- then
335 -- return False;
336 -- end if;
337 -- end loop;
338 -- end loop;
339
340 return
341 Make_Implicit_Loop_Statement (Attr,
342 Identifier => Empty,
99fc068e
RD		 343 Iteration_Scheme =>
344 Make_Iteration_Scheme (Loc,
345 Loop_Parameter_Specification =>
346 Make_Loop_Parameter_Specification (Loc,
f16cb8df 347 Defining_Identifier => Index,
99fc068e
RD		 348 Discrete_Subtype_Definition =>
349 Make_Attribute_Reference (Loc,
f16cb8df
HK		 350 Prefix =>
351 Unchecked_Convert_To (Array_Typ,
352 New_Occurrence_Of (Obj_Id, Loc)),
99fc068e
RD		 353 Attribute_Name => Name_Range,
354 Expressions => New_List (
f16cb8df
HK		 355 Make_Integer_Literal (Loc, Dim))))),
356 Statements => New_List (
357 Validate_Dimension (Obj_Id, Dim + 1, Indexes)));
99fc068e 358 end if;
f16cb8df
HK		 359 end Validate_Dimension;
360
361 -- Local variables
362
363 Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
364 Indexes : constant List_Id := New_List;
365 Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
366 Stmts : List_Id;
99fc068e
RD		 367
368 -- Start of processing for Build_Array_VS_Func
369
370 begin
f16cb8df 371 Stmts := New_List (Validate_Dimension (Obj_Id, 1, Indexes));
99fc068e 372
f16cb8df
HK		 373 -- Generate:
374 -- return True;
99fc068e 375
f16cb8df
HK		 376 Append_To (Stmts,
377 Make_Simple_Return_Statement (Loc,
378 Expression => New_Occurrence_Of (Standard_True, Loc)));
99fc068e 379
f16cb8df
HK		 380 -- Generate:
381 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
382 -- begin
383 -- Stmts
384 -- end Func_Id;
99fc068e
RD		 385
386 Set_Ekind (Func_Id, E_Function);
387 Set_Is_Internal (Func_Id);
f16cb8df
HK		 388 Set_Is_Pure (Func_Id);
389
390 if not Debug_Generated_Code then
391 Set_Debug_Info_Off (Func_Id);
392 end if;
99fc068e 393
f16cb8df 394 Insert_Action (Attr,
99fc068e
RD		 395 Make_Subprogram_Body (Loc,
396 Specification =>
397 Make_Function_Specification (Loc,
398 Defining_Unit_Name => Func_Id,
f16cb8df
HK		 399 Parameter_Specifications => New_List (
400 Make_Parameter_Specification (Loc,
401 Defining_Identifier => Obj_Id,
402 In_Present => True,
403 Out_Present => False,
404 Parameter_Type => New_Occurrence_Of (Formal_Typ, Loc))),
405 Result_Definition =>
406 New_Occurrence_Of (Standard_Boolean, Loc)),
99fc068e
RD		 407 Declarations => New_List,
408 Handled_Statement_Sequence =>
409 Make_Handled_Sequence_Of_Statements (Loc,
f16cb8df 410 Statements => Stmts)));
99fc068e 411
99fc068e
RD		 412 return Func_Id;
413 end Build_Array_VS_Func;
414
99bba92c
AC		 415 ---------------------------------
416 -- Build_Disp_Get_Task_Id_Call --
417 ---------------------------------
418
419 function Build_Disp_Get_Task_Id_Call (Actual : Node_Id) return Node_Id is
c0e938d0
AC		 420 Loc : constant Source_Ptr := Sloc (Actual);
421 Typ : constant Entity_Id := Etype (Actual);
422 Subp : constant Entity_Id := Find_Prim_Op (Typ, Name_uDisp_Get_Task_Id);
423
99bba92c 424 begin
c0e938d0
AC		 425 -- Generate:
426 -- _Disp_Get_Task_Id (Actual)
427
428 return
429 Make_Function_Call (Loc,
430 Name => New_Occurrence_Of (Subp, Loc),
431 Parameter_Associations => New_List (Actual));
99bba92c
AC		 432 end Build_Disp_Get_Task_Id_Call;
433
45ec05e1
RD		 434 --------------------------
435 -- Build_Record_VS_Func --
436 --------------------------
437
45ec05e1 438 function Build_Record_VS_Func
f16cb8df
HK		 439 (Attr : Node_Id;
440 Formal_Typ : Entity_Id;
441 Rec_Typ : Entity_Id) return Entity_Id
45ec05e1 442 is
f16cb8df
HK		 443 -- NOTE: The logic of Build_Record_VS_Func is intentionally passive.
444 -- It generates code only when there are components, discriminants,
445 -- or variant parts to validate.
446
447 -- NOTE: The routines within Build_Record_VS_Func are intentionally
448 -- unnested to avoid deep indentation of code.
449
450 Loc : constant Source_Ptr := Sloc (Attr);
451
452 procedure Validate_Component_List
453 (Obj_Id : Entity_Id;
454 Comp_List : Node_Id;
455 Stmts : in out List_Id);
456 -- Process all components and variant parts of component list Comp_List.
457 -- Obj_Id denotes the entity of the validation parameter. All new code
458 -- is added to list Stmts.
459
460 procedure Validate_Field
461 (Obj_Id : Entity_Id;
462 Field : Node_Id;
463 Cond : in out Node_Id);
464 -- Process component declaration or discriminant specification Field.
465 -- Obj_Id denotes the entity of the validation parameter. Cond denotes
466 -- an "or else" conditional expression which contains the new code (if
467 -- any).
468
469 procedure Validate_Fields
470 (Obj_Id : Entity_Id;
471 Fields : List_Id;
472 Stmts : in out List_Id);
473 -- Process component declarations or discriminant specifications in list
474 -- Fields. Obj_Id denotes the entity of the validation parameter. All
475 -- new code is added to list Stmts.
476
477 procedure Validate_Variant
478 (Obj_Id : Entity_Id;
479 Var : Node_Id;
480 Alts : in out List_Id);
481 -- Process variant Var. Obj_Id denotes the entity of the validation
482 -- parameter. Alts denotes a list of case statement alternatives which
483 -- contains the new code (if any).
484
485 procedure Validate_Variant_Part
486 (Obj_Id : Entity_Id;
487 Var_Part : Node_Id;
488 Stmts : in out List_Id);
489 -- Process variant part Var_Part. Obj_Id denotes the entity of the
490 -- validation parameter. All new code is added to list Stmts.
45ec05e1 491
f16cb8df
HK		 492 -----------------------------
493 -- Validate_Component_List --
494 -----------------------------
45ec05e1 495
f16cb8df
HK		 496 procedure Validate_Component_List
497 (Obj_Id : Entity_Id;
498 Comp_List : Node_Id;
499 Stmts : in out List_Id)
500 is
501 Var_Part : constant Node_Id := Variant_Part (Comp_List);
45ec05e1 502
f16cb8df
HK		 503 begin
504 -- Validate all components
505
506 Validate_Fields
507 (Obj_Id => Obj_Id,
508 Fields => Component_Items (Comp_List),
509 Stmts => Stmts);
510
511 -- Validate the variant part
512
513 if Present (Var_Part) then
514 Validate_Variant_Part
515 (Obj_Id => Obj_Id,
516 Var_Part => Var_Part,
517 Stmts => Stmts);
518 end if;
519 end Validate_Component_List;
45ec05e1 520
f16cb8df
HK		 521 --------------------
522 -- Validate_Field --
523 --------------------
524
525 procedure Validate_Field
526 (Obj_Id : Entity_Id;
527 Field : Node_Id;
528 Cond : in out Node_Id)
45ec05e1 529 is
f16cb8df
HK		 530 Field_Id : constant Entity_Id := Defining_Entity (Field);
531 Field_Nam : constant Name_Id := Chars (Field_Id);
532 Field_Typ : constant Entity_Id := Validated_View (Etype (Field_Id));
533 Attr_Nam : Name_Id;
45ec05e1
RD		 534
535 begin
f16cb8df
HK		 536 -- Do not process internally-generated fields. Note that checking for
537 -- Comes_From_Source is not correct because this will eliminate the
538 -- components within the corresponding record of a protected type.
45ec05e1 539
f16cb8df
HK		 540 if Nam_In (Field_Nam, Name_uObject,
541 Name_uParent,
542 Name_uTag)
c468e1fb 543 then
f16cb8df 544 null;
45ec05e1 545
f16cb8df 546 -- Do not process fields without any scalar components
45ec05e1 547
f16cb8df
HK		 548 elsif not Scalar_Part_Present (Field_Typ) then
549 null;
550
551 -- Otherwise the field needs to be validated. Use Make_Identifier
552 -- rather than New_Occurrence_Of to identify the field because the
553 -- wrong entity may be picked up when private types are involved.
554
555 -- Generate:
556 -- [or else] not Rec_Typ (Obj_Id).Item_Nam'Valid[_Scalars]
557
558 else
559 if Is_Scalar_Type (Field_Typ) then
560 Attr_Nam := Name_Valid;
561 else
562 Attr_Nam := Name_Valid_Scalars;
563 end if;
564
565 Evolve_Or_Else (Cond,
566 Make_Op_Not (Loc,
567 Right_Opnd =>
568 Make_Attribute_Reference (Loc,
569 Prefix =>
570 Make_Selected_Component (Loc,
571 Prefix =>
572 Unchecked_Convert_To (Rec_Typ,
573 New_Occurrence_Of (Obj_Id, Loc)),
574 Selector_Name => Make_Identifier (Loc, Field_Nam)),
575 Attribute_Name => Attr_Nam)));
45ec05e1 576 end if;
f16cb8df 577 end Validate_Field;
45ec05e1 578
f16cb8df
HK		 579 ---------------------
580 -- Validate_Fields --
581 ---------------------
45ec05e1 582
f16cb8df
HK		 583 procedure Validate_Fields
584 (Obj_Id : Entity_Id;
585 Fields : List_Id;
586 Stmts : in out List_Id)
587 is
588 Cond : Node_Id;
589 Field : Node_Id;
45ec05e1 590
f16cb8df
HK		 591 begin
592 -- Assume that none of the fields are eligible for verification
45ec05e1 593
f16cb8df 594 Cond := Empty;
45ec05e1 595
f16cb8df 596 -- Validate all fields
45ec05e1 597
f16cb8df
HK		 598 Field := First_Non_Pragma (Fields);
599 while Present (Field) loop
600 Validate_Field
601 (Obj_Id => Obj_Id,
602 Field => Field,
603 Cond => Cond);
45ec05e1 604
f16cb8df
HK		 605 Next_Non_Pragma (Field);
606 end loop;
45ec05e1 607
f16cb8df
HK		 608 -- Generate:
609 -- if not Rec_Typ (Obj_Id).Item_Nam_1'Valid[_Scalars]
610 -- or else not Rec_Typ (Obj_Id).Item_Nam_N'Valid[_Scalars]
611 -- then
612 -- return False;
613 -- end if;
45ec05e1 614
f16cb8df
HK		 615 if Present (Cond) then
616 Append_New_To (Stmts,
617 Make_Implicit_If_Statement (Attr,
618 Condition => Cond,
619 Then_Statements => New_List (
620 Make_Simple_Return_Statement (Loc,
621 Expression => New_Occurrence_Of (Standard_False, Loc)))));
622 end if;
623 end Validate_Fields;
45ec05e1 624
f16cb8df
HK		 625 ----------------------
626 -- Validate_Variant --
627 ----------------------
45ec05e1 628
f16cb8df
HK		 629 procedure Validate_Variant
630 (Obj_Id : Entity_Id;
631 Var : Node_Id;
632 Alts : in out List_Id)
633 is
634 Stmts : List_Id;
45ec05e1 635
f16cb8df
HK		 636 begin
637 -- Assume that none of the components and variants are eligible for
638 -- verification.
45ec05e1 639
f16cb8df 640 Stmts := No_List;
45ec05e1 641
b108c2ed 642 -- Validate components
45ec05e1 643
f16cb8df
HK		 644 Validate_Component_List
645 (Obj_Id => Obj_Id,
646 Comp_List => Component_List (Var),
647 Stmts => Stmts);
648
649 -- Generate a null statement in case none of the components were
650 -- verified because this will otherwise eliminate an alternative
651 -- from the variant case statement and render the generated code
652 -- illegal.
45ec05e1 653
f16cb8df
HK		 654 if No (Stmts) then
655 Append_New_To (Stmts, Make_Null_Statement (Loc));
656 end if;
45ec05e1 657
f16cb8df
HK		 658 -- Generate:
659 -- when Discrete_Choices =>
660 -- Stmts
661
662 Append_New_To (Alts,
663 Make_Case_Statement_Alternative (Loc,
664 Discrete_Choices =>
665 New_Copy_List_Tree (Discrete_Choices (Var)),
666 Statements => Stmts));
667 end Validate_Variant;
668
669 ---------------------------
670 -- Validate_Variant_Part --
671 ---------------------------
672
673 procedure Validate_Variant_Part
674 (Obj_Id : Entity_Id;
675 Var_Part : Node_Id;
676 Stmts : in out List_Id)
677 is
678 Vars : constant List_Id := Variants (Var_Part);
679 Alts : List_Id;
680 Var : Node_Id;
45ec05e1 681
f16cb8df
HK		 682 begin
683 -- Assume that none of the variants are eligible for verification
c468e1fb 684
f16cb8df 685 Alts := No_List;
45ec05e1 686
f16cb8df 687 -- Validate variants
45ec05e1 688
f16cb8df
HK		 689 Var := First_Non_Pragma (Vars);
690 while Present (Var) loop
691 Validate_Variant
692 (Obj_Id => Obj_Id,
693 Var => Var,
694 Alts => Alts);
45ec05e1 695
f16cb8df
HK		 696 Next_Non_Pragma (Var);
697 end loop;
45ec05e1 698
f16cb8df
HK		 699 -- Even though individual variants may lack eligible components, the
700 -- alternatives must still be generated.
45ec05e1 701
f16cb8df 702 pragma Assert (Present (Alts));
45ec05e1 703
f16cb8df
HK		 704 -- Generate:
705 -- case Rec_Typ (Obj_Id).Discriminant is
706 -- when Discrete_Choices_1 =>
707 -- Stmts_1
708 -- when Discrete_Choices_N =>
709 -- Stmts_N
710 -- end case;
711
712 Append_New_To (Stmts,
713 Make_Case_Statement (Loc,
714 Expression =>
715 Make_Selected_Component (Loc,
716 Prefix =>
717 Unchecked_Convert_To (Rec_Typ,
718 New_Occurrence_Of (Obj_Id, Loc)),
719 Selector_Name => New_Copy_Tree (Name (Var_Part))),
720 Alternatives => Alts));
721 end Validate_Variant_Part;
45ec05e1 722
bbe008b6 723 -- Local variables
45ec05e1 724
f16cb8df
HK		 725 Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
726 Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'R');
f2f9cdad 727 Comps : Node_Id;
f16cb8df 728 Stmts : List_Id;
f2f9cdad
HK		 729 Typ : Entity_Id;
730 Typ_Decl : Node_Id;
731 Typ_Def : Node_Id;
732 Typ_Ext : Node_Id;
45ec05e1 733
bbe008b6
HK		 734 -- Start of processing for Build_Record_VS_Func
735
45ec05e1 736 begin
f2f9cdad
HK		 737 Typ := Rec_Typ;
738
739 -- Use the root type when dealing with a class-wide type
740
741 if Is_Class_Wide_Type (Typ) then
742 Typ := Root_Type (Typ);
743 end if;
744
745 Typ_Decl := Declaration_Node (Typ);
746 Typ_Def := Type_Definition (Typ_Decl);
747
748 -- The components of a derived type are located in the extension part
749
750 if Nkind (Typ_Def) = N_Derived_Type_Definition then
751 Typ_Ext := Record_Extension_Part (Typ_Def);
752
753 if Present (Typ_Ext) then
754 Comps := Component_List (Typ_Ext);
755 else
756 Comps := Empty;
757 end if;
758
759 -- Otherwise the components are available in the definition
760
761 else
762 Comps := Component_List (Typ_Def);
763 end if;
764
f16cb8df
HK		 765 -- The code generated by this routine is as follows:
766 --
767 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
768 -- begin
769 -- if not Rec_Typ (Obj_Id).Discriminant_1'Valid[_Scalars]
770 -- or else not Rec_Typ (Obj_Id).Discriminant_N'Valid[_Scalars]
771 -- then
772 -- return False;
773 -- end if;
774 --
775 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
776 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
777 -- then
778 -- return False;
779 -- end if;
780 --
781 -- case Discriminant_1 is
782 -- when Choice_1 =>
783 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
784 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
785 -- then
786 -- return False;
787 -- end if;
788 --
789 -- case Discriminant_N is
790 -- ...
791 -- when Choice_N =>
792 -- ...
793 -- end case;
794 --
795 -- return True;
796 -- end Func_Id;
797
798 -- Assume that the record type lacks eligible components, discriminants,
799 -- and variant parts.
800
801 Stmts := No_List;
802
803 -- Validate the discriminants
804
805 if not Is_Unchecked_Union (Rec_Typ) then
806 Validate_Fields
807 (Obj_Id => Obj_Id,
f2f9cdad 808 Fields => Discriminant_Specifications (Typ_Decl),
f16cb8df
HK		 809 Stmts => Stmts);
810 end if;
45ec05e1 811
f16cb8df 812 -- Validate the components and variant parts
45ec05e1 813
f16cb8df
HK		 814 Validate_Component_List
815 (Obj_Id => Obj_Id,
f2f9cdad 816 Comp_List => Comps,
f16cb8df
HK		 817 Stmts => Stmts);
818
819 -- Generate:
820 -- return True;
821
822 Append_New_To (Stmts,
45ec05e1
RD		 823 Make_Simple_Return_Statement (Loc,
824 Expression => New_Occurrence_Of (Standard_True, Loc)));
825
f16cb8df
HK		 826 -- Generate:
827 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
828 -- begin
829 -- Stmts
830 -- end Func_Id;
831
832 Set_Ekind (Func_Id, E_Function);
833 Set_Is_Internal (Func_Id);
834 Set_Is_Pure (Func_Id);
835
836 if not Debug_Generated_Code then
837 Set_Debug_Info_Off (Func_Id);
838 end if;
839
840 Insert_Action (Attr,
45ec05e1
RD		 841 Make_Subprogram_Body (Loc,
842 Specification =>
843 Make_Function_Specification (Loc,
844 Defining_Unit_Name => Func_Id,
f16cb8df
HK		 845 Parameter_Specifications => New_List (
846 Make_Parameter_Specification (Loc,
847 Defining_Identifier => Obj_Id,
848 Parameter_Type => New_Occurrence_Of (Formal_Typ, Loc))),
849 Result_Definition =>
850 New_Occurrence_Of (Standard_Boolean, Loc)),
45ec05e1
RD		 851 Declarations => New_List,
852 Handled_Statement_Sequence =>
f16cb8df
HK		 853 Make_Handled_Sequence_Of_Statements (Loc,
854 Statements => Stmts)),
45ec05e1
RD		 855 Suppress => Discriminant_Check);
856
45ec05e1
RD		 857 return Func_Id;
858 end Build_Record_VS_Func;
859
70482933
RK		 860 ----------------------------------
861 -- Compile_Stream_Body_In_Scope --
862 ----------------------------------
863
864 procedure Compile_Stream_Body_In_Scope
865 (N : Node_Id;
866 Decl : Node_Id;
867 Arr : Entity_Id;
868 Check : Boolean)
869 is
d6dffa66
HK		 870 C_Type : constant Entity_Id := Base_Type (Component_Type (Arr));
871 Curr : constant Entity_Id := Current_Scope;
872 Install : Boolean := False;
873 Scop : Entity_Id := Scope (Arr);
73f05f9f 874
70482933
RK		 875 begin
876 if Is_Hidden (Arr)
877 and then not In_Open_Scopes (Scop)
878 and then Ekind (Scop) = E_Package
73f05f9f
ES		 879 then
880 Install := True;
73f05f9f 881
d6dffa66
HK		 882 else
883 -- The component type may be private, in which case we install its
884 -- full view to compile the subprogram.
3dddb11e 885
e3f94155
AC		 886 -- The component type may be private, in which case we install its
887 -- full view to compile the subprogram. We do not do this if the
888 -- type has a Stream_Convert pragma, which indicates that there are
889 -- special stream-processing operations for that type (for example
890 -- Unbounded_String and its wide varieties).
891
73f05f9f 892 Scop := Scope (C_Type);
3dddb11e 893
73f05f9f
ES		 894 if Is_Private_Type (C_Type)
895 and then Present (Full_View (C_Type))
896 and then not In_Open_Scopes (Scop)
897 and then Ekind (Scop) = E_Package
e3f94155 898 and then No (Get_Stream_Convert_Pragma (C_Type))
73f05f9f
ES		 899 then
900 Install := True;
901 end if;
902 end if;
903
904 -- If we are within an instance body, then all visibility has been
905 -- established already and there is no need to install the package.
906
d6dffa66 907 if Install and then not In_Instance_Body then
31104818 908 Push_Scope (Scop);
70482933
RK		 909 Install_Visible_Declarations (Scop);
910 Install_Private_Declarations (Scop);
70482933
RK		 911
912 -- The entities in the package are now visible, but the generated
913 -- stream entity must appear in the current scope (usually an
914 -- enclosing stream function) so that itypes all have their proper
915 -- scopes.
916
31104818 917 Push_Scope (Curr);
73f05f9f
ES		 918 else
919 Install := False;
70482933
RK		 920 end if;
921
922 if Check then
923 Insert_Action (N, Decl);
924 else
65f01153 925 Insert_Action (N, Decl, Suppress => All_Checks);
70482933
RK		 926 end if;
927
73f05f9f 928 if Install then
70482933
RK		 929
930 -- Remove extra copy of current scope, and package itself
931
932 Pop_Scope;
933 End_Package_Scope (Scop);
934 end if;
935 end Compile_Stream_Body_In_Scope;
936
7ce611e2
ES		 937 -----------------------------------
938 -- Expand_Access_To_Protected_Op --
939 -----------------------------------
940
941 procedure Expand_Access_To_Protected_Op
942 (N : Node_Id;
943 Pref : Node_Id;
944 Typ : Entity_Id)
945 is
946 -- The value of the attribute_reference is a record containing two
947 -- fields: an access to the protected object, and an access to the
948 -- subprogram itself. The prefix is a selected component.
949
950 Loc : constant Source_Ptr := Sloc (N);
951 Agg : Node_Id;
952 Btyp : constant Entity_Id := Base_Type (Typ);
953 Sub : Entity_Id;
e657b693 954 Sub_Ref : Node_Id;
7ce611e2
ES		 955 E_T : constant Entity_Id := Equivalent_Type (Btyp);
956 Acc : constant Entity_Id :=
957 Etype (Next_Component (First_Component (E_T)));
958 Obj_Ref : Node_Id;
959 Curr : Entity_Id;
960
7ce611e2
ES		 961 -- Start of processing for Expand_Access_To_Protected_Op
962
963 begin
6e1ee5c3
AC		 964 -- Within the body of the protected type, the prefix designates a local
965 -- operation, and the object is the first parameter of the corresponding
966 -- protected body of the current enclosing operation.
7ce611e2
ES		 967
968 if Is_Entity_Name (Pref) then
2290a0fe
AC		 969 -- All indirect calls are external calls, so must do locking and
970 -- barrier reevaluation, even if the 'Access occurs within the
971 -- protected body. Hence the call to External_Subprogram, as opposed
972 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means
973 -- that indirect calls from within the same protected body will
974 -- deadlock, as allowed by RM-9.5.1(8,15,17).
975
976 Sub := New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc);
7ce611e2 977
21d27997
RD		 978 -- Don't traverse the scopes when the attribute occurs within an init
979 -- proc, because we directly use the _init formal of the init proc in
980 -- that case.
981
7ce611e2 982 Curr := Current_Scope;
21d27997
RD		 983 if not Is_Init_Proc (Curr) then
984 pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
985
986 while Scope (Curr) /= Scope (Entity (Pref)) loop
987 Curr := Scope (Curr);
988 end loop;
989 end if;
7ce611e2
ES		 990
991 -- In case of protected entries the first formal of its Protected_
992 -- Body_Subprogram is the address of the object.
993
994 if Ekind (Curr) = E_Entry then
995 Obj_Ref :=
996 New_Occurrence_Of
997 (First_Formal
998 (Protected_Body_Subprogram (Curr)), Loc);
999
21d27997
RD		 1000 -- If the current scope is an init proc, then use the address of the
1001 -- _init formal as the object reference.
1002
1003 elsif Is_Init_Proc (Curr) then
1004 Obj_Ref :=
1005 Make_Attribute_Reference (Loc,
1006 Prefix => New_Occurrence_Of (First_Formal (Curr), Loc),
1007 Attribute_Name => Name_Address);
1008
7ce611e2
ES		 1009 -- In case of protected subprograms the first formal of its
1010 -- Protected_Body_Subprogram is the object and we get its address.
1011
1012 else
1013 Obj_Ref :=
1014 Make_Attribute_Reference (Loc,
1015 Prefix =>
1016 New_Occurrence_Of
1017 (First_Formal
1018 (Protected_Body_Subprogram (Curr)), Loc),
1019 Attribute_Name => Name_Address);
1020 end if;
1021
1022 -- Case where the prefix is not an entity name. Find the
1023 -- version of the protected operation to be called from
1024 -- outside the protected object.
1025
1026 else
1027 Sub :=
1028 New_Occurrence_Of
1029 (External_Subprogram
1030 (Entity (Selector_Name (Pref))), Loc);
1031
1032 Obj_Ref :=
1033 Make_Attribute_Reference (Loc,
1034 Prefix => Relocate_Node (Prefix (Pref)),
1035 Attribute_Name => Name_Address);
1036 end if;
1037
e657b693
AC		 1038 Sub_Ref :=
1039 Make_Attribute_Reference (Loc,
f7e71125 1040 Prefix => Sub,
e657b693
AC		 1041 Attribute_Name => Name_Access);
1042
1043 -- We set the type of the access reference to the already generated
1044 -- access_to_subprogram type, and declare the reference analyzed, to
1045 -- prevent further expansion when the enclosing aggregate is analyzed.
1046
1047 Set_Etype (Sub_Ref, Acc);
1048 Set_Analyzed (Sub_Ref);
1049
7ce611e2
ES		 1050 Agg :=
1051 Make_Aggregate (Loc,
f7e71125 1052 Expressions => New_List (Obj_Ref, Sub_Ref));
7ce611e2 1053
1f92d7f2
AC		 1054 -- Sub_Ref has been marked as analyzed, but we still need to make sure
1055 -- Sub is correctly frozen.
1056
6e1ee5c3 1057 Freeze_Before (N, Entity (Sub));
1f92d7f2 1058
7ce611e2 1059 Rewrite (N, Agg);
7ce611e2
ES		 1060 Analyze_And_Resolve (N, E_T);
1061
f7e71125
AC		 1062 -- For subsequent analysis, the node must retain its type. The backend
1063 -- will replace it with the equivalent type where needed.
7ce611e2
ES		 1064
1065 Set_Etype (N, Typ);
1066 end Expand_Access_To_Protected_Op;
1067
70482933
RK		 1068 --------------------------
1069 -- Expand_Fpt_Attribute --
1070 --------------------------
1071
1072 procedure Expand_Fpt_Attribute
1073 (N : Node_Id;
65f01153 1074 Pkg : RE_Id;
fbf5a39b 1075 Nam : Name_Id;
70482933
RK		 1076 Args : List_Id)
1077 is
1078 Loc : constant Source_Ptr := Sloc (N);
1079 Typ : constant Entity_Id := Etype (N);
70482933
RK		 1080 Fnm : Node_Id;
1081
1082 begin
65f01153
RD		 1083 -- The function name is the selected component Attr_xxx.yyy where
1084 -- Attr_xxx is the package name, and yyy is the argument Nam.
70482933
RK		 1085
1086 -- Note: it would be more usual to have separate RE entries for each
1087 -- of the entities in the Fat packages, but first they have identical
1088 -- names (so we would have to have lots of renaming declarations to
1089 -- meet the normal RE rule of separate names for all runtime entities),
a90bd866 1090 -- and second there would be an awful lot of them.
70482933 1091
70482933
RK		 1092 Fnm :=
1093 Make_Selected_Component (Loc,
e4494292 1094 Prefix => New_Occurrence_Of (RTE (Pkg), Loc),
fbf5a39b 1095 Selector_Name => Make_Identifier (Loc, Nam));
70482933
RK		 1096
1097 -- The generated call is given the provided set of parameters, and then
1098 -- wrapped in a conversion which converts the result to the target type
1d571f3b
AC		 1099 -- We use the base type as the target because a range check may be
1100 -- required.
70482933
RK		 1101
1102 Rewrite (N,
1d571f3b 1103 Unchecked_Convert_To (Base_Type (Etype (N)),
70482933 1104 Make_Function_Call (Loc,
65f01153 1105 Name => Fnm,
70482933
RK		 1106 Parameter_Associations => Args)));
1107
1108 Analyze_And_Resolve (N, Typ);
70482933
RK		 1109 end Expand_Fpt_Attribute;
1110
1111 ----------------------------
1112 -- Expand_Fpt_Attribute_R --
1113 ----------------------------
1114
1115 -- The single argument is converted to its root type to call the
1116 -- appropriate runtime function, with the actual call being built
1117 -- by Expand_Fpt_Attribute
1118
1119 procedure Expand_Fpt_Attribute_R (N : Node_Id) is
1120 E1 : constant Node_Id := First (Expressions (N));
65f01153
RD		 1121 Ftp : Entity_Id;
1122 Pkg : RE_Id;
70482933 1123 begin
65f01153 1124 Find_Fat_Info (Etype (E1), Ftp, Pkg);
fbf5a39b 1125 Expand_Fpt_Attribute
65f01153
RD		 1126 (N, Pkg, Attribute_Name (N),
1127 New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1))));
70482933
RK		 1128 end Expand_Fpt_Attribute_R;
1129
1130 -----------------------------
1131 -- Expand_Fpt_Attribute_RI --
1132 -----------------------------
1133
1134 -- The first argument is converted to its root type and the second
1135 -- argument is converted to standard long long integer to call the
1136 -- appropriate runtime function, with the actual call being built
1137 -- by Expand_Fpt_Attribute
1138
1139 procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
1140 E1 : constant Node_Id := First (Expressions (N));
65f01153
RD		 1141 Ftp : Entity_Id;
1142 Pkg : RE_Id;
70482933 1143 E2 : constant Node_Id := Next (E1);
70482933 1144 begin
65f01153 1145 Find_Fat_Info (Etype (E1), Ftp, Pkg);
fbf5a39b 1146 Expand_Fpt_Attribute
65f01153 1147 (N, Pkg, Attribute_Name (N),
fbf5a39b 1148 New_List (
65f01153 1149 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
fbf5a39b 1150 Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
70482933
RK		 1151 end Expand_Fpt_Attribute_RI;
1152
1153 -----------------------------
1154 -- Expand_Fpt_Attribute_RR --
1155 -----------------------------
1156
0669bebe 1157 -- The two arguments are converted to their root types to call the
70482933
RK		 1158 -- appropriate runtime function, with the actual call being built
1159 -- by Expand_Fpt_Attribute
1160
1161 procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
d436b30d
AC		 1162 E1 : constant Node_Id := First (Expressions (N));
1163 E2 : constant Node_Id := Next (E1);
65f01153
RD		 1164 Ftp : Entity_Id;
1165 Pkg : RE_Id;
d436b30d 1166
70482933 1167 begin
65f01153 1168 Find_Fat_Info (Etype (E1), Ftp, Pkg);
fbf5a39b 1169 Expand_Fpt_Attribute
65f01153 1170 (N, Pkg, Attribute_Name (N),
fbf5a39b 1171 New_List (
65f01153
RD		 1172 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
1173 Unchecked_Convert_To (Ftp, Relocate_Node (E2))));
70482933
RK		 1174 end Expand_Fpt_Attribute_RR;
1175
d436b30d
AC		 1176 ---------------------------------
1177 -- Expand_Loop_Entry_Attribute --
1178 ---------------------------------
1179
aa9b151a 1180 procedure Expand_Loop_Entry_Attribute (N : Node_Id) is
d436b30d
AC		 1181 procedure Build_Conditional_Block
1182 (Loc : Source_Ptr;
1183 Cond : Node_Id;
1184 Loop_Stmt : Node_Id;
1185 If_Stmt : out Node_Id;
1186 Blk_Stmt : out Node_Id);
1187 -- Create a block Blk_Stmt with an empty declarative list and a single
1188 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
1189 -- condition Cond. If_Stmt is Empty when there is no condition provided.
1190
1191 function Is_Array_Iteration (N : Node_Id) return Boolean;
1192 -- Determine whether loop statement N denotes an Ada 2012 iteration over
1193 -- an array object.
1194
1195 -----------------------------
1196 -- Build_Conditional_Block --
1197 -----------------------------
1198
1199 procedure Build_Conditional_Block
1200 (Loc : Source_Ptr;
1201 Cond : Node_Id;
1202 Loop_Stmt : Node_Id;
1203 If_Stmt : out Node_Id;
1204 Blk_Stmt : out Node_Id)
1205 is
1206 begin
1207 -- Do not reanalyze the original loop statement because it is simply
1208 -- being relocated.
1209
1210 Set_Analyzed (Loop_Stmt);
1211
1212 Blk_Stmt :=
1213 Make_Block_Statement (Loc,
1214 Declarations => New_List,
1215 Handled_Statement_Sequence =>
1216 Make_Handled_Sequence_Of_Statements (Loc,
1217 Statements => New_List (Loop_Stmt)));
1218
1219 if Present (Cond) then
1220 If_Stmt :=
1221 Make_If_Statement (Loc,
1222 Condition => Cond,
1223 Then_Statements => New_List (Blk_Stmt));
1224 else
1225 If_Stmt := Empty;
1226 end if;
1227 end Build_Conditional_Block;
1228
1229 ------------------------
1230 -- Is_Array_Iteration --
1231 ------------------------
1232
1233 function Is_Array_Iteration (N : Node_Id) return Boolean is
1234 Stmt : constant Node_Id := Original_Node (N);
1235 Iter : Node_Id;
1236
1237 begin
1238 if Nkind (Stmt) = N_Loop_Statement
1239 and then Present (Iteration_Scheme (Stmt))
1240 and then Present (Iterator_Specification (Iteration_Scheme (Stmt)))
1241 then
1242 Iter := Iterator_Specification (Iteration_Scheme (Stmt));
1243
1244 return
1245 Of_Present (Iter) and then Is_Array_Type (Etype (Name (Iter)));
1246 end if;
1247
1248 return False;
1249 end Is_Array_Iteration;
1250
1251 -- Local variables
1252
aa9b151a 1253 Pref : constant Node_Id := Prefix (N);
0f83b044
AC		 1254 Base_Typ : constant Entity_Id := Base_Type (Etype (Pref));
1255 Exprs : constant List_Id := Expressions (N);
1256 Aux_Decl : Node_Id;
dcd5fd67 1257 Blk : Node_Id := Empty;
d436b30d
AC		 1258 Decls : List_Id;
1259 Installed : Boolean;
1260 Loc : Source_Ptr;
1261 Loop_Id : Entity_Id;
1262 Loop_Stmt : Node_Id;
31e358e1 1263 Result : Node_Id := Empty;
d436b30d
AC		 1264 Scheme : Node_Id;
1265 Temp_Decl : Node_Id;
1266 Temp_Id : Entity_Id;
1267
1268 -- Start of processing for Expand_Loop_Entry_Attribute
1269
1270 begin
1271 -- Step 1: Find the related loop
1272
1273 -- The loop label variant of attribute 'Loop_Entry already has all the
1274 -- information in its expression.
1275
1276 if Present (Exprs) then
1277 Loop_Id := Entity (First (Exprs));
1278 Loop_Stmt := Label_Construct (Parent (Loop_Id));
1279
0f83b044
AC		 1280 -- Climb the parent chain to find the nearest enclosing loop. Skip
1281 -- all internally generated loops for quantified expressions and for
1282 -- element iterators over multidimensional arrays because the pragma
1283 -- applies to source loop.
d436b30d
AC		 1284
1285 else
aa9b151a 1286 Loop_Stmt := N;
d436b30d
AC		 1287 while Present (Loop_Stmt) loop
1288 if Nkind (Loop_Stmt) = N_Loop_Statement
ae5115dd
AC		 1289 and then Nkind (Original_Node (Loop_Stmt)) = N_Loop_Statement
1290 and then Comes_From_Source (Original_Node (Loop_Stmt))
d436b30d
AC		 1291 then
1292 exit;
1293 end if;
1294
1295 Loop_Stmt := Parent (Loop_Stmt);
1296 end loop;
1297
1298 Loop_Id := Entity (Identifier (Loop_Stmt));
1299 end if;
1300
1301 Loc := Sloc (Loop_Stmt);
1302
1303 -- Step 2: Transform the loop
1304
1305 -- The loop has already been transformed during the expansion of a prior
1306 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
1307
1308 if Has_Loop_Entry_Attributes (Loop_Id) then
3d67b239
AC		 1309
1310 -- When the related loop name appears as the argument of attribute
1311 -- Loop_Entry, the corresponding label construct is the generated
0d5fbf52 1312 -- block statement. This is because the expander reuses the label.
3d67b239 1313
24778dbb
AC		 1314 if Nkind (Loop_Stmt) = N_Block_Statement then
1315 Decls := Declarations (Loop_Stmt);
3d67b239
AC		 1316
1317 -- In all other cases, the loop must appear in the handled sequence
1318 -- of statements of the generated block.
1319
24778dbb 1320 else
3d67b239
AC		 1321 pragma Assert
1322 (Nkind (Parent (Loop_Stmt)) = N_Handled_Sequence_Of_Statements
fc999c5d
RD		 1323 and then
1324 Nkind (Parent (Parent (Loop_Stmt))) = N_Block_Statement);
24778dbb
AC		 1325
1326 Decls := Declarations (Parent (Parent (Loop_Stmt)));
1327 end if;
1328
d436b30d
AC		 1329 -- Transform the loop into a conditional block
1330
1331 else
1332 Set_Has_Loop_Entry_Attributes (Loop_Id);
1333 Scheme := Iteration_Scheme (Loop_Stmt);
1334
3d67b239
AC		 1335 -- Infinite loops are transformed into:
1336
1337 -- declare
1338 -- Temp1 : constant <type of Pref1> := <Pref1>;
1339 -- . . .
1340 -- TempN : constant <type of PrefN> := <PrefN>;
1341 -- begin
1342 -- loop
1343 -- <original source statements with attribute rewrites>
1344 -- end loop;
1345 -- end;
1346
1347 if No (Scheme) then
1348 Build_Conditional_Block (Loc,
1349 Cond => Empty,
1350 Loop_Stmt => Relocate_Node (Loop_Stmt),
1351 If_Stmt => Result,
1352 Blk_Stmt => Blk);
1353
1354 Result := Blk;
1355
d436b30d
AC		 1356 -- While loops are transformed into:
1357
fd7215d7
AC		 1358 -- function Fnn return Boolean is
1359 -- begin
1360 -- <condition actions>
1361 -- return <condition>;
1362 -- end Fnn;
1363
1364 -- if Fnn then
d436b30d
AC		 1365 -- declare
1366 -- Temp1 : constant <type of Pref1> := <Pref1>;
1367 -- . . .
1368 -- TempN : constant <type of PrefN> := <PrefN>;
1369 -- begin
1370 -- loop
1371 -- <original source statements with attribute rewrites>
fd7215d7 1372 -- exit when not Fnn;
d436b30d
AC		 1373 -- end loop;
1374 -- end;
1375 -- end if;
1376
1377 -- Note that loops over iterators and containers are already
1378 -- converted into while loops.
1379
3d67b239 1380 elsif Present (Condition (Scheme)) then
d436b30d 1381 declare
fd7215d7
AC		 1382 Func_Decl : Node_Id;
1383 Func_Id : Entity_Id;
1384 Stmts : List_Id;
d436b30d
AC		 1385
1386 begin
c961d820
EB		 1387 Func_Id := Make_Temporary (Loc, 'F');
1388
fd7215d7
AC		 1389 -- Wrap the condition of the while loop in a Boolean function.
1390 -- This avoids the duplication of the same code which may lead
1391 -- to gigi issues with respect to multiple declaration of the
1392 -- same entity in the presence of side effects or checks. Note
1393 -- that the condition actions must also be relocated to the
1394 -- wrapping function.
1395
1396 -- Generate:
1397 -- <condition actions>
1398 -- return <condition>;
1399
1400 if Present (Condition_Actions (Scheme)) then
1401 Stmts := Condition_Actions (Scheme);
1402 else
1403 Stmts := New_List;
1404 end if;
1405
1406 Append_To (Stmts,
1407 Make_Simple_Return_Statement (Loc,
c961d820
EB		 1408 Expression =>
1409 New_Copy_Tree (Condition (Scheme),
1410 New_Scope => Func_Id)));
fd7215d7
AC		 1411
1412 -- Generate:
1413 -- function Fnn return Boolean is
1414 -- begin
1415 -- <Stmts>
1416 -- end Fnn;
1417
fd7215d7
AC		 1418 Func_Decl :=
1419 Make_Subprogram_Body (Loc,
1420 Specification =>
1421 Make_Function_Specification (Loc,
1422 Defining_Unit_Name => Func_Id,
1423 Result_Definition =>
1424 New_Occurrence_Of (Standard_Boolean, Loc)),
1425 Declarations => Empty_List,
1426 Handled_Statement_Sequence =>
1427 Make_Handled_Sequence_Of_Statements (Loc,
1428 Statements => Stmts));
1429
1430 -- The function is inserted before the related loop. Make sure
1431 -- to analyze it in the context of the loop's enclosing scope.
1432
1433 Push_Scope (Scope (Loop_Id));
1434 Insert_Action (Loop_Stmt, Func_Decl);
1435 Pop_Scope;
1436
d436b30d
AC		 1437 -- Transform the original while loop into an infinite loop
1438 -- where the last statement checks the negated condition. This
1439 -- placement ensures that the condition will not be evaluated
1440 -- twice on the first iteration.
1441
fd7215d7
AC		 1442 Set_Iteration_Scheme (Loop_Stmt, Empty);
1443 Scheme := Empty;
1444
d436b30d 1445 -- Generate:
fd7215d7 1446 -- exit when not Fnn;
d436b30d
AC		 1447
1448 Append_To (Statements (Loop_Stmt),
1449 Make_Exit_Statement (Loc,
fd7215d7
AC		 1450 Condition =>
1451 Make_Op_Not (Loc,
1452 Right_Opnd =>
1453 Make_Function_Call (Loc,
1454 Name => New_Occurrence_Of (Func_Id, Loc)))));
d436b30d
AC		 1455
1456 Build_Conditional_Block (Loc,
fd7215d7
AC		 1457 Cond =>
1458 Make_Function_Call (Loc,
1459 Name => New_Occurrence_Of (Func_Id, Loc)),
d436b30d
AC		 1460 Loop_Stmt => Relocate_Node (Loop_Stmt),
1461 If_Stmt => Result,
1462 Blk_Stmt => Blk);
1463 end;
1464
1465 -- Ada 2012 iteration over an array is transformed into:
1466
1467 -- if <Array_Nam>'Length (1) > 0
1468 -- and then <Array_Nam>'Length (N) > 0
1469 -- then
1470 -- declare
1471 -- Temp1 : constant <type of Pref1> := <Pref1>;
1472 -- . . .
1473 -- TempN : constant <type of PrefN> := <PrefN>;
1474 -- begin
1475 -- for X in ... loop -- multiple loops depending on dims
1476 -- <original source statements with attribute rewrites>
1477 -- end loop;
1478 -- end;
1479 -- end if;
1480
1481 elsif Is_Array_Iteration (Loop_Stmt) then
1482 declare
1483 Array_Nam : constant Entity_Id :=
1484 Entity (Name (Iterator_Specification
1485 (Iteration_Scheme (Original_Node (Loop_Stmt)))));
1486 Num_Dims : constant Pos :=
1487 Number_Dimensions (Etype (Array_Nam));
1488 Cond : Node_Id := Empty;
1489 Check : Node_Id;
1490
1491 begin
1492 -- Generate a check which determines whether all dimensions of
1493 -- the array are non-null.
1494
1495 for Dim in 1 .. Num_Dims loop
1496 Check :=
1497 Make_Op_Gt (Loc,
1498 Left_Opnd =>
1499 Make_Attribute_Reference (Loc,
e4494292 1500 Prefix => New_Occurrence_Of (Array_Nam, Loc),
d436b30d
AC		 1501 Attribute_Name => Name_Length,
1502 Expressions => New_List (
1503 Make_Integer_Literal (Loc, Dim))),
1504 Right_Opnd =>
1505 Make_Integer_Literal (Loc, 0));
1506
1507 if No (Cond) then
1508 Cond := Check;
1509 else
1510 Cond :=
1511 Make_And_Then (Loc,
1512 Left_Opnd => Cond,
1513 Right_Opnd => Check);
1514 end if;
1515 end loop;
1516
1517 Build_Conditional_Block (Loc,
1518 Cond => Cond,
1519 Loop_Stmt => Relocate_Node (Loop_Stmt),
1520 If_Stmt => Result,
1521 Blk_Stmt => Blk);
1522 end;
1523
1524 -- For loops are transformed into:
1525
1526 -- if <Low> <= <High> then
1527 -- declare
1528 -- Temp1 : constant <type of Pref1> := <Pref1>;
1529 -- . . .
1530 -- TempN : constant <type of PrefN> := <PrefN>;
1531 -- begin
1532 -- for <Def_Id> in <Low> .. <High> loop
1533 -- <original source statements with attribute rewrites>
1534 -- end loop;
1535 -- end;
1536 -- end if;
1537
1538 elsif Present (Loop_Parameter_Specification (Scheme)) then
1539 declare
1540 Loop_Spec : constant Node_Id :=
1541 Loop_Parameter_Specification (Scheme);
1542 Cond : Node_Id;
1543 Subt_Def : Node_Id;
1544
1545 begin
1546 Subt_Def := Discrete_Subtype_Definition (Loop_Spec);
1547
1548 -- When the loop iterates over a subtype indication with a
1549 -- range, use the low and high bounds of the subtype itself.
1550
1551 if Nkind (Subt_Def) = N_Subtype_Indication then
1552 Subt_Def := Scalar_Range (Etype (Subt_Def));
1553 end if;
1554
1555 pragma Assert (Nkind (Subt_Def) = N_Range);
1556
1557 -- Generate
1558 -- Low <= High
1559
1560 Cond :=
1561 Make_Op_Le (Loc,
1562 Left_Opnd => New_Copy_Tree (Low_Bound (Subt_Def)),
1563 Right_Opnd => New_Copy_Tree (High_Bound (Subt_Def)));
1564
1565 Build_Conditional_Block (Loc,
1566 Cond => Cond,
1567 Loop_Stmt => Relocate_Node (Loop_Stmt),
1568 If_Stmt => Result,
1569 Blk_Stmt => Blk);
1570 end;
d436b30d
AC		 1571 end if;
1572
1573 Decls := Declarations (Blk);
1574 end if;
1575
1576 -- Step 3: Create a constant to capture the value of the prefix at the
1577 -- entry point into the loop.
1578
d436b30d
AC		 1579 Temp_Id := Make_Temporary (Loc, 'P');
1580
6c802906
AC		 1581 -- Preserve the tag of the prefix by offering a specific view of the
1582 -- class-wide version of the prefix.
1583
0f83b044
AC		 1584 if Is_Tagged_Type (Base_Typ) then
1585 Tagged_Case : declare
1586 CW_Temp : Entity_Id;
1587 CW_Typ : Entity_Id;
1588
1589 begin
1590 -- Generate:
1591 -- CW_Temp : constant Base_Typ'Class := Base_Typ'Class (Pref);
1592
1593 CW_Temp := Make_Temporary (Loc, 'T');
1594 CW_Typ := Class_Wide_Type (Base_Typ);
1595
1596 Aux_Decl :=
1597 Make_Object_Declaration (Loc,
1598 Defining_Identifier => CW_Temp,
1599 Constant_Present => True,
1600 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
1601 Expression =>
1602 Convert_To (CW_Typ, Relocate_Node (Pref)));
1603 Append_To (Decls, Aux_Decl);
1604
1605 -- Generate:
1606 -- Temp : Base_Typ renames Base_Typ (CW_Temp);
1607
1608 Temp_Decl :=
1609 Make_Object_Renaming_Declaration (Loc,
1610 Defining_Identifier => Temp_Id,
1611 Subtype_Mark => New_Occurrence_Of (Base_Typ, Loc),
1612 Name =>
1613 Convert_To (Base_Typ, New_Occurrence_Of (CW_Temp, Loc)));
1614 Append_To (Decls, Temp_Decl);
1615 end Tagged_Case;
1616
1617 -- Untagged case
6c802906
AC		 1618
1619 else
0f83b044
AC		 1620 Untagged_Case : declare
1621 Temp_Expr : Node_Id;
1622
1623 begin
1624 Aux_Decl := Empty;
1625
1626 -- Generate a nominal type for the constant when the prefix is of
1627 -- a constrained type. This is achieved by setting the Etype of
1628 -- the relocated prefix to its base type. Since the prefix is now
1629 -- the initialization expression of the constant, its freezing
1630 -- will produce a proper nominal type.
1631
1632 Temp_Expr := Relocate_Node (Pref);
1633 Set_Etype (Temp_Expr, Base_Typ);
1634
1635 -- Generate:
1636 -- Temp : constant Base_Typ := Pref;
1637
1638 Temp_Decl :=
1639 Make_Object_Declaration (Loc,
1640 Defining_Identifier => Temp_Id,
1641 Constant_Present => True,
1642 Object_Definition => New_Occurrence_Of (Base_Typ, Loc),
1643 Expression => Temp_Expr);
1644 Append_To (Decls, Temp_Decl);
1645 end Untagged_Case;
6c802906 1646 end if;
d436b30d
AC		 1647
1648 -- Step 4: Analyze all bits
1649
3d67b239 1650 Installed := Current_Scope = Scope (Loop_Id);
d436b30d 1651
327b1ba4
AC		 1652 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1653 -- associated loop, ensure the proper visibility for analysis.
1654
d436b30d
AC		 1655 if not Installed then
1656 Push_Scope (Scope (Loop_Id));
1657 end if;
1658
327b1ba4
AC		 1659 -- The analysis of the conditional block takes care of the constant
1660 -- declaration.
1661
d436b30d
AC		 1662 if Present (Result) then
1663 Rewrite (Loop_Stmt, Result);
1664 Analyze (Loop_Stmt);
327b1ba4
AC		 1665
1666 -- The conditional block was analyzed when a previous 'Loop_Entry was
1667 -- expanded. There is no point in reanalyzing the block, simply analyze
1668 -- the declaration of the constant.
1669
d436b30d 1670 else
0f83b044
AC		 1671 if Present (Aux_Decl) then
1672 Analyze (Aux_Decl);
6c802906
AC		 1673 end if;
1674
d436b30d
AC		 1675 Analyze (Temp_Decl);
1676 end if;
1677
fd7215d7 1678 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
aa9b151a 1679 Analyze (N);
d436b30d 1680
d436b30d
AC		 1681 if not Installed then
1682 Pop_Scope;
1683 end if;
1684 end Expand_Loop_Entry_Attribute;
1685
e0f63680
AC		 1686 ------------------------------
1687 -- Expand_Min_Max_Attribute --
1688 ------------------------------
1689
1690 procedure Expand_Min_Max_Attribute (N : Node_Id) is
1691 begin
1692 -- Min and Max are handled by the back end (except that static cases
1693 -- have already been evaluated during semantic processing, although the
1694 -- back end should not count on this). The one bit of special processing
1695 -- required in the normal case is that these two attributes typically
1696 -- generate conditionals in the code, so check the relevant restriction.
1697
1698 Check_Restriction (No_Implicit_Conditionals, N);
e0f63680
AC		 1699 end Expand_Min_Max_Attribute;
1700
70482933
RK		 1701 ----------------------------------
1702 -- Expand_N_Attribute_Reference --
1703 ----------------------------------
1704
1705 procedure Expand_N_Attribute_Reference (N : Node_Id) is
1706 Loc : constant Source_Ptr := Sloc (N);
1707 Typ : constant Entity_Id := Etype (N);
1708 Btyp : constant Entity_Id := Base_Type (Typ);
1709 Pref : constant Node_Id := Prefix (N);
21d27997 1710 Ptyp : constant Entity_Id := Etype (Pref);
70482933
RK		 1711 Exprs : constant List_Id := Expressions (N);
1712 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
1713
1714 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
1715 -- Rewrites a stream attribute for Read, Write or Output with the
1716 -- procedure call. Pname is the entity for the procedure to call.
1717
1718 ------------------------------
1719 -- Rewrite_Stream_Proc_Call --
1720 ------------------------------
1721
1722 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
1723 Item : constant Node_Id := Next (First (Exprs));
ed3fe8cc 1724 Item_Typ : constant Entity_Id := Etype (Item);
fbf5a39b
AC		 1725 Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
1726 Formal_Typ : constant Entity_Id := Etype (Formal);
ed3fe8cc 1727 Is_Written : constant Boolean := Ekind (Formal) /= E_In_Parameter;
70482933
RK		 1728
1729 begin
fbf5a39b
AC		 1730 -- The expansion depends on Item, the second actual, which is
1731 -- the object being streamed in or out.
1732
1733 -- If the item is a component of a packed array type, and
1734 -- a conversion is needed on exit, we introduce a temporary to
1735 -- hold the value, because otherwise the packed reference will
1736 -- not be properly expanded.
1737
1738 if Nkind (Item) = N_Indexed_Component
1739 and then Is_Packed (Base_Type (Etype (Prefix (Item))))
ed3fe8cc 1740 and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
fbf5a39b
AC		 1741 and then Is_Written
1742 then
1743 declare
191fcb3a 1744 Temp : constant Entity_Id := Make_Temporary (Loc, 'V');
fbf5a39b
AC		 1745 Decl : Node_Id;
1746 Assn : Node_Id;
1747
1748 begin
1749 Decl :=
1750 Make_Object_Declaration (Loc,
1751 Defining_Identifier => Temp,
ed3fe8cc 1752 Object_Definition => New_Occurrence_Of (Formal_Typ, Loc));
fbf5a39b
AC		 1753 Set_Etype (Temp, Formal_Typ);
1754
1755 Assn :=
1756 Make_Assignment_Statement (Loc,
ed3fe8cc 1757 Name => New_Copy_Tree (Item),
fbf5a39b
AC		 1758 Expression =>
1759 Unchecked_Convert_To
ed3fe8cc 1760 (Item_Typ, New_Occurrence_Of (Temp, Loc)));
fbf5a39b
AC		 1761
1762 Rewrite (Item, New_Occurrence_Of (Temp, Loc));
1763 Insert_Actions (N,
1764 New_List (
1765 Decl,
1766 Make_Procedure_Call_Statement (Loc,
ed3fe8cc 1767 Name => New_Occurrence_Of (Pname, Loc),
fbf5a39b
AC		 1768 Parameter_Associations => Exprs),
1769 Assn));
1770
1771 Rewrite (N, Make_Null_Statement (Loc));
1772 return;
1773 end;
1774 end if;
70482933
RK		 1775
1776 -- For the class-wide dispatching cases, and for cases in which
1777 -- the base type of the second argument matches the base type of
fbf5a39b
AC		 1778 -- the corresponding formal parameter (that is to say the stream
1779 -- operation is not inherited), we are all set, and can use the
1780 -- argument unchanged.
70482933 1781
70482933 1782 if not Is_Class_Wide_Type (Entity (Pref))
fbf5a39b 1783 and then not Is_Class_Wide_Type (Etype (Item))
ed3fe8cc 1784 and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
70482933 1785 then
ed3fe8cc
AC		 1786 -- Perform a view conversion when either the argument or the
1787 -- formal parameter are of a private type.
1788
b5360737
AC		 1789 if Is_Private_Type (Base_Type (Formal_Typ))
1790 or else Is_Private_Type (Base_Type (Item_Typ))
ed3fe8cc
AC		 1791 then
1792 Rewrite (Item,
1793 Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
1794
1795 -- Otherwise perform a regular type conversion to ensure that all
1796 -- relevant checks are installed.
1797
1798 else
1799 Rewrite (Item, Convert_To (Formal_Typ, Relocate_Node (Item)));
1800 end if;
70482933
RK		 1801
1802 -- For untagged derived types set Assignment_OK, to prevent
1803 -- copies from being created when the unchecked conversion
1804 -- is expanded (which would happen in Remove_Side_Effects
1805 -- if Expand_N_Unchecked_Conversion were allowed to call
365c8496
RD		 1806 -- Force_Evaluation). The copy could violate Ada semantics in
1807 -- cases such as an actual that is an out parameter. Note that
1808 -- this approach is also used in exp_ch7 for calls to controlled
1809 -- type operations to prevent problems with actuals wrapped in
1810 -- unchecked conversions.
70482933
RK		 1811
1812 if Is_Untagged_Derivation (Etype (Expression (Item))) then
1813 Set_Assignment_OK (Item);
1814 end if;
1815 end if;
1816
365c8496
RD		 1817 -- The stream operation to call may be a renaming created by an
1818 -- attribute definition clause, and may not be frozen yet. Ensure
1819 -- that it has the necessary extra formals.
99269cf5
ES		 1820
1821 if not Is_Frozen (Pname) then
1822 Create_Extra_Formals (Pname);
1823 end if;
1824
70482933
RK		 1825 -- And now rewrite the call
1826
1827 Rewrite (N,
1828 Make_Procedure_Call_Statement (Loc,
ed3fe8cc 1829 Name => New_Occurrence_Of (Pname, Loc),
70482933
RK		 1830 Parameter_Associations => Exprs));
1831
1832 Analyze (N);
1833 end Rewrite_Stream_Proc_Call;
1834
1835 -- Start of processing for Expand_N_Attribute_Reference
1836
1837 begin
82c80734
RD		 1838 -- Do required validity checking, if enabled. Do not apply check to
1839 -- output parameters of an Asm instruction, since the value of this
1dcdbfab
AC		 1840 -- is not set till after the attribute has been elaborated, and do
1841 -- not apply the check to the arguments of a 'Read or 'Input attribute
1842 -- reference since the scalar argument is an OUT scalar.
70482933 1843
82c80734
RD		 1844 if Validity_Checks_On and then Validity_Check_Operands
1845 and then Id /= Attribute_Asm_Output
1dcdbfab
AC		 1846 and then Id /= Attribute_Read
1847 and then Id /= Attribute_Input
82c80734 1848 then
70482933
RK		 1849 declare
1850 Expr : Node_Id;
70482933
RK		 1851 begin
1852 Expr := First (Expressions (N));
1853 while Present (Expr) loop
1854 Ensure_Valid (Expr);
1855 Next (Expr);
1856 end loop;
1857 end;
1858 end if;
1859
21d27997
RD		 1860 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
1861 -- place function, then a temporary return object needs to be created
d4dfb005 1862 -- and access to it must be passed to the function.
21d27997 1863
d4dfb005 1864 if Is_Build_In_Place_Function_Call (Pref) then
fb9dd1c7
PMR		 1865
1866 -- If attribute is 'Old, the context is a postcondition, and
1867 -- the temporary must go in the corresponding subprogram, not
1868 -- the postcondition function or any created blocks, as when
1869 -- the attribute appears in a quantified expression. This is
1870 -- handled below in the expansion of the attribute.
1871
1872 if Attribute_Name (Parent (Pref)) = Name_Old then
1873 null;
fb9dd1c7
PMR		 1874 else
1875 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
1876 end if;
4ac62786
AC		 1877
1878 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
1879 -- containing build-in-place function calls whose returned object covers
1880 -- interface types.
1881
d4dfb005 1882 elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then
4ac62786 1883 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);
21d27997
RD		 1884 end if;
1885
5f3f175d
AC		 1886 -- If prefix is a protected type name, this is a reference to the
1887 -- current instance of the type. For a component definition, nothing
1888 -- to do (expansion will occur in the init proc). In other contexts,
1889 -- rewrite into reference to current instance.
1890
1891 if Is_Protected_Self_Reference (Pref)
1e4b91fc 1892 and then not
8926d369
AC		 1893 (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint,
1894 N_Discriminant_Association)
1895 and then Nkind (Parent (Parent (Parent (Parent (N))))) =
69ba91ed 1896 N_Component_Definition)
1e4b91fc
AC		 1897
1898 -- No action needed for these attributes since the current instance
1899 -- will be rewritten to be the name of the _object parameter
1900 -- associated with the enclosing protected subprogram (see below).
1901
1902 and then Id /= Attribute_Access
1903 and then Id /= Attribute_Unchecked_Access
1904 and then Id /= Attribute_Unrestricted_Access
5f3f175d 1905 then
2d14501c
ST		 1906 Rewrite (Pref, Concurrent_Ref (Pref));
1907 Analyze (Pref);
1908 end if;
1909
70482933
RK		 1910 -- Remaining processing depends on specific attribute
1911
2eef7403
AC		 1912 -- Note: individual sections of the following case statement are
1913 -- allowed to assume there is no code after the case statement, and
1914 -- are legitimately allowed to execute return statements if they have
1915 -- nothing more to do.
1916
70482933
RK		 1917 case Id is
1918
82d4f390 1919 -- Attributes related to Ada 2012 iterators
0da80d7d 1920
d8f43ee6
HK		 1921 when Attribute_Constant_Indexing
1922 | Attribute_Default_Iterator
1923 | Attribute_Implicit_Dereference
1924 | Attribute_Iterable
1925 | Attribute_Iterator_Element
1926 | Attribute_Variable_Indexing
1927 =>
d48f3dca 1928 null;
b98e2969 1929
d27f3ff4
AC		 1930 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
1931 -- were already rejected by the parser. Thus they shouldn't appear here.
b98e2969 1932
c1107fa3 1933 when Internal_Attribute_Id =>
d48f3dca 1934 raise Program_Error;
0da80d7d 1935
70482933
RK		 1936 ------------
1937 -- Access --
1938 ------------
1939
d8f43ee6
HK		 1940 when Attribute_Access
1941 | Attribute_Unchecked_Access
1942 | Attribute_Unrestricted_Access
1943 =>
3192631e 1944 Access_Cases : declare
3192631e 1945 Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
0d4aed99 1946 Btyp_DDT : Entity_Id;
70482933 1947
01aef5ad
GD		 1948 function Enclosing_Object (N : Node_Id) return Node_Id;
1949 -- If N denotes a compound name (selected component, indexed
69ba91ed
AC		 1950 -- component, or slice), returns the name of the outermost such
1951 -- enclosing object. Otherwise returns N. If the object is a
1952 -- renaming, then the renamed object is returned.
01aef5ad
GD		 1953
1954 ----------------------
1955 -- Enclosing_Object --
1956 ----------------------
1957
1958 function Enclosing_Object (N : Node_Id) return Node_Id is
1959 Obj_Name : Node_Id;
1960
1961 begin
1962 Obj_Name := N;
1963 while Nkind_In (Obj_Name, N_Selected_Component,
1964 N_Indexed_Component,
1965 N_Slice)
1966 loop
1967 Obj_Name := Prefix (Obj_Name);
1968 end loop;
1969
1970 return Get_Referenced_Object (Obj_Name);
1971 end Enclosing_Object;
1972
1973 -- Local declarations
1974
1975 Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
1976
1977 -- Start of processing for Access_Cases
1978
3192631e 1979 begin
0d4aed99
AC		 1980 Btyp_DDT := Designated_Type (Btyp);
1981
1982 -- Handle designated types that come from the limited view
1983
47346923
AC		 1984 if From_Limited_With (Btyp_DDT)
1985 and then Has_Non_Limited_View (Btyp_DDT)
0d4aed99
AC		 1986 then
1987 Btyp_DDT := Non_Limited_View (Btyp_DDT);
0d4aed99
AC		 1988 end if;
1989
e10dab7f
JM		 1990 -- In order to improve the text of error messages, the designated
1991 -- type of access-to-subprogram itypes is set by the semantics as
1992 -- the associated subprogram entity (see sem_attr). Now we replace
1993 -- such node with the proper E_Subprogram_Type itype.
1994
1995 if Id = Attribute_Unrestricted_Access
1996 and then Is_Subprogram (Directly_Designated_Type (Typ))
1997 then
21d27997 1998 -- The following conditions ensure that this special management
e10dab7f
JM		 1999 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
2000 -- At this stage other cases in which the designated type is
2001 -- still a subprogram (instead of an E_Subprogram_Type) are
e14c931f 2002 -- wrong because the semantics must have overridden the type of
e10dab7f
JM		 2003 -- the node with the type imposed by the context.
2004
21d27997
RD		 2005 if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
2006 and then Etype (Parent (N)) = RTE (RE_Prim_Ptr)
2007 then
2008 Set_Etype (N, RTE (RE_Prim_Ptr));
e10dab7f 2009
21d27997
RD		 2010 else
2011 declare
2012 Subp : constant Entity_Id :=
2013 Directly_Designated_Type (Typ);
2014 Etyp : Entity_Id;
2015 Extra : Entity_Id := Empty;
2016 New_Formal : Entity_Id;
2017 Old_Formal : Entity_Id := First_Formal (Subp);
2018 Subp_Typ : Entity_Id;
e10dab7f 2019
21d27997
RD		 2020 begin
2021 Subp_Typ := Create_Itype (E_Subprogram_Type, N);
2022 Set_Etype (Subp_Typ, Etype (Subp));
2023 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
e10dab7f 2024
21d27997
RD		 2025 if Present (Old_Formal) then
2026 New_Formal := New_Copy (Old_Formal);
2027 Set_First_Entity (Subp_Typ, New_Formal);
e10dab7f 2028
21d27997
RD		 2029 loop
2030 Set_Scope (New_Formal, Subp_Typ);
2031 Etyp := Etype (New_Formal);
e10dab7f 2032
21d27997
RD		 2033 -- Handle itypes. There is no need to duplicate
2034 -- here the itypes associated with record types
2035 -- (i.e the implicit full view of private types).
e10dab7f 2036
21d27997
RD		 2037 if Is_Itype (Etyp)
2038 and then Ekind (Base_Type (Etyp)) /= E_Record_Type
e10dab7f 2039 then
21d27997
RD		 2040 Extra := New_Copy (Etyp);
2041 Set_Parent (Extra, New_Formal);
2042 Set_Etype (New_Formal, Extra);
2043 Set_Scope (Extra, Subp_Typ);
e10dab7f
JM		 2044 end if;
2045
21d27997
RD		 2046 Extra := New_Formal;
2047 Next_Formal (Old_Formal);
2048 exit when No (Old_Formal);
e10dab7f 2049
3f6d1daa
JS		 2050 Link_Entities (New_Formal, New_Copy (Old_Formal));
2051 Next_Entity (New_Formal);
21d27997 2052 end loop;
e10dab7f 2053
3f6d1daa 2054 Unlink_Next_Entity (New_Formal);
21d27997
RD		 2055 Set_Last_Entity (Subp_Typ, Extra);
2056 end if;
e10dab7f 2057
21d27997
RD		 2058 -- Now that the explicit formals have been duplicated,
2059 -- any extra formals needed by the subprogram must be
2060 -- created.
e10dab7f 2061
21d27997
RD		 2062 if Present (Extra) then
2063 Set_Extra_Formal (Extra, Empty);
2064 end if;
e10dab7f 2065
21d27997
RD		 2066 Create_Extra_Formals (Subp_Typ);
2067 Set_Directly_Designated_Type (Typ, Subp_Typ);
2068 end;
2069 end if;
e10dab7f
JM		 2070 end if;
2071
3192631e
JM		 2072 if Is_Access_Protected_Subprogram_Type (Btyp) then
2073 Expand_Access_To_Protected_Op (N, Pref, Typ);
2074
2075 -- If prefix is a type name, this is a reference to the current
2076 -- instance of the type, within its initialization procedure.
2077
2078 elsif Is_Entity_Name (Pref)
2079 and then Is_Type (Entity (Pref))
2080 then
2081 declare
2082 Par : Node_Id;
2083 Formal : Entity_Id;
2084
2085 begin
2086 -- If the current instance name denotes a task type, then
2087 -- the access attribute is rewritten to be the name of the
2088 -- "_task" parameter associated with the task type's task
2089 -- procedure. An unchecked conversion is applied to ensure
2090 -- a type match in cases of expander-generated calls (e.g.
2091 -- init procs).
2092
2093 if Is_Task_Type (Entity (Pref)) then
2094 Formal :=
2095 First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
2096 while Present (Formal) loop
2097 exit when Chars (Formal) = Name_uTask;
2098 Next_Entity (Formal);
2099 end loop;
2100
2101 pragma Assert (Present (Formal));
3e8ee849 2102
3192631e
JM		 2103 Rewrite (N,
2104 Unchecked_Convert_To (Typ,
2105 New_Occurrence_Of (Formal, Loc)));
2106 Set_Etype (N, Typ);
3e8ee849 2107
1e4b91fc
AC		 2108 elsif Is_Protected_Type (Entity (Pref)) then
2109
2110 -- No action needed for current instance located in a
2111 -- component definition (expansion will occur in the
2112 -- init proc)
2113
2114 if Is_Protected_Type (Current_Scope) then
2115 null;
2116
2117 -- If the current instance reference is located in a
2118 -- protected subprogram or entry then rewrite the access
2119 -- attribute to be the name of the "_object" parameter.
2120 -- An unchecked conversion is applied to ensure a type
2121 -- match in cases of expander-generated calls (e.g. init
2122 -- procs).
2123
289a994b
AC		 2124 -- The code may be nested in a block, so find enclosing
2125 -- scope that is a protected operation.
2126
1e4b91fc 2127 else
289a994b
AC		 2128 declare
2129 Subp : Entity_Id;
2130
2131 begin
2132 Subp := Current_Scope;
59fad002 2133 while Ekind_In (Subp, E_Loop, E_Block) loop
289a994b
AC		 2134 Subp := Scope (Subp);
2135 end loop;
2136
2137 Formal :=
2138 First_Entity
2139 (Protected_Body_Subprogram (Subp));
2140
2141 -- For a protected subprogram the _Object parameter
2142 -- is the protected record, so we create an access
2143 -- to it. The _Object parameter of an entry is an
2144 -- address.
2145
2146 if Ekind (Subp) = E_Entry then
2147 Rewrite (N,
2148 Unchecked_Convert_To (Typ,
2149 New_Occurrence_Of (Formal, Loc)));
2150 Set_Etype (N, Typ);
2151
2152 else
2153 Rewrite (N,
2154 Unchecked_Convert_To (Typ,
2155 Make_Attribute_Reference (Loc,
2156 Attribute_Name => Name_Unrestricted_Access,
59fad002
AC		 2157 Prefix =>
2158 New_Occurrence_Of (Formal, Loc))));
289a994b
AC		 2159 Analyze_And_Resolve (N);
2160 end if;
2161 end;
1e4b91fc
AC		 2162 end if;
2163
2164 -- The expression must appear in a default expression,
2165 -- (which in the initialization procedure is the right-hand
2166 -- side of an assignment), and not in a discriminant
2167 -- constraint.
3e8ee849 2168
3192631e
JM		 2169 else
2170 Par := Parent (N);
2171 while Present (Par) loop
2172 exit when Nkind (Par) = N_Assignment_Statement;
3e8ee849 2173
3192631e
JM		 2174 if Nkind (Par) = N_Component_Declaration then
2175 return;
2176 end if;
3e8ee849 2177
3192631e
JM		 2178 Par := Parent (Par);
2179 end loop;
3e8ee849 2180
3192631e
JM		 2181 if Present (Par) then
2182 Rewrite (N,
2183 Make_Attribute_Reference (Loc,
2184 Prefix => Make_Identifier (Loc, Name_uInit),
2185 Attribute_Name => Attribute_Name (N)));
3e8ee849 2186
3192631e
JM		 2187 Analyze_And_Resolve (N, Typ);
2188 end if;
3e8ee849 2189 end if;
3192631e
JM		 2190 end;
2191
2192 -- If the prefix of an Access attribute is a dereference of an
01aef5ad
GD		 2193 -- access parameter (or a renaming of such a dereference, or a
2194 -- subcomponent of such a dereference) and the context is a
ae8c7d87
RD		 2195 -- general access type (including the type of an object or
2196 -- component with an access_definition, but not the anonymous
2197 -- type of an access parameter or access discriminant), then
01aef5ad
GD		 2198 -- apply an accessibility check to the access parameter. We used
2199 -- to rewrite the access parameter as a type conversion, but that
2200 -- could only be done if the immediate prefix of the Access
2201 -- attribute was the dereference, and didn't handle cases where
2202 -- the attribute is applied to a subcomponent of the dereference,
2203 -- since there's generally no available, appropriate access type
e84e11ba
GD		 2204 -- to convert to in that case. The attribute is passed as the
2205 -- point to insert the check, because the access parameter may
2206 -- come from a renaming, possibly in a different scope, and the
2207 -- check must be associated with the attribute itself.
01aef5ad
GD		 2208
2209 elsif Id = Attribute_Access
2210 and then Nkind (Enc_Object) = N_Explicit_Dereference
2211 and then Is_Entity_Name (Prefix (Enc_Object))
ae8c7d87
RD		 2212 and then (Ekind (Btyp) = E_General_Access_Type
2213 or else Is_Local_Anonymous_Access (Btyp))
01aef5ad
GD		 2214 and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind
2215 and then Ekind (Etype (Entity (Prefix (Enc_Object))))
3192631e
JM		 2216 = E_Anonymous_Access_Type
2217 and then Present (Extra_Accessibility
01aef5ad 2218 (Entity (Prefix (Enc_Object))))
3192631e 2219 then
e84e11ba 2220 Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N);
3192631e
JM		 2221
2222 -- Ada 2005 (AI-251): If the designated type is an interface we
2223 -- add an implicit conversion to force the displacement of the
2224 -- pointer to reference the secondary dispatch table.
2225
2226 elsif Is_Interface (Btyp_DDT)
2227 and then (Comes_From_Source (N)
2228 or else Comes_From_Source (Ref_Object)
2229 or else (Nkind (Ref_Object) in N_Has_Chars
2230 and then Chars (Ref_Object) = Name_uInit))
2231 then
2232 if Nkind (Ref_Object) /= N_Explicit_Dereference then
2233
bea993f9
AC		 2234 -- No implicit conversion required if types match, or if
2235 -- the prefix is the class_wide_type of the interface. In
2236 -- either case passing an object of the interface type has
2237 -- already set the pointer correctly.
2238
2239 if Btyp_DDT = Etype (Ref_Object)
2240 or else (Is_Class_Wide_Type (Etype (Ref_Object))
2241 and then
2242 Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object))
2243 then
2244 null;
3192631e 2245
bea993f9 2246 else
3192631e 2247 Rewrite (Prefix (N),
0d4aed99 2248 Convert_To (Btyp_DDT,
3192631e
JM		 2249 New_Copy_Tree (Prefix (N))));
2250
0d4aed99 2251 Analyze_And_Resolve (Prefix (N), Btyp_DDT);
70482933 2252 end if;
758c442c 2253
3192631e
JM		 2254 -- When the object is an explicit dereference, convert the
2255 -- dereference's prefix.
3e8ee849 2256
3192631e
JM		 2257 else
2258 declare
2259 Obj_DDT : constant Entity_Id :=
2260 Base_Type
2261 (Directly_Designated_Type
2262 (Etype (Prefix (Ref_Object))));
2263 begin
2264 -- No implicit conversion required if designated types
904a2ae4 2265 -- match.
3192631e
JM		 2266
2267 if Obj_DDT /= Btyp_DDT
2268 and then not (Is_Class_Wide_Type (Obj_DDT)
3b59004a 2269 and then Etype (Obj_DDT) = Btyp_DDT)
3192631e
JM		 2270 then
2271 Rewrite (N,
2272 Convert_To (Typ,
2273 New_Copy_Tree (Prefix (Ref_Object))));
2274 Analyze_And_Resolve (N, Typ);
2275 end if;
2276 end;
70482933 2277 end if;
3192631e
JM		 2278 end if;
2279 end Access_Cases;
70482933
RK		 2280
2281 --------------
2282 -- Adjacent --
2283 --------------
2284
2285 -- Transforms 'Adjacent into a call to the floating-point attribute
2286 -- function Adjacent in Fat_xxx (where xxx is the root type)
2287
2288 when Attribute_Adjacent =>
2289 Expand_Fpt_Attribute_RR (N);
2290
2291 -------------
2292 -- Address --
2293 -------------
2294
2295 when Attribute_Address => Address : declare
2296 Task_Proc : Entity_Id;
2297
2298 begin
3e8ee849
RD		 2299 -- If the prefix is a task or a task type, the useful address is that
2300 -- of the procedure for the task body, i.e. the actual program unit.
2301 -- We replace the original entity with that of the procedure.
70482933
RK		 2302
2303 if Is_Entity_Name (Pref)
2304 and then Is_Task_Type (Entity (Pref))
2305 then
21d27997 2306 Task_Proc := Next_Entity (Root_Type (Ptyp));
70482933
RK		 2307
2308 while Present (Task_Proc) loop
2309 exit when Ekind (Task_Proc) = E_Procedure
2310 and then Etype (First_Formal (Task_Proc)) =
21d27997 2311 Corresponding_Record_Type (Ptyp);
70482933
RK		 2312 Next_Entity (Task_Proc);
2313 end loop;
2314
2315 if Present (Task_Proc) then
2316 Set_Entity (Pref, Task_Proc);
2317 Set_Etype (Pref, Etype (Task_Proc));
2318 end if;
2319
2320 -- Similarly, the address of a protected operation is the address
2321 -- of the corresponding protected body, regardless of the protected
2322 -- object from which it is selected.
2323
2324 elsif Nkind (Pref) = N_Selected_Component
2325 and then Is_Subprogram (Entity (Selector_Name (Pref)))
2326 and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref))))
2327 then
2328 Rewrite (Pref,
2329 New_Occurrence_Of (
2330 External_Subprogram (Entity (Selector_Name (Pref))), Loc));
2331
2332 elsif Nkind (Pref) = N_Explicit_Dereference
21d27997
RD		 2333 and then Ekind (Ptyp) = E_Subprogram_Type
2334 and then Convention (Ptyp) = Convention_Protected
70482933
RK		 2335 then
2336 -- The prefix is be a dereference of an access_to_protected_
2337 -- subprogram. The desired address is the second component of
2338 -- the record that represents the access.
2339
2340 declare
2341 Addr : constant Entity_Id := Etype (N);
2342 Ptr : constant Node_Id := Prefix (Pref);
2343 T : constant Entity_Id :=
2344 Equivalent_Type (Base_Type (Etype (Ptr)));
2345
2346 begin
2347 Rewrite (N,
2348 Unchecked_Convert_To (Addr,
2349 Make_Selected_Component (Loc,
2350 Prefix => Unchecked_Convert_To (T, Ptr),
2351 Selector_Name => New_Occurrence_Of (
2352 Next_Entity (First_Entity (T)), Loc))));
2353
2354 Analyze_And_Resolve (N, Addr);
2355 end;
0669bebe
GB		 2356
2357 -- Ada 2005 (AI-251): Class-wide interface objects are always
2358 -- "displaced" to reference the tag associated with the interface
2359 -- type. In order to obtain the real address of such objects we
2360 -- generate a call to a run-time subprogram that returns the base
2361 -- address of the object.
2362
470cd9e9
RD		 2363 -- This processing is not needed in the VM case, where dispatching
2364 -- issues are taken care of by the virtual machine.
2365
21d27997 2366 elsif Is_Class_Wide_Type (Ptyp)
63a5b3dc 2367 and then Is_Interface (Underlying_Type (Ptyp))
1f110335 2368 and then Tagged_Type_Expansion
31104818
HK		 2369 and then not (Nkind (Pref) in N_Has_Entity
2370 and then Is_Subprogram (Entity (Pref)))
0669bebe
GB		 2371 then
2372 Rewrite (N,
2373 Make_Function_Call (Loc,
e4494292 2374 Name => New_Occurrence_Of (RTE (RE_Base_Address), Loc),
0669bebe
GB		 2375 Parameter_Associations => New_List (
2376 Relocate_Node (N))));
2377 Analyze (N);
2378 return;
70482933
RK		 2379 end if;
2380
21d27997
RD		 2381 -- Deal with packed array reference, other cases are handled by
2382 -- the back end.
70482933
RK		 2383
2384 if Involves_Packed_Array_Reference (Pref) then
2385 Expand_Packed_Address_Reference (N);
2386 end if;
2387 end Address;
2388
fbf5a39b
AC		 2389 ---------------
2390 -- Alignment --
2391 ---------------
2392
2393 when Attribute_Alignment => Alignment : declare
fbf5a39b
AC		 2394 New_Node : Node_Id;
2395
2396 begin
2397 -- For class-wide types, X'Class'Alignment is transformed into a
2398 -- direct reference to the Alignment of the class type, so that the
2399 -- back end does not have to deal with the X'Class'Alignment
2400 -- reference.
2401
2402 if Is_Entity_Name (Pref)
2403 and then Is_Class_Wide_Type (Entity (Pref))
2404 then
2405 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
2406 return;
2407
2408 -- For x'Alignment applied to an object of a class wide type,
2409 -- transform X'Alignment into a call to the predefined primitive
2410 -- operation _Alignment applied to X.
2411
2412 elsif Is_Class_Wide_Type (Ptyp) then
2413 New_Node :=
d9937d1b
AC		 2414 Make_Attribute_Reference (Loc,
2415 Prefix => Pref,
2416 Attribute_Name => Name_Tag);
2417
535a8637 2418 New_Node := Build_Get_Alignment (Loc, New_Node);
fbf5a39b 2419
033eaf85
AC		 2420 -- Case where the context is a specific integer type with which
2421 -- the original attribute was compatible. The function has a
2422 -- specific type as well, so to preserve the compatibility we
2423 -- must convert explicitly.
fbf5a39b 2424
033eaf85 2425 if Typ /= Standard_Integer then
fbf5a39b
AC		 2426 New_Node := Convert_To (Typ, New_Node);
2427 end if;
2428
2429 Rewrite (N, New_Node);
2430 Analyze_And_Resolve (N, Typ);
2431 return;
2432
2433 -- For all other cases, we just have to deal with the case of
2434 -- the fact that the result can be universal.
2435
2436 else
2437 Apply_Universal_Integer_Attribute_Checks (N);
2438 end if;
2439 end Alignment;
2440
47d3b920
AC		 2441 ---------
2442 -- Bit --
2443 ---------
2444
2445 -- We compute this if a packed array reference was present, otherwise we
2446 -- leave the computation up to the back end.
2447
2448 when Attribute_Bit =>
2449 if Involves_Packed_Array_Reference (Pref) then
2450 Expand_Packed_Bit_Reference (N);
2451 else
2452 Apply_Universal_Integer_Attribute_Checks (N);
2453 end if;
2454
70482933
RK		 2455 ------------------
2456 -- Bit_Position --
2457 ------------------
2458
21d27997
RD		 2459 -- We compute this if a component clause was present, otherwise we leave
2460 -- the computation up to the back end, since we don't know what layout
2461 -- will be chosen.
70482933
RK		 2462
2463 -- Note that the attribute can apply to a naked record component
2464 -- in generated code (i.e. the prefix is an identifier that
2465 -- references the component or discriminant entity).
2466
47d3b920 2467 when Attribute_Bit_Position => Bit_Position : declare
70482933
RK		 2468 CE : Entity_Id;
2469
2470 begin
2471 if Nkind (Pref) = N_Identifier then
2472 CE := Entity (Pref);
2473 else
2474 CE := Entity (Selector_Name (Pref));
2475 end if;
2476
2477 if Known_Static_Component_Bit_Offset (CE) then
2478 Rewrite (N,
2479 Make_Integer_Literal (Loc,
2480 Intval => Component_Bit_Offset (CE)));
2481 Analyze_And_Resolve (N, Typ);
2482
2483 else
2484 Apply_Universal_Integer_Attribute_Checks (N);
2485 end if;
2486 end Bit_Position;
2487
2488 ------------------
2489 -- Body_Version --
2490 ------------------
2491
2492 -- A reference to P'Body_Version or P'Version is expanded to
2493
2494 -- Vnn : Unsigned;
69a0c174 2495 -- pragma Import (C, Vnn, "uuuuT");
70482933
RK		 2496 -- ...
2497 -- Get_Version_String (Vnn)
2498
2499 -- where uuuu is the unit name (dots replaced by double underscore)
2500 -- and T is B for the cases of Body_Version, or Version applied to a
2501 -- subprogram acting as its own spec, and S for Version applied to a
2502 -- subprogram spec or package. This sequence of code references the
308e6f3a 2503 -- unsigned constant created in the main program by the binder.
70482933 2504
5c52bf3b
AC		 2505 -- A special exception occurs for Standard, where the string returned
2506 -- is a copy of the library string in gnatvsn.ads.
70482933 2507
d8f43ee6
HK		 2508 when Attribute_Body_Version
2509 | Attribute_Version
2510 =>
2511 Version : declare
2512 E : constant Entity_Id := Make_Temporary (Loc, 'V');
2513 Pent : Entity_Id;
2514 S : String_Id;
70482933 2515
d8f43ee6
HK		 2516 begin
2517 -- If not library unit, get to containing library unit
2518
2519 Pent := Entity (Pref);
2520 while Pent /= Standard_Standard
2521 and then Scope (Pent) /= Standard_Standard
2522 and then not Is_Child_Unit (Pent)
2523 loop
2524 Pent := Scope (Pent);
2525 end loop;
70482933 2526
d8f43ee6 2527 -- Special case Standard and Standard.ASCII
70482933 2528
d8f43ee6
HK		 2529 if Pent = Standard_Standard or else Pent = Standard_ASCII then
2530 Rewrite (N,
2531 Make_String_Literal (Loc,
2532 Strval => Verbose_Library_Version));
70482933 2533
d8f43ee6 2534 -- All other cases
70482933 2535
d8f43ee6
HK		 2536 else
2537 -- Build required string constant
70482933 2538
d8f43ee6 2539 Get_Name_String (Get_Unit_Name (Pent));
70482933 2540
d8f43ee6
HK		 2541 Start_String;
2542 for J in 1 .. Name_Len - 2 loop
2543 if Name_Buffer (J) = '.' then
2544 Store_String_Chars ("__");
2545 else
2546 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
2547 end if;
2548 end loop;
70482933 2549
d8f43ee6 2550 -- Case of subprogram acting as its own spec, always use body
70482933 2551
d8f43ee6
HK		 2552 if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
2553 and then Nkind (Parent (Declaration_Node (Pent))) =
2554 N_Subprogram_Body
2555 and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
2556 then
2557 Store_String_Chars ("B");
70482933 2558
d8f43ee6 2559 -- Case of no body present, always use spec
70482933 2560
d8f43ee6
HK		 2561 elsif not Unit_Requires_Body (Pent) then
2562 Store_String_Chars ("S");
70482933 2563
d8f43ee6 2564 -- Otherwise use B for Body_Version, S for spec
70482933 2565
d8f43ee6
HK		 2566 elsif Id = Attribute_Body_Version then
2567 Store_String_Chars ("B");
2568 else
2569 Store_String_Chars ("S");
2570 end if;
70482933 2571
d8f43ee6
HK		 2572 S := End_String;
2573 Lib.Version_Referenced (S);
70482933 2574
d8f43ee6 2575 -- Insert the object declaration
70482933 2576
d8f43ee6
HK		 2577 Insert_Actions (N, New_List (
2578 Make_Object_Declaration (Loc,
2579 Defining_Identifier => E,
2580 Object_Definition =>
2581 New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
70482933 2582
d8f43ee6 2583 -- Set entity as imported with correct external name
70482933 2584
d8f43ee6
HK		 2585 Set_Is_Imported (E);
2586 Set_Interface_Name (E, Make_String_Literal (Loc, S));
70482933 2587
d8f43ee6
HK		 2588 -- Set entity as internal to ensure proper Sprint output of its
2589 -- implicit importation.
3e8ee849 2590
d8f43ee6 2591 Set_Is_Internal (E);
3e8ee849 2592
d8f43ee6 2593 -- And now rewrite original reference
70482933 2594
d8f43ee6
HK		 2595 Rewrite (N,
2596 Make_Function_Call (Loc,
2597 Name =>
2598 New_Occurrence_Of (RTE (RE_Get_Version_String), Loc),
2599 Parameter_Associations => New_List (
2600 New_Occurrence_Of (E, Loc))));
2601 end if;
70482933 2602
d8f43ee6
HK		 2603 Analyze_And_Resolve (N, RTE (RE_Version_String));
2604 end Version;
70482933
RK		 2605
2606 -------------
2607 -- Ceiling --
2608 -------------
2609
2610 -- Transforms 'Ceiling into a call to the floating-point attribute
2611 -- function Ceiling in Fat_xxx (where xxx is the root type)
2612
2613 when Attribute_Ceiling =>
2614 Expand_Fpt_Attribute_R (N);
2615
2616 --------------
2617 -- Callable --
2618 --------------
2619
758c442c 2620 -- Transforms 'Callable attribute into a call to the Callable function
70482933 2621
d8f43ee6 2622 when Attribute_Callable =>
99bba92c 2623
65f01153
RD		 2624 -- We have an object of a task interface class-wide type as a prefix
2625 -- to Callable. Generate:
31104818 2626 -- callable (Task_Id (Pref._disp_get_task_id));
65f01153 2627
0791fbe9 2628 if Ada_Version >= Ada_2005
21d27997
RD		 2629 and then Ekind (Ptyp) = E_Class_Wide_Type
2630 and then Is_Interface (Ptyp)
2631 and then Is_Task_Interface (Ptyp)
65f01153 2632 then
99bba92c
AC		 2633 Rewrite (N,
2634 Make_Function_Call (Loc,
c0e938d0 2635 Name =>
99bba92c
AC		 2636 New_Occurrence_Of (RTE (RE_Callable), Loc),
2637 Parameter_Associations => New_List (
2638 Make_Unchecked_Type_Conversion (Loc,
2639 Subtype_Mark =>
2640 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
c0e938d0 2641 Expression => Build_Disp_Get_Task_Id_Call (Pref)))));
31104818 2642
65f01153 2643 else
99bba92c 2644 Rewrite (N, Build_Call_With_Task (Pref, RTE (RE_Callable)));
65f01153
RD		 2645 end if;
2646
70482933 2647 Analyze_And_Resolve (N, Standard_Boolean);
70482933
RK		 2648
2649 ------------
2650 -- Caller --
2651 ------------
2652
2653 -- Transforms 'Caller attribute into a call to either the
2654 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2655
2656 when Attribute_Caller => Caller : declare
b5e792e2 2657 Id_Kind : constant Entity_Id := RTE (RO_AT_Task_Id);
fbf5a39b
AC		 2658 Ent : constant Entity_Id := Entity (Pref);
2659 Conctype : constant Entity_Id := Scope (Ent);
2660 Nest_Depth : Integer := 0;
70482933
RK		 2661 Name : Node_Id;
2662 S : Entity_Id;
2663
2664 begin
2665 -- Protected case
2666
2667 if Is_Protected_Type (Conctype) then
e10dab7f
JM		 2668 case Corresponding_Runtime_Package (Conctype) is
2669 when System_Tasking_Protected_Objects_Entries =>
2670 Name :=
e4494292 2671 New_Occurrence_Of
e10dab7f
JM		 2672 (RTE (RE_Protected_Entry_Caller), Loc);
2673
2674 when System_Tasking_Protected_Objects_Single_Entry =>
2675 Name :=
e4494292 2676 New_Occurrence_Of
e10dab7f
JM		 2677 (RTE (RE_Protected_Single_Entry_Caller), Loc);
2678
2679 when others =>
2680 raise Program_Error;
2681 end case;
70482933
RK		 2682
2683 Rewrite (N,
2684 Unchecked_Convert_To (Id_Kind,
2685 Make_Function_Call (Loc,
2686 Name => Name,
21d27997 2687 Parameter_Associations => New_List (
e4494292 2688 New_Occurrence_Of
21d27997 2689 (Find_Protection_Object (Current_Scope), Loc)))));
70482933
RK		 2690
2691 -- Task case
2692
2693 else
2694 -- Determine the nesting depth of the E'Caller attribute, that
2695 -- is, how many accept statements are nested within the accept
2696 -- statement for E at the point of E'Caller. The runtime uses
2697 -- this depth to find the specified entry call.
2698
2699 for J in reverse 0 .. Scope_Stack.Last loop
2700 S := Scope_Stack.Table (J).Entity;
2701
2702 -- We should not reach the scope of the entry, as it should
2703 -- already have been checked in Sem_Attr that this attribute
2704 -- reference is within a matching accept statement.
2705
2706 pragma Assert (S /= Conctype);
2707
2708 if S = Ent then
2709 exit;
2710
2711 elsif Is_Entry (S) then
2712 Nest_Depth := Nest_Depth + 1;
2713 end if;
2714 end loop;
2715
2716 Rewrite (N,
2717 Unchecked_Convert_To (Id_Kind,
2718 Make_Function_Call (Loc,
21d27997 2719 Name =>
e4494292 2720 New_Occurrence_Of (RTE (RE_Task_Entry_Caller), Loc),
70482933
RK		 2721 Parameter_Associations => New_List (
2722 Make_Integer_Literal (Loc,
2723 Intval => Int (Nest_Depth))))));
2724 end if;
2725
2726 Analyze_And_Resolve (N, Id_Kind);
2727 end Caller;
2728
2729 -------------
2730 -- Compose --
2731 -------------
2732
2733 -- Transforms 'Compose into a call to the floating-point attribute
2734 -- function Compose in Fat_xxx (where xxx is the root type)
2735
2736 -- Note: we strictly should have special code here to deal with the
2737 -- case of absurdly negative arguments (less than Integer'First)
2738 -- which will return a (signed) zero value, but it hardly seems
2739 -- worth the effort. Absurdly large positive arguments will raise
2740 -- constraint error which is fine.
2741
2742 when Attribute_Compose =>
2743 Expand_Fpt_Attribute_RI (N);
2744
2745 -----------------
2746 -- Constrained --
2747 -----------------
2748
2749 when Attribute_Constrained => Constrained : declare
2750 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
2751
7ce611e2
ES		 2752 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
2753 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
2754 -- view of an aliased object whose subtype is constrained.
2755
2756 ---------------------------------
2757 -- Is_Constrained_Aliased_View --
2758 ---------------------------------
2759
2760 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
2761 E : Entity_Id;
2762
2763 begin
2764 if Is_Entity_Name (Obj) then
2765 E := Entity (Obj);
2766
2767 if Present (Renamed_Object (E)) then
2768 return Is_Constrained_Aliased_View (Renamed_Object (E));
7ce611e2
ES		 2769 else
2770 return Is_Aliased (E) and then Is_Constrained (Etype (E));
2771 end if;
2772
2773 else
2774 return Is_Aliased_View (Obj)
2775 and then
2776 (Is_Constrained (Etype (Obj))
cc96a1b8
AC		 2777 or else
2778 (Nkind (Obj) = N_Explicit_Dereference
2779 and then
0fbcb11c 2780 not Object_Type_Has_Constrained_Partial_View
414b312e
AC		 2781 (Typ => Base_Type (Etype (Obj)),
2782 Scop => Current_Scope)));
7ce611e2
ES		 2783 end if;
2784 end Is_Constrained_Aliased_View;
2785
2786 -- Start of processing for Constrained
2787
70482933
RK		 2788 begin
2789 -- Reference to a parameter where the value is passed as an extra
2790 -- actual, corresponding to the extra formal referenced by the
fbf5a39b
AC		 2791 -- Extra_Constrained field of the corresponding formal. If this
2792 -- is an entry in-parameter, it is replaced by a constant renaming
2793 -- for which Extra_Constrained is never created.
70482933
RK		 2794
2795 if Present (Formal_Ent)
fbf5a39b 2796 and then Ekind (Formal_Ent) /= E_Constant
70482933
RK		 2797 and then Present (Extra_Constrained (Formal_Ent))
2798 then
2799 Rewrite (N,
2800 New_Occurrence_Of
2801 (Extra_Constrained (Formal_Ent), Sloc (N)));
2802
ed323421
AC		 2803 -- If the prefix is an access to object, the attribute applies to
2804 -- the designated object, so rewrite with an explicit dereference.
2805
2806 elsif Is_Access_Type (Etype (Pref))
2807 and then
2808 (not Is_Entity_Name (Pref) or else Is_Object (Entity (Pref)))
2809 then
2810 Rewrite (Pref,
2811 Make_Explicit_Dereference (Loc, Relocate_Node (Pref)));
2812 Analyze_And_Resolve (N, Standard_Boolean);
2813 return;
2814
70482933
RK		 2815 -- For variables with a Extra_Constrained field, we use the
2816 -- corresponding entity.
2817
2818 elsif Nkind (Pref) = N_Identifier
2819 and then Ekind (Entity (Pref)) = E_Variable
2820 and then Present (Extra_Constrained (Entity (Pref)))
2821 then
2822 Rewrite (N,
2823 New_Occurrence_Of
2824 (Extra_Constrained (Entity (Pref)), Sloc (N)));
2825
2826 -- For all other entity names, we can tell at compile time
2827
2828 elsif Is_Entity_Name (Pref) then
2829 declare
2830 Ent : constant Entity_Id := Entity (Pref);
2831 Res : Boolean;
2832
2833 begin
2834 -- (RM J.4) obsolescent cases
2835
2836 if Is_Type (Ent) then
2837
2838 -- Private type
2839
2840 if Is_Private_Type (Ent) then
2841 Res := not Has_Discriminants (Ent)
2842 or else Is_Constrained (Ent);
2843
2844 -- It not a private type, must be a generic actual type
2845 -- that corresponded to a private type. We know that this
2846 -- correspondence holds, since otherwise the reference
2847 -- within the generic template would have been illegal.
2848
2849 else
fbf5a39b
AC		 2850 if Is_Composite_Type (Underlying_Type (Ent)) then
2851 Res := Is_Constrained (Ent);
2852 else
2853 Res := True;
2854 end if;
70482933
RK		 2855 end if;
2856
f991bd8e 2857 else
be42aa71 2858 -- For access type, apply access check as needed
70482933 2859
be42aa71
AC		 2860 if Is_Access_Type (Ptyp) then
2861 Apply_Access_Check (N);
2862 end if;
7ce611e2 2863
be42aa71
AC		 2864 -- If the prefix is not a variable or is aliased, then
2865 -- definitely true; if it's a formal parameter without an
2866 -- associated extra formal, then treat it as constrained.
70482933 2867
be42aa71
AC		 2868 -- Ada 2005 (AI-363): An aliased prefix must be known to be
2869 -- constrained in order to set the attribute to True.
70482933 2870
be42aa71
AC		 2871 if not Is_Variable (Pref)
2872 or else Present (Formal_Ent)
2873 or else (Ada_Version < Ada_2005
f991bd8e 2874 and then Is_Aliased_View (Pref))
be42aa71 2875 or else (Ada_Version >= Ada_2005
f991bd8e 2876 and then Is_Constrained_Aliased_View (Pref))
be42aa71
AC		 2877 then
2878 Res := True;
0669bebe 2879
be42aa71
AC		 2880 -- Variable case, look at type to see if it is constrained.
2881 -- Note that the one case where this is not accurate (the
2882 -- procedure formal case), has been handled above.
2883
2884 -- We use the Underlying_Type here (and below) in case the
2885 -- type is private without discriminants, but the full type
2886 -- has discriminants. This case is illegal, but we generate
2887 -- it internally for passing to the Extra_Constrained
2888 -- parameter.
2889
2890 else
2891 -- In Ada 2012, test for case of a limited tagged type,
2892 -- in which case the attribute is always required to
2893 -- return True. The underlying type is tested, to make
2894 -- sure we also return True for cases where there is an
2895 -- unconstrained object with an untagged limited partial
2896 -- view which has defaulted discriminants (such objects
2897 -- always produce a False in earlier versions of
2898 -- Ada). (Ada 2012: AI05-0214)
2899
2900 Res :=
2901 Is_Constrained (Underlying_Type (Etype (Ent)))
2902 or else
2903 (Ada_Version >= Ada_2012
2904 and then Is_Tagged_Type (Underlying_Type (Ptyp))
2905 and then Is_Limited_Type (Ptyp));
2906 end if;
70482933
RK		 2907 end if;
2908
e4494292 2909 Rewrite (N, New_Occurrence_Of (Boolean_Literals (Res), Loc));
70482933
RK		 2910 end;
2911
21d27997
RD		 2912 -- Prefix is not an entity name. These are also cases where we can
2913 -- always tell at compile time by looking at the form and type of the
2914 -- prefix. If an explicit dereference of an object with constrained
5e5db3b4
GD		 2915 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
2916 -- underlying type is a limited tagged type, then Constrained is
2917 -- required to always return True (Ada 2012: AI05-0214).
70482933
RK		 2918
2919 else
aa720a54 2920 Rewrite (N,
e4494292 2921 New_Occurrence_Of (
aa720a54
AC		 2922 Boolean_Literals (
2923 not Is_Variable (Pref)
758c442c
GD		 2924 or else
2925 (Nkind (Pref) = N_Explicit_Dereference
5e5db3b4 2926 and then
0fbcb11c 2927 not Object_Type_Has_Constrained_Partial_View
414b312e
AC		 2928 (Typ => Base_Type (Ptyp),
2929 Scop => Current_Scope))
5e5db3b4
GD		 2930 or else Is_Constrained (Underlying_Type (Ptyp))
2931 or else (Ada_Version >= Ada_2012
2932 and then Is_Tagged_Type (Underlying_Type (Ptyp))
2933 and then Is_Limited_Type (Ptyp))),
aa720a54 2934 Loc));
70482933
RK		 2935 end if;
2936
2937 Analyze_And_Resolve (N, Standard_Boolean);
2938 end Constrained;
2939
2940 ---------------
2941 -- Copy_Sign --
2942 ---------------
2943
2944 -- Transforms 'Copy_Sign into a call to the floating-point attribute
2945 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
2946
2947 when Attribute_Copy_Sign =>
2948 Expand_Fpt_Attribute_RR (N);
2949
2950 -----------
2951 -- Count --
2952 -----------
2953
2954 -- Transforms 'Count attribute into a call to the Count function
2955
21d27997
RD		 2956 when Attribute_Count => Count : declare
2957 Call : Node_Id;
2958 Conctyp : Entity_Id;
2959 Entnam : Node_Id;
2960 Entry_Id : Entity_Id;
2961 Index : Node_Id;
2962 Name : Node_Id;
70482933
RK		 2963
2964 begin
2965 -- If the prefix is a member of an entry family, retrieve both
2966 -- entry name and index. For a simple entry there is no index.
2967
2968 if Nkind (Pref) = N_Indexed_Component then
2969 Entnam := Prefix (Pref);
2970 Index := First (Expressions (Pref));
2971 else
2972 Entnam := Pref;
2973 Index := Empty;
2974 end if;
2975
21d27997
RD		 2976 Entry_Id := Entity (Entnam);
2977
70482933
RK		 2978 -- Find the concurrent type in which this attribute is referenced
2979 -- (there had better be one).
2980
2981 Conctyp := Current_Scope;
2982 while not Is_Concurrent_Type (Conctyp) loop
2983 Conctyp := Scope (Conctyp);
2984 end loop;
2985
2986 -- Protected case
2987
2988 if Is_Protected_Type (Conctyp) then
97710dc7
JM		 2989
2990 -- No need to transform 'Count into a function call if the current
2991 -- scope has been eliminated. In this case such transformation is
2992 -- also not viable because the enclosing protected object is not
2993 -- available.
2994
2995 if Is_Eliminated (Current_Scope) then
2996 return;
2997 end if;
2998
e10dab7f
JM		 2999 case Corresponding_Runtime_Package (Conctyp) is
3000 when System_Tasking_Protected_Objects_Entries =>
e4494292 3001 Name := New_Occurrence_Of (RTE (RE_Protected_Count), Loc);
e10dab7f
JM		 3002
3003 Call :=
3004 Make_Function_Call (Loc,
d8f43ee6 3005 Name => Name,
e10dab7f 3006 Parameter_Associations => New_List (
e4494292 3007 New_Occurrence_Of
21d27997
RD		 3008 (Find_Protection_Object (Current_Scope), Loc),
3009 Entry_Index_Expression
3010 (Loc, Entry_Id, Index, Scope (Entry_Id))));
e10dab7f
JM		 3011
3012 when System_Tasking_Protected_Objects_Single_Entry =>
21d27997 3013 Name :=
e4494292 3014 New_Occurrence_Of (RTE (RE_Protected_Count_Entry), Loc);
e10dab7f
JM		 3015
3016 Call :=
3017 Make_Function_Call (Loc,
d8f43ee6 3018 Name => Name,
e10dab7f 3019 Parameter_Associations => New_List (
e4494292 3020 New_Occurrence_Of
21d27997
RD		 3021 (Find_Protection_Object (Current_Scope), Loc)));
3022
e10dab7f
JM		 3023 when others =>
3024 raise Program_Error;
e10dab7f 3025 end case;
70482933
RK		 3026
3027 -- Task case
3028
3029 else
3030 Call :=
3031 Make_Function_Call (Loc,
e4494292 3032 Name => New_Occurrence_Of (RTE (RE_Task_Count), Loc),
70482933 3033 Parameter_Associations => New_List (
21d27997
RD		 3034 Entry_Index_Expression (Loc,
3035 Entry_Id, Index, Scope (Entry_Id))));
70482933
RK		 3036 end if;
3037
3038 -- The call returns type Natural but the context is universal integer
3039 -- so any integer type is allowed. The attribute was already resolved
3040 -- so its Etype is the required result type. If the base type of the
3041 -- context type is other than Standard.Integer we put in a conversion
3042 -- to the required type. This can be a normal typed conversion since
3043 -- both input and output types of the conversion are integer types
3044
3045 if Base_Type (Typ) /= Base_Type (Standard_Integer) then
3046 Rewrite (N, Convert_To (Typ, Call));
3047 else
3048 Rewrite (N, Call);
3049 end if;
3050
3051 Analyze_And_Resolve (N, Typ);
3052 end Count;
3053
203ddcea
AC		 3054 ---------------------
3055 -- Descriptor_Size --
3056 ---------------------
3057
203ddcea 3058 when Attribute_Descriptor_Size =>
cb3d8731
HK		 3059
3060 -- Attribute Descriptor_Size is handled by the back end when applied
3061 -- to an unconstrained array type.
3062
3063 if Is_Array_Type (Ptyp)
3064 and then not Is_Constrained (Ptyp)
3065 then
3066 Apply_Universal_Integer_Attribute_Checks (N);
3067
3068 -- For any other type, the descriptor size is 0 because there is no
08f8a983 3069 -- actual descriptor, but the result is not formally static.
cb3d8731
HK		 3070
3071 else
3072 Rewrite (N, Make_Integer_Literal (Loc, 0));
3073 Analyze (N);
08f8a983 3074 Set_Is_Static_Expression (N, False);
cb3d8731 3075 end if;
203ddcea 3076
70482933
RK		 3077 ---------------
3078 -- Elab_Body --
3079 ---------------
3080
3081 -- This processing is shared by Elab_Spec
3082
3083 -- What we do is to insert the following declarations
3084
3085 -- procedure tnn;
3086 -- pragma Import (C, enn, "name___elabb/s");
3087
3088 -- and then the Elab_Body/Spec attribute is replaced by a reference
3089 -- to this defining identifier.
3090
d8f43ee6
HK		 3091 when Attribute_Elab_Body
3092 | Attribute_Elab_Spec
3093 =>
3f5a8fee 3094 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
2c1a2cf3 3095 -- back-end knows how to handle these attributes directly.
3f5a8fee 3096
2c1a2cf3 3097 if CodePeer_Mode then
3f5a8fee
AC		 3098 return;
3099 end if;
3100
70482933 3101 Elab_Body : declare
191fcb3a 3102 Ent : constant Entity_Id := Make_Temporary (Loc, 'E');
70482933
RK		 3103 Str : String_Id;
3104 Lang : Node_Id;
3105
3106 procedure Make_Elab_String (Nod : Node_Id);
3107 -- Given Nod, an identifier, or a selected component, put the
3108 -- image into the current string literal, with double underline
3109 -- between components.
3110
7ce611e2
ES		 3111 ----------------------
3112 -- Make_Elab_String --
3113 ----------------------
3114
70482933
RK		 3115 procedure Make_Elab_String (Nod : Node_Id) is
3116 begin
3117 if Nkind (Nod) = N_Selected_Component then
3118 Make_Elab_String (Prefix (Nod));
535a8637
AC		 3119 Store_String_Char ('_');
3120 Store_String_Char ('_');
70482933
RK		 3121 Get_Name_String (Chars (Selector_Name (Nod)));
3122
3123 else
3124 pragma Assert (Nkind (Nod) = N_Identifier);
3125 Get_Name_String (Chars (Nod));
3126 end if;
3127
3128 Store_String_Chars (Name_Buffer (1 .. Name_Len));
3129 end Make_Elab_String;
3130
3131 -- Start of processing for Elab_Body/Elab_Spec
3132
3133 begin
3134 -- First we need to prepare the string literal for the name of
3135 -- the elaboration routine to be referenced.
3136
3137 Start_String;
3138 Make_Elab_String (Pref);
535a8637
AC		 3139 Store_String_Chars ("___elab");
3140 Lang := Make_Identifier (Loc, Name_C);
70482933
RK		 3141
3142 if Id = Attribute_Elab_Body then
3143 Store_String_Char ('b');
3144 else
3145 Store_String_Char ('s');
3146 end if;
3147
3148 Str := End_String;
3149
3150 Insert_Actions (N, New_List (
3151 Make_Subprogram_Declaration (Loc,
3152 Specification =>
3153 Make_Procedure_Specification (Loc,
3154 Defining_Unit_Name => Ent)),
3155
3156 Make_Pragma (Loc,
3860d469 3157 Chars => Name_Import,
70482933 3158 Pragma_Argument_Associations => New_List (
7675ad4f 3159 Make_Pragma_Argument_Association (Loc, Expression => Lang),
70482933
RK		 3160
3161 Make_Pragma_Argument_Association (Loc,
7675ad4f 3162 Expression => Make_Identifier (Loc, Chars (Ent))),
70482933
RK		 3163
3164 Make_Pragma_Argument_Association (Loc,
7675ad4f 3165 Expression => Make_String_Literal (Loc, Str))))));
70482933
RK		 3166
3167 Set_Entity (N, Ent);
3168 Rewrite (N, New_Occurrence_Of (Ent, Loc));
3169 end Elab_Body;
3170
2c1a2cf3
RD		 3171 --------------------
3172 -- Elab_Subp_Body --
3173 --------------------
3174
3175 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
3176 -- this attribute directly, and if we are not in CodePeer mode it is
3177 -- entirely ignored ???
3178
3179 when Attribute_Elab_Subp_Body =>
3180 return;
3181
70482933
RK		 3182 ----------------
3183 -- Elaborated --
3184 ----------------
3185
21d27997
RD		 3186 -- Elaborated is always True for preelaborated units, predefined units,
3187 -- pure units and units which have Elaborate_Body pragmas. These units
3188 -- have no elaboration entity.
70482933 3189
21d27997 3190 -- Note: The Elaborated attribute is never passed to the back end
70482933
RK		 3191
3192 when Attribute_Elaborated => Elaborated : declare
7327f5c2 3193 Elab_Id : constant Entity_Id := Elaboration_Entity (Entity (Pref));
70482933
RK		 3194
3195 begin
7327f5c2 3196 if Present (Elab_Id) then
70482933 3197 Rewrite (N,
824e9320 3198 Make_Op_Ne (Loc,
7327f5c2
AC		 3199 Left_Opnd => New_Occurrence_Of (Elab_Id, Loc),
3200 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)));
3201
824e9320 3202 Analyze_And_Resolve (N, Typ);
70482933
RK		 3203 else
3204 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
3205 end if;
3206 end Elaborated;
3207
3208 --------------
3209 -- Enum_Rep --
3210 --------------
3211
1956beb8
BD		 3212 when Attribute_Enum_Rep => Enum_Rep : declare
3213 Expr : Node_Id;
75e4e36d 3214
70482933 3215 begin
75e4e36d
AC		 3216 -- Get the expression, which is X for Enum_Type'Enum_Rep (X) or
3217 -- X'Enum_Rep.
70482933
RK		 3218
3219 if Is_Non_Empty_List (Exprs) then
1956beb8
BD		 3220 Expr := First (Exprs);
3221 else
3222 Expr := Pref;
3223 end if;
70482933 3224
75e4e36d
AC		 3225 -- If the expression is an enumeration literal, it is replaced by the
3226 -- literal value.
70482933 3227
1956beb8
BD		 3228 if Nkind (Expr) in N_Has_Entity
3229 and then Ekind (Entity (Expr)) = E_Enumeration_Literal
3230 then
70482933 3231 Rewrite (N,
1956beb8 3232 Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Expr))));
70482933 3233
fbf5a39b 3234 -- If this is a renaming of a literal, recover the representation
75e4e36d
AC		 3235 -- of the original. If it renames an expression there is nothing to
3236 -- fold.
fbf5a39b 3237
1956beb8
BD		 3238 elsif Nkind (Expr) in N_Has_Entity
3239 and then Ekind (Entity (Expr)) = E_Constant
3240 and then Present (Renamed_Object (Entity (Expr)))
3241 and then Is_Entity_Name (Renamed_Object (Entity (Expr)))
3242 and then Ekind (Entity (Renamed_Object (Entity (Expr)))) =
48bb06a7 3243 E_Enumeration_Literal
fbf5a39b
AC		 3244 then
3245 Rewrite (N,
3246 Make_Integer_Literal (Loc,
1956beb8
BD		 3247 Enumeration_Rep (Entity (Renamed_Object (Entity (Expr))))));
3248
3249 -- If not constant-folded above, Enum_Type'Enum_Rep (X) or
3250 -- X'Enum_Rep expands to
fbf5a39b 3251
1956beb8
BD		 3252 -- target-type (X)
3253
3254 -- This is simply a direct conversion from the enumeration type to
3255 -- the target integer type, which is treated by the back end as a
3256 -- normal integer conversion, treating the enumeration type as an
3257 -- integer, which is exactly what we want. We set Conversion_OK to
3258 -- make sure that the analyzer does not complain about what otherwise
3259 -- might be an illegal conversion.
70482933
RK		 3260
3261 else
75e4e36d 3262 Rewrite (N, OK_Convert_To (Typ, Relocate_Node (Expr)));
70482933
RK		 3263 end if;
3264
3265 Set_Etype (N, Typ);
3266 Analyze_And_Resolve (N, Typ);
70482933
RK		 3267 end Enum_Rep;
3268
21d27997
RD		 3269 --------------
3270 -- Enum_Val --
3271 --------------
3272
3273 when Attribute_Enum_Val => Enum_Val : declare
3274 Expr : Node_Id;
3275 Btyp : constant Entity_Id := Base_Type (Ptyp);
3276
3277 begin
3278 -- X'Enum_Val (Y) expands to
3279
3280 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
3281 -- X!(Y);
3282
3283 Expr := Unchecked_Convert_To (Ptyp, First (Exprs));
3284
3285 Insert_Action (N,
3286 Make_Raise_Constraint_Error (Loc,
3287 Condition =>
3288 Make_Op_Eq (Loc,
3289 Left_Opnd =>
3290 Make_Function_Call (Loc,
3291 Name =>
e4494292 3292 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
21d27997
RD		 3293 Parameter_Associations => New_List (
3294 Relocate_Node (Duplicate_Subexpr (Expr)),
3295 New_Occurrence_Of (Standard_False, Loc))),
3296
3297 Right_Opnd => Make_Integer_Literal (Loc, -1)),
3298 Reason => CE_Range_Check_Failed));
3299
3300 Rewrite (N, Expr);
3301 Analyze_And_Resolve (N, Ptyp);
3302 end Enum_Val;
3303
70482933
RK		 3304 --------------
3305 -- Exponent --
3306 --------------
3307
3308 -- Transforms 'Exponent into a call to the floating-point attribute
3309 -- function Exponent in Fat_xxx (where xxx is the root type)
3310
3311 when Attribute_Exponent =>
3312 Expand_Fpt_Attribute_R (N);
3313
3314 ------------------
3315 -- External_Tag --
3316 ------------------
3317
3318 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
3319
d8f43ee6 3320 when Attribute_External_Tag =>
70482933
RK		 3321 Rewrite (N,
3322 Make_Function_Call (Loc,
d8f43ee6
HK		 3323 Name =>
3324 New_Occurrence_Of (RTE (RE_External_Tag), Loc),
70482933
RK		 3325 Parameter_Associations => New_List (
3326 Make_Attribute_Reference (Loc,
3327 Attribute_Name => Name_Tag,
d8f43ee6 3328 Prefix => Prefix (N)))));
70482933
RK		 3329
3330 Analyze_And_Resolve (N, Standard_String);
70482933 3331
f68d3344
JS		 3332 -----------------------
3333 -- Finalization_Size --
3334 -----------------------
3335
3336 when Attribute_Finalization_Size => Finalization_Size : declare
f68d3344 3337 function Calculate_Header_Size return Node_Id;
d9c59db4
AC		 3338 -- Generate a runtime call to calculate the size of the hidden header
3339 -- along with any added padding which would precede a heap-allocated
3340 -- object of the prefix type.
f68d3344
JS		 3341
3342 ---------------------------
3343 -- Calculate_Header_Size --
3344 ---------------------------
3345
3346 function Calculate_Header_Size return Node_Id is
3347 begin
3348 -- Generate:
3349 -- Universal_Integer
d9c59db4 3350 -- (Header_Size_With_Padding (Pref'Alignment))
f68d3344
JS		 3351
3352 return
3353 Convert_To (Universal_Integer,
3354 Make_Function_Call (Loc,
3355 Name =>
d9c59db4
AC		 3356 New_Occurrence_Of (RTE (RE_Header_Size_With_Padding), Loc),
3357
f68d3344
JS		 3358 Parameter_Associations => New_List (
3359 Make_Attribute_Reference (Loc,
d9c59db4 3360 Prefix => New_Copy_Tree (Pref),
f68d3344
JS		 3361 Attribute_Name => Name_Alignment))));
3362 end Calculate_Header_Size;
3363
d9c59db4 3364 -- Local variables
f68d3344 3365
d9c59db4 3366 Size : Entity_Id;
f68d3344
JS		 3367
3368 -- Start of Finalization_Size
3369
3370 begin
d9c59db4 3371 -- An object of a class-wide type first requires a runtime check to
f68d3344
JS		 3372 -- determine whether it is actually controlled or not. Depending on
3373 -- the outcome of this check, the Finalization_Size of the object
3374 -- may be zero or some positive value.
3375 --
d9c59db4 3376 -- In this scenario, Pref'Finalization_Size is expanded into
f68d3344 3377 --
d9c59db4 3378 -- Size : Integer := 0;
f68d3344 3379 --
d9c59db4
AC		 3380 -- if Needs_Finalization (Pref'Tag) then
3381 -- Size :=
3382 -- Universal_Integer
3383 -- (Header_Size_With_Padding (Pref'Alignment));
3384 -- end if;
f68d3344
JS		 3385 --
3386 -- and the attribute reference is replaced with a reference to Size.
3387
3388 if Is_Class_Wide_Type (Ptyp) then
d9c59db4
AC		 3389 Size := Make_Temporary (Loc, 'S');
3390
f68d3344
JS		 3391 Insert_Actions (N, New_List (
3392
3393 -- Generate:
3394 -- Size : Integer := 0;
3395
3396 Make_Object_Declaration (Loc,
3397 Defining_Identifier => Size,
3398 Object_Definition =>
3399 New_Occurrence_Of (Standard_Integer, Loc),
3400 Expression => Make_Integer_Literal (Loc, 0)),
3401
3402 -- Generate:
3403 -- if Needs_Finalization (Pref'Tag) then
d9c59db4
AC		 3404 -- Size :=
3405 -- Universal_Integer
3406 -- (Header_Size_With_Padding (Pref'Alignment));
f68d3344
JS		 3407 -- end if;
3408
3409 Make_If_Statement (Loc,
3410 Condition =>
3411 Make_Function_Call (Loc,
3412 Name =>
d9c59db4
AC		 3413 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
3414
f68d3344
JS		 3415 Parameter_Associations => New_List (
3416 Make_Attribute_Reference (Loc,
d9c59db4
AC		 3417 Prefix => New_Copy_Tree (Pref),
3418 Attribute_Name => Name_Tag))),
3419
f68d3344
JS		 3420 Then_Statements => New_List (
3421 Make_Assignment_Statement (Loc,
3422 Name => New_Occurrence_Of (Size, Loc),
3423 Expression => Calculate_Header_Size)))));
3424
3425 Rewrite (N, New_Occurrence_Of (Size, Loc));
3426
d9c59db4
AC		 3427 -- The prefix is known to be controlled at compile time. Calculate
3428 -- Finalization_Size by calling function Header_Size_With_Padding.
f68d3344
JS		 3429
3430 elsif Needs_Finalization (Ptyp) then
3431 Rewrite (N, Calculate_Header_Size);
3432
d9c59db4
AC		 3433 -- The prefix is not an object with controlled parts, so its
3434 -- Finalization_Size is zero.
f68d3344
JS		 3435
3436 else
3437 Rewrite (N, Make_Integer_Literal (Loc, 0));
3438 end if;
3439
5f325af2
AC		 3440 -- Due to cases where the entity type of the attribute is already
3441 -- resolved the rewritten N must get re-resolved to its appropriate
3442 -- type.
3443
3444 Analyze_And_Resolve (N, Typ);
f68d3344
JS		 3445 end Finalization_Size;
3446
70482933
RK		 3447 -----------
3448 -- First --
3449 -----------
3450
21d27997 3451 when Attribute_First =>
70482933 3452
70482933 3453 -- If the prefix type is a constrained packed array type which
8ca597af 3454 -- already has a Packed_Array_Impl_Type representation defined, then
70482933 3455 -- replace this attribute with a direct reference to 'First of the
21d27997
RD		 3456 -- appropriate index subtype (since otherwise the back end will try
3457 -- to give us the value of 'First for this implementation type).
70482933
RK		 3458
3459 if Is_Constrained_Packed_Array (Ptyp) then
3460 Rewrite (N,
3461 Make_Attribute_Reference (Loc,
3462 Attribute_Name => Name_First,
41a58113
RD		 3463 Prefix =>
3464 New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
70482933
RK		 3465 Analyze_And_Resolve (N, Typ);
3466
41a58113
RD		 3467 -- For access type, apply access check as needed
3468
70482933
RK		 3469 elsif Is_Access_Type (Ptyp) then
3470 Apply_Access_Check (N);
41a58113
RD		 3471
3472 -- For scalar type, if low bound is a reference to an entity, just
3473 -- replace with a direct reference. Note that we can only have a
3474 -- reference to a constant entity at this stage, anything else would
8e888920 3475 -- have already been rewritten.
41a58113 3476
8e888920 3477 elsif Is_Scalar_Type (Ptyp) then
41a58113
RD		 3478 declare
3479 Lo : constant Node_Id := Type_Low_Bound (Ptyp);
3480 begin
3481 if Is_Entity_Name (Lo) then
3482 Rewrite (N, New_Occurrence_Of (Entity (Lo), Loc));
3483 end if;
3484 end;
70482933 3485 end if;
70482933
RK		 3486
3487 ---------------
3488 -- First_Bit --
3489 ---------------
3490
21d27997
RD		 3491 -- Compute this if component clause was present, otherwise we leave the
3492 -- computation to be completed in the back-end, since we don't know what
70482933
RK		 3493 -- layout will be chosen.
3494
be482a8c 3495 when Attribute_First_Bit => First_Bit_Attr : declare
70482933
RK		 3496 CE : constant Entity_Id := Entity (Selector_Name (Pref));
3497
3498 begin
fd8b8c01
AC		 3499 -- In Ada 2005 (or later) if we have the non-default bit order, then
3500 -- we return the original value as given in the component clause
3501 -- (RM 2005 13.5.2(3/2)).
be482a8c
AC		 3502
3503 if Present (Component_Clause (CE))
3504 and then Ada_Version >= Ada_2005
fd8b8c01 3505 and then Reverse_Bit_Order (Scope (CE))
be482a8c 3506 then
70482933
RK		 3507 Rewrite (N,
3508 Make_Integer_Literal (Loc,
be482a8c
AC		 3509 Intval => Expr_Value (First_Bit (Component_Clause (CE)))));
3510 Analyze_And_Resolve (N, Typ);
70482933 3511
fd8b8c01 3512 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
be482a8c
AC		 3513 -- rewrite with normalized value if we know it statically.
3514
3515 elsif Known_Static_Component_Bit_Offset (CE) then
3516 Rewrite (N,
3517 Make_Integer_Literal (Loc,
3518 Component_Bit_Offset (CE) mod System_Storage_Unit));
70482933
RK		 3519 Analyze_And_Resolve (N, Typ);
3520
be482a8c
AC		 3521 -- Otherwise left to back end, just do universal integer checks
3522
70482933
RK		 3523 else
3524 Apply_Universal_Integer_Attribute_Checks (N);
3525 end if;
be482a8c 3526 end First_Bit_Attr;
70482933 3527
304757d2
AC		 3528 --------------------------------
3529 -- Fixed_Value, Integer_Value --
3530 --------------------------------
70482933 3531
304757d2 3532 -- We transform
70482933
RK		 3533
3534 -- fixtype'Fixed_Value (integer-value)
304757d2 3535 -- inttype'Fixed_Value (fixed-value)
70482933
RK		 3536
3537 -- into
3538
304757d2
AC		 3539 -- fixtype (integer-value)
3540 -- inttype (fixed-value)
3541
3542 -- respectively.
70482933 3543
21d27997
RD		 3544 -- We do all the required analysis of the conversion here, because we do
3545 -- not want this to go through the fixed-point conversion circuits. Note
3546 -- that the back end always treats fixed-point as equivalent to the
3547 -- corresponding integer type anyway.
948071fa
ES		 3548 -- However, in order to remove the handling of Do_Range_Check from the
3549 -- backend, we force the generation of a check on the result by
3550 -- setting the result type appropriately. Apply_Conversion_Checks
3551 -- will generate the required expansion.
70482933 3552
304757d2
AC		 3553 when Attribute_Fixed_Value
3554 | Attribute_Integer_Value
3555 =>
70482933
RK		 3556 Rewrite (N,
3557 Make_Type_Conversion (Loc,
3558 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
3559 Expression => Relocate_Node (First (Exprs))));
948071fa
ES		 3560
3561 -- Indicate that the result of the conversion may require a
3562 -- range check (see below);
3563
3564 Set_Etype (N, Base_Type (Entity (Pref)));
70482933 3565 Set_Analyzed (N);
fbf5a39b 3566
d8f43ee6
HK		 3567 -- Note: it might appear that a properly analyzed unchecked
3568 -- conversion would be just fine here, but that's not the case,
948071fa 3569 -- since the full range checks performed by the following code
d8f43ee6 3570 -- are critical.
948071fa
ES		 3571 -- Given that Fixed-point conversions are not further expanded
3572 -- to prevent the involvement of real type operations we have to
3573 -- construct two checks explicitly: one on the operand, and one
3574 -- on the result. This used to be done in part in the back-end,
3575 -- but for other targets (E.g. LLVM) it is preferable to create
3576 -- the tests in full in the front-end.
3577
3578 if Is_Fixed_Point_Type (Etype (N)) then
3579 declare
3580 Loc : constant Source_Ptr := Sloc (N);
92a68a04
HK		 3581 Equiv_T : constant Entity_Id := Make_Temporary (Loc, 'T', N);
3582 Expr : constant Node_Id := Expression (N);
3583 Fst : constant Entity_Id := Root_Type (Etype (N));
948071fa 3584 Decl : Node_Id;
fbf5a39b 3585
948071fa 3586 begin
92a68a04
HK		 3587 Decl :=
3588 Make_Full_Type_Declaration (Sloc (N),
3589 Defining_Identifier => Equiv_T,
3590 Type_Definition =>
3591 Make_Signed_Integer_Type_Definition (Loc,
3592 Low_Bound =>
3593 Make_Integer_Literal (Loc,
3594 Intval =>
3595 Corresponding_Integer_Value
3596 (Type_Low_Bound (Fst))),
3597 High_Bound =>
3598 Make_Integer_Literal (Loc,
3599 Intval =>
3600 Corresponding_Integer_Value
3601 (Type_High_Bound (Fst)))));
948071fa
ES		 3602 Insert_Action (N, Decl);
3603
92a68a04
HK		 3604 -- Verify that the conversion is possible
3605
3606 Generate_Range_Check (Expr, Equiv_T, CE_Overflow_Check_Failed);
3607
3608 -- and verify that the result is in range
948071fa 3609
948071fa
ES		 3610 Generate_Range_Check (N, Etype (N), CE_Range_Check_Failed);
3611 end;
3612 end if;
70482933
RK		 3613
3614 -----------
3615 -- Floor --
3616 -----------
3617
3618 -- Transforms 'Floor into a call to the floating-point attribute
3619 -- function Floor in Fat_xxx (where xxx is the root type)
3620
3621 when Attribute_Floor =>
3622 Expand_Fpt_Attribute_R (N);
3623
3624 ----------
3625 -- Fore --
3626 ----------
3627
3628 -- For the fixed-point type Typ:
3629
3630 -- Typ'Fore
3631
3632 -- expands into
3633
65f01153
RD		 3634 -- Result_Type (System.Fore (Universal_Real (Type'First)),
3635 -- Universal_Real (Type'Last))
70482933
RK		 3636
3637 -- Note that we know that the type is a non-static subtype, or Fore
3638 -- would have itself been computed dynamically in Eval_Attribute.
3639
d8f43ee6 3640 when Attribute_Fore =>
70482933
RK		 3641 Rewrite (N,
3642 Convert_To (Typ,
3643 Make_Function_Call (Loc,
d8f43ee6
HK		 3644 Name =>
3645 New_Occurrence_Of (RTE (RE_Fore), Loc),
70482933
RK		 3646
3647 Parameter_Associations => New_List (
65f01153 3648 Convert_To (Universal_Real,
70482933 3649 Make_Attribute_Reference (Loc,
d8f43ee6 3650 Prefix => New_Occurrence_Of (Ptyp, Loc),
70482933
RK		 3651 Attribute_Name => Name_First)),
3652
65f01153 3653 Convert_To (Universal_Real,
70482933 3654 Make_Attribute_Reference (Loc,
d8f43ee6 3655 Prefix => New_Occurrence_Of (Ptyp, Loc),
70482933
RK		 3656 Attribute_Name => Name_Last))))));
3657
3658 Analyze_And_Resolve (N, Typ);
70482933
RK		 3659
3660 --------------
3661 -- Fraction --
3662 --------------
3663
3664 -- Transforms 'Fraction into a call to the floating-point attribute
3665 -- function Fraction in Fat_xxx (where xxx is the root type)
3666
3667 when Attribute_Fraction =>
3668 Expand_Fpt_Attribute_R (N);
3669
54838d1f
AC		 3670 --------------
3671 -- From_Any --
3672 --------------
3673
3674 when Attribute_From_Any => From_Any : declare
3675 P_Type : constant Entity_Id := Etype (Pref);
3676 Decls : constant List_Id := New_List;
d8f43ee6 3677
54838d1f
AC		 3678 begin
3679 Rewrite (N,
3680 Build_From_Any_Call (P_Type,
3681 Relocate_Node (First (Exprs)),
3682 Decls));
3683 Insert_Actions (N, Decls);
3684 Analyze_And_Resolve (N, P_Type);
3685 end From_Any;
3686
ea70f3d0
RD		 3687 ----------------------
3688 -- Has_Same_Storage --
3689 ----------------------
3690
3691 when Attribute_Has_Same_Storage => Has_Same_Storage : declare
d8f43ee6 3692 Loc : constant Source_Ptr := Sloc (N);
ea70f3d0 3693
d8f43ee6
HK		 3694 X : constant Node_Id := Prefix (N);
3695 Y : constant Node_Id := First (Expressions (N));
3696 -- The arguments
ea70f3d0 3697
d8f43ee6
HK		 3698 X_Addr : Node_Id;
3699 Y_Addr : Node_Id;
3700 -- Rhe expressions for their addresses
ea70f3d0 3701
d8f43ee6
HK		 3702 X_Size : Node_Id;
3703 Y_Size : Node_Id;
3704 -- Rhe expressions for their sizes
ea70f3d0
RD		 3705
3706 begin
3707 -- The attribute is expanded as:
3708
3709 -- (X'address = Y'address)
3710 -- and then (X'Size = Y'Size)
3711
3712 -- If both arguments have the same Etype the second conjunct can be
3713 -- omitted.
3714
3715 X_Addr :=
3716 Make_Attribute_Reference (Loc,
d8f43ee6
HK		 3717 Attribute_Name => Name_Address,
3718 Prefix => New_Copy_Tree (X));
ea70f3d0
RD		 3719
3720 Y_Addr :=
3721 Make_Attribute_Reference (Loc,
d8f43ee6
HK		 3722 Attribute_Name => Name_Address,
3723 Prefix => New_Copy_Tree (Y));
ea70f3d0
RD		 3724
3725 X_Size :=
3726 Make_Attribute_Reference (Loc,
d8f43ee6
HK		 3727 Attribute_Name => Name_Size,
3728 Prefix => New_Copy_Tree (X));
ea70f3d0
RD		 3729
3730 Y_Size :=
3731 Make_Attribute_Reference (Loc,
d8f43ee6
HK		 3732 Attribute_Name => Name_Size,
3733 Prefix => New_Copy_Tree (Y));
ea70f3d0
RD		 3734
3735 if Etype (X) = Etype (Y) then
3736 Rewrite (N,
d8f43ee6
HK		 3737 Make_Op_Eq (Loc,
3738 Left_Opnd => X_Addr,
3739 Right_Opnd => Y_Addr));
ea70f3d0
RD		 3740 else
3741 Rewrite (N,
d8f43ee6
HK		 3742 Make_Op_And (Loc,
3743 Left_Opnd =>
3744 Make_Op_Eq (Loc,
3745 Left_Opnd => X_Addr,
3746 Right_Opnd => Y_Addr),
3747 Right_Opnd =>
3748 Make_Op_Eq (Loc,
3749 Left_Opnd => X_Size,
3750 Right_Opnd => Y_Size)));
ea70f3d0
RD		 3751 end if;
3752
3753 Analyze_And_Resolve (N, Standard_Boolean);
3754 end Has_Same_Storage;
3755
70482933
RK		 3756 --------------
3757 -- Identity --
3758 --------------
3759
3760 -- For an exception returns a reference to the exception data:
3761 -- Exception_Id!(Prefix'Reference)
3762
3763 -- For a task it returns a reference to the _task_id component of
3764 -- corresponding record:
3765
b5e792e2 3766 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
70482933 3767
758c442c 3768 -- in Ada.Task_Identification
70482933
RK		 3769
3770 when Attribute_Identity => Identity : declare
3771 Id_Kind : Entity_Id;
3772
3773 begin
21d27997 3774 if Ptyp = Standard_Exception_Type then
70482933
RK		 3775 Id_Kind := RTE (RE_Exception_Id);
3776
3777 if Present (Renamed_Object (Entity (Pref))) then
3778 Set_Entity (Pref, Renamed_Object (Entity (Pref)));
3779 end if;
3780
3781 Rewrite (N,
3782 Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref)));
3783 else
b5e792e2 3784 Id_Kind := RTE (RO_AT_Task_Id);
70482933 3785
470cd9e9
RD		 3786 -- If the prefix is a task interface, the Task_Id is obtained
3787 -- dynamically through a dispatching call, as for other task
3788 -- attributes applied to interfaces.
3789
0791fbe9 3790 if Ada_Version >= Ada_2005
21d27997
RD		 3791 and then Ekind (Ptyp) = E_Class_Wide_Type
3792 and then Is_Interface (Ptyp)
3793 and then Is_Task_Interface (Ptyp)
470cd9e9 3794 then
c0e938d0
AC		 3795 Rewrite (N,
3796 Unchecked_Convert_To
3797 (Id_Kind, Build_Disp_Get_Task_Id_Call (Pref)));
470cd9e9
RD		 3798
3799 else
3800 Rewrite (N,
3801 Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
3802 end if;
70482933
RK		 3803 end if;
3804
3805 Analyze_And_Resolve (N, Id_Kind);
3806 end Identity;
3807
3808 -----------
3809 -- Image --
3810 -----------
3811
3812 -- Image attribute is handled in separate unit Exp_Imgv
3813
3814 when Attribute_Image =>
643827e9 3815
b63d61f7
AC		 3816 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
3817 -- back-end knows how to handle this attribute directly.
3818
3819 if CodePeer_Mode then
3820 return;
3821 end if;
3822
643827e9 3823 Expand_Image_Attribute (N);
70482933
RK		 3824
3825 ---------
3826 -- Img --
3827 ---------
3828
3829 -- X'Img is expanded to typ'Image (X), where typ is the type of X
3830
d8f43ee6 3831 when Attribute_Img =>
643827e9 3832 Expand_Image_Attribute (N);
70482933
RK		 3833
3834 -----------
3835 -- Input --
3836 -----------
3837
3838 when Attribute_Input => Input : declare
3839 P_Type : constant Entity_Id := Entity (Pref);
3840 B_Type : constant Entity_Id := Base_Type (P_Type);
3841 U_Type : constant Entity_Id := Underlying_Type (P_Type);
3842 Strm : constant Node_Id := First (Exprs);
3843 Fname : Entity_Id;
3844 Decl : Node_Id;
3845 Call : Node_Id;
3846 Prag : Node_Id;
3847 Arg2 : Node_Id;
3848 Rfunc : Node_Id;
3849
3850 Cntrl : Node_Id := Empty;
3851 -- Value for controlling argument in call. Always Empty except in
3852 -- the dispatching (class-wide type) case, where it is a reference
3853 -- to the dummy object initialized to the right internal tag.
3854
1c6c6771
ES		 3855 procedure Freeze_Stream_Subprogram (F : Entity_Id);
3856 -- The expansion of the attribute reference may generate a call to
3857 -- a user-defined stream subprogram that is frozen by the call. This
3858 -- can lead to access-before-elaboration problem if the reference
3859 -- appears in an object declaration and the subprogram body has not
3860 -- been seen. The freezing of the subprogram requires special code
3861 -- because it appears in an expanded context where expressions do
3862 -- not freeze their constituents.
3863
3864 ------------------------------
3865 -- Freeze_Stream_Subprogram --
3866 ------------------------------
3867
3868 procedure Freeze_Stream_Subprogram (F : Entity_Id) is
3869 Decl : constant Node_Id := Unit_Declaration_Node (F);
3870 Bod : Node_Id;
3871
3872 begin
3873 -- If this is user-defined subprogram, the corresponding
3874 -- stream function appears as a renaming-as-body, and the
3875 -- user subprogram must be retrieved by tree traversal.
3876
3877 if Present (Decl)
3878 and then Nkind (Decl) = N_Subprogram_Declaration
3879 and then Present (Corresponding_Body (Decl))
3880 then
3881 Bod := Corresponding_Body (Decl);
3882
3883 if Nkind (Unit_Declaration_Node (Bod)) =
3884 N_Subprogram_Renaming_Declaration
3885 then
3886 Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod))));
3887 end if;
3888 end if;
3889 end Freeze_Stream_Subprogram;
3890
3891 -- Start of processing for Input
3892
70482933
RK		 3893 begin
3894 -- If no underlying type, we have an error that will be diagnosed
3895 -- elsewhere, so here we just completely ignore the expansion.
3896
3897 if No (U_Type) then
3898 return;
3899 end if;
3900
baa571ab
AC		 3901 -- Stream operations can appear in user code even if the restriction
3902 -- No_Streams is active (for example, when instantiating a predefined
3903 -- container). In that case rewrite the attribute as a Raise to
3904 -- prevent any run-time use.
3905
3906 if Restriction_Active (No_Streams) then
3907 Rewrite (N,
3908 Make_Raise_Program_Error (Sloc (N),
b8b2d982 3909 Reason => PE_Stream_Operation_Not_Allowed));
baa571ab
AC		 3910 Set_Etype (N, B_Type);
3911 return;
3912 end if;
3913
70482933
RK		 3914 -- If there is a TSS for Input, just call it
3915
fbf5a39b 3916 Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
70482933
RK		 3917
3918 if Present (Fname) then
3919 null;
3920
3921 else
3922 -- If there is a Stream_Convert pragma, use it, we rewrite
3923
3924 -- sourcetyp'Input (stream)
3925
3926 -- as
3927
3928 -- sourcetyp (streamread (strmtyp'Input (stream)));
3929
f3d0f304 3930 -- where streamread is the given Read function that converts an
21d27997
RD		 3931 -- argument of type strmtyp to type sourcetyp or a type from which
3932 -- it is derived (extra conversion required for the derived case).
70482933 3933
1d571f3b 3934 Prag := Get_Stream_Convert_Pragma (P_Type);
70482933
RK		 3935
3936 if Present (Prag) then
3937 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
3938 Rfunc := Entity (Expression (Arg2));
3939
3940 Rewrite (N,
3941 Convert_To (B_Type,
3942 Make_Function_Call (Loc,
3943 Name => New_Occurrence_Of (Rfunc, Loc),
3944 Parameter_Associations => New_List (
3945 Make_Attribute_Reference (Loc,
3946 Prefix =>
3947 New_Occurrence_Of
3948 (Etype (First_Formal (Rfunc)), Loc),
3949 Attribute_Name => Name_Input,
3950 Expressions => Exprs)))));
3951
3952 Analyze_And_Resolve (N, B_Type);
3953 return;
3954
3955 -- Elementary types
3956
3957 elsif Is_Elementary_Type (U_Type) then
3958
3959 -- A special case arises if we have a defined _Read routine,
3960 -- since in this case we are required to call this routine.
3961
4b7fd131
AC		 3962 declare
3963 Typ : Entity_Id := P_Type;
3964 begin
3965 if Present (Full_View (Typ)) then
3966 Typ := Full_View (Typ);
3967 end if;
70482933 3968
4b7fd131
AC		 3969 if Present (TSS (Base_Type (Typ), TSS_Stream_Read)) then
3970 Build_Record_Or_Elementary_Input_Function
3971 (Loc, Typ, Decl, Fname, Use_Underlying => False);
3972 Insert_Action (N, Decl);
70482933 3973
4b7fd131
AC		 3974 -- For normal cases, we call the I_xxx routine directly
3975
3976 else
3977 Rewrite (N, Build_Elementary_Input_Call (N));
3978 Analyze_And_Resolve (N, P_Type);
3979 return;
3980 end if;
3981 end;
70482933
RK		 3982
3983 -- Array type case
3984
3985 elsif Is_Array_Type (U_Type) then
3986 Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
3987 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3988
3989 -- Dispatching case with class-wide type
3990
3991 elsif Is_Class_Wide_Type (P_Type) then
3992
0669bebe
GB		 3993 -- No need to do anything else compiling under restriction
3994 -- No_Dispatching_Calls. During the semantic analysis we
3995 -- already notified such violation.
3996
3997 if Restriction_Active (No_Dispatching_Calls) then
3998 return;
3999 end if;
4000
70482933
RK		 4001 declare
4002 Rtyp : constant Entity_Id := Root_Type (P_Type);
6d0289b1
HK		 4003
4004 Expr : Node_Id; -- call to Descendant_Tag
8e28429a 4005 Get_Tag : Node_Id; -- expression to read the 'Tag
70482933
RK		 4006
4007 begin
4008 -- Read the internal tag (RM 13.13.2(34)) and use it to
8e28429a
BD		 4009 -- initialize a dummy tag value. We used to unconditionally
4010 -- generate:
6a237c45 4011 --
c9d70ab1 4012 -- Descendant_Tag (String'Input (Strm), P_Type);
6a237c45
AC		 4013 --
4014 -- which turns into a call to String_Input_Blk_IO. However,
4015 -- if the input is malformed, that could try to read an
4016 -- enormous String, causing chaos. So instead we call
4017 -- String_Input_Tag, which does the same thing as
4018 -- String_Input_Blk_IO, except that if the String is
4019 -- absurdly long, it raises an exception.
4020 --
8e28429a
BD		 4021 -- However, if the No_Stream_Optimizations restriction
4022 -- is active, we disable this unnecessary attempt at
4023 -- robustness; we really need to read the string
4024 -- character-by-character.
4025 --
c9d70ab1 4026 -- This value is used only to provide a controlling
758c442c
GD		 4027 -- argument for the eventual _Input call. Descendant_Tag is
4028 -- called rather than Internal_Tag to ensure that we have a
4029 -- tag for a type that is descended from the prefix type and
4030 -- declared at the same accessibility level (the exception
4031 -- Tag_Error will be raised otherwise). The level check is
4032 -- required for Ada 2005 because tagged types can be
4033 -- extended in nested scopes (AI-344).
70482933 4034
c9d70ab1
AC		 4035 -- Note: we used to generate an explicit declaration of a
4036 -- constant Ada.Tags.Tag object, and use an occurrence of
4037 -- this constant in Cntrl, but this caused a secondary stack
4038 -- leak.
4039
8e28429a
BD		 4040 if Restriction_Active (No_Stream_Optimizations) then
4041 Get_Tag :=
4042 Make_Attribute_Reference (Loc,
4043 Prefix =>
4044 New_Occurrence_Of (Standard_String, Loc),
4045 Attribute_Name => Name_Input,
4046 Expressions => New_List (
4047 Relocate_Node (Duplicate_Subexpr (Strm))));
4048 else
4049 Get_Tag :=
4050 Make_Function_Call (Loc,
4051 Name =>
4052 New_Occurrence_Of
4053 (RTE (RE_String_Input_Tag), Loc),
4054 Parameter_Associations => New_List (
4055 Relocate_Node (Duplicate_Subexpr (Strm))));
4056 end if;
4057
191fcb3a
RD		 4058 Expr :=
4059 Make_Function_Call (Loc,
e0c23ac7 4060 Name =>
191fcb3a
RD		 4061 New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
4062 Parameter_Associations => New_List (
8e28429a 4063 Get_Tag,
191fcb3a 4064 Make_Attribute_Reference (Loc,
e0c23ac7 4065 Prefix => New_Occurrence_Of (P_Type, Loc),
191fcb3a 4066 Attribute_Name => Name_Tag)));
683af98c 4067
c9d70ab1 4068 Set_Etype (Expr, RTE (RE_Tag));
70482933
RK		 4069
4070 -- Now we need to get the entity for the call, and construct
4071 -- a function call node, where we preset a reference to Dnn
758c442c
GD		 4072 -- as the controlling argument (doing an unchecked convert
4073 -- to the class-wide tagged type to make it look like a real
4074 -- tagged object).
70482933 4075
fbf5a39b 4076 Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
c9d70ab1 4077 Cntrl := Unchecked_Convert_To (P_Type, Expr);
fbf5a39b 4078 Set_Etype (Cntrl, P_Type);
70482933
RK		 4079 Set_Parent (Cntrl, N);
4080 end;
4081
4082 -- For tagged types, use the primitive Input function
4083
4084 elsif Is_Tagged_Type (U_Type) then
fbf5a39b 4085 Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
70482933 4086
758c442c
GD		 4087 -- All other record type cases, including protected records. The
4088 -- latter only arise for expander generated code for handling
4089 -- shared passive partition access.
70482933
RK		 4090
4091 else
4092 pragma Assert
4093 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
4094
21d27997
RD		 4095 -- Ada 2005 (AI-216): Program_Error is raised executing default
4096 -- implementation of the Input attribute of an unchecked union
4097 -- type if the type lacks default discriminant values.
5d09245e
AC		 4098
4099 if Is_Unchecked_Union (Base_Type (U_Type))
80d4224f 4100 and then No (Discriminant_Constraint (U_Type))
5d09245e
AC		 4101 then
4102 Insert_Action (N,
4103 Make_Raise_Program_Error (Loc,
4104 Reason => PE_Unchecked_Union_Restriction));
4105
4106 return;
4107 end if;
4108
f2404867
AC		 4109 -- Build the type's Input function, passing the subtype rather
4110 -- than its base type, because checks are needed in the case of
4111 -- constrained discriminants (see Ada 2012 AI05-0192).
4112
70482933 4113 Build_Record_Or_Elementary_Input_Function
f2404867 4114 (Loc, U_Type, Decl, Fname);
70482933 4115 Insert_Action (N, Decl);
1c6c6771
ES		 4116
4117 if Nkind (Parent (N)) = N_Object_Declaration
4118 and then Is_Record_Type (U_Type)
4119 then
4120 -- The stream function may contain calls to user-defined
4121 -- Read procedures for individual components.
4122
4123 declare
4124 Comp : Entity_Id;
4125 Func : Entity_Id;
4126
4127 begin
4128 Comp := First_Component (U_Type);
4129 while Present (Comp) loop
4130 Func :=
4131 Find_Stream_Subprogram
4132 (Etype (Comp), TSS_Stream_Read);
4133
4134 if Present (Func) then
4135 Freeze_Stream_Subprogram (Func);
4136 end if;
4137
4138 Next_Component (Comp);
4139 end loop;
4140 end;
4141 end if;
70482933
RK		 4142 end if;
4143 end if;
4144
758c442c
GD		 4145 -- If we fall through, Fname is the function to be called. The result
4146 -- is obtained by calling the appropriate function, then converting
4147 -- the result. The conversion does a subtype check.
70482933
RK		 4148
4149 Call :=
4150 Make_Function_Call (Loc,
4151 Name => New_Occurrence_Of (Fname, Loc),
4152 Parameter_Associations => New_List (
4153 Relocate_Node (Strm)));
4154
4155 Set_Controlling_Argument (Call, Cntrl);
4156 Rewrite (N, Unchecked_Convert_To (P_Type, Call));
4157 Analyze_And_Resolve (N, P_Type);
1c6c6771
ES		 4158
4159 if Nkind (Parent (N)) = N_Object_Declaration then
4160 Freeze_Stream_Subprogram (Fname);
4161 end if;
70482933
RK		 4162 end Input;
4163
21d27997
RD		 4164 -------------------
4165 -- Invalid_Value --
4166 -------------------
4167
4168 when Attribute_Invalid_Value =>
4169 Rewrite (N, Get_Simple_Init_Val (Ptyp, N));
4170
68f27c97
HK		 4171 -- The value produced may be a conversion of a literal, which must be
4172 -- resolved to establish its proper type.
6a04c943
ES		 4173
4174 Analyze_And_Resolve (N);
4175
70482933
RK		 4176 ----------
4177 -- Last --
4178 ----------
4179
21d27997 4180 when Attribute_Last =>
70482933 4181
70482933 4182 -- If the prefix type is a constrained packed array type which
8ca597af 4183 -- already has a Packed_Array_Impl_Type representation defined, then
70482933 4184 -- replace this attribute with a direct reference to 'Last of the
21d27997
RD		 4185 -- appropriate index subtype (since otherwise the back end will try
4186 -- to give us the value of 'Last for this implementation type).
70482933
RK		 4187
4188 if Is_Constrained_Packed_Array (Ptyp) then
4189 Rewrite (N,
4190 Make_Attribute_Reference (Loc,
4191 Attribute_Name => Name_Last,
e4494292 4192 Prefix => New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
70482933
RK		 4193 Analyze_And_Resolve (N, Typ);
4194
41a58113
RD		 4195 -- For access type, apply access check as needed
4196
70482933
RK		 4197 elsif Is_Access_Type (Ptyp) then
4198 Apply_Access_Check (N);
41a58113
RD		 4199
4200 -- For scalar type, if low bound is a reference to an entity, just
4201 -- replace with a direct reference. Note that we can only have a
4202 -- reference to a constant entity at this stage, anything else would
8e888920 4203 -- have already been rewritten.
41a58113 4204
8e888920 4205 elsif Is_Scalar_Type (Ptyp) then
41a58113
RD		 4206 declare
4207 Hi : constant Node_Id := Type_High_Bound (Ptyp);
4208 begin
4209 if Is_Entity_Name (Hi) then
4210 Rewrite (N, New_Occurrence_Of (Entity (Hi), Loc));
4211 end if;
4212 end;
70482933 4213 end if;
70482933
RK		 4214
4215 --------------
4216 -- Last_Bit --
4217 --------------
4218
21d27997
RD		 4219 -- We compute this if a component clause was present, otherwise we leave
4220 -- the computation up to the back end, since we don't know what layout
4221 -- will be chosen.
70482933 4222
be482a8c 4223 when Attribute_Last_Bit => Last_Bit_Attr : declare
70482933
RK		 4224 CE : constant Entity_Id := Entity (Selector_Name (Pref));
4225
4226 begin
fd8b8c01
AC		 4227 -- In Ada 2005 (or later) if we have the non-default bit order, then
4228 -- we return the original value as given in the component clause
4229 -- (RM 2005 13.5.2(3/2)).
be482a8c
AC		 4230
4231 if Present (Component_Clause (CE))
4232 and then Ada_Version >= Ada_2005
fd8b8c01 4233 and then Reverse_Bit_Order (Scope (CE))
be482a8c
AC		 4234 then
4235 Rewrite (N,
4236 Make_Integer_Literal (Loc,
4237 Intval => Expr_Value (Last_Bit (Component_Clause (CE)))));
4238 Analyze_And_Resolve (N, Typ);
4239
fd8b8c01 4240 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
be482a8c
AC		 4241 -- rewrite with normalized value if we know it statically.
4242
4243 elsif Known_Static_Component_Bit_Offset (CE)
70482933
RK		 4244 and then Known_Static_Esize (CE)
4245 then
4246 Rewrite (N,
4247 Make_Integer_Literal (Loc,
4248 Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
4249 + Esize (CE) - 1));
70482933
RK		 4250 Analyze_And_Resolve (N, Typ);
4251
be482a8c
AC		 4252 -- Otherwise leave to back end, just apply universal integer checks
4253
70482933
RK		 4254 else
4255 Apply_Universal_Integer_Attribute_Checks (N);
4256 end if;
be482a8c 4257 end Last_Bit_Attr;
70482933
RK		 4258
4259 ------------------
4260 -- Leading_Part --
4261 ------------------
4262
4263 -- Transforms 'Leading_Part into a call to the floating-point attribute
4264 -- function Leading_Part in Fat_xxx (where xxx is the root type)
4265
21d27997 4266 -- Note: strictly, we should generate special case code to deal with
758c442c
GD		 4267 -- absurdly large positive arguments (greater than Integer'Last), which
4268 -- result in returning the first argument unchanged, but it hardly seems
4269 -- worth the effort. We raise constraint error for absurdly negative
4270 -- arguments which is fine.
70482933
RK		 4271
4272 when Attribute_Leading_Part =>
4273 Expand_Fpt_Attribute_RI (N);
4274
4275 ------------
4276 -- Length --
4277 ------------
4278
150ac76e 4279 when Attribute_Length => Length : declare
70482933
RK		 4280 Ityp : Entity_Id;
4281 Xnum : Uint;
4282
4283 begin
4284 -- Processing for packed array types
4285
4286 if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
4287 Ityp := Get_Index_Subtype (N);
4288
21d27997
RD		 4289 -- If the index type, Ityp, is an enumeration type with holes,
4290 -- then we calculate X'Length explicitly using
70482933
RK		 4291
4292 -- Typ'Max
4293 -- (0, Ityp'Pos (X'Last (N)) -
4294 -- Ityp'Pos (X'First (N)) + 1);
4295
21d27997
RD		 4296 -- Since the bounds in the template are the representation values
4297 -- and the back end would get the wrong value.
70482933
RK		 4298
4299 if Is_Enumeration_Type (Ityp)
4300 and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
4301 then
4302 if No (Exprs) then
4303 Xnum := Uint_1;
4304 else
4305 Xnum := Expr_Value (First (Expressions (N)));
4306 end if;
4307
4308 Rewrite (N,
4309 Make_Attribute_Reference (Loc,
4310 Prefix => New_Occurrence_Of (Typ, Loc),
4311 Attribute_Name => Name_Max,
4312 Expressions => New_List
4313 (Make_Integer_Literal (Loc, 0),
4314
4315 Make_Op_Add (Loc,
4316 Left_Opnd =>
4317 Make_Op_Subtract (Loc,
4318 Left_Opnd =>
4319 Make_Attribute_Reference (Loc,
4320 Prefix => New_Occurrence_Of (Ityp, Loc),
4321 Attribute_Name => Name_Pos,
4322
4323 Expressions => New_List (
4324 Make_Attribute_Reference (Loc,
4325 Prefix => Duplicate_Subexpr (Pref),
4326 Attribute_Name => Name_Last,
4327 Expressions => New_List (
4328 Make_Integer_Literal (Loc, Xnum))))),
4329
4330 Right_Opnd =>
4331 Make_Attribute_Reference (Loc,
4332 Prefix => New_Occurrence_Of (Ityp, Loc),
4333 Attribute_Name => Name_Pos,
4334
4335 Expressions => New_List (
4336 Make_Attribute_Reference (Loc,
fbf5a39b
AC		 4337 Prefix =>
4338 Duplicate_Subexpr_No_Checks (Pref),
70482933
RK		 4339 Attribute_Name => Name_First,
4340 Expressions => New_List (
4341 Make_Integer_Literal (Loc, Xnum)))))),
4342
4343 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
4344
4345 Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
4346 return;
4347
4348 -- If the prefix type is a constrained packed array type which
8ca597af
RD		 4349 -- already has a Packed_Array_Impl_Type representation defined,
4350 -- then replace this attribute with a reference to 'Range_Length
4351 -- of the appropriate index subtype (since otherwise the
4352 -- back end will try to give us the value of 'Length for
4353 -- this implementation type).s
70482933
RK		 4354
4355 elsif Is_Constrained (Ptyp) then
4356 Rewrite (N,
4357 Make_Attribute_Reference (Loc,
4358 Attribute_Name => Name_Range_Length,
e4494292 4359 Prefix => New_Occurrence_Of (Ityp, Loc)));
70482933
RK		 4360 Analyze_And_Resolve (N, Typ);
4361 end if;
4362
70482933
RK		 4363 -- Access type case
4364
4365 elsif Is_Access_Type (Ptyp) then
4366 Apply_Access_Check (N);
4367
21d27997
RD		 4368 -- If the designated type is a packed array type, then we convert
4369 -- the reference to:
70482933
RK		 4370
4371 -- typ'Max (0, 1 +
4372 -- xtyp'Pos (Pref'Last (Expr)) -
4373 -- xtyp'Pos (Pref'First (Expr)));
4374
21d27997
RD		 4375 -- This is a bit complex, but it is the easiest thing to do that
4376 -- works in all cases including enum types with holes xtyp here
4377 -- is the appropriate index type.
70482933
RK		 4378
4379 declare
4380 Dtyp : constant Entity_Id := Designated_Type (Ptyp);
4381 Xtyp : Entity_Id;
4382
4383 begin
4384 if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
4385 Xtyp := Get_Index_Subtype (N);
4386
4387 Rewrite (N,
4388 Make_Attribute_Reference (Loc,
4389 Prefix => New_Occurrence_Of (Typ, Loc),
4390 Attribute_Name => Name_Max,
4391 Expressions => New_List (
4392 Make_Integer_Literal (Loc, 0),
4393
4394 Make_Op_Add (Loc,
4395 Make_Integer_Literal (Loc, 1),
4396 Make_Op_Subtract (Loc,
4397 Left_Opnd =>
4398 Make_Attribute_Reference (Loc,
4399 Prefix => New_Occurrence_Of (Xtyp, Loc),
4400 Attribute_Name => Name_Pos,
4401 Expressions => New_List (
4402 Make_Attribute_Reference (Loc,
4403 Prefix => Duplicate_Subexpr (Pref),
4404 Attribute_Name => Name_Last,
4405 Expressions =>
4406 New_Copy_List (Exprs)))),
4407
4408 Right_Opnd =>
4409 Make_Attribute_Reference (Loc,
4410 Prefix => New_Occurrence_Of (Xtyp, Loc),
4411 Attribute_Name => Name_Pos,
4412 Expressions => New_List (
4413 Make_Attribute_Reference (Loc,
fbf5a39b
AC		 4414 Prefix =>
4415 Duplicate_Subexpr_No_Checks (Pref),
70482933
RK		 4416 Attribute_Name => Name_First,
4417 Expressions =>
4418 New_Copy_List (Exprs)))))))));
4419
4420 Analyze_And_Resolve (N, Typ);
4421 end if;
4422 end;
4423
21d27997 4424 -- Otherwise leave it to the back end
70482933
RK		 4425
4426 else
4427 Apply_Universal_Integer_Attribute_Checks (N);
4428 end if;
150ac76e
AC		 4429 end Length;
4430
d436b30d
AC		 4431 -- Attribute Loop_Entry is replaced with a reference to a constant value
4432 -- which captures the prefix at the entry point of the related loop. The
4433 -- loop itself may be transformed into a conditional block.
150ac76e
AC		 4434
4435 when Attribute_Loop_Entry =>
d436b30d 4436 Expand_Loop_Entry_Attribute (N);
70482933
RK		 4437
4438 -------------
4439 -- Machine --
4440 -------------
4441
4442 -- Transforms 'Machine into a call to the floating-point attribute
24228312
AC		 4443 -- function Machine in Fat_xxx (where xxx is the root type).
4444 -- Expansion is avoided for cases the back end can handle directly.
70482933
RK		 4445
4446 when Attribute_Machine =>
24228312
AC		 4447 if not Is_Inline_Floating_Point_Attribute (N) then
4448 Expand_Fpt_Attribute_R (N);
4449 end if;
70482933 4450
65f01153
RD		 4451 ----------------------
4452 -- Machine_Rounding --
4453 ----------------------
4454
4455 -- Transforms 'Machine_Rounding into a call to the floating-point
4456 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
0669bebe
GB		 4457 -- type). Expansion is avoided for cases the back end can handle
4458 -- directly.
65f01153
RD		 4459
4460 when Attribute_Machine_Rounding =>
0669bebe
GB		 4461 if not Is_Inline_Floating_Point_Attribute (N) then
4462 Expand_Fpt_Attribute_R (N);
4463 end if;
65f01153 4464
70482933
RK		 4465 ------------------
4466 -- Machine_Size --
4467 ------------------
4468
4469 -- Machine_Size is equivalent to Object_Size, so transform it into
21d27997 4470 -- Object_Size and that way the back end never sees Machine_Size.
70482933
RK		 4471
4472 when Attribute_Machine_Size =>
4473 Rewrite (N,
4474 Make_Attribute_Reference (Loc,
4475 Prefix => Prefix (N),
4476 Attribute_Name => Name_Object_Size));
4477
4478 Analyze_And_Resolve (N, Typ);
4479
4480 --------------
4481 -- Mantissa --
4482 --------------
4483
758c442c 4484 -- The only case that can get this far is the dynamic case of the old
21d27997
RD		 4485 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
4486 -- we expand:
70482933
RK		 4487
4488 -- typ'Mantissa
4489
4490 -- into
4491
4492 -- ityp (System.Mantissa.Mantissa_Value
4493 -- (Integer'Integer_Value (typ'First),
4494 -- Integer'Integer_Value (typ'Last)));
4495
d8f43ee6 4496 when Attribute_Mantissa =>
70482933
RK		 4497 Rewrite (N,
4498 Convert_To (Typ,
4499 Make_Function_Call (Loc,
d8f43ee6
HK		 4500 Name =>
4501 New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
70482933
RK		 4502
4503 Parameter_Associations => New_List (
70482933 4504 Make_Attribute_Reference (Loc,
d8f43ee6 4505 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
70482933 4506 Attribute_Name => Name_Integer_Value,
d8f43ee6 4507 Expressions => New_List (
70482933 4508 Make_Attribute_Reference (Loc,
d8f43ee6 4509 Prefix => New_Occurrence_Of (Ptyp, Loc),
70482933
RK		 4510 Attribute_Name => Name_First))),
4511
4512 Make_Attribute_Reference (Loc,
d8f43ee6 4513 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
70482933 4514 Attribute_Name => Name_Integer_Value,
d8f43ee6 4515 Expressions => New_List (
70482933 4516 Make_Attribute_Reference (Loc,
d8f43ee6 4517 Prefix => New_Occurrence_Of (Ptyp, Loc),
70482933
RK		 4518 Attribute_Name => Name_Last)))))));
4519
4520 Analyze_And_Resolve (N, Typ);
70482933 4521
aa9b151a
AC		 4522 ---------
4523 -- Max --
4524 ---------
4525
4526 when Attribute_Max =>
e0f63680 4527 Expand_Min_Max_Attribute (N);
aa9b151a 4528
ca20a08e
AC		 4529 ----------------------------------
4530 -- Max_Size_In_Storage_Elements --
4531 ----------------------------------
4532
24cb156d
AC		 4533 when Attribute_Max_Size_In_Storage_Elements => declare
4534 Typ : constant Entity_Id := Etype (N);
4535 Attr : Node_Id;
4536
4537 Conversion_Added : Boolean := False;
4538 -- A flag which tracks whether the original attribute has been
4539 -- wrapped inside a type conversion.
4540
4541 begin
d85badc7
BD		 4542 -- If the prefix is X'Class, we transform it into a direct reference
4543 -- to the class-wide type, because the back end must not see a 'Class
4544 -- reference. See also 'Size.
4545
4546 if Is_Entity_Name (Pref)
4547 and then Is_Class_Wide_Type (Entity (Pref))
4548 then
4549 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
4550 return;
4551 end if;
4552
ca20a08e
AC		 4553 Apply_Universal_Integer_Attribute_Checks (N);
4554
24cb156d
AC		 4555 -- The universal integer check may sometimes add a type conversion,
4556 -- retrieve the original attribute reference from the expression.
4557
4558 Attr := N;
d18b1548 4559
24cb156d
AC		 4560 if Nkind (Attr) = N_Type_Conversion then
4561 Attr := Expression (Attr);
4562 Conversion_Added := True;
4563 end if;
d18b1548 4564
d85badc7 4565 pragma Assert (Nkind (Attr) = N_Attribute_Reference);
24cb156d 4566
ca20a08e
AC		 4567 -- Heap-allocated controlled objects contain two extra pointers which
4568 -- are not part of the actual type. Transform the attribute reference
4569 -- into a runtime expression to add the size of the hidden header.
4570
535a8637 4571 if Needs_Finalization (Ptyp)
24cb156d 4572 and then not Header_Size_Added (Attr)
ca20a08e 4573 then
24cb156d 4574 Set_Header_Size_Added (Attr);
ca20a08e
AC		 4575
4576 -- Generate:
4577 -- P'Max_Size_In_Storage_Elements +
4578 -- Universal_Integer
4579 -- (Header_Size_With_Padding (Ptyp'Alignment))
4580
24cb156d 4581 Rewrite (Attr,
ca20a08e 4582 Make_Op_Add (Loc,
24cb156d 4583 Left_Opnd => Relocate_Node (Attr),
ca20a08e
AC		 4584 Right_Opnd =>
4585 Convert_To (Universal_Integer,
4586 Make_Function_Call (Loc,
4587 Name =>
e4494292 4588 New_Occurrence_Of
ca20a08e
AC		 4589 (RTE (RE_Header_Size_With_Padding), Loc),
4590
4591 Parameter_Associations => New_List (
4592 Make_Attribute_Reference (Loc,
4593 Prefix =>
e4494292 4594 New_Occurrence_Of (Ptyp, Loc),
ca20a08e
AC		 4595 Attribute_Name => Name_Alignment))))));
4596
24cb156d
AC		 4597 -- Add a conversion to the target type
4598
4599 if not Conversion_Added then
4600 Rewrite (Attr,
4601 Make_Type_Conversion (Loc,
e4494292 4602 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
24cb156d
AC		 4603 Expression => Relocate_Node (Attr)));
4604 end if;
4605
4606 Analyze (Attr);
ca20a08e
AC		 4607 return;
4608 end if;
24cb156d 4609 end;
ca20a08e 4610
80d4224f
RD		 4611 --------------------
4612 -- Mechanism_Code --
4613 --------------------
4614
4615 when Attribute_Mechanism_Code =>
4616
d8f43ee6 4617 -- We must replace the prefix in the renamed case
80d4224f
RD		 4618
4619 if Is_Entity_Name (Pref)
4620 and then Present (Alias (Entity (Pref)))
4621 then
4622 Set_Renamed_Subprogram (Pref, Alias (Entity (Pref)));
4623 end if;
4624
aa9b151a
AC		 4625 ---------
4626 -- Min --
4627 ---------
4628
4629 when Attribute_Min =>
e0f63680 4630 Expand_Min_Max_Attribute (N);
aa9b151a 4631
5f3ab6fb
AC		 4632 ---------
4633 -- Mod --
4634 ---------
4635
4636 when Attribute_Mod => Mod_Case : declare
4637 Arg : constant Node_Id := Relocate_Node (First (Exprs));
4638 Hi : constant Node_Id := Type_High_Bound (Etype (Arg));
4639 Modv : constant Uint := Modulus (Btyp);
4640
4641 begin
4642
4643 -- This is not so simple. The issue is what type to use for the
4644 -- computation of the modular value.
4645
4646 -- The easy case is when the modulus value is within the bounds
4647 -- of the signed integer type of the argument. In this case we can
4648 -- just do the computation in that signed integer type, and then
4649 -- do an ordinary conversion to the target type.
4650
4651 if Modv <= Expr_Value (Hi) then
4652 Rewrite (N,
4653 Convert_To (Btyp,
4654 Make_Op_Mod (Loc,
4655 Left_Opnd => Arg,
4656 Right_Opnd => Make_Integer_Literal (Loc, Modv))));
4657
4658 -- Here we know that the modulus is larger than type'Last of the
3b641023 4659 -- integer type. There are two cases to consider:
5f3ab6fb
AC		 4660
4661 -- a) The integer value is non-negative. In this case, it is
4662 -- returned as the result (since it is less than the modulus).
4663
758c442c
GD		 4664 -- b) The integer value is negative. In this case, we know that the
4665 -- result is modulus + value, where the value might be as small as
4666 -- -modulus. The trouble is what type do we use to do the subtract.
4667 -- No type will do, since modulus can be as big as 2**64, and no
f3d0f304 4668 -- integer type accommodates this value. Let's do bit of algebra
5f3ab6fb
AC		 4669
4670 -- modulus + value
4671 -- = modulus - (-value)
4672 -- = (modulus - 1) - (-value - 1)
4673
4674 -- Now modulus - 1 is certainly in range of the modular type.
4675 -- -value is in the range 1 .. modulus, so -value -1 is in the
4676 -- range 0 .. modulus-1 which is in range of the modular type.
4677 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
4678 -- which we can compute using the integer base type.
4679
9b16cb57
RD		 4680 -- Once this is done we analyze the if expression without range
4681 -- checks, because we know everything is in range, and we want
4682 -- to prevent spurious warnings on either branch.
3b641023 4683
5f3ab6fb
AC		 4684 else
4685 Rewrite (N,
9b16cb57 4686 Make_If_Expression (Loc,
5f3ab6fb
AC		 4687 Expressions => New_List (
4688 Make_Op_Ge (Loc,
4689 Left_Opnd => Duplicate_Subexpr (Arg),
4690 Right_Opnd => Make_Integer_Literal (Loc, 0)),
4691
4692 Convert_To (Btyp,
4693 Duplicate_Subexpr_No_Checks (Arg)),
4694
4695 Make_Op_Subtract (Loc,
4696 Left_Opnd =>
4697 Make_Integer_Literal (Loc,
4698 Intval => Modv - 1),
4699 Right_Opnd =>
4700 Convert_To (Btyp,
4701 Make_Op_Minus (Loc,
4702 Right_Opnd =>
4703 Make_Op_Add (Loc,
4704 Left_Opnd => Duplicate_Subexpr_No_Checks (Arg),
4705 Right_Opnd =>
4706 Make_Integer_Literal (Loc,
4707 Intval => 1))))))));
4708
5f3ab6fb
AC		 4709 end if;
4710
65f01153 4711 Analyze_And_Resolve (N, Btyp, Suppress => All_Checks);
5f3ab6fb
AC		 4712 end Mod_Case;
4713
70482933
RK		 4714 -----------
4715 -- Model --
4716 -----------
4717
4718 -- Transforms 'Model into a call to the floating-point attribute
24228312
AC		 4719 -- function Model in Fat_xxx (where xxx is the root type).
4720 -- Expansion is avoided for cases the back end can handle directly.
70482933
RK		 4721
4722 when Attribute_Model =>
24228312
AC		 4723 if not Is_Inline_Floating_Point_Attribute (N) then
4724 Expand_Fpt_Attribute_R (N);
4725 end if;
70482933
RK		 4726
4727 -----------------
4728 -- Object_Size --
4729 -----------------
4730
4731 -- The processing for Object_Size shares the processing for Size
4732
e10dab7f
JM		 4733 ---------
4734 -- Old --
4735 ---------
4736
4737 when Attribute_Old => Old : declare
6c802906
AC		 4738 Typ : constant Entity_Id := Etype (N);
4739 CW_Temp : Entity_Id;
4740 CW_Typ : Entity_Id;
64f5d139 4741 Ins_Nod : Node_Id;
8e1e62e3
AC		 4742 Subp : Node_Id;
4743 Temp : Entity_Id;
e10dab7f
JM		 4744
4745 begin
64f5d139
JM		 4746 -- Generating C code we don't need to expand this attribute when
4747 -- we are analyzing the internally built nested postconditions
4748 -- procedure since it will be expanded inline (and later it will
4749 -- be removed by Expand_N_Subprogram_Body). It this expansion is
4750 -- performed in such case then the compiler generates unreferenced
4751 -- extra temporaries.
4752
4753 if Modify_Tree_For_C
4754 and then Chars (Current_Scope) = Name_uPostconditions
4755 then
4756 return;
4757 end if;
4758
8e1e62e3 4759 -- Climb the parent chain looking for subprogram _Postconditions
21d27997 4760
e10dab7f 4761 Subp := N;
8e1e62e3 4762 while Present (Subp) loop
21d27997 4763 exit when Nkind (Subp) = N_Subprogram_Body
8e1e62e3
AC		 4764 and then Chars (Defining_Entity (Subp)) = Name_uPostconditions;
4765
4de10025
AC		 4766 -- If assertions are disabled, no need to create the declaration
4767 -- that preserves the value. The postcondition pragma in which
4768 -- 'Old appears will be checked or disabled according to the
4769 -- current policy in effect.
4770
890f1954 4771 if Nkind (Subp) = N_Pragma and then not Is_Checked (Subp) then
4de10025
AC		 4772 return;
4773 end if;
4774
8e1e62e3 4775 Subp := Parent (Subp);
e10dab7f
JM		 4776 end loop;
4777
8e1e62e3 4778 -- 'Old can only appear in a postcondition, the generated body of
64f5d139
JM		 4779 -- _Postconditions must be in the tree (or inlined if we are
4780 -- generating C code).
8e1e62e3 4781
fb757f7d
AC		 4782 pragma Assert
4783 (Present (Subp)
4784 or else (Modify_Tree_For_C and then In_Inlined_Body));
8e1e62e3 4785
6c802906 4786 Temp := Make_Temporary (Loc, 'T', Pref);
21d27997 4787
6c802906
AC		 4788 -- Set the entity kind now in order to mark the temporary as a
4789 -- handler of attribute 'Old's prefix.
4790
4791 Set_Ekind (Temp, E_Constant);
4792 Set_Stores_Attribute_Old_Prefix (Temp);
e10dab7f 4793
8e1e62e3
AC		 4794 -- Push the scope of the related subprogram where _Postcondition
4795 -- resides as this ensures that the object will be analyzed in the
4796 -- proper context.
7425962b 4797
64f5d139
JM		 4798 if Present (Subp) then
4799 Push_Scope (Scope (Defining_Entity (Subp)));
4800
4801 -- No need to push the scope when generating C code since the
4802 -- _Postcondition procedure has been inlined.
4803
4804 else pragma Assert (Modify_Tree_For_C);
4805 pragma Assert (In_Inlined_Body);
4806 null;
4807 end if;
4808
4809 -- Locate the insertion place of the internal temporary that saves
4810 -- the 'Old value.
4811
4812 if Present (Subp) then
4813 Ins_Nod := Subp;
4814
4815 -- Generating C, the postcondition procedure has been inlined and the
4816 -- temporary is added before the first declaration of the enclosing
4817 -- subprogram.
4818
4819 else pragma Assert (Modify_Tree_For_C);
4820 Ins_Nod := N;
4821 while Nkind (Ins_Nod) /= N_Subprogram_Body loop
4822 Ins_Nod := Parent (Ins_Nod);
4823 end loop;
4824
4825 Ins_Nod := First (Declarations (Ins_Nod));
4826 end if;
7425962b 4827
6c802906
AC		 4828 -- Preserve the tag of the prefix by offering a specific view of the
4829 -- class-wide version of the prefix.
4830
4831 if Is_Tagged_Type (Typ) then
4832
4833 -- Generate:
4834 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
4835
4836 CW_Temp := Make_Temporary (Loc, 'T');
4837 CW_Typ := Class_Wide_Type (Typ);
4838
64f5d139 4839 Insert_Before_And_Analyze (Ins_Nod,
6c802906
AC		 4840 Make_Object_Declaration (Loc,
4841 Defining_Identifier => CW_Temp,
4842 Constant_Present => True,
4843 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
4844 Expression =>
4845 Convert_To (CW_Typ, Relocate_Node (Pref))));
4846
4847 -- Generate:
4848 -- Temp : Typ renames Typ (CW_Temp);
4849
64f5d139 4850 Insert_Before_And_Analyze (Ins_Nod,
6c802906
AC		 4851 Make_Object_Renaming_Declaration (Loc,
4852 Defining_Identifier => Temp,
4853 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4854 Name =>
4855 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))));
4856
4857 -- Non-tagged case
4858
4859 else
4860 -- Generate:
4861 -- Temp : constant Typ := Pref;
4862
64f5d139 4863 Insert_Before_And_Analyze (Ins_Nod,
6c802906
AC		 4864 Make_Object_Declaration (Loc,
4865 Defining_Identifier => Temp,
4866 Constant_Present => True,
4867 Object_Definition => New_Occurrence_Of (Typ, Loc),
4868 Expression => Relocate_Node (Pref)));
4869 end if;
8e1e62e3 4870
64f5d139
JM		 4871 if Present (Subp) then
4872 Pop_Scope;
4873 end if;
e10dab7f 4874
2838fa93
AC		 4875 -- Ensure that the prefix of attribute 'Old is valid. The check must
4876 -- be inserted after the expansion of the attribute has taken place
4877 -- to reflect the new placement of the prefix.
4878
4879 if Validity_Checks_On and then Validity_Check_Operands then
4880 Ensure_Valid (Pref);
4881 end if;
4882
8e1e62e3 4883 Rewrite (N, New_Occurrence_Of (Temp, Loc));
e10dab7f
JM		 4884 end Old;
4885
2d42e881
ES		 4886 ----------------------
4887 -- Overlaps_Storage --
4888 ----------------------
4889
4890 when Attribute_Overlaps_Storage => Overlaps_Storage : declare
4891 Loc : constant Source_Ptr := Sloc (N);
4892
4893 X : constant Node_Id := Prefix (N);
4894 Y : constant Node_Id := First (Expressions (N));
90b510e4 4895 -- The arguments
2d42e881
ES		 4896
4897 X_Addr, Y_Addr : Node_Id;
4898 -- the expressions for their integer addresses
4899
4900 X_Size, Y_Size : Node_Id;
4901 -- the expressions for their sizes
4902
4903 Cond : Node_Id;
4904
4905 begin
4906 -- Attribute expands into:
4907
4908 -- if X'Address < Y'address then
4909 -- (X'address + X'Size - 1) >= Y'address
4910 -- else
4911 -- (Y'address + Y'size - 1) >= X'Address
4912 -- end if;
4913
4914 -- with the proper address operations. We convert addresses to
4915 -- integer addresses to use predefined arithmetic. The size is
90b510e4
AC		 4916 -- expressed in storage units. We add copies of X_Addr and Y_Addr
4917 -- to prevent the appearance of the same node in two places in
4918 -- the tree.
2d42e881
ES		 4919
4920 X_Addr :=
4921 Unchecked_Convert_To (RTE (RE_Integer_Address),
4922 Make_Attribute_Reference (Loc,
4923 Attribute_Name => Name_Address,
4924 Prefix => New_Copy_Tree (X)));
4925
4926 Y_Addr :=
4927 Unchecked_Convert_To (RTE (RE_Integer_Address),
4928 Make_Attribute_Reference (Loc,
4929 Attribute_Name => Name_Address,
4930 Prefix => New_Copy_Tree (Y)));
4931
4932 X_Size :=
4933 Make_Op_Divide (Loc,
4934 Left_Opnd =>
4935 Make_Attribute_Reference (Loc,
4936 Attribute_Name => Name_Size,
4937 Prefix => New_Copy_Tree (X)),
4938 Right_Opnd =>
4939 Make_Integer_Literal (Loc, System_Storage_Unit));
4940
4941 Y_Size :=
4942 Make_Op_Divide (Loc,
4943 Left_Opnd =>
4944 Make_Attribute_Reference (Loc,
4945 Attribute_Name => Name_Size,
4946 Prefix => New_Copy_Tree (Y)),
4947 Right_Opnd =>
4948 Make_Integer_Literal (Loc, System_Storage_Unit));
4949
4950 Cond :=
4951 Make_Op_Le (Loc,
4952 Left_Opnd => X_Addr,
4953 Right_Opnd => Y_Addr);
4954
4955 Rewrite (N,
9ba9f4c0
AC		 4956 Make_If_Expression (Loc, New_List (
4957 Cond,
4958
4959 Make_Op_Ge (Loc,
4960 Left_Opnd =>
4961 Make_Op_Add (Loc,
4962 Left_Opnd => New_Copy_Tree (X_Addr),
4963 Right_Opnd =>
4964 Make_Op_Subtract (Loc,
4965 Left_Opnd => X_Size,
4966 Right_Opnd => Make_Integer_Literal (Loc, 1))),
4967 Right_Opnd => Y_Addr),
4968
4969 Make_Op_Ge (Loc,
4970 Left_Opnd =>
4971 Make_Op_Add (Loc,
4972 Left_Opnd => New_Copy_Tree (Y_Addr),
4973 Right_Opnd =>
4974 Make_Op_Subtract (Loc,
4975 Left_Opnd => Y_Size,
4976 Right_Opnd => Make_Integer_Literal (Loc, 1))),
4977 Right_Opnd => X_Addr))));
2d42e881
ES		 4978
4979 Analyze_And_Resolve (N, Standard_Boolean);
4980 end Overlaps_Storage;
4981
70482933
RK		 4982 ------------
4983 -- Output --
4984 ------------
4985
4986 when Attribute_Output => Output : declare
4987 P_Type : constant Entity_Id := Entity (Pref);
70482933
RK		 4988 U_Type : constant Entity_Id := Underlying_Type (P_Type);
4989 Pname : Entity_Id;
4990 Decl : Node_Id;
4991 Prag : Node_Id;
4992 Arg3 : Node_Id;
4993 Wfunc : Node_Id;
4994
4995 begin
4996 -- If no underlying type, we have an error that will be diagnosed
4997 -- elsewhere, so here we just completely ignore the expansion.
4998
4999 if No (U_Type) then
5000 return;
5001 end if;
5002
baa571ab
AC		 5003 -- Stream operations can appear in user code even if the restriction
5004 -- No_Streams is active (for example, when instantiating a predefined
5005 -- container). In that case rewrite the attribute as a Raise to
5006 -- prevent any run-time use.
5007
5008 if Restriction_Active (No_Streams) then
5009 Rewrite (N,
5010 Make_Raise_Program_Error (Sloc (N),
b8b2d982 5011 Reason => PE_Stream_Operation_Not_Allowed));
baa571ab
AC		 5012 Set_Etype (N, Standard_Void_Type);
5013 return;
5014 end if;
5015
70482933
RK		 5016 -- If TSS for Output is present, just call it
5017
fbf5a39b 5018 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
70482933
RK		 5019
5020 if Present (Pname) then
5021 null;
5022
5023 else
5024 -- If there is a Stream_Convert pragma, use it, we rewrite
5025
5026 -- sourcetyp'Output (stream, Item)
5027
5028 -- as
5029
5030 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
5031
758c442c
GD		 5032 -- where strmwrite is the given Write function that converts an
5033 -- argument of type sourcetyp or a type acctyp, from which it is
5034 -- derived to type strmtyp. The conversion to acttyp is required
5035 -- for the derived case.
70482933 5036
1d571f3b 5037 Prag := Get_Stream_Convert_Pragma (P_Type);
70482933
RK		 5038
5039 if Present (Prag) then
5040 Arg3 :=
5041 Next (Next (First (Pragma_Argument_Associations (Prag))));
5042 Wfunc := Entity (Expression (Arg3));
5043
5044 Rewrite (N,
5045 Make_Attribute_Reference (Loc,
5046 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
5047 Attribute_Name => Name_Output,
5048 Expressions => New_List (
5049 Relocate_Node (First (Exprs)),
5050 Make_Function_Call (Loc,
5051 Name => New_Occurrence_Of (Wfunc, Loc),
5052 Parameter_Associations => New_List (
31104818 5053 OK_Convert_To (Etype (First_Formal (Wfunc)),
70482933
RK		 5054 Relocate_Node (Next (First (Exprs)))))))));
5055
5056 Analyze (N);
5057 return;
5058
890f1954
RD		 5059 -- For elementary types, we call the W_xxx routine directly. Note
5060 -- that the effect of Write and Output is identical for the case
5061 -- of an elementary type (there are no discriminants or bounds).
70482933
RK		 5062
5063 elsif Is_Elementary_Type (U_Type) then
5064
5065 -- A special case arises if we have a defined _Write routine,
5066 -- since in this case we are required to call this routine.
5067
4b7fd131
AC		 5068 declare
5069 Typ : Entity_Id := P_Type;
5070 begin
5071 if Present (Full_View (Typ)) then
5072 Typ := Full_View (Typ);
5073 end if;
70482933 5074
4b7fd131
AC		 5075 if Present (TSS (Base_Type (Typ), TSS_Stream_Write)) then
5076 Build_Record_Or_Elementary_Output_Procedure
5077 (Loc, Typ, Decl, Pname);
5078 Insert_Action (N, Decl);
70482933 5079
4b7fd131
AC		 5080 -- For normal cases, we call the W_xxx routine directly
5081
5082 else
5083 Rewrite (N, Build_Elementary_Write_Call (N));
5084 Analyze (N);
5085 return;
5086 end if;
5087 end;
70482933
RK		 5088
5089 -- Array type case
5090
5091 elsif Is_Array_Type (U_Type) then
5092 Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
5093 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
5094
5095 -- Class-wide case, first output external tag, then dispatch
5096 -- to the appropriate primitive Output function (RM 13.13.2(31)).
5097
5098 elsif Is_Class_Wide_Type (P_Type) then
0669bebe
GB		 5099
5100 -- No need to do anything else compiling under restriction
5101 -- No_Dispatching_Calls. During the semantic analysis we
5102 -- already notified such violation.
5103
5104 if Restriction_Active (No_Dispatching_Calls) then
5105 return;
5106 end if;
5107
70482933
RK		 5108 Tag_Write : declare
5109 Strm : constant Node_Id := First (Exprs);
5110 Item : constant Node_Id := Next (Strm);
5111
5112 begin
31104818
HK		 5113 -- Ada 2005 (AI-344): Check that the accessibility level
5114 -- of the type of the output object is not deeper than
5115 -- that of the attribute's prefix type.
5116
758c442c
GD		 5117 -- if Get_Access_Level (Item'Tag)
5118 -- /= Get_Access_Level (P_Type'Tag)
5119 -- then
5120 -- raise Tag_Error;
5121 -- end if;
31104818 5122
758c442c
GD		 5123 -- String'Output (Strm, External_Tag (Item'Tag));
5124
31104818
HK		 5125 -- We cannot figure out a practical way to implement this
5126 -- accessibility check on virtual machines, so we omit it.
758c442c 5127
0791fbe9 5128 if Ada_Version >= Ada_2005
1f110335 5129 and then Tagged_Type_Expansion
31104818 5130 then
758c442c
GD		 5131 Insert_Action (N,
5132 Make_Implicit_If_Statement (N,
5133 Condition =>
5134 Make_Op_Ne (Loc,
5135 Left_Opnd =>
0669bebe
GB		 5136 Build_Get_Access_Level (Loc,
5137 Make_Attribute_Reference (Loc,
5138 Prefix =>
5139 Relocate_Node (
5140 Duplicate_Subexpr (Item,
5141 Name_Req => True)),
5142 Attribute_Name => Name_Tag)),
5143
758c442c 5144 Right_Opnd =>
0669bebe
GB		 5145 Make_Integer_Literal (Loc,
5146 Type_Access_Level (P_Type))),
5147
758c442c
GD		 5148 Then_Statements =>
5149 New_List (Make_Raise_Statement (Loc,
5150 New_Occurrence_Of (
5151 RTE (RE_Tag_Error), Loc)))));
5152 end if;
70482933
RK		 5153
5154 Insert_Action (N,
5155 Make_Attribute_Reference (Loc,
5156 Prefix => New_Occurrence_Of (Standard_String, Loc),
5157 Attribute_Name => Name_Output,
5158 Expressions => New_List (
5159 Relocate_Node (Duplicate_Subexpr (Strm)),
5160 Make_Function_Call (Loc,
5161 Name =>
5162 New_Occurrence_Of (RTE (RE_External_Tag), Loc),
5163 Parameter_Associations => New_List (
5164 Make_Attribute_Reference (Loc,
5165 Prefix =>
5166 Relocate_Node
5167 (Duplicate_Subexpr (Item, Name_Req => True)),
5168 Attribute_Name => Name_Tag))))));
5169 end Tag_Write;
5170
fbf5a39b 5171 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
70482933
RK		 5172
5173 -- Tagged type case, use the primitive Output function
5174
5175 elsif Is_Tagged_Type (U_Type) then
fbf5a39b 5176 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
70482933 5177
0669bebe
GB		 5178 -- All other record type cases, including protected records.
5179 -- The latter only arise for expander generated code for
5180 -- handling shared passive partition access.
70482933
RK		 5181
5182 else
5183 pragma Assert
5184 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
5185
5d09245e
AC		 5186 -- Ada 2005 (AI-216): Program_Error is raised when executing
5187 -- the default implementation of the Output attribute of an
5188 -- unchecked union type if the type lacks default discriminant
5189 -- values.
5190
5191 if Is_Unchecked_Union (Base_Type (U_Type))
80d4224f 5192 and then No (Discriminant_Constraint (U_Type))
5d09245e
AC		 5193 then
5194 Insert_Action (N,
5195 Make_Raise_Program_Error (Loc,
5196 Reason => PE_Unchecked_Union_Restriction));
5197
5198 return;
5199 end if;
5200
70482933
RK		 5201 Build_Record_Or_Elementary_Output_Procedure
5202 (Loc, Base_Type (U_Type), Decl, Pname);
5203 Insert_Action (N, Decl);
5204 end if;
5205 end if;
5206
5207 -- If we fall through, Pname is the name of the procedure to call
5208
5209 Rewrite_Stream_Proc_Call (Pname);
5210 end Output;
5211
5212 ---------
5213 -- Pos --
5214 ---------
5215
5216 -- For enumeration types with a standard representation, Pos is
21d27997 5217 -- handled by the back end.
70482933 5218
47d3b920
AC		 5219 -- For enumeration types, with a non-standard representation we generate
5220 -- a call to the _Rep_To_Pos function created when the type was frozen.
5221 -- The call has the form
70482933 5222
fbf5a39b 5223 -- _rep_to_pos (expr, flag)
70482933 5224
fbf5a39b
AC		 5225 -- The parameter flag is True if range checks are enabled, causing
5226 -- Program_Error to be raised if the expression has an invalid
5227 -- representation, and False if range checks are suppressed.
70482933
RK		 5228
5229 -- For integer types, Pos is equivalent to a simple integer
5230 -- conversion and we rewrite it as such
5231
d8f43ee6 5232 when Attribute_Pos => Pos : declare
70482933
RK		 5233 Etyp : Entity_Id := Base_Type (Entity (Pref));
5234
5235 begin
5236 -- Deal with zero/non-zero boolean values
5237
5238 if Is_Boolean_Type (Etyp) then
5239 Adjust_Condition (First (Exprs));
5240 Etyp := Standard_Boolean;
5241 Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
5242 end if;
5243
5244 -- Case of enumeration type
5245
5246 if Is_Enumeration_Type (Etyp) then
5247
5248 -- Non-standard enumeration type (generate call)
5249
5250 if Present (Enum_Pos_To_Rep (Etyp)) then
fbf5a39b 5251 Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
70482933
RK		 5252 Rewrite (N,
5253 Convert_To (Typ,
5254 Make_Function_Call (Loc,
5255 Name =>
e4494292 5256 New_Occurrence_Of (TSS (Etyp, TSS_Rep_To_Pos), Loc),
70482933
RK		 5257 Parameter_Associations => Exprs)));
5258
5259 Analyze_And_Resolve (N, Typ);
5260
5261 -- Standard enumeration type (do universal integer check)
5262
5263 else
5264 Apply_Universal_Integer_Attribute_Checks (N);
5265 end if;
5266
5267 -- Deal with integer types (replace by conversion)
5268
5269 elsif Is_Integer_Type (Etyp) then
5270 Rewrite (N, Convert_To (Typ, First (Exprs)));
5271 Analyze_And_Resolve (N, Typ);
5272 end if;
5273
5274 end Pos;
5275
5276 --------------
5277 -- Position --
5278 --------------
5279
21d27997
RD		 5280 -- We compute this if a component clause was present, otherwise we leave
5281 -- the computation up to the back end, since we don't know what layout
5282 -- will be chosen.
70482933 5283
d8f43ee6 5284 when Attribute_Position => Position_Attr : declare
70482933
RK		 5285 CE : constant Entity_Id := Entity (Selector_Name (Pref));
5286
5287 begin
5288 if Present (Component_Clause (CE)) then
be482a8c 5289
fd8b8c01
AC		 5290 -- In Ada 2005 (or later) if we have the non-default bit order,
5291 -- then we return the original value as given in the component
5292 -- clause (RM 2005 13.5.2(2/2)).
be482a8c
AC		 5293
5294 if Ada_Version >= Ada_2005
fd8b8c01 5295 and then Reverse_Bit_Order (Scope (CE))
be482a8c
AC		 5296 then
5297 Rewrite (N,
5298 Make_Integer_Literal (Loc,
5299 Intval => Expr_Value (Position (Component_Clause (CE)))));
5300
fd8b8c01 5301 -- Otherwise (Ada 83 or 95, or default bit order specified in
be482a8c
AC		 5302 -- later Ada version), return the normalized value.
5303
5304 else
5305 Rewrite (N,
5306 Make_Integer_Literal (Loc,
5307 Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
5308 end if;
5309
70482933
RK		 5310 Analyze_And_Resolve (N, Typ);
5311
be482a8c
AC		 5312 -- If back end is doing things, just apply universal integer checks
5313
70482933
RK		 5314 else
5315 Apply_Universal_Integer_Attribute_Checks (N);
5316 end if;
be482a8c 5317 end Position_Attr;
70482933
RK		 5318
5319 ----------
5320 -- Pred --
5321 ----------
5322
29049f0b
AC		 5323 -- 1. Deal with enumeration types with holes.
5324 -- 2. For floating-point, generate call to attribute function.
5325 -- 3. For other cases, deal with constraint checking.
70482933 5326
d8f43ee6 5327 when Attribute_Pred => Pred : declare
21d27997 5328 Etyp : constant Entity_Id := Base_Type (Ptyp);
70482933
RK		 5329
5330 begin
21d27997 5331
70482933
RK		 5332 -- For enumeration types with non-standard representations, we
5333 -- expand typ'Pred (x) into
5334
5335 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
5336
fbf5a39b
AC		 5337 -- If the representation is contiguous, we compute instead
5338 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
21d27997
RD		 5339 -- The conversion function Enum_Pos_To_Rep is defined on the
5340 -- base type, not the subtype, so we have to use the base type
5341 -- explicitly for this and other enumeration attributes.
fbf5a39b 5342
70482933 5343 if Is_Enumeration_Type (Ptyp)
21d27997 5344 and then Present (Enum_Pos_To_Rep (Etyp))
70482933 5345 then
21d27997 5346 if Has_Contiguous_Rep (Etyp) then
fbf5a39b
AC		 5347 Rewrite (N,
5348 Unchecked_Convert_To (Ptyp,
5349 Make_Op_Add (Loc,
5350 Left_Opnd =>
5351 Make_Integer_Literal (Loc,
5352 Enumeration_Rep (First_Literal (Ptyp))),
5353 Right_Opnd =>
5354 Make_Function_Call (Loc,
5355 Name =>
e4494292 5356 New_Occurrence_Of
21d27997 5357 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
fbf5a39b
AC		 5358
5359 Parameter_Associations =>
5360 New_List (
5361 Unchecked_Convert_To (Ptyp,
5362 Make_Op_Subtract (Loc,
5363 Left_Opnd =>
5364 Unchecked_Convert_To (Standard_Integer,
5365 Relocate_Node (First (Exprs))),
5366 Right_Opnd =>
5367 Make_Integer_Literal (Loc, 1))),
5368 Rep_To_Pos_Flag (Ptyp, Loc))))));
70482933 5369
fbf5a39b
AC		 5370 else
5371 -- Add Boolean parameter True, to request program errror if
5372 -- we have a bad representation on our hands. If checks are
5373 -- suppressed, then add False instead
70482933 5374
fbf5a39b
AC		 5375 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
5376 Rewrite (N,
5377 Make_Indexed_Component (Loc,
21d27997 5378 Prefix =>
e4494292 5379 New_Occurrence_Of
21d27997 5380 (Enum_Pos_To_Rep (Etyp), Loc),
fbf5a39b
AC		 5381 Expressions => New_List (
5382 Make_Op_Subtract (Loc,
70482933
RK		 5383 Left_Opnd =>
5384 Make_Function_Call (Loc,
5385 Name =>
e4494292 5386 New_Occurrence_Of
21d27997 5387 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
fbf5a39b 5388 Parameter_Associations => Exprs),
70482933 5389 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
fbf5a39b 5390 end if;
70482933
RK		 5391
5392 Analyze_And_Resolve (N, Typ);
5393
5394 -- For floating-point, we transform 'Pred into a call to the Pred
0083dd66 5395 -- floating-point attribute function in Fat_xxx (xxx is root type).
29049f0b 5396 -- Note that this function takes care of the overflow case.
70482933
RK		 5397
5398 elsif Is_Floating_Point_Type (Ptyp) then
5399 Expand_Fpt_Attribute_R (N);
5400 Analyze_And_Resolve (N, Typ);
5401
5402 -- For modular types, nothing to do (no overflow, since wraps)
5403
5404 elsif Is_Modular_Integer_Type (Ptyp) then
5405 null;
5406
d79e621a
GD		 5407 -- For other types, if argument is marked as needing a range check or
5408 -- overflow checking is enabled, we must generate a check.
70482933 5409
d79e621a
GD		 5410 elsif not Overflow_Checks_Suppressed (Ptyp)
5411 or else Do_Range_Check (First (Exprs))
5412 then
5413 Set_Do_Range_Check (First (Exprs), False);
aa9b151a 5414 Expand_Pred_Succ_Attribute (N);
70482933 5415 end if;
70482933
RK		 5416 end Pred;
5417
7ce611e2
ES		 5418 --------------
5419 -- Priority --
5420 --------------
5421
5422 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5423
5424 -- We rewrite X'Priority as the following run-time call:
5425
5426 -- Get_Ceiling (X._Object)
5427
5428 -- Note that although X'Priority is notionally an object, it is quite
5429 -- deliberately not defined as an aliased object in the RM. This means
5430 -- that it works fine to rewrite it as a call, without having to worry
5431 -- about complications that would other arise from X'Priority'Access,
5432 -- which is illegal, because of the lack of aliasing.
5433
d8f43ee6
HK		 5434 when Attribute_Priority => Priority : declare
5435 Call : Node_Id;
5436 Conctyp : Entity_Id;
5437 New_Itype : Entity_Id;
5438 Object_Parm : Node_Id;
5439 Subprg : Entity_Id;
5440 RT_Subprg_Name : Node_Id;
7ce611e2 5441
d8f43ee6
HK		 5442 begin
5443 -- Look for the enclosing concurrent type
7ce611e2 5444
d8f43ee6
HK		 5445 Conctyp := Current_Scope;
5446 while not Is_Concurrent_Type (Conctyp) loop
5447 Conctyp := Scope (Conctyp);
5448 end loop;
7ce611e2 5449
d8f43ee6 5450 pragma Assert (Is_Protected_Type (Conctyp));
7ce611e2 5451
d8f43ee6 5452 -- Generate the actual of the call
7ce611e2 5453
d8f43ee6
HK		 5454 Subprg := Current_Scope;
5455 while not Present (Protected_Body_Subprogram (Subprg)) loop
5456 Subprg := Scope (Subprg);
5457 end loop;
16f67b79 5458
d8f43ee6
HK		 5459 -- Use of 'Priority inside protected entries and barriers (in both
5460 -- cases the type of the first formal of their expanded subprogram
5461 -- is Address)
16f67b79 5462
d8f43ee6
HK		 5463 if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) =
5464 RTE (RE_Address)
5465 then
5466 -- In the expansion of protected entries the type of the first
5467 -- formal of the Protected_Body_Subprogram is an Address. In order
5468 -- to reference the _object component we generate:
16f67b79 5469
d8f43ee6
HK		 5470 -- type T is access p__ptTV;
5471 -- freeze T []
16f67b79 5472
d8f43ee6
HK		 5473 New_Itype := Create_Itype (E_Access_Type, N);
5474 Set_Etype (New_Itype, New_Itype);
5475 Set_Directly_Designated_Type (New_Itype,
5476 Corresponding_Record_Type (Conctyp));
5477 Freeze_Itype (New_Itype, N);
16f67b79 5478
d8f43ee6
HK		 5479 -- Generate:
5480 -- T!(O)._object'unchecked_access
16f67b79 5481
d8f43ee6
HK		 5482 Object_Parm :=
5483 Make_Attribute_Reference (Loc,
5484 Prefix =>
5485 Make_Selected_Component (Loc,
5486 Prefix =>
5487 Unchecked_Convert_To (New_Itype,
5488 New_Occurrence_Of
5489 (First_Entity (Protected_Body_Subprogram (Subprg)),
5490 Loc)),
5491 Selector_Name => Make_Identifier (Loc, Name_uObject)),
5492 Attribute_Name => Name_Unchecked_Access);
16f67b79 5493
d8f43ee6 5494 -- Use of 'Priority inside a protected subprogram
16f67b79 5495
d8f43ee6
HK		 5496 else
5497 Object_Parm :=
5498 Make_Attribute_Reference (Loc,
5499 Prefix =>
5500 Make_Selected_Component (Loc,
5501 Prefix =>
5502 New_Occurrence_Of
5503 (First_Entity (Protected_Body_Subprogram (Subprg)),
5504 Loc),
5505 Selector_Name => Make_Identifier (Loc, Name_uObject)),
5506 Attribute_Name => Name_Unchecked_Access);
5507 end if;
7ce611e2 5508
d8f43ee6 5509 -- Select the appropriate run-time subprogram
7ce611e2 5510
d8f43ee6
HK		 5511 if Number_Entries (Conctyp) = 0 then
5512 RT_Subprg_Name := New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc);
5513 else
5514 RT_Subprg_Name := New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc);
5515 end if;
7ce611e2 5516
d8f43ee6
HK		 5517 Call :=
5518 Make_Function_Call (Loc,
5519 Name => RT_Subprg_Name,
5520 Parameter_Associations => New_List (Object_Parm));
7ce611e2 5521
d8f43ee6 5522 Rewrite (N, Call);
16f67b79 5523
d8f43ee6
HK		 5524 -- Avoid the generation of extra checks on the pointer to the
5525 -- protected object.
16f67b79 5526
d8f43ee6
HK		 5527 Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
5528 end Priority;
7ce611e2 5529
70482933
RK		 5530 ------------------
5531 -- Range_Length --
5532 ------------------
5533
d8f43ee6 5534 when Attribute_Range_Length =>
47d3b920 5535
70482933
RK		 5536 -- The only special processing required is for the case where
5537 -- Range_Length is applied to an enumeration type with holes.
5538 -- In this case we transform
5539
5540 -- X'Range_Length
5541
5542 -- to
5543
5544 -- X'Pos (X'Last) - X'Pos (X'First) + 1
5545
5546 -- So that the result reflects the proper Pos values instead
5547 -- of the underlying representations.
5548
21d27997
RD		 5549 if Is_Enumeration_Type (Ptyp)
5550 and then Has_Non_Standard_Rep (Ptyp)
70482933
RK		 5551 then
5552 Rewrite (N,
5553 Make_Op_Add (Loc,
d8f43ee6 5554 Left_Opnd =>
70482933 5555 Make_Op_Subtract (Loc,
d8f43ee6 5556 Left_Opnd =>
70482933
RK		 5557 Make_Attribute_Reference (Loc,
5558 Attribute_Name => Name_Pos,
d8f43ee6
HK		 5559 Prefix => New_Occurrence_Of (Ptyp, Loc),
5560 Expressions => New_List (
70482933
RK		 5561 Make_Attribute_Reference (Loc,
5562 Attribute_Name => Name_Last,
d8f43ee6
HK		 5563 Prefix =>
5564 New_Occurrence_Of (Ptyp, Loc)))),
70482933
RK		 5565
5566 Right_Opnd =>
5567 Make_Attribute_Reference (Loc,
5568 Attribute_Name => Name_Pos,
d8f43ee6
HK		 5569 Prefix => New_Occurrence_Of (Ptyp, Loc),
5570 Expressions => New_List (
70482933
RK		 5571 Make_Attribute_Reference (Loc,
5572 Attribute_Name => Name_First,
d8f43ee6
HK		 5573 Prefix =>
5574 New_Occurrence_Of (Ptyp, Loc))))),
70482933 5575
49d140bb 5576 Right_Opnd => Make_Integer_Literal (Loc, 1)));
70482933
RK		 5577
5578 Analyze_And_Resolve (N, Typ);
5579
21d27997
RD		 5580 -- For all other cases, the attribute is handled by the back end, but
5581 -- we need to deal with the case of the range check on a universal
5582 -- integer.
70482933
RK		 5583
5584 else
5585 Apply_Universal_Integer_Attribute_Checks (N);
5586 end if;
70482933
RK		 5587
5588 ----------
5589 -- Read --
5590 ----------
5591
5592 when Attribute_Read => Read : declare
5593 P_Type : constant Entity_Id := Entity (Pref);
5594 B_Type : constant Entity_Id := Base_Type (P_Type);
5595 U_Type : constant Entity_Id := Underlying_Type (P_Type);
5596 Pname : Entity_Id;
5597 Decl : Node_Id;
5598 Prag : Node_Id;
5599 Arg2 : Node_Id;
5600 Rfunc : Node_Id;
5601 Lhs : Node_Id;
5602 Rhs : Node_Id;
5603
5604 begin
5605 -- If no underlying type, we have an error that will be diagnosed
5606 -- elsewhere, so here we just completely ignore the expansion.
5607
5608 if No (U_Type) then
5609 return;
5610 end if;
5611
baa571ab
AC		 5612 -- Stream operations can appear in user code even if the restriction
5613 -- No_Streams is active (for example, when instantiating a predefined
5614 -- container). In that case rewrite the attribute as a Raise to
5615 -- prevent any run-time use.
5616
5617 if Restriction_Active (No_Streams) then
5618 Rewrite (N,
5619 Make_Raise_Program_Error (Sloc (N),
b8b2d982 5620 Reason => PE_Stream_Operation_Not_Allowed));
baa571ab
AC		 5621 Set_Etype (N, B_Type);
5622 return;
5623 end if;
5624
70482933
RK		 5625 -- The simple case, if there is a TSS for Read, just call it
5626
fbf5a39b 5627 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
70482933
RK		 5628
5629 if Present (Pname) then
5630 null;
5631
5632 else
5633 -- If there is a Stream_Convert pragma, use it, we rewrite
5634
5635 -- sourcetyp'Read (stream, Item)
5636
5637 -- as
5638
5639 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
5640
758c442c
GD		 5641 -- where strmread is the given Read function that converts an
5642 -- argument of type strmtyp to type sourcetyp or a type from which
5643 -- it is derived. The conversion to sourcetyp is required in the
5644 -- latter case.
70482933
RK		 5645
5646 -- A special case arises if Item is a type conversion in which
5647 -- case, we have to expand to:
5648
5649 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
5650
5651 -- where Itemx is the expression of the type conversion (i.e.
5652 -- the actual object), and typex is the type of Itemx.
5653
1d571f3b 5654 Prag := Get_Stream_Convert_Pragma (P_Type);
70482933
RK		 5655
5656 if Present (Prag) then
5657 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
5658 Rfunc := Entity (Expression (Arg2));
5659 Lhs := Relocate_Node (Next (First (Exprs)));
5660 Rhs :=
31104818 5661 OK_Convert_To (B_Type,
70482933
RK		 5662 Make_Function_Call (Loc,
5663 Name => New_Occurrence_Of (Rfunc, Loc),
5664 Parameter_Associations => New_List (
5665 Make_Attribute_Reference (Loc,
5666 Prefix =>
5667 New_Occurrence_Of
5668 (Etype (First_Formal (Rfunc)), Loc),
5669 Attribute_Name => Name_Input,
5670 Expressions => New_List (
5671 Relocate_Node (First (Exprs)))))));
5672
5673 if Nkind (Lhs) = N_Type_Conversion then
5674 Lhs := Expression (Lhs);
5675 Rhs := Convert_To (Etype (Lhs), Rhs);
5676 end if;
5677
5678 Rewrite (N,
5679 Make_Assignment_Statement (Loc,
fbf5a39b 5680 Name => Lhs,
70482933
RK		 5681 Expression => Rhs));
5682 Set_Assignment_OK (Lhs);
5683 Analyze (N);
5684 return;
5685
5686 -- For elementary types, we call the I_xxx routine using the first
5687 -- parameter and then assign the result into the second parameter.
5688 -- We set Assignment_OK to deal with the conversion case.
5689
5690 elsif Is_Elementary_Type (U_Type) then
5691 declare
5692 Lhs : Node_Id;
5693 Rhs : Node_Id;
5694
5695 begin
5696 Lhs := Relocate_Node (Next (First (Exprs)));
5697 Rhs := Build_Elementary_Input_Call (N);
5698
5699 if Nkind (Lhs) = N_Type_Conversion then
5700 Lhs := Expression (Lhs);
5701 Rhs := Convert_To (Etype (Lhs), Rhs);
5702 end if;
5703
5704 Set_Assignment_OK (Lhs);
5705
5706 Rewrite (N,
5707 Make_Assignment_Statement (Loc,
49d140bb 5708 Name => Lhs,
70482933
RK		 5709 Expression => Rhs));
5710
5711 Analyze (N);
5712 return;
5713 end;
5714
5715 -- Array type case
5716
5717 elsif Is_Array_Type (U_Type) then
5718 Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
5719 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
5720
5721 -- Tagged type case, use the primitive Read function. Note that
5722 -- this will dispatch in the class-wide case which is what we want
5723
5724 elsif Is_Tagged_Type (U_Type) then
fbf5a39b 5725 Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
70482933 5726
758c442c
GD		 5727 -- All other record type cases, including protected records. The
5728 -- latter only arise for expander generated code for handling
5729 -- shared passive partition access.
70482933
RK		 5730
5731 else
5732 pragma Assert
5733 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
5734
5d09245e
AC		 5735 -- Ada 2005 (AI-216): Program_Error is raised when executing
5736 -- the default implementation of the Read attribute of an
1f70c47f
AC		 5737 -- Unchecked_Union type. We replace the attribute with a
5738 -- raise statement (rather than inserting it before) to handle
5739 -- properly the case of an unchecked union that is a record
5740 -- component.
5d09245e
AC		 5741
5742 if Is_Unchecked_Union (Base_Type (U_Type)) then
1f70c47f 5743 Rewrite (N,
5d09245e
AC		 5744 Make_Raise_Program_Error (Loc,
5745 Reason => PE_Unchecked_Union_Restriction));
1f70c47f
AC		 5746 Set_Etype (N, B_Type);
5747 return;
5d09245e
AC		 5748 end if;
5749
70482933
RK		 5750 if Has_Discriminants (U_Type)
5751 and then Present
5752 (Discriminant_Default_Value (First_Discriminant (U_Type)))
5753 then
5754 Build_Mutable_Record_Read_Procedure
96d2756f 5755 (Loc, Full_Base (U_Type), Decl, Pname);
70482933
RK		 5756 else
5757 Build_Record_Read_Procedure
96d2756f 5758 (Loc, Full_Base (U_Type), Decl, Pname);
70482933
RK		 5759 end if;
5760
5761 -- Suppress checks, uninitialized or otherwise invalid
5762 -- data does not cause constraint errors to be raised for
5763 -- a complete record read.
5764
5765 Insert_Action (N, Decl, All_Checks);
5766 end if;
5767 end if;
5768
5769 Rewrite_Stream_Proc_Call (Pname);
5770 end Read;
5771
1b0b0f18
AC		 5772 ---------
5773 -- Ref --
5774 ---------
5775
5776 -- Ref is identical to To_Address, see To_Address for processing
5777
70482933
RK		 5778 ---------------
5779 -- Remainder --
5780 ---------------
5781
5782 -- Transforms 'Remainder into a call to the floating-point attribute
5783 -- function Remainder in Fat_xxx (where xxx is the root type)
5784
5785 when Attribute_Remainder =>
5786 Expand_Fpt_Attribute_RR (N);
5787
21d27997
RD		 5788 ------------
5789 -- Result --
5790 ------------
5791
5792 -- Transform 'Result into reference to _Result formal. At the point
5793 -- where a legal 'Result attribute is expanded, we know that we are in
5794 -- the context of a _Postcondition function with a _Result parameter.
5795
5796 when Attribute_Result =>
49d140bb 5797 Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult));
21d27997
RD		 5798 Analyze_And_Resolve (N, Typ);
5799
70482933
RK		 5800 -----------
5801 -- Round --
5802 -----------
5803
758c442c
GD		 5804 -- The handling of the Round attribute is quite delicate. The processing
5805 -- in Sem_Attr introduced a conversion to universal real, reflecting the
5806 -- semantics of Round, but we do not want anything to do with universal
5807 -- real at runtime, since this corresponds to using floating-point
5808 -- arithmetic.
5809
5810 -- What we have now is that the Etype of the Round attribute correctly
5811 -- indicates the final result type. The operand of the Round is the
5812 -- conversion to universal real, described above, and the operand of
5813 -- this conversion is the actual operand of Round, which may be the
5814 -- special case of a fixed point multiplication or division (Etype =
5815 -- universal fixed)
5816
5817 -- The exapander will expand first the operand of the conversion, then
5818 -- the conversion, and finally the round attribute itself, since we
5819 -- always work inside out. But we cannot simply process naively in this
5820 -- order. In the semantic world where universal fixed and real really
5821 -- exist and have infinite precision, there is no problem, but in the
5822 -- implementation world, where universal real is a floating-point type,
5823 -- we would get the wrong result.
5824
5825 -- So the approach is as follows. First, when expanding a multiply or
5826 -- divide whose type is universal fixed, we do nothing at all, instead
5827 -- deferring the operation till later.
70482933
RK		 5828
5829 -- The actual processing is done in Expand_N_Type_Conversion which
758c442c
GD		 5830 -- handles the special case of Round by looking at its parent to see if
5831 -- it is a Round attribute, and if it is, handling the conversion (or
5832 -- its fixed multiply/divide child) in an appropriate manner.
70482933
RK		 5833
5834 -- This means that by the time we get to expanding the Round attribute
5835 -- itself, the Round is nothing more than a type conversion (and will
5836 -- often be a null type conversion), so we just replace it with the
5837 -- appropriate conversion operation.
5838
5839 when Attribute_Round =>
5840 Rewrite (N,
5841 Convert_To (Etype (N), Relocate_Node (First (Exprs))));
5842 Analyze_And_Resolve (N);
5843
5844 --------------
5845 -- Rounding --
5846 --------------
5847
5848 -- Transforms 'Rounding into a call to the floating-point attribute
5849 -- function Rounding in Fat_xxx (where xxx is the root type)
24228312 5850 -- Expansion is avoided for cases the back end can handle directly.
70482933
RK		 5851
5852 when Attribute_Rounding =>
24228312
AC		 5853 if not Is_Inline_Floating_Point_Attribute (N) then
5854 Expand_Fpt_Attribute_R (N);
5855 end if;
70482933
RK		 5856
5857 -------------
5858 -- Scaling --
5859 -------------
5860
5861 -- Transforms 'Scaling into a call to the floating-point attribute
5862 -- function Scaling in Fat_xxx (where xxx is the root type)
5863
5864 when Attribute_Scaling =>
5865 Expand_Fpt_Attribute_RI (N);
5866
a8551b5f
AC		 5867 -------------------------
5868 -- Simple_Storage_Pool --
5869 -------------------------
5870
5871 when Attribute_Simple_Storage_Pool =>
5872 Rewrite (N,
5873 Make_Type_Conversion (Loc,
e4494292
RD		 5874 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
5875 Expression => New_Occurrence_Of (Entity (N), Loc)));
a8551b5f
AC		 5876 Analyze_And_Resolve (N, Typ);
5877
70482933
RK		 5878 ----------
5879 -- Size --
5880 ----------
5881
d8f43ee6
HK		 5882 when Attribute_Object_Size
5883 | Attribute_Size
5884 | Attribute_Value_Size
5885 | Attribute_VADS_Size
5886 =>
5887 Size : declare
5888 Siz : Uint;
5889 New_Node : Node_Id;
70482933 5890
d8f43ee6
HK		 5891 begin
5892 -- Processing for VADS_Size case. Note that this processing
5893 -- removes all traces of VADS_Size from the tree, and completes
5894 -- all required processing for VADS_Size by translating the
5895 -- attribute reference to an appropriate Size or Object_Size
5896 -- reference.
5897
5898 if Id = Attribute_VADS_Size
5899 or else (Use_VADS_Size and then Id = Attribute_Size)
70482933 5900 then
d8f43ee6
HK		 5901 -- If the size is specified, then we simply use the specified
5902 -- size. This applies to both types and objects. The size of an
5903 -- object can be specified in the following ways:
5904
5905 -- An explicit size object is given for an object
5906 -- A component size is specified for an indexed component
5907 -- A component clause is specified for a selected component
5908 -- The object is a component of a packed composite object
5909
5910 -- If the size is specified, then VADS_Size of an object
5911
5912 if (Is_Entity_Name (Pref)
5913 and then Present (Size_Clause (Entity (Pref))))
5914 or else
5915 (Nkind (Pref) = N_Component_Clause
5916 and then (Present (Component_Clause
5917 (Entity (Selector_Name (Pref))))
5918 or else Is_Packed (Etype (Prefix (Pref)))))
5919 or else
5920 (Nkind (Pref) = N_Indexed_Component
5921 and then (Component_Size (Etype (Prefix (Pref))) /= 0
5922 or else Is_Packed (Etype (Prefix (Pref)))))
5923 then
5924 Set_Attribute_Name (N, Name_Size);
70482933 5925
d8f43ee6
HK		 5926 -- Otherwise if we have an object rather than a type, then
5927 -- the VADS_Size attribute applies to the type of the object,
5928 -- rather than the object itself. This is one of the respects
5929 -- in which VADS_Size differs from Size.
70482933 5930
d8f43ee6
HK		 5931 else
5932 if (not Is_Entity_Name (Pref)
5933 or else not Is_Type (Entity (Pref)))
5934 and then (Is_Scalar_Type (Ptyp)
5935 or else Is_Constrained (Ptyp))
5936 then
5937 Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
5938 end if;
70482933 5939
d8f43ee6
HK		 5940 -- For a scalar type for which no size was explicitly given,
5941 -- VADS_Size means Object_Size. This is the other respect in
5942 -- which VADS_Size differs from Size.
70482933 5943
d8f43ee6
HK		 5944 if Is_Scalar_Type (Ptyp)
5945 and then No (Size_Clause (Ptyp))
5946 then
5947 Set_Attribute_Name (N, Name_Object_Size);
70482933 5948
d8f43ee6 5949 -- In all other cases, Size and VADS_Size are the sane
70482933 5950
d8f43ee6
HK		 5951 else
5952 Set_Attribute_Name (N, Name_Size);
5953 end if;
70482933
RK		 5954 end if;
5955 end if;
70482933 5956
d8f43ee6
HK		 5957 -- If the prefix is X'Class, transform it into a direct reference
5958 -- to the class-wide type, because the back end must not see a
5959 -- 'Class reference.
70482933 5960
d8f43ee6
HK		 5961 if Is_Entity_Name (Pref)
5962 and then Is_Class_Wide_Type (Entity (Pref))
5963 then
5964 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
5965 return;
fbf5a39b 5966
d8f43ee6
HK		 5967 -- For X'Size applied to an object of a class-wide type, transform
5968 -- X'Size into a call to the primitive operation _Size applied to
5969 -- X.
fbf5a39b 5970
d8f43ee6 5971 elsif Is_Class_Wide_Type (Ptyp) then
e23e04db 5972
d8f43ee6
HK		 5973 -- No need to do anything else compiling under restriction
5974 -- No_Dispatching_Calls. During the semantic analysis we
5975 -- already noted this restriction violation.
0669bebe 5976
d8f43ee6
HK		 5977 if Restriction_Active (No_Dispatching_Calls) then
5978 return;
5979 end if;
0669bebe 5980
d8f43ee6
HK		 5981 New_Node :=
5982 Make_Function_Call (Loc,
5983 Name =>
5984 New_Occurrence_Of (Find_Prim_Op (Ptyp, Name_uSize), Loc),
5985 Parameter_Associations => New_List (Pref));
70482933 5986
d8f43ee6 5987 if Typ /= Standard_Long_Long_Integer then
70482933 5988
d8f43ee6
HK		 5989 -- The context is a specific integer type with which the
5990 -- original attribute was compatible. The function has a
5991 -- specific type as well, so to preserve the compatibility
5992 -- we must convert explicitly.
70482933 5993
d8f43ee6
HK		 5994 New_Node := Convert_To (Typ, New_Node);
5995 end if;
70482933 5996
d8f43ee6
HK		 5997 Rewrite (N, New_Node);
5998 Analyze_And_Resolve (N, Typ);
5999 return;
31104818 6000
d8f43ee6 6001 -- Case of known RM_Size of a type
31104818 6002
d8f43ee6
HK		 6003 elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
6004 and then Is_Entity_Name (Pref)
6005 and then Is_Type (Entity (Pref))
6006 and then Known_Static_RM_Size (Entity (Pref))
6007 then
6008 Siz := RM_Size (Entity (Pref));
31104818 6009
d8f43ee6 6010 -- Case of known Esize of a type
31104818 6011
d8f43ee6
HK		 6012 elsif Id = Attribute_Object_Size
6013 and then Is_Entity_Name (Pref)
6014 and then Is_Type (Entity (Pref))
6015 and then Known_Static_Esize (Entity (Pref))
6016 then
6017 Siz := Esize (Entity (Pref));
31104818 6018
d8f43ee6 6019 -- Case of known size of object
31104818 6020
d8f43ee6
HK		 6021 elsif Id = Attribute_Size
6022 and then Is_Entity_Name (Pref)
6023 and then Is_Object (Entity (Pref))
6024 and then Known_Esize (Entity (Pref))
6025 and then Known_Static_Esize (Entity (Pref))
6026 then
6027 Siz := Esize (Entity (Pref));
70482933 6028
d8f43ee6
HK		 6029 -- For an array component, we can do Size in the front end if the
6030 -- component_size of the array is set.
70482933 6031
d8f43ee6
HK		 6032 elsif Nkind (Pref) = N_Indexed_Component then
6033 Siz := Component_Size (Etype (Prefix (Pref)));
70482933 6034
d8f43ee6
HK		 6035 -- For a record component, we can do Size in the front end if
6036 -- there is a component clause, or if the record is packed and the
6037 -- component's size is known at compile time.
70482933 6038
d8f43ee6
HK		 6039 elsif Nkind (Pref) = N_Selected_Component then
6040 declare
6041 Rec : constant Entity_Id := Etype (Prefix (Pref));
6042 Comp : constant Entity_Id := Entity (Selector_Name (Pref));
70482933 6043
d8f43ee6
HK		 6044 begin
6045 if Present (Component_Clause (Comp)) then
6046 Siz := Esize (Comp);
70482933 6047
d8f43ee6
HK		 6048 elsif Is_Packed (Rec) then
6049 Siz := RM_Size (Ptyp);
70482933 6050
d8f43ee6
HK		 6051 else
6052 Apply_Universal_Integer_Attribute_Checks (N);
6053 return;
6054 end if;
6055 end;
70482933 6056
d8f43ee6 6057 -- All other cases are handled by the back end
70482933 6058
d8f43ee6
HK		 6059 else
6060 Apply_Universal_Integer_Attribute_Checks (N);
70482933 6061
d8f43ee6
HK		 6062 -- If Size is applied to a formal parameter that is of a packed
6063 -- array subtype, then apply Size to the actual subtype.
70482933 6064
d8f43ee6
HK		 6065 if Is_Entity_Name (Pref)
6066 and then Is_Formal (Entity (Pref))
6067 and then Is_Array_Type (Ptyp)
6068 and then Is_Packed (Ptyp)
6069 then
6070 Rewrite (N,
6071 Make_Attribute_Reference (Loc,
6072 Prefix =>
6073 New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
6074 Attribute_Name => Name_Size));
6075 Analyze_And_Resolve (N, Typ);
6076 end if;
70482933 6077
d8f43ee6
HK		 6078 -- If Size applies to a dereference of an access to
6079 -- unconstrained packed array, the back end needs to see its
6080 -- unconstrained nominal type, but also a hint to the actual
6081 -- constrained type.
65f01153 6082
d8f43ee6
HK		 6083 if Nkind (Pref) = N_Explicit_Dereference
6084 and then Is_Array_Type (Ptyp)
6085 and then not Is_Constrained (Ptyp)
6086 and then Is_Packed (Ptyp)
6087 then
6088 Set_Actual_Designated_Subtype (Pref,
6089 Get_Actual_Subtype (Pref));
6090 end if;
65f01153 6091
d8f43ee6
HK		 6092 return;
6093 end if;
70482933 6094
d8f43ee6 6095 -- Common processing for record and array component case
70482933 6096
d8f43ee6
HK		 6097 if Siz /= No_Uint and then Siz /= 0 then
6098 declare
6099 CS : constant Boolean := Comes_From_Source (N);
70482933 6100
d8f43ee6
HK		 6101 begin
6102 Rewrite (N, Make_Integer_Literal (Loc, Siz));
cf284c75 6103
d8f43ee6
HK		 6104 -- This integer literal is not a static expression. We do
6105 -- not call Analyze_And_Resolve here, because this would
6106 -- activate the circuit for deciding that a static value
6107 -- was out of range, and we don't want that.
70482933 6108
d8f43ee6
HK		 6109 -- So just manually set the type, mark the expression as
6110 -- non-static, and then ensure that the result is checked
6111 -- properly if the attribute comes from source (if it was
6112 -- internally generated, we never need a constraint check).
70482933 6113
d8f43ee6
HK		 6114 Set_Etype (N, Typ);
6115 Set_Is_Static_Expression (N, False);
cf284c75 6116
d8f43ee6
HK		 6117 if CS then
6118 Apply_Constraint_Check (N, Typ);
6119 end if;
6120 end;
6121 end if;
6122 end Size;
70482933
RK		 6123
6124 ------------------
6125 -- Storage_Pool --
6126 ------------------
6127
6128 when Attribute_Storage_Pool =>
6129 Rewrite (N,
6130 Make_Type_Conversion (Loc,
e4494292
RD		 6131 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
6132 Expression => New_Occurrence_Of (Entity (N), Loc)));
70482933
RK		 6133 Analyze_And_Resolve (N, Typ);
6134
6135 ------------------
6136 -- Storage_Size --
6137 ------------------
6138
a8551b5f
AC		 6139 when Attribute_Storage_Size => Storage_Size : declare
6140 Alloc_Op : Entity_Id := Empty;
6141
6142 begin
70482933 6143
70482933
RK		 6144 -- Access type case, always go to the root type
6145
6146 -- The case of access types results in a value of zero for the case
6147 -- where no storage size attribute clause has been given. If a
6148 -- storage size has been given, then the attribute is converted
6149 -- to a reference to the variable used to hold this value.
6150
6151 if Is_Access_Type (Ptyp) then
6152 if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
6153 Rewrite (N,
6154 Make_Attribute_Reference (Loc,
e4494292 6155 Prefix => New_Occurrence_Of (Typ, Loc),
70482933
RK		 6156 Attribute_Name => Name_Max,
6157 Expressions => New_List (
6158 Make_Integer_Literal (Loc, 0),
6159 Convert_To (Typ,
e4494292 6160 New_Occurrence_Of
70482933
RK		 6161 (Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
6162
6163 elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
7ce611e2 6164
a8551b5f
AC		 6165 -- If the access type is associated with a simple storage pool
6166 -- object, then attempt to locate the optional Storage_Size
6167 -- function of the simple storage pool type. If not found,
6168 -- then the result will default to zero.
6169
6170 if Present (Get_Rep_Pragma (Root_Type (Ptyp),
f6205414 6171 Name_Simple_Storage_Pool_Type))
a8551b5f
AC		 6172 then
6173 declare
6174 Pool_Type : constant Entity_Id :=
6175 Base_Type (Etype (Entity (N)));
6176
6177 begin
6178 Alloc_Op := Get_Name_Entity_Id (Name_Storage_Size);
6179 while Present (Alloc_Op) loop
6180 if Scope (Alloc_Op) = Scope (Pool_Type)
6181 and then Present (First_Formal (Alloc_Op))
6182 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
6183 then
6184 exit;
6185 end if;
6186
6187 Alloc_Op := Homonym (Alloc_Op);
6188 end loop;
6189 end;
6190
6191 -- In the normal Storage_Pool case, retrieve the primitive
6192 -- function associated with the pool type.
6193
6194 else
6195 Alloc_Op :=
6196 Find_Prim_Op
6197 (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
6198 Attribute_Name (N));
6199 end if;
6200
6201 -- If Storage_Size wasn't found (can only occur in the simple
6202 -- storage pool case), then simply use zero for the result.
6203
6204 if not Present (Alloc_Op) then
6205 Rewrite (N, Make_Integer_Literal (Loc, 0));
6206
6207 -- Otherwise, rewrite the allocator as a call to pool type's
6208 -- Storage_Size function.
6209
6210 else
6211 Rewrite (N,
6212 OK_Convert_To (Typ,
6213 Make_Function_Call (Loc,
6214 Name =>
e4494292 6215 New_Occurrence_Of (Alloc_Op, Loc),
a8551b5f
AC		 6216
6217 Parameter_Associations => New_List (
e4494292 6218 New_Occurrence_Of
a8551b5f
AC		 6219 (Associated_Storage_Pool
6220 (Root_Type (Ptyp)), Loc)))));
6221 end if;
70482933 6222
70482933
RK		 6223 else
6224 Rewrite (N, Make_Integer_Literal (Loc, 0));
6225 end if;
6226
6227 Analyze_And_Resolve (N, Typ);
6228
7ce611e2
ES		 6229 -- For tasks, we retrieve the size directly from the TCB. The
6230 -- size may depend on a discriminant of the type, and therefore
6231 -- can be a per-object expression, so type-level information is
6232 -- not sufficient in general. There are four cases to consider:
70482933 6233
7ce611e2
ES		 6234 -- a) If the attribute appears within a task body, the designated
6235 -- TCB is obtained by a call to Self.
70482933 6236
7ce611e2
ES		 6237 -- b) If the prefix of the attribute is the name of a task object,
6238 -- the designated TCB is the one stored in the corresponding record.
70482933 6239
7ce611e2
ES		 6240 -- c) If the prefix is a task type, the size is obtained from the
6241 -- size variable created for each task type
70482933 6242
f145ece7 6243 -- d) If no Storage_Size was specified for the type, there is no
7ce611e2 6244 -- size variable, and the value is a system-specific default.
70482933
RK		 6245
6246 else
7ce611e2
ES		 6247 if In_Open_Scopes (Ptyp) then
6248
6249 -- Storage_Size (Self)
6250
70482933
RK		 6251 Rewrite (N,
6252 Convert_To (Typ,
6253 Make_Function_Call (Loc,
6254 Name =>
7ce611e2
ES		 6255 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
6256 Parameter_Associations =>
6257 New_List (
6258 Make_Function_Call (Loc,
6259 Name =>
e4494292 6260 New_Occurrence_Of (RTE (RE_Self), Loc))))));
70482933 6261
7ce611e2
ES		 6262 elsif not Is_Entity_Name (Pref)
6263 or else not Is_Type (Entity (Pref))
6264 then
6265 -- Storage_Size (Rec (Obj).Size)
6266
6267 Rewrite (N,
6268 Convert_To (Typ,
6269 Make_Function_Call (Loc,
6270 Name =>
6271 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
6272 Parameter_Associations =>
70482933
RK		 6273 New_List (
6274 Make_Selected_Component (Loc,
6275 Prefix =>
6276 Unchecked_Convert_To (
6277 Corresponding_Record_Type (Ptyp),
7ce611e2 6278 New_Copy_Tree (Pref)),
70482933 6279 Selector_Name =>
7ce611e2 6280 Make_Identifier (Loc, Name_uTask_Id))))));
70482933 6281
7ce611e2 6282 elsif Present (Storage_Size_Variable (Ptyp)) then
70482933 6283
f145ece7 6284 -- Static Storage_Size pragma given for type: retrieve value
7ce611e2 6285 -- from its allocated storage variable.
70482933 6286
7ce611e2
ES		 6287 Rewrite (N,
6288 Convert_To (Typ,
6289 Make_Function_Call (Loc,
6290 Name => New_Occurrence_Of (
6291 RTE (RE_Adjust_Storage_Size), Loc),
6292 Parameter_Associations =>
6293 New_List (
e4494292 6294 New_Occurrence_Of (
7ce611e2
ES		 6295 Storage_Size_Variable (Ptyp), Loc)))));
6296 else
6297 -- Get system default
6298
6299 Rewrite (N,
6300 Convert_To (Typ,
6301 Make_Function_Call (Loc,
6302 Name =>
6303 New_Occurrence_Of (
6304 RTE (RE_Default_Stack_Size), Loc))));
70482933 6305 end if;
7ce611e2
ES		 6306
6307 Analyze_And_Resolve (N, Typ);
70482933
RK		 6308 end if;
6309 end Storage_Size;
6310
82c80734
RD		 6311 -----------------
6312 -- Stream_Size --
6313 -----------------
6314
9eea4346
GB		 6315 when Attribute_Stream_Size =>
6316 Rewrite (N,
6317 Make_Integer_Literal (Loc, Intval => Get_Stream_Size (Ptyp)));
82c80734 6318 Analyze_And_Resolve (N, Typ);
82c80734 6319
70482933
RK		 6320 ----------
6321 -- Succ --
6322 ----------
6323
29049f0b
AC		 6324 -- 1. Deal with enumeration types with holes.
6325 -- 2. For floating-point, generate call to attribute function.
6326 -- 3. For other cases, deal with constraint checking.
70482933 6327
47d3b920 6328 when Attribute_Succ => Succ : declare
21d27997 6329 Etyp : constant Entity_Id := Base_Type (Ptyp);
70482933
RK		 6330
6331 begin
6332 -- For enumeration types with non-standard representations, we
6333 -- expand typ'Succ (x) into
6334
6335 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
6336
fbf5a39b
AC		 6337 -- If the representation is contiguous, we compute instead
6338 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
6339
70482933 6340 if Is_Enumeration_Type (Ptyp)
21d27997 6341 and then Present (Enum_Pos_To_Rep (Etyp))
70482933 6342 then
21d27997 6343 if Has_Contiguous_Rep (Etyp) then
fbf5a39b
AC		 6344 Rewrite (N,
6345 Unchecked_Convert_To (Ptyp,
6346 Make_Op_Add (Loc,
6347 Left_Opnd =>
6348 Make_Integer_Literal (Loc,
6349 Enumeration_Rep (First_Literal (Ptyp))),
6350 Right_Opnd =>
6351 Make_Function_Call (Loc,
6352 Name =>
e4494292 6353 New_Occurrence_Of
21d27997 6354 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
fbf5a39b
AC		 6355
6356 Parameter_Associations =>
6357 New_List (
6358 Unchecked_Convert_To (Ptyp,
6359 Make_Op_Add (Loc,
6360 Left_Opnd =>
6361 Unchecked_Convert_To (Standard_Integer,
6362 Relocate_Node (First (Exprs))),
6363 Right_Opnd =>
6364 Make_Integer_Literal (Loc, 1))),
6365 Rep_To_Pos_Flag (Ptyp, Loc))))));
6366 else
6367 -- Add Boolean parameter True, to request program errror if
6368 -- we have a bad representation on our hands. Add False if
6369 -- checks are suppressed.
70482933 6370
fbf5a39b
AC		 6371 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
6372 Rewrite (N,
6373 Make_Indexed_Component (Loc,
21d27997 6374 Prefix =>
e4494292 6375 New_Occurrence_Of
21d27997 6376 (Enum_Pos_To_Rep (Etyp), Loc),
fbf5a39b
AC		 6377 Expressions => New_List (
6378 Make_Op_Add (Loc,
6379 Left_Opnd =>
6380 Make_Function_Call (Loc,
6381 Name =>
e4494292 6382 New_Occurrence_Of
21d27997 6383 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
fbf5a39b
AC		 6384 Parameter_Associations => Exprs),
6385 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
6386 end if;
70482933
RK		 6387
6388 Analyze_And_Resolve (N, Typ);
6389
6390 -- For floating-point, we transform 'Succ into a call to the Succ
6391 -- floating-point attribute function in Fat_xxx (xxx is root type)
6392
6393 elsif Is_Floating_Point_Type (Ptyp) then
6394 Expand_Fpt_Attribute_R (N);
6395 Analyze_And_Resolve (N, Typ);
6396
6397 -- For modular types, nothing to do (no overflow, since wraps)
6398
6399 elsif Is_Modular_Integer_Type (Ptyp) then
6400 null;
6401
d79e621a
GD		 6402 -- For other types, if argument is marked as needing a range check or
6403 -- overflow checking is enabled, we must generate a check.
70482933 6404
d79e621a
GD		 6405 elsif not Overflow_Checks_Suppressed (Ptyp)
6406 or else Do_Range_Check (First (Exprs))
6407 then
6408 Set_Do_Range_Check (First (Exprs), False);
aa9b151a 6409 Expand_Pred_Succ_Attribute (N);
70482933
RK		 6410 end if;
6411 end Succ;
6412
6413 ---------
6414 -- Tag --
6415 ---------
6416
6417 -- Transforms X'Tag into a direct reference to the tag of X
6418
47d3b920 6419 when Attribute_Tag => Tag : declare
70482933
RK		 6420 Ttyp : Entity_Id;
6421 Prefix_Is_Type : Boolean;
6422
6423 begin
6424 if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then
6425 Ttyp := Entity (Pref);
6426 Prefix_Is_Type := True;
6427 else
21d27997 6428 Ttyp := Ptyp;
70482933
RK		 6429 Prefix_Is_Type := False;
6430 end if;
6431
6432 if Is_Class_Wide_Type (Ttyp) then
6433 Ttyp := Root_Type (Ttyp);
6434 end if;
6435
6436 Ttyp := Underlying_Type (Ttyp);
6437
8a78c50d
AC		 6438 -- Ada 2005: The type may be a synchronized tagged type, in which
6439 -- case the tag information is stored in the corresponding record.
6440
6441 if Is_Concurrent_Type (Ttyp) then
6442 Ttyp := Corresponding_Record_Type (Ttyp);
6443 end if;
6444
70482933 6445 if Prefix_Is_Type then
3a77b68d 6446
31104818 6447 -- For VMs we leave the type attribute unexpanded because
3a77b68d
GB		 6448 -- there's not a dispatching table to reference.
6449
1f110335 6450 if Tagged_Type_Expansion then
3a77b68d
GB		 6451 Rewrite (N,
6452 Unchecked_Convert_To (RTE (RE_Tag),
e4494292 6453 New_Occurrence_Of
a9d8907c 6454 (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc)));
3a77b68d
GB		 6455 Analyze_And_Resolve (N, RTE (RE_Tag));
6456 end if;
70482933 6457
934a3a25 6458 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
31104818
HK		 6459 -- references the primary tag of the actual object. If 'Tag is
6460 -- applied to class-wide interface objects we generate code that
6461 -- displaces "this" to reference the base of the object.
6462
6463 elsif Comes_From_Source (N)
6464 and then Is_Class_Wide_Type (Etype (Prefix (N)))
63a5b3dc 6465 and then Is_Interface (Underlying_Type (Etype (Prefix (N))))
31104818
HK		 6466 then
6467 -- Generate:
6468 -- (To_Tag_Ptr (Prefix'Address)).all
6469
6470 -- Note that Prefix'Address is recursively expanded into a call
6471 -- to Base_Address (Obj.Tag)
6472
470cd9e9
RD		 6473 -- Not needed for VM targets, since all handled by the VM
6474
1f110335 6475 if Tagged_Type_Expansion then
470cd9e9
RD		 6476 Rewrite (N,
6477 Make_Explicit_Dereference (Loc,
6478 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6479 Make_Attribute_Reference (Loc,
6480 Prefix => Relocate_Node (Pref),
6481 Attribute_Name => Name_Address))));
6482 Analyze_And_Resolve (N, RTE (RE_Tag));
6483 end if;
31104818 6484
70482933
RK		 6485 else
6486 Rewrite (N,
6487 Make_Selected_Component (Loc,
6488 Prefix => Relocate_Node (Pref),
6489 Selector_Name =>
e4494292 6490 New_Occurrence_Of (First_Tag_Component (Ttyp), Loc)));
3a77b68d 6491 Analyze_And_Resolve (N, RTE (RE_Tag));
70482933 6492 end if;
70482933
RK		 6493 end Tag;
6494
6495 ----------------
6496 -- Terminated --
6497 ----------------
6498
758c442c 6499 -- Transforms 'Terminated attribute into a call to Terminated function
70482933 6500
d8f43ee6
HK		 6501 when Attribute_Terminated => Terminated : begin
6502
65f01153
RD		 6503 -- The prefix of Terminated is of a task interface class-wide type.
6504 -- Generate:
31e358e1 6505 -- terminated (Task_Id (_disp_get_task_id (Pref)));
65f01153 6506
0791fbe9 6507 if Ada_Version >= Ada_2005
21d27997
RD		 6508 and then Ekind (Ptyp) = E_Class_Wide_Type
6509 and then Is_Interface (Ptyp)
6510 and then Is_Task_Interface (Ptyp)
65f01153 6511 then
99bba92c
AC		 6512 Rewrite (N,
6513 Make_Function_Call (Loc,
c0e938d0 6514 Name =>
99bba92c
AC		 6515 New_Occurrence_Of (RTE (RE_Terminated), Loc),
6516 Parameter_Associations => New_List (
6517 Make_Unchecked_Type_Conversion (Loc,
6518 Subtype_Mark =>
6519 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
c0e938d0 6520 Expression => Build_Disp_Get_Task_Id_Call (Pref)))));
65f01153
RD		 6521
6522 elsif Restricted_Profile then
70482933
RK		 6523 Rewrite (N,
6524 Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
6525
6526 else
6527 Rewrite (N,
6528 Build_Call_With_Task (Pref, RTE (RE_Terminated)));
6529 end if;
6530
6531 Analyze_And_Resolve (N, Standard_Boolean);
6532 end Terminated;
6533
6534 ----------------
6535 -- To_Address --
6536 ----------------
6537
1b0b0f18 6538 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
1e3c434f
BD		 6539 -- unchecked conversion from (integral) type of X to type address. If
6540 -- the To_Address is a static expression, the transformed expression
6541 -- also needs to be static, because we do some legality checks (e.g.
6542 -- for Thread_Local_Storage) after this transformation.
70482933 6543
89beb653
HK		 6544 when Attribute_Ref
6545 | Attribute_To_Address
6546 =>
6547 To_Address : declare
6548 Is_Static : constant Boolean := Is_Static_Expression (N);
6549
6550 begin
6551 Rewrite (N,
6552 Unchecked_Convert_To (RTE (RE_Address),
6553 Relocate_Node (First (Exprs))));
6554 Set_Is_Static_Expression (N, Is_Static);
6555
6556 Analyze_And_Resolve (N, RTE (RE_Address));
6557 end To_Address;
70482933 6558
54838d1f
AC		 6559 ------------
6560 -- To_Any --
6561 ------------
6562
6563 when Attribute_To_Any => To_Any : declare
6564 P_Type : constant Entity_Id := Etype (Pref);
6565 Decls : constant List_Id := New_List;
6566 begin
6567 Rewrite (N,
6568 Build_To_Any_Call
30ebb114
AC		 6569 (Loc,
6570 Convert_To (P_Type,
54838d1f
AC		 6571 Relocate_Node (First (Exprs))), Decls));
6572 Insert_Actions (N, Decls);
6573 Analyze_And_Resolve (N, RTE (RE_Any));
6574 end To_Any;
6575
70482933
RK		 6576 ----------------
6577 -- Truncation --
6578 ----------------
6579
6580 -- Transforms 'Truncation into a call to the floating-point attribute
0669bebe
GB		 6581 -- function Truncation in Fat_xxx (where xxx is the root type).
6582 -- Expansion is avoided for cases the back end can handle directly.
70482933
RK		 6583
6584 when Attribute_Truncation =>
0669bebe
GB		 6585 if not Is_Inline_Floating_Point_Attribute (N) then
6586 Expand_Fpt_Attribute_R (N);
6587 end if;
70482933 6588
54838d1f
AC		 6589 --------------
6590 -- TypeCode --
6591 --------------
6592
6593 when Attribute_TypeCode => TypeCode : declare
6594 P_Type : constant Entity_Id := Etype (Pref);
6595 Decls : constant List_Id := New_List;
6596 begin
6597 Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls));
6598 Insert_Actions (N, Decls);
6599 Analyze_And_Resolve (N, RTE (RE_TypeCode));
6600 end TypeCode;
6601
70482933
RK		 6602 -----------------------
6603 -- Unbiased_Rounding --
6604 -----------------------
6605
6606 -- Transforms 'Unbiased_Rounding into a call to the floating-point
6607 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
0669bebe
GB		 6608 -- root type). Expansion is avoided for cases the back end can handle
6609 -- directly.
70482933
RK		 6610
6611 when Attribute_Unbiased_Rounding =>
0669bebe
GB		 6612 if not Is_Inline_Floating_Point_Attribute (N) then
6613 Expand_Fpt_Attribute_R (N);
6614 end if;
70482933 6615
18a2ad5d
AC		 6616 ------------
6617 -- Update --
6618 ------------
6619
6620 when Attribute_Update =>
6621 Expand_Update_Attribute (N);
6622
70482933
RK		 6623 ---------------
6624 -- VADS_Size --
6625 ---------------
6626
6627 -- The processing for VADS_Size is shared with Size
6628
6629 ---------
6630 -- Val --
6631 ---------
6632
6633 -- For enumeration types with a standard representation, and for all
21d27997
RD		 6634 -- other types, Val is handled by the back end. For enumeration types
6635 -- with a non-standard representation we use the _Pos_To_Rep array that
70482933
RK		 6636 -- was created when the type was frozen.
6637
47d3b920 6638 when Attribute_Val => Val : declare
70482933
RK		 6639 Etyp : constant Entity_Id := Base_Type (Entity (Pref));
6640
6641 begin
6642 if Is_Enumeration_Type (Etyp)
6643 and then Present (Enum_Pos_To_Rep (Etyp))
6644 then
fbf5a39b
AC		 6645 if Has_Contiguous_Rep (Etyp) then
6646 declare
6647 Rep_Node : constant Node_Id :=
6648 Unchecked_Convert_To (Etyp,
6649 Make_Op_Add (Loc,
6650 Left_Opnd =>
6651 Make_Integer_Literal (Loc,
6652 Enumeration_Rep (First_Literal (Etyp))),
6653 Right_Opnd =>
6654 (Convert_To (Standard_Integer,
6655 Relocate_Node (First (Exprs))))));
6656
6657 begin
6658 Rewrite (N,
6659 Unchecked_Convert_To (Etyp,
6660 Make_Op_Add (Loc,
6661 Left_Opnd =>
6662 Make_Integer_Literal (Loc,
6663 Enumeration_Rep (First_Literal (Etyp))),
6664 Right_Opnd =>
6665 Make_Function_Call (Loc,
6666 Name =>
e4494292 6667 New_Occurrence_Of
fbf5a39b
AC		 6668 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
6669 Parameter_Associations => New_List (
6670 Rep_Node,
6671 Rep_To_Pos_Flag (Etyp, Loc))))));
6672 end;
6673
6674 else
6675 Rewrite (N,
6676 Make_Indexed_Component (Loc,
e4494292 6677 Prefix => New_Occurrence_Of (Enum_Pos_To_Rep (Etyp), Loc),
fbf5a39b
AC		 6678 Expressions => New_List (
6679 Convert_To (Standard_Integer,
6680 Relocate_Node (First (Exprs))))));
6681 end if;
70482933
RK		 6682
6683 Analyze_And_Resolve (N, Typ);
d79e621a
GD		 6684
6685 -- If the argument is marked as requiring a range check then generate
6686 -- it here.
6687
6688 elsif Do_Range_Check (First (Exprs)) then
d79e621a 6689 Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
70482933
RK		 6690 end if;
6691 end Val;
6692
6693 -----------
6694 -- Valid --
6695 -----------
6696
6697 -- The code for valid is dependent on the particular types involved.
6698 -- See separate sections below for the generated code in each case.
6699
47d3b920 6700 when Attribute_Valid => Valid : declare
21d27997 6701 Btyp : Entity_Id := Base_Type (Ptyp);
70482933 6702
fbf5a39b
AC		 6703 Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
6704 -- Save the validity checking mode. We always turn off validity
6705 -- checking during process of 'Valid since this is one place
9e40de1d 6706 -- where we do not want the implicit validity checks to interfere
fbf5a39b
AC		 6707 -- with the explicit validity check that the programmer is doing.
6708
70482933
RK		 6709 function Make_Range_Test return Node_Id;
6710 -- Build the code for a range test of the form
ea034236 6711 -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
70482933 6712
fbf5a39b
AC		 6713 ---------------------
6714 -- Make_Range_Test --
6715 ---------------------
6716
70482933 6717 function Make_Range_Test return Node_Id is
89b6c83e 6718 Temp : Node_Id;
dbf04430 6719
70482933 6720 begin
89b6c83e
AC		 6721 -- The prefix of attribute 'Valid should always denote an object
6722 -- reference. The reference is either coming directly from source
5168a9b3
PMR		 6723 -- or is produced by validity check expansion. The object may be
6724 -- wrapped in a conversion in which case the call to Unqual_Conv
6725 -- will yield it.
dbf04430 6726
89b6c83e
AC		 6727 -- If the prefix denotes a variable which captures the value of
6728 -- an object for validation purposes, use the variable in the
6729 -- range test. This ensures that no extra copies or extra reads
6730 -- are produced as part of the test. Generate:
6731
6732 -- Temp : ... := Object;
6733 -- if not Temp in ... then
6734
6735 if Is_Validation_Variable_Reference (Pref) then
5168a9b3 6736 Temp := New_Occurrence_Of (Entity (Unqual_Conv (Pref)), Loc);
89b6c83e
AC		 6737
6738 -- Otherwise the prefix is either a source object or a constant
6739 -- produced by validity check expansion. Generate:
6740
6741 -- Temp : constant ... := Pref;
6742 -- if not Temp in ... then
6743
6744 else
6745 Temp := Duplicate_Subexpr (Pref);
dbf04430
AC		 6746 end if;
6747
70482933 6748 return
ea034236 6749 Make_In (Loc,
89b6c83e 6750 Left_Opnd => Unchecked_Convert_To (Btyp, Temp),
ea034236
AC		 6751 Right_Opnd =>
6752 Make_Range (Loc,
89b6c83e 6753 Low_Bound =>
70482933
RK		 6754 Unchecked_Convert_To (Btyp,
6755 Make_Attribute_Reference (Loc,
89b6c83e 6756 Prefix => New_Occurrence_Of (Ptyp, Loc),
ea034236
AC		 6757 Attribute_Name => Name_First)),
6758 High_Bound =>
70482933
RK		 6759 Unchecked_Convert_To (Btyp,
6760 Make_Attribute_Reference (Loc,
89b6c83e 6761 Prefix => New_Occurrence_Of (Ptyp, Loc),
70482933
RK		 6762 Attribute_Name => Name_Last))));
6763 end Make_Range_Test;
6764
f16cb8df
HK		 6765 -- Local variables
6766
6767 Tst : Node_Id;
6768
70482933
RK		 6769 -- Start of processing for Attribute_Valid
6770
6771 begin
1d57c04f
AC		 6772 -- Do not expand sourced code 'Valid reference in CodePeer mode,
6773 -- will be handled by the back-end directly.
6774
6775 if CodePeer_Mode and then Comes_From_Source (N) then
6776 return;
6777 end if;
6778
fbf5a39b
AC		 6779 -- Turn off validity checks. We do not want any implicit validity
6780 -- checks to intefere with the explicit check from the attribute
6781
6782 Validity_Checks_On := False;
6783
d7a44b14
AC		 6784 -- Retrieve the base type. Handle the case where the base type is a
6785 -- private enumeration type.
6786
6787 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
6788 Btyp := Full_View (Btyp);
6789 end if;
6790
70482933
RK		 6791 -- Floating-point case. This case is handled by the Valid attribute
6792 -- code in the floating-point attribute run-time library.
6793
6794 if Is_Floating_Point_Type (Ptyp) then
dfaff97b 6795 Float_Valid : declare
65f01153
RD		 6796 Pkg : RE_Id;
6797 Ftp : Entity_Id;
70482933 6798
8575023c
AC		 6799 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id;
6800 -- Return entity for Pkg.Nam
6801
6802 --------------------
6803 -- Get_Fat_Entity --
6804 --------------------
6805
6806 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id is
6807 Exp_Name : constant Node_Id :=
6808 Make_Selected_Component (Loc,
6809 Prefix => New_Occurrence_Of (RTE (Pkg), Loc),
6810 Selector_Name => Make_Identifier (Loc, Nam));
6811 begin
6812 Find_Selected_Component (Exp_Name);
6813 return Entity (Exp_Name);
6814 end Get_Fat_Entity;
6815
dfaff97b
RD		 6816 -- Start of processing for Float_Valid
6817
70482933 6818 begin
88438c0e 6819 -- The C and AAMP back-ends handle Valid for fpt types
8575023c 6820
c63a2ad6 6821 if Modify_Tree_For_C or else Float_Rep (Btyp) = AAMP then
88438c0e
AC		 6822 Analyze_And_Resolve (Pref, Ptyp);
6823 Set_Etype (N, Standard_Boolean);
6824 Set_Analyzed (N);
8575023c 6825
88438c0e
AC		 6826 else
6827 Find_Fat_Info (Ptyp, Ftp, Pkg);
6828
6829 -- If the prefix is a reverse SSO component, or is possibly
6830 -- unaligned, first create a temporary copy that is in
6831 -- native SSO, and properly aligned. Make it Volatile to
6832 -- prevent folding in the back-end. Note that we use an
6833 -- intermediate constrained string type to initialize the
6834 -- temporary, as the value at hand might be invalid, and in
6835 -- that case it cannot be copied using a floating point
6836 -- register.
6837
6838 if In_Reverse_Storage_Order_Object (Pref)
6839 or else Is_Possibly_Unaligned_Object (Pref)
6840 then
6841 declare
6842 Temp : constant Entity_Id :=
6843 Make_Temporary (Loc, 'F');
6844
6845 Fat_S : constant Entity_Id :=
6846 Get_Fat_Entity (Name_S);
6847 -- Constrained string subtype of appropriate size
6848
6849 Fat_P : constant Entity_Id :=
6850 Get_Fat_Entity (Name_P);
6851 -- Access to Fat_S
6852
6853 Decl : constant Node_Id :=
6854 Make_Object_Declaration (Loc,
6855 Defining_Identifier => Temp,
6856 Aliased_Present => True,
6857 Object_Definition =>
6858 New_Occurrence_Of (Ptyp, Loc));
6859
6860 begin
6861 Set_Aspect_Specifications (Decl, New_List (
6862 Make_Aspect_Specification (Loc,
6863 Identifier =>
6864 Make_Identifier (Loc, Name_Volatile))));
6865
6866 Insert_Actions (N,
6867 New_List (
6868 Decl,
6869
6870 Make_Assignment_Statement (Loc,
6871 Name =>
6872 Make_Explicit_Dereference (Loc,
6873 Prefix =>
6874 Unchecked_Convert_To (Fat_P,
6875 Make_Attribute_Reference (Loc,
6876 Prefix =>
6877 New_Occurrence_Of (Temp, Loc),
6878 Attribute_Name =>
6879 Name_Unrestricted_Access))),
6880 Expression =>
6881 Unchecked_Convert_To (Fat_S,
6882 Relocate_Node (Pref)))),
6883
6884 Suppress => All_Checks);
6885
6886 Rewrite (Pref, New_Occurrence_Of (Temp, Loc));
6887 end;
6888 end if;
8575023c 6889
88438c0e
AC		 6890 -- We now have an object of the proper endianness and
6891 -- alignment, and can construct a Valid attribute.
74014283 6892
88438c0e
AC		 6893 -- We make sure the prefix of this valid attribute is
6894 -- marked as not coming from source, to avoid losing
6895 -- warnings from 'Valid looking like a possible update.
74014283 6896
88438c0e 6897 Set_Comes_From_Source (Pref, False);
8575023c 6898
88438c0e
AC		 6899 Expand_Fpt_Attribute
6900 (N, Pkg, Name_Valid,
6901 New_List (
6902 Make_Attribute_Reference (Loc,
6903 Prefix => Unchecked_Convert_To (Ftp, Pref),
6904 Attribute_Name => Name_Unrestricted_Access)));
6905 end if;
70482933
RK		 6906
6907 -- One more task, we still need a range check. Required
6908 -- only if we have a constraint, since the Valid routine
6909 -- catches infinities properly (infinities are never valid).
6910
6911 -- The way we do the range check is simply to create the
6912 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
6913
6914 if not Subtypes_Statically_Match (Ptyp, Btyp) then
6915 Rewrite (N,
6916 Make_And_Then (Loc,
6917 Left_Opnd => Relocate_Node (N),
6918 Right_Opnd =>
6919 Make_In (Loc,
8575023c 6920 Left_Opnd => Convert_To (Btyp, Pref),
70482933
RK		 6921 Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
6922 end if;
dfaff97b 6923 end Float_Valid;
70482933
RK		 6924
6925 -- Enumeration type with holes
6926
6927 -- For enumeration types with holes, the Pos value constructed by
6928 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
6929 -- second argument of False returns minus one for an invalid value,
6930 -- and the non-negative pos value for a valid value, so the
6931 -- expansion of X'Valid is simply:
6932
6933 -- type(X)'Pos (X) >= 0
6934
6935 -- We can't quite generate it that way because of the requirement
7324bf49
AC		 6936 -- for the non-standard second argument of False in the resulting
6937 -- rep_to_pos call, so we have to explicitly create:
70482933
RK		 6938
6939 -- _rep_to_pos (X, False) >= 0
6940
6941 -- If we have an enumeration subtype, we also check that the
6942 -- value is in range:
6943
6944 -- _rep_to_pos (X, False) >= 0
6945 -- and then
7324bf49 6946 -- (X >= type(X)'First and then type(X)'Last <= X)
70482933
RK		 6947
6948 elsif Is_Enumeration_Type (Ptyp)
d7a44b14 6949 and then Present (Enum_Pos_To_Rep (Btyp))
70482933
RK		 6950 then
6951 Tst :=
6952 Make_Op_Ge (Loc,
6953 Left_Opnd =>
6954 Make_Function_Call (Loc,
6955 Name =>
e4494292 6956 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
70482933
RK		 6957 Parameter_Associations => New_List (
6958 Pref,
6959 New_Occurrence_Of (Standard_False, Loc))),
6960 Right_Opnd => Make_Integer_Literal (Loc, 0));
6961
6962 if Ptyp /= Btyp
6963 and then
6964 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
6965 or else
6966 Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
6967 then
6968 -- The call to Make_Range_Test will create declarations
6969 -- that need a proper insertion point, but Pref is now
6970 -- attached to a node with no ancestor. Attach to tree
6971 -- even if it is to be rewritten below.
6972
6973 Set_Parent (Tst, Parent (N));
6974
6975 Tst :=
6976 Make_And_Then (Loc,
6977 Left_Opnd => Make_Range_Test,
6978 Right_Opnd => Tst);
6979 end if;
6980
6981 Rewrite (N, Tst);
6982
6983 -- Fortran convention booleans
6984
6985 -- For the very special case of Fortran convention booleans, the
6986 -- value is always valid, since it is an integer with the semantics
6987 -- that non-zero is true, and any value is permissible.
6988
6989 elsif Is_Boolean_Type (Ptyp)
6990 and then Convention (Ptyp) = Convention_Fortran
6991 then
6992 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6993
6994 -- For biased representations, we will be doing an unchecked
758c442c
GD		 6995 -- conversion without unbiasing the result. That means that the range
6996 -- test has to take this into account, and the proper form of the
6997 -- test is:
70482933
RK		 6998
6999 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
7000
7001 elsif Has_Biased_Representation (Ptyp) then
7002 Btyp := RTE (RE_Unsigned_32);
7003 Rewrite (N,
7004 Make_Op_Lt (Loc,
7005 Left_Opnd =>
7006 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
7007 Right_Opnd =>
7008 Unchecked_Convert_To (Btyp,
7009 Make_Attribute_Reference (Loc,
7010 Prefix => New_Occurrence_Of (Ptyp, Loc),
7011 Attribute_Name => Name_Range_Length))));
7012
7013 -- For all other scalar types, what we want logically is a
7014 -- range test:
7015
7016 -- X in type(X)'First .. type(X)'Last
7017
7018 -- But that's precisely what won't work because of possible
7019 -- unwanted optimization (and indeed the basic motivation for
a90bd866 7020 -- the Valid attribute is exactly that this test does not work).
70482933
RK		 7021 -- What will work is:
7022
7023 -- Btyp!(X) >= Btyp!(type(X)'First)
7024 -- and then
7025 -- Btyp!(X) <= Btyp!(type(X)'Last)
7026
7027 -- where Btyp is an integer type large enough to cover the full
7028 -- range of possible stored values (i.e. it is chosen on the basis
7029 -- of the size of the type, not the range of the values). We write
7030 -- this as two tests, rather than a range check, so that static
7031 -- evaluation will easily remove either or both of the checks if
7032 -- they can be -statically determined to be true (this happens
7033 -- when the type of X is static and the range extends to the full
7034 -- range of stored values).
7035
7036 -- Unsigned types. Note: it is safe to consider only whether the
7037 -- subtype is unsigned, since we will in that case be doing all
758c442c
GD		 7038 -- unsigned comparisons based on the subtype range. Since we use the
7039 -- actual subtype object size, this is appropriate.
70482933
RK		 7040
7041 -- For example, if we have
7042
7043 -- subtype x is integer range 1 .. 200;
7044 -- for x'Object_Size use 8;
7045
758c442c
GD		 7046 -- Now the base type is signed, but objects of this type are bits
7047 -- unsigned, and doing an unsigned test of the range 1 to 200 is
7048 -- correct, even though a value greater than 127 looks signed to a
7049 -- signed comparison.
70482933
RK		 7050
7051 elsif Is_Unsigned_Type (Ptyp) then
7052 if Esize (Ptyp) <= 32 then
7053 Btyp := RTE (RE_Unsigned_32);
7054 else
7055 Btyp := RTE (RE_Unsigned_64);
7056 end if;
7057
7058 Rewrite (N, Make_Range_Test);
7059
7060 -- Signed types
7061
7062 else
7063 if Esize (Ptyp) <= Esize (Standard_Integer) then
7064 Btyp := Standard_Integer;
7065 else
7066 Btyp := Universal_Integer;
7067 end if;
7068
7069 Rewrite (N, Make_Range_Test);
7070 end if;
7071
3d6db7f8
GD		 7072 -- If a predicate is present, then we do the predicate test, even if
7073 -- within the predicate function (infinite recursion is warned about
97948f41 7074 -- in Sem_Attr in that case).
3d6db7f8
GD		 7075
7076 declare
7077 Pred_Func : constant Entity_Id := Predicate_Function (Ptyp);
7078
7079 begin
7080 if Present (Pred_Func) then
7081 Rewrite (N,
7082 Make_And_Then (Loc,
7083 Left_Opnd => Relocate_Node (N),
7084 Right_Opnd => Make_Predicate_Call (Ptyp, Pref)));
3d6db7f8
GD		 7085 end if;
7086 end;
7087
70482933 7088 Analyze_And_Resolve (N, Standard_Boolean);
fbf5a39b 7089 Validity_Checks_On := Save_Validity_Checks_On;
70482933
RK		 7090 end Valid;
7091
2a1f6a1f
AC		 7092 -------------------
7093 -- Valid_Scalars --
7094 -------------------
7095
7096 when Attribute_Valid_Scalars => Valid_Scalars : declare
f16cb8df
HK		 7097 Val_Typ : constant Entity_Id := Validated_View (Ptyp);
7098 Comp_Typ : Entity_Id;
7099 Expr : Node_Id;
99fc068e 7100
2a1f6a1f 7101 begin
f16cb8df 7102 -- Assume that the prefix does not need validation
99fc068e 7103
f16cb8df 7104 Expr := Empty;
45ec05e1 7105
f16cb8df 7106 -- Attribute 'Valid_Scalars is not supported on private tagged types
99fc068e 7107
f16cb8df
HK		 7108 if Is_Private_Type (Ptyp) and then Is_Tagged_Type (Ptyp) then
7109 null;
99fc068e 7110
f16cb8df
HK		 7111 -- Attribute 'Valid_Scalars evaluates to True when the type lacks
7112 -- scalars.
99fc068e 7113
f16cb8df
HK		 7114 elsif not Scalar_Part_Present (Val_Typ) then
7115 null;
99fc068e 7116
f16cb8df
HK		 7117 -- Attribute 'Valid_Scalars is the same as attribute 'Valid when the
7118 -- validated type is a scalar type. Generate:
45ec05e1 7119
f16cb8df 7120 -- Val_Typ (Pref)'Valid
45ec05e1 7121
f16cb8df
HK		 7122 elsif Is_Scalar_Type (Val_Typ) then
7123 Expr :=
7124 Make_Attribute_Reference (Loc,
7125 Prefix =>
7126 Unchecked_Convert_To (Val_Typ, New_Copy_Tree (Pref)),
7127 Attribute_Name => Name_Valid);
45ec05e1 7128
f16cb8df
HK		 7129 -- Validate the scalar components of an array by iterating over all
7130 -- dimensions of the array while checking individual components.
45ec05e1 7131
f16cb8df
HK		 7132 elsif Is_Array_Type (Val_Typ) then
7133 Comp_Typ := Validated_View (Component_Type (Val_Typ));
99fc068e 7134
f16cb8df
HK		 7135 if Scalar_Part_Present (Comp_Typ) then
7136 Expr :=
7137 Make_Function_Call (Loc,
7138 Name =>
7139 New_Occurrence_Of
7140 (Build_Array_VS_Func
7141 (Attr => N,
7142 Formal_Typ => Ptyp,
7143 Array_Typ => Val_Typ,
7144 Comp_Typ => Comp_Typ),
7145 Loc),
7146 Parameter_Associations => New_List (Pref));
7147 end if;
99fc068e 7148
f16cb8df
HK		 7149 -- Validate the scalar components, discriminants of a record type by
7150 -- examining the structure of a record type.
99fc068e 7151
f16cb8df
HK		 7152 elsif Is_Record_Type (Val_Typ) then
7153 Expr :=
7154 Make_Function_Call (Loc,
7155 Name =>
7156 New_Occurrence_Of
7157 (Build_Record_VS_Func
7158 (Attr => N,
7159 Formal_Typ => Ptyp,
7160 Rec_Typ => Val_Typ),
7161 Loc),
7162 Parameter_Associations => New_List (Pref));
7163 end if;
99fc068e 7164
f16cb8df
HK		 7165 -- Default the attribute to True when the type of the prefix does not
7166 -- need validation.
99fc068e 7167
f16cb8df
HK		 7168 if No (Expr) then
7169 Expr := New_Occurrence_Of (Standard_True, Loc);
99fc068e 7170 end if;
45ec05e1 7171
f16cb8df 7172 Rewrite (N, Expr);
45ec05e1
RD		 7173 Analyze_And_Resolve (N, Standard_Boolean);
7174 Set_Is_Static_Expression (N, False);
2a1f6a1f
AC		 7175 end Valid_Scalars;
7176
70482933
RK		 7177 -----------
7178 -- Value --
7179 -----------
7180
4ee646da 7181 -- Value attribute is handled in separate unit Exp_Imgv
70482933
RK		 7182
7183 when Attribute_Value =>
7184 Exp_Imgv.Expand_Value_Attribute (N);
7185
7186 -----------------
7187 -- Value_Size --
7188 -----------------
7189
7190 -- The processing for Value_Size shares the processing for Size
7191
7192 -------------
7193 -- Version --
7194 -------------
7195
7196 -- The processing for Version shares the processing for Body_Version
7197
7198 ----------------
7199 -- Wide_Image --
7200 ----------------
7201
470cd9e9 7202 -- Wide_Image attribute is handled in separate unit Exp_Imgv
70482933 7203
470cd9e9 7204 when Attribute_Wide_Image =>
b63d61f7
AC		 7205 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7206 -- back-end knows how to handle this attribute directly.
7207
7208 if CodePeer_Mode then
7209 return;
7210 end if;
7211
470cd9e9 7212 Exp_Imgv.Expand_Wide_Image_Attribute (N);
70482933 7213
82c80734
RD		 7214 ---------------------
7215 -- Wide_Wide_Image --
7216 ---------------------
7217
470cd9e9 7218 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
82c80734 7219
470cd9e9 7220 when Attribute_Wide_Wide_Image =>
b63d61f7
AC		 7221 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7222 -- back-end knows how to handle this attribute directly.
7223
7224 if CodePeer_Mode then
7225 return;
7226 end if;
7227
470cd9e9 7228 Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N);
82c80734 7229
70482933
RK		 7230 ----------------
7231 -- Wide_Value --
7232 ----------------
7233
7234 -- We expand typ'Wide_Value (X) into
7235
7236 -- typ'Value
7237 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
7238
7239 -- Wide_String_To_String is a runtime function that converts its wide
7240 -- string argument to String, converting any non-translatable characters
7241 -- into appropriate escape sequences. This preserves the required
7242 -- semantics of Wide_Value in all cases, and results in a very simple
7243 -- implementation approach.
7244
7ce611e2
ES		 7245 -- Note: for this approach to be fully standard compliant for the cases
7246 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
7247 -- method must cover the entire character range (e.g. UTF-8). But that
7248 -- is a reasonable requirement when dealing with encoded character
7249 -- sequences. Presumably if one of the restrictive encoding mechanisms
7250 -- is in use such as Shift-JIS, then characters that cannot be
7251 -- represented using this encoding will not appear in any case.
70482933 7252
d8f43ee6 7253 when Attribute_Wide_Value =>
70482933
RK		 7254 Rewrite (N,
7255 Make_Attribute_Reference (Loc,
7256 Prefix => Pref,
7257 Attribute_Name => Name_Value,
7258
7259 Expressions => New_List (
7260 Make_Function_Call (Loc,
7261 Name =>
e4494292 7262 New_Occurrence_Of (RTE (RE_Wide_String_To_String), Loc),
70482933
RK		 7263
7264 Parameter_Associations => New_List (
7265 Relocate_Node (First (Exprs)),
7266 Make_Integer_Literal (Loc,
7267 Intval => Int (Wide_Character_Encoding_Method)))))));
7268
7269 Analyze_And_Resolve (N, Typ);
70482933 7270
82c80734
RD		 7271 ---------------------
7272 -- Wide_Wide_Value --
7273 ---------------------
7274
7275 -- We expand typ'Wide_Value_Value (X) into
7276
7277 -- typ'Value
7278 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
7279
7280 -- Wide_Wide_String_To_String is a runtime function that converts its
7281 -- wide string argument to String, converting any non-translatable
7282 -- characters into appropriate escape sequences. This preserves the
7283 -- required semantics of Wide_Wide_Value in all cases, and results in a
7284 -- very simple implementation approach.
7285
7286 -- It's not quite right where typ = Wide_Wide_Character, because the
7287 -- encoding method may not cover the whole character type ???
7288
d8f43ee6 7289 when Attribute_Wide_Wide_Value =>
82c80734
RD		 7290 Rewrite (N,
7291 Make_Attribute_Reference (Loc,
7292 Prefix => Pref,
7293 Attribute_Name => Name_Value,
7294
7295 Expressions => New_List (
7296 Make_Function_Call (Loc,
d8f43ee6 7297 Name =>
e4494292
RD		 7298 New_Occurrence_Of
7299 (RTE (RE_Wide_Wide_String_To_String), Loc),
82c80734
RD		 7300
7301 Parameter_Associations => New_List (
7302 Relocate_Node (First (Exprs)),
7303 Make_Integer_Literal (Loc,
7304 Intval => Int (Wide_Character_Encoding_Method)))))));
7305
7306 Analyze_And_Resolve (N, Typ);
82c80734
RD		 7307
7308 ---------------------
7309 -- Wide_Wide_Width --
7310 ---------------------
7311
7312 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
7313
7314 when Attribute_Wide_Wide_Width =>
7315 Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide);
7316
70482933
RK		 7317 ----------------
7318 -- Wide_Width --
7319 ----------------
7320
7321 -- Wide_Width attribute is handled in separate unit Exp_Imgv
7322
7323 when Attribute_Wide_Width =>
82c80734 7324 Exp_Imgv.Expand_Width_Attribute (N, Wide);
70482933
RK		 7325
7326 -----------
7327 -- Width --
7328 -----------
7329
7330 -- Width attribute is handled in separate unit Exp_Imgv
7331
7332 when Attribute_Width =>
82c80734 7333 Exp_Imgv.Expand_Width_Attribute (N, Normal);
70482933
RK		 7334
7335 -----------
7336 -- Write --
7337 -----------
7338
7339 when Attribute_Write => Write : declare
7340 P_Type : constant Entity_Id := Entity (Pref);
7341 U_Type : constant Entity_Id := Underlying_Type (P_Type);
7342 Pname : Entity_Id;
7343 Decl : Node_Id;
7344 Prag : Node_Id;
7345 Arg3 : Node_Id;
7346 Wfunc : Node_Id;
7347
7348 begin
7349 -- If no underlying type, we have an error that will be diagnosed
7350 -- elsewhere, so here we just completely ignore the expansion.
7351
7352 if No (U_Type) then
7353 return;
7354 end if;
7355
baa571ab
AC		 7356 -- Stream operations can appear in user code even if the restriction
7357 -- No_Streams is active (for example, when instantiating a predefined
7358 -- container). In that case rewrite the attribute as a Raise to
7359 -- prevent any run-time use.
7360
7361 if Restriction_Active (No_Streams) then
7362 Rewrite (N,
7363 Make_Raise_Program_Error (Sloc (N),
b8b2d982 7364 Reason => PE_Stream_Operation_Not_Allowed));
baa571ab
AC		 7365 Set_Etype (N, U_Type);
7366 return;
7367 end if;
7368
70482933
RK		 7369 -- The simple case, if there is a TSS for Write, just call it
7370
fbf5a39b 7371 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
70482933
RK		 7372
7373 if Present (Pname) then
7374 null;
7375
7376 else
7377 -- If there is a Stream_Convert pragma, use it, we rewrite
7378
7379 -- sourcetyp'Output (stream, Item)
7380
7381 -- as
7382
7383 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
7384
758c442c
GD		 7385 -- where strmwrite is the given Write function that converts an
7386 -- argument of type sourcetyp or a type acctyp, from which it is
7387 -- derived to type strmtyp. The conversion to acttyp is required
7388 -- for the derived case.
70482933 7389
1d571f3b 7390 Prag := Get_Stream_Convert_Pragma (P_Type);
70482933
RK		 7391
7392 if Present (Prag) then
7393 Arg3 :=
7394 Next (Next (First (Pragma_Argument_Associations (Prag))));
7395 Wfunc := Entity (Expression (Arg3));
7396
7397 Rewrite (N,
7398 Make_Attribute_Reference (Loc,
7399 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
7400 Attribute_Name => Name_Output,
7401 Expressions => New_List (
7402 Relocate_Node (First (Exprs)),
7403 Make_Function_Call (Loc,
7404 Name => New_Occurrence_Of (Wfunc, Loc),
7405 Parameter_Associations => New_List (
31104818 7406 OK_Convert_To (Etype (First_Formal (Wfunc)),
70482933
RK		 7407 Relocate_Node (Next (First (Exprs)))))))));
7408
7409 Analyze (N);
7410 return;
7411
7412 -- For elementary types, we call the W_xxx routine directly
7413
7414 elsif Is_Elementary_Type (U_Type) then
7415 Rewrite (N, Build_Elementary_Write_Call (N));
7416 Analyze (N);
7417 return;
7418
7419 -- Array type case
7420
7421 elsif Is_Array_Type (U_Type) then
7422 Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
7423 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
7424
7425 -- Tagged type case, use the primitive Write function. Note that
7426 -- this will dispatch in the class-wide case which is what we want
7427
7428 elsif Is_Tagged_Type (U_Type) then
fbf5a39b 7429 Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
70482933
RK		 7430
7431 -- All other record type cases, including protected records.
7432 -- The latter only arise for expander generated code for
7433 -- handling shared passive partition access.
7434
7435 else
7436 pragma Assert
7437 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
7438
5d09245e
AC		 7439 -- Ada 2005 (AI-216): Program_Error is raised when executing
7440 -- the default implementation of the Write attribute of an
0669bebe
GB		 7441 -- Unchecked_Union type. However, if the 'Write reference is
7442 -- within the generated Output stream procedure, Write outputs
7443 -- the components, and the default values of the discriminant
1f70c47f
AC		 7444 -- are streamed by the Output procedure itself. If there are
7445 -- no default values this is also erroneous.
5d09245e 7446
1f70c47f
AC		 7447 if Is_Unchecked_Union (Base_Type (U_Type)) then
7448 if (not Is_TSS (Current_Scope, TSS_Stream_Output)
7449 and not Is_TSS (Current_Scope, TSS_Stream_Write))
7450 or else No (Discriminant_Default_Value
7451 (First_Discriminant (U_Type)))
7452 then
7453 Rewrite (N,
7454 Make_Raise_Program_Error (Loc,
7455 Reason => PE_Unchecked_Union_Restriction));
7456 Set_Etype (N, U_Type);
7457 return;
7458 end if;
5d09245e
AC		 7459 end if;
7460
70482933
RK		 7461 if Has_Discriminants (U_Type)
7462 and then Present
7463 (Discriminant_Default_Value (First_Discriminant (U_Type)))
7464 then
7465 Build_Mutable_Record_Write_Procedure
96d2756f 7466 (Loc, Full_Base (U_Type), Decl, Pname);
70482933
RK		 7467 else
7468 Build_Record_Write_Procedure
96d2756f 7469 (Loc, Full_Base (U_Type), Decl, Pname);
70482933
RK		 7470 end if;
7471
7472 Insert_Action (N, Decl);
7473 end if;
7474 end if;
7475
7476 -- If we fall through, Pname is the procedure to be called
7477
7478 Rewrite_Stream_Proc_Call (Pname);
7479 end Write;
7480
21d27997
RD		 7481 -- Component_Size is handled by the back end, unless the component size
7482 -- is known at compile time, which is always true in the packed array
7483 -- case. It is important that the packed array case is handled in the
7484 -- front end (see Eval_Attribute) since the back end would otherwise get
7485 -- confused by the equivalent packed array type.
70482933
RK		 7486
7487 when Attribute_Component_Size =>
7488 null;
7489
80d4224f
RD		 7490 -- The following attributes are handled by the back end (except that
7491 -- static cases have already been evaluated during semantic processing,
7492 -- but in any case the back end should not count on this).
70482933 7493
21d27997 7494 -- The back end also handles the non-class-wide cases of Size
70482933 7495
d8f43ee6
HK		 7496 when Attribute_Bit_Order
7497 | Attribute_Code_Address
7498 | Attribute_Definite
7499 | Attribute_Deref
7500 | Attribute_Null_Parameter
7501 | Attribute_Passed_By_Reference
7502 | Attribute_Pool_Address
7503 | Attribute_Scalar_Storage_Order
7504 =>
70482933
RK		 7505 null;
7506
21d27997
RD		 7507 -- The following attributes are also handled by the back end, but return
7508 -- a universal integer result, so may need a conversion for checking
70482933
RK		 7509 -- that the result is in range.
7510
d8f43ee6
HK		 7511 when Attribute_Aft
7512 | Attribute_Max_Alignment_For_Allocation
7513 =>
70482933
RK		 7514 Apply_Universal_Integer_Attribute_Checks (N);
7515
7516 -- The following attributes should not appear at this stage, since they
7517 -- have already been handled by the analyzer (and properly rewritten
7518 -- with corresponding values or entities to represent the right values)
7519
d8f43ee6
HK		 7520 when Attribute_Abort_Signal
7521 | Attribute_Address_Size
7522 | Attribute_Atomic_Always_Lock_Free
7523 | Attribute_Base
7524 | Attribute_Class
7525 | Attribute_Compiler_Version
7526 | Attribute_Default_Bit_Order
7527 | Attribute_Default_Scalar_Storage_Order
7528 | Attribute_Delta
7529 | Attribute_Denorm
7530 | Attribute_Digits
7531 | Attribute_Emax
7532 | Attribute_Enabled
7533 | Attribute_Epsilon
7534 | Attribute_Fast_Math
7535 | Attribute_First_Valid
7536 | Attribute_Has_Access_Values
7537 | Attribute_Has_Discriminants
7538 | Attribute_Has_Tagged_Values
7539 | Attribute_Large
7540 | Attribute_Last_Valid
7541 | Attribute_Library_Level
7542 | Attribute_Lock_Free
7543 | Attribute_Machine_Emax
7544 | Attribute_Machine_Emin
7545 | Attribute_Machine_Mantissa
7546 | Attribute_Machine_Overflows
7547 | Attribute_Machine_Radix
7548 | Attribute_Machine_Rounds
7549 | Attribute_Maximum_Alignment
7550 | Attribute_Model_Emin
7551 | Attribute_Model_Epsilon
7552 | Attribute_Model_Mantissa
7553 | Attribute_Model_Small
7554 | Attribute_Modulus
7555 | Attribute_Partition_ID
7556 | Attribute_Range
7557 | Attribute_Restriction_Set
7558 | Attribute_Safe_Emax
7559 | Attribute_Safe_First
7560 | Attribute_Safe_Large
7561 | Attribute_Safe_Last
7562 | Attribute_Safe_Small
7563 | Attribute_Scale
7564 | Attribute_Signed_Zeros
7565 | Attribute_Small
7566 | Attribute_Storage_Unit
7567 | Attribute_Stub_Type
7568 | Attribute_System_Allocator_Alignment
7569 | Attribute_Target_Name
7570 | Attribute_Type_Class
7571 | Attribute_Type_Key
7572 | Attribute_Unconstrained_Array
7573 | Attribute_Universal_Literal_String
7574 | Attribute_Wchar_T_Size
7575 | Attribute_Word_Size
7576 =>
70482933
RK		 7577 raise Program_Error;
7578
7579 -- The Asm_Input and Asm_Output attributes are not expanded at this
21d27997
RD		 7580 -- stage, but will be eliminated in the expansion of the Asm call, see
7581 -- Exp_Intr for details. So the back end will never see these either.
70482933 7582
d8f43ee6
HK		 7583 when Attribute_Asm_Input
7584 | Attribute_Asm_Output
7585 =>
70482933 7586 null;
70482933
RK		 7587 end case;
7588
2eef7403
AC		 7589 -- Note: as mentioned earlier, individual sections of the above case
7590 -- statement assume there is no code after the case statement, and are
7591 -- legitimately allowed to execute return statements if they have nothing
7592 -- more to do, so DO NOT add code at this point.
7593
fbf5a39b
AC		 7594 exception
7595 when RE_Not_Available =>
7596 return;
70482933
RK		 7597 end Expand_N_Attribute_Reference;
7598
aa9b151a
AC		 7599 --------------------------------
7600 -- Expand_Pred_Succ_Attribute --
7601 --------------------------------
70482933
RK		 7602
7603 -- For typ'Pred (exp), we generate the check
7604
7605 -- [constraint_error when exp = typ'Base'First]
7606
7607 -- Similarly, for typ'Succ (exp), we generate the check
7608
7609 -- [constraint_error when exp = typ'Base'Last]
7610
7611 -- These checks are not generated for modular types, since the proper
7612 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
c7532b2d
AC		 7613 -- We also suppress these checks if we are the right side of an assignment
7614 -- statement or the expression of an object declaration, where the flag
7615 -- Suppress_Assignment_Checks is set for the assignment/declaration.
70482933 7616
aa9b151a 7617 procedure Expand_Pred_Succ_Attribute (N : Node_Id) is
70482933 7618 Loc : constant Source_Ptr := Sloc (N);
c7532b2d 7619 P : constant Node_Id := Parent (N);
70482933
RK		 7620 Cnam : Name_Id;
7621
7622 begin
7623 if Attribute_Name (N) = Name_Pred then
7624 Cnam := Name_First;
7625 else
7626 Cnam := Name_Last;
7627 end if;
7628
c7532b2d
AC		 7629 if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration)
7630 or else not Suppress_Assignment_Checks (P)
7631 then
7632 Insert_Action (N,
7633 Make_Raise_Constraint_Error (Loc,
7634 Condition =>
7635 Make_Op_Eq (Loc,
7636 Left_Opnd =>
7637 Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
7638 Right_Opnd =>
7639 Make_Attribute_Reference (Loc,
7640 Prefix =>
e4494292 7641 New_Occurrence_Of (Base_Type (Etype (Prefix (N))), Loc),
c7532b2d
AC		 7642 Attribute_Name => Cnam)),
7643 Reason => CE_Overflow_Check_Failed));
7644 end if;
aa9b151a 7645 end Expand_Pred_Succ_Attribute;
70482933 7646
18a2ad5d
AC		 7647 -----------------------------
7648 -- Expand_Update_Attribute --
7649 -----------------------------
7650
7651 procedure Expand_Update_Attribute (N : Node_Id) is
7652 procedure Process_Component_Or_Element_Update
7653 (Temp : Entity_Id;
7654 Comp : Node_Id;
7655 Expr : Node_Id;
7656 Typ : Entity_Id);
7657 -- Generate the statements necessary to update a single component or an
7658 -- element of the prefix. The code is inserted before the attribute N.
7659 -- Temp denotes the entity of the anonymous object created to reflect
7660 -- the changes in values. Comp is the component/index expression to be
7661 -- updated. Expr is an expression yielding the new value of Comp. Typ
7662 -- is the type of the prefix of attribute Update.
7663
7664 procedure Process_Range_Update
7665 (Temp : Entity_Id;
7666 Comp : Node_Id;
d12b19fa
AC		 7667 Expr : Node_Id;
7668 Typ : Entity_Id);
18a2ad5d
AC		 7669 -- Generate the statements necessary to update a slice of the prefix.
7670 -- The code is inserted before the attribute N. Temp denotes the entity
7671 -- of the anonymous object created to reflect the changes in values.
7672 -- Comp is range of the slice to be updated. Expr is an expression
d12b19fa
AC		 7673 -- yielding the new value of Comp. Typ is the type of the prefix of
7674 -- attribute Update.
18a2ad5d
AC		 7675
7676 -----------------------------------------
7677 -- Process_Component_Or_Element_Update --
7678 -----------------------------------------
7679
7680 procedure Process_Component_Or_Element_Update
7681 (Temp : Entity_Id;
7682 Comp : Node_Id;
7683 Expr : Node_Id;
7684 Typ : Entity_Id)
7685 is
7686 Loc : constant Source_Ptr := Sloc (Comp);
7687 Exprs : List_Id;
7688 LHS : Node_Id;
7689
7690 begin
7691 -- An array element may be modified by the following relations
7692 -- depending on the number of dimensions:
7693
7694 -- 1 => Expr -- one dimensional update
7695 -- (1, ..., N) => Expr -- multi dimensional update
7696
7697 -- The above forms are converted in assignment statements where the
7698 -- left hand side is an indexed component:
7699
7700 -- Temp (1) := Expr; -- one dimensional update
7701 -- Temp (1, ..., N) := Expr; -- multi dimensional update
7702
7703 if Is_Array_Type (Typ) then
7704
7705 -- The index expressions of a multi dimensional array update
7706 -- appear as an aggregate.
7707
7708 if Nkind (Comp) = N_Aggregate then
7709 Exprs := New_Copy_List_Tree (Expressions (Comp));
7710 else
7711 Exprs := New_List (Relocate_Node (Comp));
7712 end if;
7713
7714 LHS :=
7715 Make_Indexed_Component (Loc,
e4494292 7716 Prefix => New_Occurrence_Of (Temp, Loc),
18a2ad5d
AC		 7717 Expressions => Exprs);
7718
7719 -- A record component update appears in the following form:
7720
7721 -- Comp => Expr
7722
7723 -- The above relation is transformed into an assignment statement
7724 -- where the left hand side is a selected component:
7725
7726 -- Temp.Comp := Expr;
7727
7728 else pragma Assert (Is_Record_Type (Typ));
7729 LHS :=
7730 Make_Selected_Component (Loc,
e4494292 7731 Prefix => New_Occurrence_Of (Temp, Loc),
18a2ad5d
AC		 7732 Selector_Name => Relocate_Node (Comp));
7733 end if;
7734
7735 Insert_Action (N,
7736 Make_Assignment_Statement (Loc,
7737 Name => LHS,
7738 Expression => Relocate_Node (Expr)));
7739 end Process_Component_Or_Element_Update;
7740
7741 --------------------------
7742 -- Process_Range_Update --
7743 --------------------------
7744
7745 procedure Process_Range_Update
7746 (Temp : Entity_Id;
7747 Comp : Node_Id;
d12b19fa
AC		 7748 Expr : Node_Id;
7749 Typ : Entity_Id)
18a2ad5d 7750 is
d12b19fa
AC		 7751 Index_Typ : constant Entity_Id := Etype (First_Index (Typ));
7752 Loc : constant Source_Ptr := Sloc (Comp);
7753 Index : Entity_Id;
18a2ad5d
AC		 7754
7755 begin
7756 -- A range update appears as
7757
7758 -- (Low .. High => Expr)
7759
7760 -- The above construct is transformed into a loop that iterates over
7761 -- the given range and modifies the corresponding array values to the
7762 -- value of Expr:
7763
7764 -- for Index in Low .. High loop
d12b19fa 7765 -- Temp (<Index_Typ> (Index)) := Expr;
18a2ad5d
AC		 7766 -- end loop;
7767
7768 Index := Make_Temporary (Loc, 'I');
7769
7770 Insert_Action (N,
7771 Make_Loop_Statement (Loc,
7772 Iteration_Scheme =>
7773 Make_Iteration_Scheme (Loc,
7774 Loop_Parameter_Specification =>
7775 Make_Loop_Parameter_Specification (Loc,
7776 Defining_Identifier => Index,
7777 Discrete_Subtype_Definition => Relocate_Node (Comp))),
7778
7779 Statements => New_List (
7780 Make_Assignment_Statement (Loc,
7781 Name =>
7782 Make_Indexed_Component (Loc,
e4494292 7783 Prefix => New_Occurrence_Of (Temp, Loc),
d12b19fa 7784 Expressions => New_List (
e4494292
RD		 7785 Convert_To (Index_Typ,
7786 New_Occurrence_Of (Index, Loc)))),
18a2ad5d
AC		 7787 Expression => Relocate_Node (Expr))),
7788
7789 End_Label => Empty));
7790 end Process_Range_Update;
7791
7792 -- Local variables
7793
6c802906
AC		 7794 Aggr : constant Node_Id := First (Expressions (N));
7795 Loc : constant Source_Ptr := Sloc (N);
7796 Pref : constant Node_Id := Prefix (N);
7797 Typ : constant Entity_Id := Etype (Pref);
7798 Assoc : Node_Id;
7799 Comp : Node_Id;
7800 CW_Temp : Entity_Id;
7801 CW_Typ : Entity_Id;
7802 Expr : Node_Id;
7803 Temp : Entity_Id;
18a2ad5d
AC		 7804
7805 -- Start of processing for Expand_Update_Attribute
7806
7807 begin
6c802906
AC		 7808 -- Create the anonymous object to store the value of the prefix and
7809 -- capture subsequent changes in value.
7810
7811 Temp := Make_Temporary (Loc, 'T', Pref);
18a2ad5d 7812
6c802906
AC		 7813 -- Preserve the tag of the prefix by offering a specific view of the
7814 -- class-wide version of the prefix.
18a2ad5d 7815
6c802906 7816 if Is_Tagged_Type (Typ) then
18a2ad5d 7817
6c802906
AC		 7818 -- Generate:
7819 -- CW_Temp : Typ'Class := Typ'Class (Pref);
7820
7821 CW_Temp := Make_Temporary (Loc, 'T');
7822 CW_Typ := Class_Wide_Type (Typ);
7823
7824 Insert_Action (N,
7825 Make_Object_Declaration (Loc,
7826 Defining_Identifier => CW_Temp,
7827 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
7828 Expression =>
7829 Convert_To (CW_Typ, Relocate_Node (Pref))));
7830
7831 -- Generate:
7832 -- Temp : Typ renames Typ (CW_Temp);
7833
7834 Insert_Action (N,
7835 Make_Object_Renaming_Declaration (Loc,
7836 Defining_Identifier => Temp,
7837 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
7838 Name =>
7839 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))));
7840
7841 -- Non-tagged case
7842
7843 else
7844 -- Generate:
7845 -- Temp : Typ := Pref;
7846
7847 Insert_Action (N,
7848 Make_Object_Declaration (Loc,
7849 Defining_Identifier => Temp,
7850 Object_Definition => New_Occurrence_Of (Typ, Loc),
7851 Expression => Relocate_Node (Pref)));
7852 end if;
18a2ad5d
AC		 7853
7854 -- Process the update aggregate
7855
7856 Assoc := First (Component_Associations (Aggr));
7857 while Present (Assoc) loop
7858 Comp := First (Choices (Assoc));
7859 Expr := Expression (Assoc);
7860 while Present (Comp) loop
7861 if Nkind (Comp) = N_Range then
d12b19fa 7862 Process_Range_Update (Temp, Comp, Expr, Typ);
18a2ad5d
AC		 7863 else
7864 Process_Component_Or_Element_Update (Temp, Comp, Expr, Typ);
7865 end if;
7866
7867 Next (Comp);
7868 end loop;
7869
7870 Next (Assoc);
7871 end loop;
7872
7873 -- The attribute is replaced by a reference to the anonymous object
7874
e4494292 7875 Rewrite (N, New_Occurrence_Of (Temp, Loc));
18a2ad5d
AC		 7876 Analyze (N);
7877 end Expand_Update_Attribute;
7878
65f01153
RD		 7879 -------------------
7880 -- Find_Fat_Info --
7881 -------------------
7882
7883 procedure Find_Fat_Info
7884 (T : Entity_Id;
7885 Fat_Type : out Entity_Id;
7886 Fat_Pkg : out RE_Id)
7887 is
65f01153 7888 Rtyp : constant Entity_Id := Root_Type (T);
65f01153
RD		 7889
7890 begin
80211802
AC		 7891 -- All we do is use the root type (historically this dealt with
7892 -- VAX-float .. to be cleaned up further later ???)
65f01153 7893
80211802 7894 Fat_Type := Rtyp;
65f01153 7895
80211802
AC		 7896 if Fat_Type = Standard_Short_Float then
7897 Fat_Pkg := RE_Attr_Short_Float;
65f01153 7898
80211802
AC		 7899 elsif Fat_Type = Standard_Float then
7900 Fat_Pkg := RE_Attr_Float;
65f01153 7901
80211802
AC		 7902 elsif Fat_Type = Standard_Long_Float then
7903 Fat_Pkg := RE_Attr_Long_Float;
7ce611e2 7904
80211802
AC		 7905 elsif Fat_Type = Standard_Long_Long_Float then
7906 Fat_Pkg := RE_Attr_Long_Long_Float;
7ce611e2
ES		 7907
7908 -- Universal real (which is its own root type) is treated as being
7909 -- equivalent to Standard.Long_Long_Float, since it is defined to
7910 -- have the same precision as the longest Float type.
7911
80211802
AC		 7912 elsif Fat_Type = Universal_Real then
7913 Fat_Type := Standard_Long_Long_Float;
7914 Fat_Pkg := RE_Attr_Long_Long_Float;
7ce611e2 7915
80211802
AC		 7916 else
7917 raise Program_Error;
65f01153
RD		 7918 end if;
7919 end Find_Fat_Info;
7920
fbf5a39b
AC		 7921 ----------------------------
7922 -- Find_Stream_Subprogram --
7923 ----------------------------
7924
7925 function Find_Stream_Subprogram
7926 (Typ : Entity_Id;
758c442c
GD		 7927 Nam : TSS_Name_Type) return Entity_Id
7928 is
b2c6b35f
HK		 7929 Base_Typ : constant Entity_Id := Base_Type (Typ);
7930 Ent : constant Entity_Id := TSS (Typ, Nam);
21d27997 7931
90878b12
AC		 7932 function Is_Available (Entity : RE_Id) return Boolean;
7933 pragma Inline (Is_Available);
7934 -- Function to check whether the specified run-time call is available
7935 -- in the run time used. In the case of a configurable run time, it
7936 -- is normal that some subprograms are not there.
161c5cc5 7937 --
a20f4389
AC		 7938 -- I don't understand this routine at all, why is this not just a
7939 -- call to RTE_Available? And if for some reason we need a different
7940 -- routine with different semantics, why is not in Rtsfind ???
7941
7942 ------------------
7943 -- Is_Available --
7944 ------------------
7945
90878b12
AC		 7946 function Is_Available (Entity : RE_Id) return Boolean is
7947 begin
7948 -- Assume that the unit will always be available when using a
7949 -- "normal" (not configurable) run time.
7950
161c5cc5 7951 return not Configurable_Run_Time_Mode or else RTE_Available (Entity);
90878b12
AC		 7952 end Is_Available;
7953
a20f4389
AC		 7954 -- Start of processing for Find_Stream_Subprogram
7955
fbf5a39b 7956 begin
758c442c
GD		 7957 if Present (Ent) then
7958 return Ent;
7959 end if;
7960
21d27997
RD		 7961 -- Stream attributes for strings are expanded into library calls. The
7962 -- following checks are disabled when the run-time is not available or
7963 -- when compiling predefined types due to bootstrap issues. As a result,
7964 -- the compiler will generate in-place stream routines for string types
7965 -- that appear in GNAT's library, but will generate calls via rtsfind
7966 -- to library routines for user code.
f4b049db 7967
a20f4389 7968 -- Note: In the case of using a configurable run time, it is very likely
90878b12
AC		 7969 -- that stream routines for string types are not present (they require
7970 -- file system support). In this case, the specific stream routines for
7971 -- strings are not used, relying on the regular stream mechanism
a20f4389
AC		 7972 -- instead. That is why we include the test Is_Available when dealing
7973 -- with these cases.
90878b12 7974
8ab31c0c 7975 if not Is_Predefined_Unit (Current_Sem_Unit) then
161c5cc5
AC		 7976 -- Storage_Array as defined in package System.Storage_Elements
7977
7978 if Is_RTE (Base_Typ, RE_Storage_Array) then
7979
7980 -- Case of No_Stream_Optimizations restriction active
7981
7982 if Restriction_Active (No_Stream_Optimizations) then
7983 if Nam = TSS_Stream_Input
7984 and then Is_Available (RE_Storage_Array_Input)
7985 then
7986 return RTE (RE_Storage_Array_Input);
7987
7988 elsif Nam = TSS_Stream_Output
7989 and then Is_Available (RE_Storage_Array_Output)
7990 then
7991 return RTE (RE_Storage_Array_Output);
7992
7993 elsif Nam = TSS_Stream_Read
7994 and then Is_Available (RE_Storage_Array_Read)
7995 then
7996 return RTE (RE_Storage_Array_Read);
7997
7998 elsif Nam = TSS_Stream_Write
7999 and then Is_Available (RE_Storage_Array_Write)
8000 then
8001 return RTE (RE_Storage_Array_Write);
8002
8003 elsif Nam /= TSS_Stream_Input and then
8004 Nam /= TSS_Stream_Output and then
8005 Nam /= TSS_Stream_Read and then
8006 Nam /= TSS_Stream_Write
8007 then
8008 raise Program_Error;
8009 end if;
8010
8011 -- Restriction No_Stream_Optimizations is not set, so we can go
8012 -- ahead and optimize using the block IO forms of the routines.
8013
8014 else
8015 if Nam = TSS_Stream_Input
8016 and then Is_Available (RE_Storage_Array_Input_Blk_IO)
8017 then
8018 return RTE (RE_Storage_Array_Input_Blk_IO);
8019
8020 elsif Nam = TSS_Stream_Output
8021 and then Is_Available (RE_Storage_Array_Output_Blk_IO)
8022 then
8023 return RTE (RE_Storage_Array_Output_Blk_IO);
8024
8025 elsif Nam = TSS_Stream_Read
8026 and then Is_Available (RE_Storage_Array_Read_Blk_IO)
8027 then
8028 return RTE (RE_Storage_Array_Read_Blk_IO);
8029
8030 elsif Nam = TSS_Stream_Write
8031 and then Is_Available (RE_Storage_Array_Write_Blk_IO)
8032 then
8033 return RTE (RE_Storage_Array_Write_Blk_IO);
8034
8035 elsif Nam /= TSS_Stream_Input and then
8036 Nam /= TSS_Stream_Output and then
8037 Nam /= TSS_Stream_Read and then
8038 Nam /= TSS_Stream_Write
8039 then
8040 raise Program_Error;
8041 end if;
8042 end if;
8043
8044 -- Stream_Element_Array as defined in package Ada.Streams
8045
8046 elsif Is_RTE (Base_Typ, RE_Stream_Element_Array) then
8047
8048 -- Case of No_Stream_Optimizations restriction active
8049
8050 if Restriction_Active (No_Stream_Optimizations) then
8051 if Nam = TSS_Stream_Input
8052 and then Is_Available (RE_Stream_Element_Array_Input)
8053 then
8054 return RTE (RE_Stream_Element_Array_Input);
8055
8056 elsif Nam = TSS_Stream_Output
8057 and then Is_Available (RE_Stream_Element_Array_Output)
8058 then
8059 return RTE (RE_Stream_Element_Array_Output);
8060
8061 elsif Nam = TSS_Stream_Read
8062 and then Is_Available (RE_Stream_Element_Array_Read)
8063 then
8064 return RTE (RE_Stream_Element_Array_Read);
8065
8066 elsif Nam = TSS_Stream_Write
8067 and then Is_Available (RE_Stream_Element_Array_Write)
8068 then
8069 return RTE (RE_Stream_Element_Array_Write);
8070
8071 elsif Nam /= TSS_Stream_Input and then
8072 Nam /= TSS_Stream_Output and then
8073 Nam /= TSS_Stream_Read and then
8074 Nam /= TSS_Stream_Write
8075 then
8076 raise Program_Error;
8077 end if;
8078
8079 -- Restriction No_Stream_Optimizations is not set, so we can go
8080 -- ahead and optimize using the block IO forms of the routines.
8081
8082 else
8083 if Nam = TSS_Stream_Input
8084 and then Is_Available (RE_Stream_Element_Array_Input_Blk_IO)
8085 then
8086 return RTE (RE_Stream_Element_Array_Input_Blk_IO);
8087
8088 elsif Nam = TSS_Stream_Output
8089 and then Is_Available (RE_Stream_Element_Array_Output_Blk_IO)
8090 then
8091 return RTE (RE_Stream_Element_Array_Output_Blk_IO);
8092
8093 elsif Nam = TSS_Stream_Read
8094 and then Is_Available (RE_Stream_Element_Array_Read_Blk_IO)
8095 then
8096 return RTE (RE_Stream_Element_Array_Read_Blk_IO);
8097
8098 elsif Nam = TSS_Stream_Write
8099 and then Is_Available (RE_Stream_Element_Array_Write_Blk_IO)
8100 then
8101 return RTE (RE_Stream_Element_Array_Write_Blk_IO);
8102
8103 elsif Nam /= TSS_Stream_Input and then
8104 Nam /= TSS_Stream_Output and then
8105 Nam /= TSS_Stream_Read and then
8106 Nam /= TSS_Stream_Write
8107 then
8108 raise Program_Error;
8109 end if;
8110 end if;
8111
21d27997
RD		 8112 -- String as defined in package Ada
8113
161c5cc5
AC		 8114 elsif Base_Typ = Standard_String then
8115
8116 -- Case of No_Stream_Optimizations restriction active
8117
585df50b 8118 if Restriction_Active (No_Stream_Optimizations) then
90878b12
AC		 8119 if Nam = TSS_Stream_Input
8120 and then Is_Available (RE_String_Input)
8121 then
585df50b
AC		 8122 return RTE (RE_String_Input);
8123
90878b12
AC		 8124 elsif Nam = TSS_Stream_Output
8125 and then Is_Available (RE_String_Output)
8126 then
585df50b
AC		 8127 return RTE (RE_String_Output);
8128
90878b12
AC		 8129 elsif Nam = TSS_Stream_Read
8130 and then Is_Available (RE_String_Read)
8131 then
585df50b 8132 return RTE (RE_String_Read);
21d27997 8133
90878b12
AC		 8134 elsif Nam = TSS_Stream_Write
8135 and then Is_Available (RE_String_Write)
8136 then
585df50b 8137 return RTE (RE_String_Write);
90878b12
AC		 8138
8139 elsif Nam /= TSS_Stream_Input and then
8140 Nam /= TSS_Stream_Output and then
8141 Nam /= TSS_Stream_Read and then
8142 Nam /= TSS_Stream_Write
8143 then
8144 raise Program_Error;
585df50b
AC		 8145 end if;
8146
161c5cc5
AC		 8147 -- Restriction No_Stream_Optimizations is not set, so we can go
8148 -- ahead and optimize using the block IO forms of the routines.
8149
585df50b 8150 else
90878b12
AC		 8151 if Nam = TSS_Stream_Input
8152 and then Is_Available (RE_String_Input_Blk_IO)
8153 then
585df50b 8154 return RTE (RE_String_Input_Blk_IO);
21d27997 8155
90878b12
AC		 8156 elsif Nam = TSS_Stream_Output
8157 and then Is_Available (RE_String_Output_Blk_IO)
8158 then
585df50b 8159 return RTE (RE_String_Output_Blk_IO);
21d27997 8160
90878b12
AC		 8161 elsif Nam = TSS_Stream_Read
8162 and then Is_Available (RE_String_Read_Blk_IO)
8163 then
585df50b
AC		 8164 return RTE (RE_String_Read_Blk_IO);
8165
90878b12
AC		 8166 elsif Nam = TSS_Stream_Write
8167 and then Is_Available (RE_String_Write_Blk_IO)
8168 then
585df50b 8169 return RTE (RE_String_Write_Blk_IO);
90878b12 8170
161c5cc5 8171 elsif Nam /= TSS_Stream_Input and then
90878b12 8172 Nam /= TSS_Stream_Output and then
161c5cc5 8173 Nam /= TSS_Stream_Read and then
90878b12
AC		 8174 Nam /= TSS_Stream_Write
8175 then
8176 raise Program_Error;
585df50b 8177 end if;
21d27997
RD		 8178 end if;
8179
8180 -- Wide_String as defined in package Ada
8181
b2c6b35f 8182 elsif Base_Typ = Standard_Wide_String then
161c5cc5
AC		 8183
8184 -- Case of No_Stream_Optimizations restriction active
8185
585df50b 8186 if Restriction_Active (No_Stream_Optimizations) then
90878b12
AC		 8187 if Nam = TSS_Stream_Input
8188 and then Is_Available (RE_Wide_String_Input)
8189 then
585df50b
AC		 8190 return RTE (RE_Wide_String_Input);
8191
90878b12
AC		 8192 elsif Nam = TSS_Stream_Output
8193 and then Is_Available (RE_Wide_String_Output)
8194 then
585df50b
AC		 8195 return RTE (RE_Wide_String_Output);
8196
90878b12
AC		 8197 elsif Nam = TSS_Stream_Read
8198 and then Is_Available (RE_Wide_String_Read)
8199 then
585df50b
AC		 8200 return RTE (RE_Wide_String_Read);
8201
90878b12
AC		 8202 elsif Nam = TSS_Stream_Write
8203 and then Is_Available (RE_Wide_String_Write)
8204 then
585df50b 8205 return RTE (RE_Wide_String_Write);
90878b12 8206
161c5cc5 8207 elsif Nam /= TSS_Stream_Input and then
90878b12 8208 Nam /= TSS_Stream_Output and then
161c5cc5 8209 Nam /= TSS_Stream_Read and then
90878b12
AC		 8210 Nam /= TSS_Stream_Write
8211 then
8212 raise Program_Error;
585df50b
AC		 8213 end if;
8214
161c5cc5
AC		 8215 -- Restriction No_Stream_Optimizations is not set, so we can go
8216 -- ahead and optimize using the block IO forms of the routines.
8217
585df50b 8218 else
90878b12
AC		 8219 if Nam = TSS_Stream_Input
8220 and then Is_Available (RE_Wide_String_Input_Blk_IO)
8221 then
585df50b 8222 return RTE (RE_Wide_String_Input_Blk_IO);
21d27997 8223
90878b12
AC		 8224 elsif Nam = TSS_Stream_Output
8225 and then Is_Available (RE_Wide_String_Output_Blk_IO)
8226 then
585df50b 8227 return RTE (RE_Wide_String_Output_Blk_IO);
21d27997 8228
90878b12
AC		 8229 elsif Nam = TSS_Stream_Read
8230 and then Is_Available (RE_Wide_String_Read_Blk_IO)
8231 then
585df50b 8232 return RTE (RE_Wide_String_Read_Blk_IO);
21d27997 8233
90878b12
AC		 8234 elsif Nam = TSS_Stream_Write
8235 and then Is_Available (RE_Wide_String_Write_Blk_IO)
8236 then
585df50b 8237 return RTE (RE_Wide_String_Write_Blk_IO);
90878b12 8238
161c5cc5 8239 elsif Nam /= TSS_Stream_Input and then
90878b12 8240 Nam /= TSS_Stream_Output and then
161c5cc5 8241 Nam /= TSS_Stream_Read and then
90878b12
AC		 8242 Nam /= TSS_Stream_Write
8243 then
8244 raise Program_Error;
585df50b 8245 end if;
21d27997
RD		 8246 end if;
8247
8248 -- Wide_Wide_String as defined in package Ada
8249
b2c6b35f 8250 elsif Base_Typ = Standard_Wide_Wide_String then
161c5cc5
AC		 8251
8252 -- Case of No_Stream_Optimizations restriction active
8253
585df50b 8254 if Restriction_Active (No_Stream_Optimizations) then
90878b12
AC		 8255 if Nam = TSS_Stream_Input
8256 and then Is_Available (RE_Wide_Wide_String_Input)
8257 then
585df50b
AC		 8258 return RTE (RE_Wide_Wide_String_Input);
8259
90878b12
AC		 8260 elsif Nam = TSS_Stream_Output
8261 and then Is_Available (RE_Wide_Wide_String_Output)
8262 then
585df50b 8263 return RTE (RE_Wide_Wide_String_Output);
21d27997 8264
90878b12
AC		 8265 elsif Nam = TSS_Stream_Read
8266 and then Is_Available (RE_Wide_Wide_String_Read)
8267 then
585df50b 8268 return RTE (RE_Wide_Wide_String_Read);
21d27997 8269
90878b12
AC		 8270 elsif Nam = TSS_Stream_Write
8271 and then Is_Available (RE_Wide_Wide_String_Write)
8272 then
585df50b 8273 return RTE (RE_Wide_Wide_String_Write);
90878b12 8274
161c5cc5 8275 elsif Nam /= TSS_Stream_Input and then
90878b12 8276 Nam /= TSS_Stream_Output and then
161c5cc5 8277 Nam /= TSS_Stream_Read and then
90878b12
AC		 8278 Nam /= TSS_Stream_Write
8279 then
8280 raise Program_Error;
585df50b 8281 end if;
21d27997 8282
161c5cc5
AC		 8283 -- Restriction No_Stream_Optimizations is not set, so we can go
8284 -- ahead and optimize using the block IO forms of the routines.
8285
585df50b 8286 else
90878b12
AC		 8287 if Nam = TSS_Stream_Input
8288 and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO)
8289 then
585df50b
AC		 8290 return RTE (RE_Wide_Wide_String_Input_Blk_IO);
8291
90878b12
AC		 8292 elsif Nam = TSS_Stream_Output
8293 and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO)
8294 then
585df50b
AC		 8295 return RTE (RE_Wide_Wide_String_Output_Blk_IO);
8296
90878b12
AC		 8297 elsif Nam = TSS_Stream_Read
8298 and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO)
8299 then
585df50b
AC		 8300 return RTE (RE_Wide_Wide_String_Read_Blk_IO);
8301
90878b12
AC		 8302 elsif Nam = TSS_Stream_Write
8303 and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO)
8304 then
585df50b 8305 return RTE (RE_Wide_Wide_String_Write_Blk_IO);
90878b12 8306
161c5cc5 8307 elsif Nam /= TSS_Stream_Input and then
90878b12 8308 Nam /= TSS_Stream_Output and then
161c5cc5 8309 Nam /= TSS_Stream_Read and then
90878b12
AC		 8310 Nam /= TSS_Stream_Write
8311 then
8312 raise Program_Error;
585df50b 8313 end if;
21d27997
RD		 8314 end if;
8315 end if;
8316 end if;
8317
161c5cc5 8318 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
fbf5a39b
AC		 8319 return Find_Prim_Op (Typ, Nam);
8320 else
8321 return Find_Inherited_TSS (Typ, Nam);
8322 end if;
8323 end Find_Stream_Subprogram;
8324
96d2756f
AC		 8325 ---------------
8326 -- Full_Base --
8327 ---------------
8328
8329 function Full_Base (T : Entity_Id) return Entity_Id is
8330 BT : Entity_Id;
8331
8332 begin
8333 BT := Base_Type (T);
8334
8335 if Is_Private_Type (BT)
8336 and then Present (Full_View (BT))
8337 then
8338 BT := Full_View (BT);
8339 end if;
8340
8341 return BT;
8342 end Full_Base;
8343
70482933
RK		 8344 -----------------------
8345 -- Get_Index_Subtype --
8346 -----------------------
8347
8348 function Get_Index_Subtype (N : Node_Id) return Node_Id is
8349 P_Type : Entity_Id := Etype (Prefix (N));
8350 Indx : Node_Id;
8351 J : Int;
8352
8353 begin
8354 if Is_Access_Type (P_Type) then
8355 P_Type := Designated_Type (P_Type);
8356 end if;
8357
8358 if No (Expressions (N)) then
8359 J := 1;
8360 else
8361 J := UI_To_Int (Expr_Value (First (Expressions (N))));
8362 end if;
8363
8364 Indx := First_Index (P_Type);
8365 while J > 1 loop
8366 Next_Index (Indx);
8367 J := J - 1;
8368 end loop;
8369
8370 return Etype (Indx);
8371 end Get_Index_Subtype;
8372
1d571f3b
AC		 8373 -------------------------------
8374 -- Get_Stream_Convert_Pragma --
8375 -------------------------------
8376
8377 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is
8378 Typ : Entity_Id;
8379 N : Node_Id;
8380
8381 begin
8382 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
8383 -- that a stream convert pragma for a tagged type is not inherited from
8384 -- its parent. Probably what is wrong here is that it is basically
8385 -- incorrect to consider a stream convert pragma to be a representation
8386 -- pragma at all ???
8387
8388 N := First_Rep_Item (Implementation_Base_Type (T));
8389 while Present (N) loop
e10dab7f 8390 if Nkind (N) = N_Pragma
6e759c2a 8391 and then Pragma_Name (N) = Name_Stream_Convert
e10dab7f 8392 then
1d571f3b
AC		 8393 -- For tagged types this pragma is not inherited, so we
8394 -- must verify that it is defined for the given type and
8395 -- not an ancestor.
8396
8397 Typ :=
8398 Entity (Expression (First (Pragma_Argument_Associations (N))));
8399
8400 if not Is_Tagged_Type (T)
8401 or else T = Typ
8402 or else (Is_Private_Type (Typ) and then T = Full_View (Typ))
8403 then
8404 return N;
8405 end if;
8406 end if;
8407
8408 Next_Rep_Item (N);
8409 end loop;
8410
8411 return Empty;
8412 end Get_Stream_Convert_Pragma;
8413
70482933
RK		 8414 ---------------------------------
8415 -- Is_Constrained_Packed_Array --
8416 ---------------------------------
8417
8418 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is
8419 Arr : Entity_Id := Typ;
8420
8421 begin
8422 if Is_Access_Type (Arr) then
8423 Arr := Designated_Type (Arr);
8424 end if;
8425
8426 return Is_Array_Type (Arr)
8427 and then Is_Constrained (Arr)
8ca597af 8428 and then Present (Packed_Array_Impl_Type (Arr));
70482933
RK		 8429 end Is_Constrained_Packed_Array;
8430
0669bebe
GB		 8431 ----------------------------------------
8432 -- Is_Inline_Floating_Point_Attribute --
8433 ----------------------------------------
8434
8435 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is
8436 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
8437
d18bbd25
AC		 8438 function Is_GCC_Target return Boolean;
8439 -- Return True if we are using a GCC target/back-end
8440 -- ??? Note: the implementation is kludgy/fragile
8441
8442 -------------------
8443 -- Is_GCC_Target --
8444 -------------------
8445
8446 function Is_GCC_Target return Boolean is
8447 begin
9a476d75 8448 return not CodePeer_Mode
c63a2ad6 8449 and then not Modify_Tree_For_C;
d18bbd25
AC		 8450 end Is_GCC_Target;
8451
b943a971 8452 -- Start of processing for Is_Inline_Floating_Point_Attribute
d18bbd25 8453
0669bebe 8454 begin
56af8688 8455 -- Machine and Model can be expanded by the GCC back end only
78433fec 8456
24228312 8457 if Id = Attribute_Machine or else Id = Attribute_Model then
f8f50235 8458 return Is_GCC_Target;
78433fec 8459
d18bbd25 8460 -- Remaining cases handled by all back ends are Rounding and Truncation
78433fec 8461 -- when appearing as the operand of a conversion to some integer type.
24228312
AC		 8462
8463 elsif Nkind (Parent (N)) /= N_Type_Conversion
0669bebe
GB		 8464 or else not Is_Integer_Type (Etype (Parent (N)))
8465 then
8466 return False;
8467 end if;
8468
78433fec
AC		 8469 -- Here we are in the integer conversion context
8470
8471 -- Very probably we should also recognize the cases of Machine_Rounding
8472 -- and unbiased rounding in this conversion context, but the back end is
8473 -- not yet prepared to handle these cases ???
0669bebe 8474
24228312 8475 return Id = Attribute_Rounding or else Id = Attribute_Truncation;
0669bebe
GB		 8476 end Is_Inline_Floating_Point_Attribute;
8477
70482933 8478end Exp_Attr;
GNU Compiler Collection
This page took 6.737838 seconds and 5 git commands to generate.