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