?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2010-07-27 Paolo Carlini <paolo.carlini@oracle.com>
[official-gcc/alias-decl.git] / gcc / ada / exp_strm.adb
blobddb1064c475aed880637a758f9f292f572c1f46a
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ S T R M --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. 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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Namet; use Namet;
29 with Nlists; use Nlists;
30 with Nmake; use Nmake;
31 with Opt; use Opt;
32 with Rtsfind; use Rtsfind;
33 with Sem_Aux; use Sem_Aux;
34 with Sem_Util; use Sem_Util;
35 with Sinfo; use Sinfo;
36 with Snames; use Snames;
37 with Stand; use Stand;
38 with Tbuild; use Tbuild;
39 with Ttypes; use Ttypes;
40 with Uintp; use Uintp;
41
42 package body Exp_Strm is
43
44 -----------------------
45 -- Local Subprograms --
46 -----------------------
47
48 procedure Build_Array_Read_Write_Procedure
49 (Nod : Node_Id;
50 Typ : Entity_Id;
51 Decl : out Node_Id;
52 Pnam : Entity_Id;
53 Nam : Name_Id);
54 -- Common routine shared to build either an array Read procedure or an
55 -- array Write procedure, Nam is Name_Read or Name_Write to select which.
56 -- Pnam is the defining identifier for the constructed procedure. The
57 -- other parameters are as for Build_Array_Read_Procedure except that
58 -- the first parameter Nod supplies the Sloc to be used to generate code.
59
60 procedure Build_Record_Read_Write_Procedure
61 (Loc : Source_Ptr;
62 Typ : Entity_Id;
63 Decl : out Node_Id;
64 Pnam : Entity_Id;
65 Nam : Name_Id);
66 -- Common routine shared to build a record Read Write procedure, Nam
67 -- is Name_Read or Name_Write to select which. Pnam is the defining
68 -- identifier for the constructed procedure. The other parameters are
69 -- as for Build_Record_Read_Procedure.
70
71 procedure Build_Stream_Function
72 (Loc : Source_Ptr;
73 Typ : Entity_Id;
74 Decl : out Node_Id;
75 Fnam : Entity_Id;
76 Decls : List_Id;
77 Stms : List_Id);
78 -- Called to build an array or record stream function. The first three
79 -- arguments are the same as Build_Record_Or_Elementary_Input_Function.
80 -- Decls and Stms are the declarations and statements for the body and
81 -- The parameter Fnam is the name of the constructed function.
82
83 function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean;
84 -- This function is used to test the type U_Type, to determine if it has
85 -- a standard representation from a streaming point of view. Standard means
86 -- that it has a standard representation (e.g. no enumeration rep clause),
87 -- and the size of the root type is the same as the streaming size (which
88 -- is defined as value specified by a Stream_Size clause if present, or
89 -- the Esize of U_Type if not).
90
91 function Make_Stream_Subprogram_Name
92 (Loc : Source_Ptr;
93 Typ : Entity_Id;
94 Nam : TSS_Name_Type) return Entity_Id;
95 -- Return the entity that identifies the stream subprogram for type Typ
96 -- that is identified by the given Nam. This procedure deals with the
97 -- difference between tagged types (where a single subprogram associated
98 -- with the type is generated) and all other cases (where a subprogram
99 -- is generated at the point of the stream attribute reference). The
100 -- Loc parameter is used as the Sloc of the created entity.
101
102 function Stream_Base_Type (E : Entity_Id) return Entity_Id;
103 -- Stream attributes work on the basis of the base type except for the
104 -- array case. For the array case, we do not go to the base type, but
105 -- to the first subtype if it is constrained. This avoids problems with
106 -- incorrect conversions in the packed array case. Stream_Base_Type is
107 -- exactly this function (returns the base type, unless we have an array
108 -- type whose first subtype is constrained, in which case it returns the
109 -- first subtype).
110
111 --------------------------------
112 -- Build_Array_Input_Function --
113 --------------------------------
114
115 -- The function we build looks like
116
117 -- function typSI[_nnn] (S : access RST) return Typ is
118 -- L1 : constant Index_Type_1 := Index_Type_1'Input (S);
119 -- H1 : constant Index_Type_1 := Index_Type_1'Input (S);
120 -- L2 : constant Index_Type_2 := Index_Type_2'Input (S);
121 -- H2 : constant Index_Type_2 := Index_Type_2'Input (S);
122 -- ..
123 -- Ln : constant Index_Type_n := Index_Type_n'Input (S);
124 -- Hn : constant Index_Type_n := Index_Type_n'Input (S);
125 --
126 -- V : Typ'Base (L1 .. H1, L2 .. H2, ... Ln .. Hn)
127
128 -- begin
129 -- Typ'Read (S, V);
130 -- return V;
131 -- end typSI[_nnn]
132
133 -- Note: the suffix [_nnn] is present for non-tagged types, where we
134 -- generate a local subprogram at the point of the occurrence of the
135 -- attribute reference, so the name must be unique.
136
137 procedure Build_Array_Input_Function
138 (Loc : Source_Ptr;
139 Typ : Entity_Id;
140 Decl : out Node_Id;
141 Fnam : out Entity_Id)
142 is
143 Dim : constant Pos := Number_Dimensions (Typ);
144 Lnam : Name_Id;
145 Hnam : Name_Id;
146 Decls : List_Id;
147 Ranges : List_Id;
148 Stms : List_Id;
149 Indx : Node_Id;
150
151 begin
152 Decls := New_List;
153 Ranges := New_List;
154 Indx := First_Index (Typ);
155
156 for J in 1 .. Dim loop
157 Lnam := New_External_Name ('L', J);
158 Hnam := New_External_Name ('H', J);
159
160 Append_To (Decls,
161 Make_Object_Declaration (Loc,
162 Defining_Identifier => Make_Defining_Identifier (Loc, Lnam),
163 Constant_Present => True,
164 Object_Definition => New_Occurrence_Of (Etype (Indx), Loc),
165 Expression =>
166 Make_Attribute_Reference (Loc,
167 Prefix =>
168 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
169 Attribute_Name => Name_Input,
170 Expressions => New_List (Make_Identifier (Loc, Name_S)))));
171
172 Append_To (Decls,
173 Make_Object_Declaration (Loc,
174 Defining_Identifier => Make_Defining_Identifier (Loc, Hnam),
175 Constant_Present => True,
176 Object_Definition =>
177 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
178 Expression =>
179 Make_Attribute_Reference (Loc,
180 Prefix =>
181 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
182 Attribute_Name => Name_Input,
183 Expressions => New_List (Make_Identifier (Loc, Name_S)))));
184
185 Append_To (Ranges,
186 Make_Range (Loc,
187 Low_Bound => Make_Identifier (Loc, Lnam),
188 High_Bound => Make_Identifier (Loc, Hnam)));
189
190 Next_Index (Indx);
191 end loop;
192
193 -- If the first subtype is constrained, use it directly. Otherwise
194 -- build a subtype indication with the proper bounds.
195
196 if Is_Constrained (Stream_Base_Type (Typ)) then
197 Append_To (Decls,
198 Make_Object_Declaration (Loc,
199 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
200 Object_Definition =>
201 New_Occurrence_Of (Stream_Base_Type (Typ), Loc)));
202 else
203 Append_To (Decls,
204 Make_Object_Declaration (Loc,
205 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
206 Object_Definition =>
207 Make_Subtype_Indication (Loc,
208 Subtype_Mark =>
209 New_Occurrence_Of (Stream_Base_Type (Typ), Loc),
210 Constraint =>
211 Make_Index_Or_Discriminant_Constraint (Loc,
212 Constraints => Ranges))));
213 end if;
214
215 Stms := New_List (
216 Make_Attribute_Reference (Loc,
217 Prefix => New_Occurrence_Of (Typ, Loc),
218 Attribute_Name => Name_Read,
219 Expressions => New_List (
220 Make_Identifier (Loc, Name_S),
221 Make_Identifier (Loc, Name_V))),
222
223 Make_Simple_Return_Statement (Loc,
224 Expression => Make_Identifier (Loc, Name_V)));
225
226 Fnam :=
227 Make_Defining_Identifier (Loc,
228 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Input));
229
230 Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
231 end Build_Array_Input_Function;
232
233 ----------------------------------
234 -- Build_Array_Output_Procedure --
235 ----------------------------------
236
237 procedure Build_Array_Output_Procedure
238 (Loc : Source_Ptr;
239 Typ : Entity_Id;
240 Decl : out Node_Id;
241 Pnam : out Entity_Id)
242 is
243 Stms : List_Id;
244 Indx : Node_Id;
245
246 begin
247 -- Build series of statements to output bounds
248
249 Indx := First_Index (Typ);
250 Stms := New_List;
251
252 for J in 1 .. Number_Dimensions (Typ) loop
253 Append_To (Stms,
254 Make_Attribute_Reference (Loc,
255 Prefix =>
256 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
257 Attribute_Name => Name_Write,
258 Expressions => New_List (
259 Make_Identifier (Loc, Name_S),
260 Make_Attribute_Reference (Loc,
261 Prefix => Make_Identifier (Loc, Name_V),
262 Attribute_Name => Name_First,
263 Expressions => New_List (
264 Make_Integer_Literal (Loc, J))))));
265
266 Append_To (Stms,
267 Make_Attribute_Reference (Loc,
268 Prefix =>
269 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
270 Attribute_Name => Name_Write,
271 Expressions => New_List (
272 Make_Identifier (Loc, Name_S),
273 Make_Attribute_Reference (Loc,
274 Prefix => Make_Identifier (Loc, Name_V),
275 Attribute_Name => Name_Last,
276 Expressions => New_List (
277 Make_Integer_Literal (Loc, J))))));
278
279 Next_Index (Indx);
280 end loop;
281
282 -- Append Write attribute to write array elements
283
284 Append_To (Stms,
285 Make_Attribute_Reference (Loc,
286 Prefix => New_Occurrence_Of (Typ, Loc),
287 Attribute_Name => Name_Write,
288 Expressions => New_List (
289 Make_Identifier (Loc, Name_S),
290 Make_Identifier (Loc, Name_V))));
291
292 Pnam :=
293 Make_Defining_Identifier (Loc,
294 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Output));
295
296 Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
297 end Build_Array_Output_Procedure;
298
299 --------------------------------
300 -- Build_Array_Read_Procedure --
301 --------------------------------
302
303 procedure Build_Array_Read_Procedure
304 (Nod : Node_Id;
305 Typ : Entity_Id;
306 Decl : out Node_Id;
307 Pnam : out Entity_Id)
308 is
309 Loc : constant Source_Ptr := Sloc (Nod);
310
311 begin
312 Pnam :=
313 Make_Defining_Identifier (Loc,
314 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
315 Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Read);
316 end Build_Array_Read_Procedure;
317
318 --------------------------------------
319 -- Build_Array_Read_Write_Procedure --
320 --------------------------------------
321
322 -- The form of the array read/write procedure is as follows:
323
324 -- procedure pnam (S : access RST, V : [out] Typ) is
325 -- begin
326 -- for L1 in V'Range (1) loop
327 -- for L2 in V'Range (2) loop
328 -- ...
329 -- for Ln in V'Range (n) loop
330 -- Component_Type'Read/Write (S, V (L1, L2, .. Ln));
331 -- end loop;
332 -- ..
333 -- end loop;
334 -- end loop
335 -- end pnam;
336
337 -- The out keyword for V is supplied in the Read case
338
339 procedure Build_Array_Read_Write_Procedure
340 (Nod : Node_Id;
341 Typ : Entity_Id;
342 Decl : out Node_Id;
343 Pnam : Entity_Id;
344 Nam : Name_Id)
345 is
346 Loc : constant Source_Ptr := Sloc (Nod);
347 Ndim : constant Pos := Number_Dimensions (Typ);
348 Ctyp : constant Entity_Id := Component_Type (Typ);
349
350 Stm : Node_Id;
351 Exl : List_Id;
352 RW : Entity_Id;
353
354 begin
355 -- First build the inner attribute call
356
357 Exl := New_List;
358
359 for J in 1 .. Ndim loop
360 Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', J)));
361 end loop;
362
363 Stm :=
364 Make_Attribute_Reference (Loc,
365 Prefix => New_Occurrence_Of (Stream_Base_Type (Ctyp), Loc),
366 Attribute_Name => Nam,
367 Expressions => New_List (
368 Make_Identifier (Loc, Name_S),
369 Make_Indexed_Component (Loc,
370 Prefix => Make_Identifier (Loc, Name_V),
371 Expressions => Exl)));
372
373 -- The corresponding stream attribute for the component type of the
374 -- array may be user-defined, and be frozen after the type for which
375 -- we are generating the stream subprogram. In that case, freeze the
376 -- stream attribute of the component type, whose declaration could not
377 -- generate any additional freezing actions in any case.
378
379 if Nam = Name_Read then
380 RW := TSS (Base_Type (Ctyp), TSS_Stream_Read);
381 else
382 RW := TSS (Base_Type (Ctyp), TSS_Stream_Write);
383 end if;
384
385 if Present (RW)
386 and then not Is_Frozen (RW)
387 then
388 Set_Is_Frozen (RW);
389 end if;
390
391 -- Now this is the big loop to wrap that statement up in a sequence
392 -- of loops. The first time around, Stm is the attribute call. The
393 -- second and subsequent times, Stm is an inner loop.
394
395 for J in 1 .. Ndim loop
396 Stm :=
397 Make_Implicit_Loop_Statement (Nod,
398 Iteration_Scheme =>
399 Make_Iteration_Scheme (Loc,
400 Loop_Parameter_Specification =>
401 Make_Loop_Parameter_Specification (Loc,
402 Defining_Identifier =>
403 Make_Defining_Identifier (Loc,
404 Chars => New_External_Name ('L', Ndim - J + 1)),
405
406 Discrete_Subtype_Definition =>
407 Make_Attribute_Reference (Loc,
408 Prefix => Make_Identifier (Loc, Name_V),
409 Attribute_Name => Name_Range,
410
411 Expressions => New_List (
412 Make_Integer_Literal (Loc, Ndim - J + 1))))),
413
414 Statements => New_List (Stm));
415
416 end loop;
417
418 Build_Stream_Procedure
419 (Loc, Typ, Decl, Pnam, New_List (Stm), Nam = Name_Read);
420 end Build_Array_Read_Write_Procedure;
421
422 ---------------------------------
423 -- Build_Array_Write_Procedure --
424 ---------------------------------
425
426 procedure Build_Array_Write_Procedure
427 (Nod : Node_Id;
428 Typ : Entity_Id;
429 Decl : out Node_Id;
430 Pnam : out Entity_Id)
431 is
432 Loc : constant Source_Ptr := Sloc (Nod);
433
434 begin
435 Pnam :=
436 Make_Defining_Identifier (Loc,
437 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
438 Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Write);
439 end Build_Array_Write_Procedure;
440
441 ---------------------------------
442 -- Build_Elementary_Input_Call --
443 ---------------------------------
444
445 function Build_Elementary_Input_Call (N : Node_Id) return Node_Id is
446 Loc : constant Source_Ptr := Sloc (N);
447 P_Type : constant Entity_Id := Entity (Prefix (N));
448 U_Type : constant Entity_Id := Underlying_Type (P_Type);
449 Rt_Type : constant Entity_Id := Root_Type (U_Type);
450 FST : constant Entity_Id := First_Subtype (U_Type);
451 Strm : constant Node_Id := First (Expressions (N));
452 Targ : constant Node_Id := Next (Strm);
453 P_Size : Uint;
454 Res : Node_Id;
455 Lib_RE : RE_Id;
456
457 begin
458 -- Compute the size of the stream element. This is either the size of
459 -- the first subtype or if given the size of the Stream_Size attribute.
460
461 if Has_Stream_Size_Clause (FST) then
462 P_Size := Static_Integer (Expression (Stream_Size_Clause (FST)));
463 else
464 P_Size := Esize (FST);
465 end if;
466
467 -- Check first for Boolean and Character. These are enumeration types,
468 -- but we treat them specially, since they may require special handling
469 -- in the transfer protocol. However, this special handling only applies
470 -- if they have standard representation, otherwise they are treated like
471 -- any other enumeration type.
472
473 if Rt_Type = Standard_Boolean
474 and then Has_Stream_Standard_Rep (U_Type)
475 then
476 Lib_RE := RE_I_B;
477
478 elsif Rt_Type = Standard_Character
479 and then Has_Stream_Standard_Rep (U_Type)
480 then
481 Lib_RE := RE_I_C;
482
483 elsif Rt_Type = Standard_Wide_Character
484 and then Has_Stream_Standard_Rep (U_Type)
485 then
486 Lib_RE := RE_I_WC;
487
488 elsif Rt_Type = Standard_Wide_Wide_Character
489 and then Has_Stream_Standard_Rep (U_Type)
490 then
491 Lib_RE := RE_I_WWC;
492
493 -- Floating point types
494
495 elsif Is_Floating_Point_Type (U_Type) then
496
497 -- Question: should we use P_Size or Rt_Type to distinguish between
498 -- possible floating point types? If a non-standard size or a stream
499 -- size is specified, then we should certainly use the size. But if
500 -- we have two types the same (notably Short_Float_Size = Float_Size
501 -- which is close to universally true, and Long_Long_Float_Size =
502 -- Long_Float_Size, true on most targets except the x86), then we
503 -- would really rather use the root type, so that if people want to
504 -- fiddle with System.Stream_Attributes to get inter-target portable
505 -- streams, they get the size they expect. Consider in particular the
506 -- case of a stream written on an x86, with 96-bit Long_Long_Float
507 -- being read into a non-x86 target with 64 bit Long_Long_Float. A
508 -- special version of System.Stream_Attributes can deal with this
509 -- provided the proper type is always used.
510
511 -- To deal with these two requirements we add the special checks
512 -- on equal sizes and use the root type to distinguish.
513
514 if P_Size <= Standard_Short_Float_Size
515 and then (Standard_Short_Float_Size /= Standard_Float_Size
516 or else Rt_Type = Standard_Short_Float)
517 then
518 Lib_RE := RE_I_SF;
519
520 elsif P_Size <= Standard_Float_Size then
521 Lib_RE := RE_I_F;
522
523 elsif P_Size <= Standard_Long_Float_Size
524 and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size
525 or else Rt_Type = Standard_Long_Float)
526 then
527 Lib_RE := RE_I_LF;
528
529 else
530 Lib_RE := RE_I_LLF;
531 end if;
532
533 -- Signed integer types. Also includes signed fixed-point types and
534 -- enumeration types with a signed representation.
535
536 -- Note on signed integer types. We do not consider types as signed for
537 -- this purpose if they have no negative numbers, or if they have biased
538 -- representation. The reason is that the value in either case basically
539 -- represents an unsigned value.
540
541 -- For example, consider:
542
543 -- type W is range 0 .. 2**32 - 1;
544 -- for W'Size use 32;
545
546 -- This is a signed type, but the representation is unsigned, and may
547 -- be outside the range of a 32-bit signed integer, so this must be
548 -- treated as 32-bit unsigned.
549
550 -- Similarly, if we have
551
552 -- type W is range -1 .. +254;
553 -- for W'Size use 8;
554
555 -- then the representation is unsigned
556
557 elsif not Is_Unsigned_Type (FST)
558 and then
559 (Is_Fixed_Point_Type (U_Type)
560 or else
561 Is_Enumeration_Type (U_Type)
562 or else
563 (Is_Signed_Integer_Type (U_Type)
564 and then not Has_Biased_Representation (FST)))
565 then
566 if P_Size <= Standard_Short_Short_Integer_Size then
567 Lib_RE := RE_I_SSI;
568
569 elsif P_Size <= Standard_Short_Integer_Size then
570 Lib_RE := RE_I_SI;
571
572 elsif P_Size <= Standard_Integer_Size then
573 Lib_RE := RE_I_I;
574
575 elsif P_Size <= Standard_Long_Integer_Size then
576 Lib_RE := RE_I_LI;
577
578 else
579 Lib_RE := RE_I_LLI;
580 end if;
581
582 -- Unsigned integer types, also includes unsigned fixed-point types
583 -- and enumeration types with an unsigned representation (note that
584 -- we know they are unsigned because we already tested for signed).
585
586 -- Also includes signed integer types that are unsigned in the sense
587 -- that they do not include negative numbers. See above for details.
588
589 elsif Is_Modular_Integer_Type (U_Type)
590 or else Is_Fixed_Point_Type (U_Type)
591 or else Is_Enumeration_Type (U_Type)
592 or else Is_Signed_Integer_Type (U_Type)
593 then
594 if P_Size <= Standard_Short_Short_Integer_Size then
595 Lib_RE := RE_I_SSU;
596
597 elsif P_Size <= Standard_Short_Integer_Size then
598 Lib_RE := RE_I_SU;
599
600 elsif P_Size <= Standard_Integer_Size then
601 Lib_RE := RE_I_U;
602
603 elsif P_Size <= Standard_Long_Integer_Size then
604 Lib_RE := RE_I_LU;
605
606 else
607 Lib_RE := RE_I_LLU;
608 end if;
609
610 else pragma Assert (Is_Access_Type (U_Type));
611 if P_Size > System_Address_Size then
612 Lib_RE := RE_I_AD;
613 else
614 Lib_RE := RE_I_AS;
615 end if;
616 end if;
617
618 -- Call the function, and do an unchecked conversion of the result
619 -- to the actual type of the prefix. If the target is a discriminant,
620 -- and we are in the body of the default implementation of a 'Read
621 -- attribute, set target type to force a constraint check (13.13.2(35)).
622 -- If the type of the discriminant is currently private, add another
623 -- unchecked conversion from the full view.
624
625 if Nkind (Targ) = N_Identifier
626 and then Is_Internal_Name (Chars (Targ))
627 and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read)
628 then
629 Res :=
630 Unchecked_Convert_To (Base_Type (U_Type),
631 Make_Function_Call (Loc,
632 Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
633 Parameter_Associations => New_List (
634 Relocate_Node (Strm))));
635
636 Set_Do_Range_Check (Res);
637 if Base_Type (P_Type) /= Base_Type (U_Type) then
638 Res := Unchecked_Convert_To (Base_Type (P_Type), Res);
639 end if;
640
641 return Res;
642
643 else
644 return
645 Unchecked_Convert_To (P_Type,
646 Make_Function_Call (Loc,
647 Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
648 Parameter_Associations => New_List (
649 Relocate_Node (Strm))));
650 end if;
651 end Build_Elementary_Input_Call;
652
653 ---------------------------------
654 -- Build_Elementary_Write_Call --
655 ---------------------------------
656
657 function Build_Elementary_Write_Call (N : Node_Id) return Node_Id is
658 Loc : constant Source_Ptr := Sloc (N);
659 P_Type : constant Entity_Id := Entity (Prefix (N));
660 U_Type : constant Entity_Id := Underlying_Type (P_Type);
661 Rt_Type : constant Entity_Id := Root_Type (U_Type);
662 FST : constant Entity_Id := First_Subtype (U_Type);
663 Strm : constant Node_Id := First (Expressions (N));
664 Item : constant Node_Id := Next (Strm);
665 P_Size : Uint;
666 Lib_RE : RE_Id;
667 Libent : Entity_Id;
668
669 begin
670 -- Compute the size of the stream element. This is either the size of
671 -- the first subtype or if given the size of the Stream_Size attribute.
672
673 if Has_Stream_Size_Clause (FST) then
674 P_Size := Static_Integer (Expression (Stream_Size_Clause (FST)));
675 else
676 P_Size := Esize (FST);
677 end if;
678
679 -- Find the routine to be called
680
681 -- Check for First Boolean and Character. These are enumeration types,
682 -- but we treat them specially, since they may require special handling
683 -- in the transfer protocol. However, this special handling only applies
684 -- if they have standard representation, otherwise they are treated like
685 -- any other enumeration type.
686
687 if Rt_Type = Standard_Boolean
688 and then Has_Stream_Standard_Rep (U_Type)
689 then
690 Lib_RE := RE_W_B;
691
692 elsif Rt_Type = Standard_Character
693 and then Has_Stream_Standard_Rep (U_Type)
694 then
695 Lib_RE := RE_W_C;
696
697 elsif Rt_Type = Standard_Wide_Character
698 and then Has_Stream_Standard_Rep (U_Type)
699 then
700 Lib_RE := RE_W_WC;
701
702 elsif Rt_Type = Standard_Wide_Wide_Character
703 and then Has_Stream_Standard_Rep (U_Type)
704 then
705 Lib_RE := RE_W_WWC;
706
707 -- Floating point types
708
709 elsif Is_Floating_Point_Type (U_Type) then
710
711 -- Question: should we use P_Size or Rt_Type to distinguish between
712 -- possible floating point types? If a non-standard size or a stream
713 -- size is specified, then we should certainly use the size. But if
714 -- we have two types the same (notably Short_Float_Size = Float_Size
715 -- which is close to universally true, and Long_Long_Float_Size =
716 -- Long_Float_Size, true on most targets except the x86), then we
717 -- would really rather use the root type, so that if people want to
718 -- fiddle with System.Stream_Attributes to get inter-target portable
719 -- streams, they get the size they expect. Consider in particular the
720 -- case of a stream written on an x86, with 96-bit Long_Long_Float
721 -- being read into a non-x86 target with 64 bit Long_Long_Float. A
722 -- special version of System.Stream_Attributes can deal with this
723 -- provided the proper type is always used.
724
725 -- To deal with these two requirements we add the special checks
726 -- on equal sizes and use the root type to distinguish.
727
728 if P_Size <= Standard_Short_Float_Size
729 and then (Standard_Short_Float_Size /= Standard_Float_Size
730 or else Rt_Type = Standard_Short_Float)
731 then
732 Lib_RE := RE_W_SF;
733
734 elsif P_Size <= Standard_Float_Size then
735 Lib_RE := RE_W_F;
736
737 elsif P_Size <= Standard_Long_Float_Size
738 and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size
739 or else Rt_Type = Standard_Long_Float)
740 then
741 Lib_RE := RE_W_LF;
742
743 else
744 Lib_RE := RE_W_LLF;
745 end if;
746
747 -- Signed integer types. Also includes signed fixed-point types and
748 -- signed enumeration types share this circuitry.
749
750 -- Note on signed integer types. We do not consider types as signed for
751 -- this purpose if they have no negative numbers, or if they have biased
752 -- representation. The reason is that the value in either case basically
753 -- represents an unsigned value.
754
755 -- For example, consider:
756
757 -- type W is range 0 .. 2**32 - 1;
758 -- for W'Size use 32;
759
760 -- This is a signed type, but the representation is unsigned, and may
761 -- be outside the range of a 32-bit signed integer, so this must be
762 -- treated as 32-bit unsigned.
763
764 -- Similarly, the representation is also unsigned if we have:
765
766 -- type W is range -1 .. +254;
767 -- for W'Size use 8;
768
769 -- forcing a biased and unsigned representation
770
771 elsif not Is_Unsigned_Type (FST)
772 and then
773 (Is_Fixed_Point_Type (U_Type)
774 or else
775 Is_Enumeration_Type (U_Type)
776 or else
777 (Is_Signed_Integer_Type (U_Type)
778 and then not Has_Biased_Representation (FST)))
779 then
780 if P_Size <= Standard_Short_Short_Integer_Size then
781 Lib_RE := RE_W_SSI;
782 elsif P_Size <= Standard_Short_Integer_Size then
783 Lib_RE := RE_W_SI;
784 elsif P_Size <= Standard_Integer_Size then
785 Lib_RE := RE_W_I;
786 elsif P_Size <= Standard_Long_Integer_Size then
787 Lib_RE := RE_W_LI;
788 else
789 Lib_RE := RE_W_LLI;
790 end if;
791
792 -- Unsigned integer types, also includes unsigned fixed-point types
793 -- and unsigned enumeration types (note we know they are unsigned
794 -- because we already tested for signed above).
795
796 -- Also includes signed integer types that are unsigned in the sense
797 -- that they do not include negative numbers. See above for details.
798
799 elsif Is_Modular_Integer_Type (U_Type)
800 or else Is_Fixed_Point_Type (U_Type)
801 or else Is_Enumeration_Type (U_Type)
802 or else Is_Signed_Integer_Type (U_Type)
803 then
804 if P_Size <= Standard_Short_Short_Integer_Size then
805 Lib_RE := RE_W_SSU;
806 elsif P_Size <= Standard_Short_Integer_Size then
807 Lib_RE := RE_W_SU;
808 elsif P_Size <= Standard_Integer_Size then
809 Lib_RE := RE_W_U;
810 elsif P_Size <= Standard_Long_Integer_Size then
811 Lib_RE := RE_W_LU;
812 else
813 Lib_RE := RE_W_LLU;
814 end if;
815
816 else pragma Assert (Is_Access_Type (U_Type));
817
818 if P_Size > System_Address_Size then
819 Lib_RE := RE_W_AD;
820 else
821 Lib_RE := RE_W_AS;
822 end if;
823 end if;
824
825 -- Unchecked-convert parameter to the required type (i.e. the type of
826 -- the corresponding parameter, and call the appropriate routine.
827
828 Libent := RTE (Lib_RE);
829
830 return
831 Make_Procedure_Call_Statement (Loc,
832 Name => New_Occurrence_Of (Libent, Loc),
833 Parameter_Associations => New_List (
834 Relocate_Node (Strm),
835 Unchecked_Convert_To (Etype (Next_Formal (First_Formal (Libent))),
836 Relocate_Node (Item))));
837 end Build_Elementary_Write_Call;
838
839 -----------------------------------------
840 -- Build_Mutable_Record_Read_Procedure --
841 -----------------------------------------
842
843 procedure Build_Mutable_Record_Read_Procedure
844 (Loc : Source_Ptr;
845 Typ : Entity_Id;
846 Decl : out Node_Id;
847 Pnam : out Entity_Id)
848 is
849 Out_Formal : Node_Id;
850 -- Expression denoting the out formal parameter
851
852 Dcls : constant List_Id := New_List;
853 -- Declarations for the 'Read body
854
855 Stms : List_Id := New_List;
856 -- Statements for the 'Read body
857
858 Disc : Entity_Id;
859 -- Entity of the discriminant being processed
860
861 Tmp_For_Disc : Entity_Id;
862 -- Temporary object used to read the value of Disc
863
864 Tmps_For_Discs : constant List_Id := New_List;
865 -- List of object declarations for temporaries holding the read values
866 -- for the discriminants.
867
868 Cstr : constant List_Id := New_List;
869 -- List of constraints to be applied on temporary record
870
871 Discriminant_Checks : constant List_Id := New_List;
872 -- List of discriminant checks to be performed if the actual object
873 -- is constrained.
874
875 Tmp : constant Entity_Id := Make_Defining_Identifier (Loc, Name_V);
876 -- Temporary record must hide formal (assignments to components of the
877 -- record are always generated with V as the identifier for the record).
878
879 Constrained_Stms : List_Id := New_List;
880 -- Statements within the block where we have the constrained temporary
881
882 begin
883
884 Disc := First_Discriminant (Typ);
885
886 -- A mutable type cannot be a tagged type, so we generate a new name
887 -- for the stream procedure.
888
889 Pnam :=
890 Make_Defining_Identifier (Loc,
891 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
892
893 Out_Formal :=
894 Make_Selected_Component (Loc,
895 Prefix => New_Occurrence_Of (Pnam, Loc),
896 Selector_Name => Make_Identifier (Loc, Name_V));
897
898 -- Generate Reads for the discriminants of the type. The discriminants
899 -- need to be read before the rest of the components, so that
900 -- variants are initialized correctly. The discriminants must be read
901 -- into temporary variables so an incomplete Read (interrupted by an
902 -- exception, for example) does not alter the passed object.
903
904 while Present (Disc) loop
905 Tmp_For_Disc := Make_Defining_Identifier (Loc,
906 New_External_Name (Chars (Disc), "D"));
907
908 Append_To (Tmps_For_Discs,
909 Make_Object_Declaration (Loc,
910 Defining_Identifier => Tmp_For_Disc,
911 Object_Definition => New_Occurrence_Of (Etype (Disc), Loc)));
912 Set_No_Initialization (Last (Tmps_For_Discs));
913
914 Append_To (Stms,
915 Make_Attribute_Reference (Loc,
916 Prefix => New_Occurrence_Of (Etype (Disc), Loc),
917 Attribute_Name => Name_Read,
918 Expressions => New_List (
919 Make_Identifier (Loc, Name_S),
920 New_Occurrence_Of (Tmp_For_Disc, Loc))));
921
922 Append_To (Cstr,
923 Make_Discriminant_Association (Loc,
924 Selector_Names => New_List (New_Occurrence_Of (Disc, Loc)),
925 Expression => New_Occurrence_Of (Tmp_For_Disc, Loc)));
926
927 Append_To (Discriminant_Checks,
928 Make_Raise_Constraint_Error (Loc,
929 Condition =>
930 Make_Op_Ne (Loc,
931 Left_Opnd => New_Occurrence_Of (Tmp_For_Disc, Loc),
932 Right_Opnd =>
933 Make_Selected_Component (Loc,
934 Prefix => New_Copy_Tree (Out_Formal),
935 Selector_Name => New_Occurrence_Of (Disc, Loc))),
936 Reason => CE_Discriminant_Check_Failed));
937 Next_Discriminant (Disc);
938 end loop;
939
940 -- Generate reads for the components of the record (including
941 -- those that depend on discriminants).
942
943 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
944
945 -- If Typ has controlled components (i.e. if it is classwide
946 -- or Has_Controlled), or components constrained using the discriminants
947 -- of Typ, then we need to ensure that all component assignments
948 -- are performed on an object that has been appropriately constrained
949 -- prior to being initialized. To this effect, we wrap the component
950 -- assignments in a block where V is a constrained temporary.
951
952 Append_To (Dcls,
953 Make_Object_Declaration (Loc,
954 Defining_Identifier => Tmp,
955 Object_Definition =>
956 Make_Subtype_Indication (Loc,
957 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
958 Constraint =>
959 Make_Index_Or_Discriminant_Constraint (Loc,
960 Constraints => Cstr))));
961
962 Constrained_Stms := Statements (Handled_Statement_Sequence (Decl));
963 Append_To (Stms,
964 Make_Block_Statement (Loc,
965 Declarations => Dcls,
966 Handled_Statement_Sequence => Parent (Constrained_Stms)));
967
968 Append_To (Constrained_Stms,
969 Make_Implicit_If_Statement (Pnam,
970 Condition =>
971 Make_Attribute_Reference (Loc,
972 Prefix => New_Copy_Tree (Out_Formal),
973 Attribute_Name => Name_Constrained),
974 Then_Statements => Discriminant_Checks));
975
976 Append_To (Constrained_Stms,
977 Make_Assignment_Statement (Loc,
978 Name => Out_Formal,
979 Expression => Make_Identifier (Loc, Name_V)));
980
981 if Is_Unchecked_Union (Typ) then
982
983 -- If this is an unchecked union, the stream procedure is erroneous,
984 -- because there are no discriminants to read.
985
986 -- This should generate a warning ???
987
988 Stms :=
989 New_List (
990 Make_Raise_Program_Error (Loc,
991 Reason => PE_Unchecked_Union_Restriction));
992 end if;
993
994 Set_Declarations (Decl, Tmps_For_Discs);
995 Set_Handled_Statement_Sequence (Decl,
996 Make_Handled_Sequence_Of_Statements (Loc,
997 Statements => Stms));
998 end Build_Mutable_Record_Read_Procedure;
999
1000 ------------------------------------------
1001 -- Build_Mutable_Record_Write_Procedure --
1002 ------------------------------------------
1003
1004 procedure Build_Mutable_Record_Write_Procedure
1005 (Loc : Source_Ptr;
1006 Typ : Entity_Id;
1007 Decl : out Node_Id;
1008 Pnam : out Entity_Id)
1009 is
1010 Stms : List_Id;
1011 Disc : Entity_Id;
1012 D_Ref : Node_Id;
1013
1014 begin
1015 Stms := New_List;
1016 Disc := First_Discriminant (Typ);
1017
1018 -- Generate Writes for the discriminants of the type
1019 -- If the type is an unchecked union, use the default values of
1020 -- the discriminants, because they are not stored.
1021
1022 while Present (Disc) loop
1023 if Is_Unchecked_Union (Typ) then
1024 D_Ref :=
1025 New_Copy_Tree (Discriminant_Default_Value (Disc));
1026 else
1027 D_Ref :=
1028 Make_Selected_Component (Loc,
1029 Prefix => Make_Identifier (Loc, Name_V),
1030 Selector_Name => New_Occurrence_Of (Disc, Loc));
1031 end if;
1032
1033 Append_To (Stms,
1034 Make_Attribute_Reference (Loc,
1035 Prefix => New_Occurrence_Of (Etype (Disc), Loc),
1036 Attribute_Name => Name_Write,
1037 Expressions => New_List (
1038 Make_Identifier (Loc, Name_S),
1039 D_Ref)));
1040
1041 Next_Discriminant (Disc);
1042 end loop;
1043
1044 -- A mutable type cannot be a tagged type, so we generate a new name
1045 -- for the stream procedure.
1046
1047 Pnam :=
1048 Make_Defining_Identifier (Loc,
1049 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
1050 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
1051
1052 -- Write the discriminants before the rest of the components, so
1053 -- that discriminant values are properly set of variants, etc.
1054
1055 if Is_Non_Empty_List (
1056 Statements (Handled_Statement_Sequence (Decl)))
1057 then
1058 Insert_List_Before
1059 (First (Statements (Handled_Statement_Sequence (Decl))), Stms);
1060 else
1061 Set_Statements (Handled_Statement_Sequence (Decl), Stms);
1062 end if;
1063 end Build_Mutable_Record_Write_Procedure;
1064
1065 -----------------------------------------------
1066 -- Build_Record_Or_Elementary_Input_Function --
1067 -----------------------------------------------
1068
1069 -- The function we build looks like
1070
1071 -- function InputN (S : access RST) return Typ is
1072 -- C1 : constant Disc_Type_1;
1073 -- Discr_Type_1'Read (S, C1);
1074 -- C2 : constant Disc_Type_2;
1075 -- Discr_Type_2'Read (S, C2);
1076 -- ...
1077 -- Cn : constant Disc_Type_n;
1078 -- Discr_Type_n'Read (S, Cn);
1079 -- V : Typ (C1, C2, .. Cn)
1080
1081 -- begin
1082 -- Typ'Read (S, V);
1083 -- return V;
1084 -- end InputN
1085
1086 -- The discriminants are of course only present in the case of a record
1087 -- with discriminants. In the case of a record with no discriminants, or
1088 -- an elementary type, then no Cn constants are defined.
1089
1090 procedure Build_Record_Or_Elementary_Input_Function
1091 (Loc : Source_Ptr;
1092 Typ : Entity_Id;
1093 Decl : out Node_Id;
1094 Fnam : out Entity_Id)
1095 is
1096 Cn : Name_Id;
1097 J : Pos;
1098 Decls : List_Id;
1099 Constr : List_Id;
1100 Obj_Decl : Node_Id;
1101 Stms : List_Id;
1102 Discr : Entity_Id;
1103 Odef : Node_Id;
1104
1105 begin
1106 Decls := New_List;
1107 Constr := New_List;
1108
1109 J := 1;
1110
1111 if Has_Discriminants (Typ) then
1112 Discr := First_Discriminant (Typ);
1113
1114 while Present (Discr) loop
1115 Cn := New_External_Name ('C', J);
1116
1117 Decl :=
1118 Make_Object_Declaration (Loc,
1119 Defining_Identifier => Make_Defining_Identifier (Loc, Cn),
1120 Object_Definition =>
1121 New_Occurrence_Of (Etype (Discr), Loc));
1122
1123 -- If this is an access discriminant, do not perform default
1124 -- initialization. The discriminant is about to get its value
1125 -- from Read, and if the type is null excluding we do not want
1126 -- spurious warnings on an initial null value.
1127
1128 if Is_Access_Type (Etype (Discr)) then
1129 Set_No_Initialization (Decl);
1130 end if;
1131
1132 Append_To (Decls, Decl);
1133 Append_To (Decls,
1134 Make_Attribute_Reference (Loc,
1135 Prefix => New_Occurrence_Of (Etype (Discr), Loc),
1136 Attribute_Name => Name_Read,
1137 Expressions => New_List (
1138 Make_Identifier (Loc, Name_S),
1139 Make_Identifier (Loc, Cn))));
1140
1141 Append_To (Constr, Make_Identifier (Loc, Cn));
1142
1143 Next_Discriminant (Discr);
1144 J := J + 1;
1145 end loop;
1146
1147 Odef :=
1148 Make_Subtype_Indication (Loc,
1149 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
1150 Constraint =>
1151 Make_Index_Or_Discriminant_Constraint (Loc,
1152 Constraints => Constr));
1153
1154 -- If no discriminants, then just use the type with no constraint
1155
1156 else
1157 Odef := New_Occurrence_Of (Typ, Loc);
1158 end if;
1159
1160 -- For Ada 2005 we create an extended return statement encapsulating
1161 -- the result object and 'Read call, which is needed in general for
1162 -- proper handling of build-in-place results (such as when the result
1163 -- type is inherently limited).
1164
1165 -- Perhaps we should just generate an extended return in all cases???
1166
1167 Obj_Decl :=
1168 Make_Object_Declaration (Loc,
1169 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1170 Object_Definition => Odef);
1171
1172 -- If the type is an access type, do not perform default initialization.
1173 -- The object is about to get its value from Read, and if the type is
1174 -- null excluding we do not want spurious warnings on an initial null.
1175
1176 if Is_Access_Type (Typ) then
1177 Set_No_Initialization (Obj_Decl);
1178 end if;
1179
1180 if Ada_Version >= Ada_05 then
1181 Stms := New_List (
1182 Make_Extended_Return_Statement (Loc,
1183 Return_Object_Declarations => New_List (Obj_Decl),
1184 Handled_Statement_Sequence =>
1185 Make_Handled_Sequence_Of_Statements (Loc,
1186 New_List (Make_Attribute_Reference (Loc,
1187 Prefix => New_Occurrence_Of (Typ, Loc),
1188 Attribute_Name => Name_Read,
1189 Expressions => New_List (
1190 Make_Identifier (Loc, Name_S),
1191 Make_Identifier (Loc, Name_V)))))));
1192
1193 else
1194 Append_To (Decls, Obj_Decl);
1195
1196 Stms := New_List (
1197 Make_Attribute_Reference (Loc,
1198 Prefix => New_Occurrence_Of (Typ, Loc),
1199 Attribute_Name => Name_Read,
1200 Expressions => New_List (
1201 Make_Identifier (Loc, Name_S),
1202 Make_Identifier (Loc, Name_V))),
1203
1204 Make_Simple_Return_Statement (Loc,
1205 Expression => Make_Identifier (Loc, Name_V)));
1206 end if;
1207
1208 Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input);
1209
1210 Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
1211 end Build_Record_Or_Elementary_Input_Function;
1212
1213 -------------------------------------------------
1214 -- Build_Record_Or_Elementary_Output_Procedure --
1215 -------------------------------------------------
1216
1217 procedure Build_Record_Or_Elementary_Output_Procedure
1218 (Loc : Source_Ptr;
1219 Typ : Entity_Id;
1220 Decl : out Node_Id;
1221 Pnam : out Entity_Id)
1222 is
1223 Stms : List_Id;
1224 Disc : Entity_Id;
1225 Disc_Ref : Node_Id;
1226
1227 begin
1228 Stms := New_List;
1229
1230 -- Note that of course there will be no discriminants for the
1231 -- elementary type case, so Has_Discriminants will be False.
1232
1233 if Has_Discriminants (Typ) then
1234 Disc := First_Discriminant (Typ);
1235
1236 while Present (Disc) loop
1237
1238 -- If the type is an unchecked union, it must have default
1239 -- discriminants (this is checked earlier), and those defaults
1240 -- are written out to the stream.
1241
1242 if Is_Unchecked_Union (Typ) then
1243 Disc_Ref := New_Copy_Tree (Discriminant_Default_Value (Disc));
1244
1245 else
1246 Disc_Ref :=
1247 Make_Selected_Component (Loc,
1248 Prefix => Make_Identifier (Loc, Name_V),
1249 Selector_Name => New_Occurrence_Of (Disc, Loc));
1250 end if;
1251
1252 Append_To (Stms,
1253 Make_Attribute_Reference (Loc,
1254 Prefix =>
1255 New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc),
1256 Attribute_Name => Name_Write,
1257 Expressions => New_List (
1258 Make_Identifier (Loc, Name_S),
1259 Disc_Ref)));
1260
1261 Next_Discriminant (Disc);
1262 end loop;
1263 end if;
1264
1265 Append_To (Stms,
1266 Make_Attribute_Reference (Loc,
1267 Prefix => New_Occurrence_Of (Typ, Loc),
1268 Attribute_Name => Name_Write,
1269 Expressions => New_List (
1270 Make_Identifier (Loc, Name_S),
1271 Make_Identifier (Loc, Name_V))));
1272
1273 Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output);
1274
1275 Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
1276 end Build_Record_Or_Elementary_Output_Procedure;
1277
1278 ---------------------------------
1279 -- Build_Record_Read_Procedure --
1280 ---------------------------------
1281
1282 procedure Build_Record_Read_Procedure
1283 (Loc : Source_Ptr;
1284 Typ : Entity_Id;
1285 Decl : out Node_Id;
1286 Pnam : out Entity_Id)
1287 is
1288 begin
1289 Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Read);
1290 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
1291 end Build_Record_Read_Procedure;
1292
1293 ---------------------------------------
1294 -- Build_Record_Read_Write_Procedure --
1295 ---------------------------------------
1296
1297 -- The form of the record read/write procedure is as shown by the
1298 -- following example for a case with one discriminant case variant:
1299
1300 -- procedure pnam (S : access RST, V : [out] Typ) is
1301 -- begin
1302 -- Component_Type'Read/Write (S, V.component);
1303 -- Component_Type'Read/Write (S, V.component);
1304 -- ...
1305 -- Component_Type'Read/Write (S, V.component);
1306 --
1307 -- case V.discriminant is
1308 -- when choices =>
1309 -- Component_Type'Read/Write (S, V.component);
1310 -- Component_Type'Read/Write (S, V.component);
1311 -- ...
1312 -- Component_Type'Read/Write (S, V.component);
1313 --
1314 -- when choices =>
1315 -- Component_Type'Read/Write (S, V.component);
1316 -- Component_Type'Read/Write (S, V.component);
1317 -- ...
1318 -- Component_Type'Read/Write (S, V.component);
1319 -- ...
1320 -- end case;
1321 -- end pnam;
1322
1323 -- The out keyword for V is supplied in the Read case
1324
1325 procedure Build_Record_Read_Write_Procedure
1326 (Loc : Source_Ptr;
1327 Typ : Entity_Id;
1328 Decl : out Node_Id;
1329 Pnam : Entity_Id;
1330 Nam : Name_Id)
1331 is
1332 Rdef : Node_Id;
1333 Stms : List_Id;
1334 Typt : Entity_Id;
1335
1336 In_Limited_Extension : Boolean := False;
1337 -- Set to True while processing the record extension definition
1338 -- for an extension of a limited type (for which an ancestor type
1339 -- has an explicit Nam attribute definition).
1340
1341 function Make_Component_List_Attributes (CL : Node_Id) return List_Id;
1342 -- Returns a sequence of attributes to process the components that
1343 -- are referenced in the given component list.
1344
1345 function Make_Field_Attribute (C : Entity_Id) return Node_Id;
1346 -- Given C, the entity for a discriminant or component, build
1347 -- an attribute for the corresponding field values.
1348
1349 function Make_Field_Attributes (Clist : List_Id) return List_Id;
1350 -- Given Clist, a component items list, construct series of attributes
1351 -- for fieldwise processing of the corresponding components.
1352
1353 ------------------------------------
1354 -- Make_Component_List_Attributes --
1355 ------------------------------------
1356
1357 function Make_Component_List_Attributes (CL : Node_Id) return List_Id is
1358 CI : constant List_Id := Component_Items (CL);
1359 VP : constant Node_Id := Variant_Part (CL);
1360
1361 Result : List_Id;
1362 Alts : List_Id;
1363 V : Node_Id;
1364 DC : Node_Id;
1365 DCH : List_Id;
1366 D_Ref : Node_Id;
1367
1368 begin
1369 Result := Make_Field_Attributes (CI);
1370
1371 if Present (VP) then
1372 Alts := New_List;
1373
1374 V := First_Non_Pragma (Variants (VP));
1375 while Present (V) loop
1376 DCH := New_List;
1377
1378 DC := First (Discrete_Choices (V));
1379 while Present (DC) loop
1380 Append_To (DCH, New_Copy_Tree (DC));
1381 Next (DC);
1382 end loop;
1383
1384 Append_To (Alts,
1385 Make_Case_Statement_Alternative (Loc,
1386 Discrete_Choices => DCH,
1387 Statements =>
1388 Make_Component_List_Attributes (Component_List (V))));
1389 Next_Non_Pragma (V);
1390 end loop;
1391
1392 -- Note: in the following, we make sure that we use new occurrence
1393 -- of for the selector, since there are cases in which we make a
1394 -- reference to a hidden discriminant that is not visible.
1395
1396 -- If the enclosing record is an unchecked_union, we use the
1397 -- default expressions for the discriminant (it must exist)
1398 -- because we cannot generate a reference to it, given that
1399 -- it is not stored.
1400
1401 if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then
1402 D_Ref :=
1403 New_Copy_Tree
1404 (Discriminant_Default_Value (Entity (Name (VP))));
1405 else
1406 D_Ref :=
1407 Make_Selected_Component (Loc,
1408 Prefix => Make_Identifier (Loc, Name_V),
1409 Selector_Name =>
1410 New_Occurrence_Of (Entity (Name (VP)), Loc));
1411 end if;
1412
1413 Append_To (Result,
1414 Make_Case_Statement (Loc,
1415 Expression => D_Ref,
1416 Alternatives => Alts));
1417 end if;
1418
1419 return Result;
1420 end Make_Component_List_Attributes;
1421
1422 --------------------------
1423 -- Make_Field_Attribute --
1424 --------------------------
1425
1426 function Make_Field_Attribute (C : Entity_Id) return Node_Id is
1427 Field_Typ : constant Entity_Id := Stream_Base_Type (Etype (C));
1428
1429 TSS_Names : constant array (Name_Input .. Name_Write) of
1430 TSS_Name_Type :=
1431 (Name_Read => TSS_Stream_Read,
1432 Name_Write => TSS_Stream_Write,
1433 Name_Input => TSS_Stream_Input,
1434 Name_Output => TSS_Stream_Output,
1435 others => TSS_Null);
1436 pragma Assert (TSS_Names (Nam) /= TSS_Null);
1437
1438 begin
1439 if In_Limited_Extension
1440 and then Is_Limited_Type (Field_Typ)
1441 and then No (Find_Inherited_TSS (Field_Typ, TSS_Names (Nam)))
1442 then
1443 -- The declaration is illegal per 13.13.2(9/1), and this is
1444 -- enforced in Exp_Ch3.Check_Stream_Attributes. Keep the caller
1445 -- happy by returning a null statement.
1446
1447 return Make_Null_Statement (Loc);
1448 end if;
1449
1450 return
1451 Make_Attribute_Reference (Loc,
1452 Prefix =>
1453 New_Occurrence_Of (Field_Typ, Loc),
1454 Attribute_Name => Nam,
1455 Expressions => New_List (
1456 Make_Identifier (Loc, Name_S),
1457 Make_Selected_Component (Loc,
1458 Prefix => Make_Identifier (Loc, Name_V),
1459 Selector_Name => New_Occurrence_Of (C, Loc))));
1460 end Make_Field_Attribute;
1461
1462 ---------------------------
1463 -- Make_Field_Attributes --
1464 ---------------------------
1465
1466 function Make_Field_Attributes (Clist : List_Id) return List_Id is
1467 Item : Node_Id;
1468 Result : List_Id;
1469
1470 begin
1471 Result := New_List;
1472
1473 if Present (Clist) then
1474 Item := First (Clist);
1475
1476 -- Loop through components, skipping all internal components,
1477 -- which are not part of the value (e.g. _Tag), except that we
1478 -- don't skip the _Parent, since we do want to process that
1479 -- recursively. If _Parent is an interface type, being abstract
1480 -- with no components there is no need to handle it.
1481
1482 while Present (Item) loop
1483 if Nkind (Item) = N_Component_Declaration
1484 and then
1485 ((Chars (Defining_Identifier (Item)) = Name_uParent
1486 and then not Is_Interface
1487 (Etype (Defining_Identifier (Item))))
1488 or else
1489 not Is_Internal_Name (Chars (Defining_Identifier (Item))))
1490 then
1491 Append_To
1492 (Result,
1493 Make_Field_Attribute (Defining_Identifier (Item)));
1494 end if;
1495
1496 Next (Item);
1497 end loop;
1498 end if;
1499
1500 return Result;
1501 end Make_Field_Attributes;
1502
1503 -- Start of processing for Build_Record_Read_Write_Procedure
1504
1505 begin
1506 -- For the protected type case, use corresponding record
1507
1508 if Is_Protected_Type (Typ) then
1509 Typt := Corresponding_Record_Type (Typ);
1510 else
1511 Typt := Typ;
1512 end if;
1513
1514 -- Note that we do nothing with the discriminants, since Read and
1515 -- Write do not read or write the discriminant values. All handling
1516 -- of discriminants occurs in the Input and Output subprograms.
1517
1518 Rdef := Type_Definition
1519 (Declaration_Node (Base_Type (Underlying_Type (Typt))));
1520 Stms := Empty_List;
1521
1522 -- In record extension case, the fields we want, including the _Parent
1523 -- field representing the parent type, are to be found in the extension.
1524 -- Note that we will naturally process the _Parent field using the type
1525 -- of the parent, and hence its stream attributes, which is appropriate.
1526
1527 if Nkind (Rdef) = N_Derived_Type_Definition then
1528 Rdef := Record_Extension_Part (Rdef);
1529
1530 if Is_Limited_Type (Typt) then
1531 In_Limited_Extension := True;
1532 end if;
1533 end if;
1534
1535 if Present (Component_List (Rdef)) then
1536 Append_List_To (Stms,
1537 Make_Component_List_Attributes (Component_List (Rdef)));
1538 end if;
1539
1540 Build_Stream_Procedure
1541 (Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read);
1542 end Build_Record_Read_Write_Procedure;
1543
1544 ----------------------------------
1545 -- Build_Record_Write_Procedure --
1546 ----------------------------------
1547
1548 procedure Build_Record_Write_Procedure
1549 (Loc : Source_Ptr;
1550 Typ : Entity_Id;
1551 Decl : out Node_Id;
1552 Pnam : out Entity_Id)
1553 is
1554 begin
1555 Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Write);
1556 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
1557 end Build_Record_Write_Procedure;
1558
1559 -------------------------------
1560 -- Build_Stream_Attr_Profile --
1561 -------------------------------
1562
1563 function Build_Stream_Attr_Profile
1564 (Loc : Source_Ptr;
1565 Typ : Entity_Id;
1566 Nam : TSS_Name_Type) return List_Id
1567 is
1568 Profile : List_Id;
1569
1570 begin
1571 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has
1572 -- no semantic meaning in Ada 95 but it is a requirement in Ada2005.
1573
1574 Profile := New_List (
1575 Make_Parameter_Specification (Loc,
1576 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1577 Parameter_Type =>
1578 Make_Access_Definition (Loc,
1579 Null_Exclusion_Present => True,
1580 Subtype_Mark => New_Reference_To (
1581 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))));
1582
1583 if Nam /= TSS_Stream_Input then
1584 Append_To (Profile,
1585 Make_Parameter_Specification (Loc,
1586 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1587 Out_Present => (Nam = TSS_Stream_Read),
1588 Parameter_Type => New_Reference_To (Typ, Loc)));
1589 end if;
1590
1591 return Profile;
1592 end Build_Stream_Attr_Profile;
1593
1594 ---------------------------
1595 -- Build_Stream_Function --
1596 ---------------------------
1597
1598 procedure Build_Stream_Function
1599 (Loc : Source_Ptr;
1600 Typ : Entity_Id;
1601 Decl : out Node_Id;
1602 Fnam : Entity_Id;
1603 Decls : List_Id;
1604 Stms : List_Id)
1605 is
1606 Spec : Node_Id;
1607
1608 begin
1609 -- Construct function specification
1610
1611 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has
1612 -- no semantic meaning in Ada 95 but it is a requirement in Ada2005.
1613
1614 Spec :=
1615 Make_Function_Specification (Loc,
1616 Defining_Unit_Name => Fnam,
1617
1618 Parameter_Specifications => New_List (
1619 Make_Parameter_Specification (Loc,
1620 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1621 Parameter_Type =>
1622 Make_Access_Definition (Loc,
1623 Null_Exclusion_Present => True,
1624 Subtype_Mark => New_Reference_To (
1625 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))),
1626
1627 Result_Definition => New_Occurrence_Of (Typ, Loc));
1628
1629 Decl :=
1630 Make_Subprogram_Body (Loc,
1631 Specification => Spec,
1632 Declarations => Decls,
1633 Handled_Statement_Sequence =>
1634 Make_Handled_Sequence_Of_Statements (Loc,
1635 Statements => Stms));
1636 end Build_Stream_Function;
1637
1638 ----------------------------
1639 -- Build_Stream_Procedure --
1640 ----------------------------
1641
1642 procedure Build_Stream_Procedure
1643 (Loc : Source_Ptr;
1644 Typ : Entity_Id;
1645 Decl : out Node_Id;
1646 Pnam : Entity_Id;
1647 Stms : List_Id;
1648 Outp : Boolean)
1649 is
1650 Spec : Node_Id;
1651
1652 begin
1653 -- Construct procedure specification
1654
1655 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has
1656 -- no semantic meaning in Ada 95 but it is a requirement in Ada2005.
1657
1658 Spec :=
1659 Make_Procedure_Specification (Loc,
1660 Defining_Unit_Name => Pnam,
1661
1662 Parameter_Specifications => New_List (
1663 Make_Parameter_Specification (Loc,
1664 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1665 Parameter_Type =>
1666 Make_Access_Definition (Loc,
1667 Null_Exclusion_Present => True,
1668 Subtype_Mark => New_Reference_To (
1669 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))),
1670
1671 Make_Parameter_Specification (Loc,
1672 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1673 Out_Present => Outp,
1674 Parameter_Type => New_Occurrence_Of (Typ, Loc))));
1675
1676 Decl :=
1677 Make_Subprogram_Body (Loc,
1678 Specification => Spec,
1679 Declarations => Empty_List,
1680 Handled_Statement_Sequence =>
1681 Make_Handled_Sequence_Of_Statements (Loc,
1682 Statements => Stms));
1683 end Build_Stream_Procedure;
1684
1685 -----------------------------
1686 -- Has_Stream_Standard_Rep --
1687 -----------------------------
1688
1689 function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean is
1690 Siz : Uint;
1691
1692 begin
1693 if Has_Non_Standard_Rep (U_Type) then
1694 return False;
1695 end if;
1696
1697 if Has_Stream_Size_Clause (U_Type) then
1698 Siz := Static_Integer (Expression (Stream_Size_Clause (U_Type)));
1699 else
1700 Siz := Esize (First_Subtype (U_Type));
1701 end if;
1702
1703 return Siz = Esize (Root_Type (U_Type));
1704 end Has_Stream_Standard_Rep;
1705
1706 ---------------------------------
1707 -- Make_Stream_Subprogram_Name --
1708 ---------------------------------
1709
1710 function Make_Stream_Subprogram_Name
1711 (Loc : Source_Ptr;
1712 Typ : Entity_Id;
1713 Nam : TSS_Name_Type) return Entity_Id
1714 is
1715 Sname : Name_Id;
1716
1717 begin
1718 -- For tagged types, we are dealing with a TSS associated with the
1719 -- declaration, so we use the standard primitive function name. For
1720 -- other types, generate a local TSS name since we are generating
1721 -- the subprogram at the point of use.
1722
1723 if Is_Tagged_Type (Typ) then
1724 Sname := Make_TSS_Name (Typ, Nam);
1725 else
1726 Sname := Make_TSS_Name_Local (Typ, Nam);
1727 end if;
1728
1729 return Make_Defining_Identifier (Loc, Sname);
1730 end Make_Stream_Subprogram_Name;
1731
1732 ----------------------
1733 -- Stream_Base_Type --
1734 ----------------------
1735
1736 function Stream_Base_Type (E : Entity_Id) return Entity_Id is
1737 begin
1738 if Is_Array_Type (E)
1739 and then Is_First_Subtype (E)
1740 then
1741 return E;
1742 else
1743 return Base_Type (E);
1744 end if;
1745 end Stream_Base_Type;
1746
1747 end Exp_Strm;