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