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