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