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