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