?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
(extendsfdf2): Add pattern accidentally deleted when cirrus instructions were
[official-gcc.git] / gcc / ada / exp_strm.adb
blob006b107749e36d5209ea4e653f9d128136c5431c
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ S T R M --
6 -- --
7 -- B o d y --
8 -- --
9 -- --
10 -- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
11 -- --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
22 -- --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 -- --
26 ------------------------------------------------------------------------------
27
28 with Atree; use Atree;
29 with Einfo; use Einfo;
30 with Lib; use Lib;
31 with Namet; use Namet;
32 with Nlists; use Nlists;
33 with Nmake; use Nmake;
34 with Rtsfind; use Rtsfind;
35 with Sinfo; use Sinfo;
36 with Snames; use Snames;
37 with Stand; use Stand;
38 with Tbuild; use Tbuild;
39 with Ttypes; use Ttypes;
40 with Exp_Tss; use Exp_Tss;
41 with Uintp; use Uintp;
42
43 package body Exp_Strm is
44
45 -----------------------
46 -- Local Subprograms --
47 -----------------------
48
49 procedure Build_Array_Read_Write_Procedure
50 (Nod : Node_Id;
51 Typ : Entity_Id;
52 Decl : out Node_Id;
53 Pnam : Entity_Id;
54 Nam : Name_Id);
55 -- Common routine shared to build either an array Read procedure or an
56 -- array Write procedure, Nam is Name_Read or Name_Write to select which.
57 -- Pnam is the defining identifier for the constructed procedure. The
58 -- other parameters are as for Build_Array_Read_Procedure except that
59 -- the first parameter Nod supplies the Sloc to be used to generate code.
60
61 procedure Build_Record_Read_Write_Procedure
62 (Loc : Source_Ptr;
63 Typ : Entity_Id;
64 Decl : out Node_Id;
65 Pnam : Entity_Id;
66 Nam : Name_Id);
67 -- Common routine shared to build a record Read Write procedure, Nam
68 -- is Name_Read or Name_Write to select which. Pnam is the defining
69 -- identifier for the constructed procedure. The other parameters are
70 -- as for Build_Record_Read_Procedure.
71
72 procedure Build_Stream_Function
73 (Loc : Source_Ptr;
74 Typ : Entity_Id;
75 Decl : out Node_Id;
76 Fnam : Entity_Id;
77 Decls : List_Id;
78 Stms : List_Id);
79 -- Called to build an array or record stream function. The first three
80 -- arguments are the same as Build_Record_Or_Elementary_Input_Function.
81 -- Decls and Stms are the declarations and statements for the body and
82 -- The parameter Fnam is the name of the constructed function.
83
84 procedure Build_Stream_Procedure
85 (Loc : Source_Ptr;
86 Typ : Entity_Id;
87 Decl : out Node_Id;
88 Pnam : Entity_Id;
89 Stms : List_Id;
90 Outp : Boolean);
91 -- Called to build an array or record stream procedure. The first three
92 -- arguments are the same as Build_Record_Or_Elementary_Output_Procedure.
93 -- Stms is the list of statements for the body (the declaration list is
94 -- always null), and Pnam is the name of the constructed procedure.
95
96 function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean;
97 -- This function is used to test U_Type, which is a type
98 -- Returns True if U_Type has a standard representation for stream
99 -- purposes, i.e. there is no non-standard enumeration representation
100 -- clause, and the size of the first subtype is the same as the size
101 -- of the root type.
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 InputN (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 InputN
133
134 procedure Build_Array_Input_Function
135 (Loc : Source_Ptr;
136 Typ : Entity_Id;
137 Decl : out Node_Id;
138 Fnam : out Entity_Id)
139 is
140 Dim : constant Pos := Number_Dimensions (Typ);
141 Lnam : Name_Id;
142 Hnam : Name_Id;
143 Decls : List_Id;
144 Ranges : List_Id;
145 Stms : List_Id;
146 Indx : Node_Id;
147
148 begin
149 Decls := New_List;
150 Ranges := New_List;
151 Indx := First_Index (Typ);
152
153 for J in 1 .. Dim loop
154 Lnam := New_External_Name ('L', J);
155 Hnam := New_External_Name ('H', J);
156
157 Append_To (Decls,
158 Make_Object_Declaration (Loc,
159 Defining_Identifier => Make_Defining_Identifier (Loc, Lnam),
160 Constant_Present => True,
161 Object_Definition => New_Occurrence_Of (Etype (Indx), Loc),
162 Expression =>
163 Make_Attribute_Reference (Loc,
164 Prefix =>
165 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
166 Attribute_Name => Name_Input,
167 Expressions => New_List (Make_Identifier (Loc, Name_S)))));
168
169 Append_To (Decls,
170 Make_Object_Declaration (Loc,
171 Defining_Identifier => Make_Defining_Identifier (Loc, Hnam),
172 Constant_Present => True,
173 Object_Definition =>
174 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
175 Expression =>
176 Make_Attribute_Reference (Loc,
177 Prefix =>
178 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
179 Attribute_Name => Name_Input,
180 Expressions => New_List (Make_Identifier (Loc, Name_S)))));
181
182 Append_To (Ranges,
183 Make_Range (Loc,
184 Low_Bound => Make_Identifier (Loc, Lnam),
185 High_Bound => Make_Identifier (Loc, Hnam)));
186
187 Next_Index (Indx);
188 end loop;
189
190 -- If the first subtype is constrained, use it directly. Otherwise
191 -- build a subtype indication with the proper bounds.
192
193 if Is_Constrained (Stream_Base_Type (Typ)) then
194 Append_To (Decls,
195 Make_Object_Declaration (Loc,
196 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
197 Object_Definition =>
198 New_Occurrence_Of (Stream_Base_Type (Typ), Loc)));
199 else
200 Append_To (Decls,
201 Make_Object_Declaration (Loc,
202 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
203 Object_Definition =>
204 Make_Subtype_Indication (Loc,
205 Subtype_Mark =>
206 New_Occurrence_Of (Stream_Base_Type (Typ), Loc),
207 Constraint =>
208 Make_Index_Or_Discriminant_Constraint (Loc,
209 Constraints => Ranges))));
210 end if;
211
212 Stms := New_List (
213 Make_Attribute_Reference (Loc,
214 Prefix => New_Occurrence_Of (Typ, Loc),
215 Attribute_Name => Name_Read,
216 Expressions => New_List (
217 Make_Identifier (Loc, Name_S),
218 Make_Identifier (Loc, Name_V))),
219
220 Make_Return_Statement (Loc,
221 Expression => Make_Identifier (Loc, Name_V)));
222
223 Fnam :=
224 Make_Defining_Identifier (Loc,
225 Chars =>
226 New_External_Name (Name_uInput, ' ', Increment_Serial_Number));
227
228 Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
229 end Build_Array_Input_Function;
230
231 ----------------------------------
232 -- Build_Array_Output_Procedure --
233 ----------------------------------
234
235 procedure Build_Array_Output_Procedure
236 (Loc : Source_Ptr;
237 Typ : Entity_Id;
238 Decl : out Node_Id;
239 Pnam : out Entity_Id)
240 is
241 Stms : List_Id;
242 Indx : Node_Id;
243
244 begin
245 -- Build series of statements to output bounds
246
247 Indx := First_Index (Typ);
248 Stms := New_List;
249
250 for J in 1 .. Number_Dimensions (Typ) loop
251 Append_To (Stms,
252 Make_Attribute_Reference (Loc,
253 Prefix =>
254 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
255 Attribute_Name => Name_Write,
256 Expressions => New_List (
257 Make_Identifier (Loc, Name_S),
258 Make_Attribute_Reference (Loc,
259 Prefix => Make_Identifier (Loc, Name_V),
260 Attribute_Name => Name_First,
261 Expressions => New_List (
262 Make_Integer_Literal (Loc, J))))));
263
264 Append_To (Stms,
265 Make_Attribute_Reference (Loc,
266 Prefix =>
267 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
268 Attribute_Name => Name_Write,
269 Expressions => New_List (
270 Make_Identifier (Loc, Name_S),
271 Make_Attribute_Reference (Loc,
272 Prefix => Make_Identifier (Loc, Name_V),
273 Attribute_Name => Name_Last,
274 Expressions => New_List (
275 Make_Integer_Literal (Loc, J))))));
276
277 Next_Index (Indx);
278 end loop;
279
280 -- Append Write attribute to write array elements
281
282 Append_To (Stms,
283 Make_Attribute_Reference (Loc,
284 Prefix => New_Occurrence_Of (Typ, Loc),
285 Attribute_Name => Name_Write,
286 Expressions => New_List (
287 Make_Identifier (Loc, Name_S),
288 Make_Identifier (Loc, Name_V))));
289
290 Pnam :=
291 Make_Defining_Identifier (Loc,
292 Chars =>
293 New_External_Name (Name_uOutput, ' ', Increment_Serial_Number));
294
295 Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
296 end Build_Array_Output_Procedure;
297
298 --------------------------------
299 -- Build_Array_Read_Procedure --
300 --------------------------------
301
302 procedure Build_Array_Read_Procedure
303 (Nod : Node_Id;
304 Typ : Entity_Id;
305 Decl : out Node_Id;
306 Pnam : out Entity_Id)
307 is
308 Loc : constant Source_Ptr := Sloc (Nod);
309
310 begin
311 Pnam :=
312 Make_Defining_Identifier (Loc,
313 New_External_Name
314 (Name_uRead, ' ', Increment_Serial_Number));
315
316 Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Read);
317 end Build_Array_Read_Procedure;
318
319 --------------------------------------
320 -- Build_Array_Read_Write_Procedure --
321 --------------------------------------
322
323 -- The form of the array read/write procedure is as follows:
324
325 -- procedure pnam (S : access RST, V : [out] Typ) is
326 -- begin
327 -- for L1 in V'Range (1) loop
328 -- for L2 in V'Range (2) loop
329 -- ...
330 -- for Ln in V'Range (n) loop
331 -- Component_Type'Read/Write (S, V (L1, L2, .. Ln));
332 -- end loop;
333 -- ..
334 -- end loop;
335 -- end loop
336 -- end pnam;
337
338 -- The out keyword for V is supplied in the Read case
339
340 procedure Build_Array_Read_Write_Procedure
341 (Nod : Node_Id;
342 Typ : Entity_Id;
343 Decl : out Node_Id;
344 Pnam : Entity_Id;
345 Nam : Name_Id)
346 is
347 Loc : constant Source_Ptr := Sloc (Nod);
348
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. See 5509-003.
380
381 if Nam = Name_Read then
382 RW := TSS (Base_Type (Ctyp), Name_uRead);
383 else
384 RW := TSS (Base_Type (Ctyp), Name_uWrite);
385 end if;
386
387 if Present (RW)
388 and then not Is_Frozen (RW)
389 then
390 Set_Is_Frozen (RW);
391 end if;
392
393 -- Now this is the big loop to wrap that statement up in a sequence
394 -- of loops. The first time around, Stm is the attribute call. The
395 -- second and subsequent times, Stm is an inner loop.
396
397 for J in 1 .. Ndim loop
398 Stm :=
399 Make_Implicit_Loop_Statement (Nod,
400 Iteration_Scheme =>
401 Make_Iteration_Scheme (Loc,
402 Loop_Parameter_Specification =>
403 Make_Loop_Parameter_Specification (Loc,
404 Defining_Identifier =>
405 Make_Defining_Identifier (Loc,
406 Chars => New_External_Name ('L', Ndim - J + 1)),
407
408 Discrete_Subtype_Definition =>
409 Make_Attribute_Reference (Loc,
410 Prefix => Make_Identifier (Loc, Name_V),
411 Attribute_Name => Name_Range,
412
413 Expressions => New_List (
414 Make_Integer_Literal (Loc, Ndim - J + 1))))),
415
416 Statements => New_List (Stm));
417
418 end loop;
419
420 Build_Stream_Procedure
421 (Loc, Typ, Decl, Pnam, New_List (Stm), Nam = Name_Read);
422 end Build_Array_Read_Write_Procedure;
423
424 ---------------------------------
425 -- Build_Array_Write_Procedure --
426 ---------------------------------
427
428 procedure Build_Array_Write_Procedure
429 (Nod : Node_Id;
430 Typ : Entity_Id;
431 Decl : out Node_Id;
432 Pnam : out Entity_Id)
433 is
434 Loc : constant Source_Ptr := Sloc (Nod);
435
436 begin
437 Pnam :=
438 Make_Defining_Identifier (Loc,
439 Chars =>
440 New_External_Name (Name_uWrite, ' ', Increment_Serial_Number));
441
442 Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Write);
443 end Build_Array_Write_Procedure;
444
445 ---------------------------------
446 -- Build_Elementary_Input_Call --
447 ---------------------------------
448
449 function Build_Elementary_Input_Call (N : Node_Id) return Node_Id is
450 Loc : constant Source_Ptr := Sloc (N);
451 P_Type : constant Entity_Id := Entity (Prefix (N));
452 U_Type : constant Entity_Id := Underlying_Type (P_Type);
453 Rt_Type : constant Entity_Id := Root_Type (U_Type);
454 FST : constant Entity_Id := First_Subtype (U_Type);
455 P_Size : constant Uint := Esize (FST);
456 Strm : constant Node_Id := First (Expressions (N));
457 Lib_RE : RE_Id;
458
459 begin
460 -- Check first for Boolean and Character. These are enumeration types,
461 -- but we treat them specially, since they may require special handling
462 -- in the transfer protocol. However, this special handling only applies
463 -- if they have standard representation, otherwise they are treated like
464 -- any other enumeration type.
465
466 if Rt_Type = Standard_Boolean
467 and then Has_Stream_Standard_Rep (U_Type)
468 then
469 Lib_RE := RE_I_B;
470
471 elsif Rt_Type = Standard_Character
472 and then Has_Stream_Standard_Rep (U_Type)
473 then
474 Lib_RE := RE_I_C;
475
476 elsif Rt_Type = Standard_Wide_Character
477 and then Has_Stream_Standard_Rep (U_Type)
478 then
479 Lib_RE := RE_I_WC;
480
481 -- Floating point types
482
483 elsif Is_Floating_Point_Type (U_Type) then
484
485 if Rt_Type = Standard_Short_Float then
486 Lib_RE := RE_I_SF;
487
488 elsif Rt_Type = Standard_Float then
489 Lib_RE := RE_I_F;
490
491 elsif Rt_Type = Standard_Long_Float then
492 Lib_RE := RE_I_LF;
493
494 else pragma Assert (Rt_Type = Standard_Long_Long_Float);
495 Lib_RE := RE_I_LLF;
496 end if;
497
498 -- Signed integer types. Also includes signed fixed-point types and
499 -- enumeration types with a signed representation.
500
501 -- Note on signed integer types. We do not consider types as signed for
502 -- this purpose if they have no negative numbers, or if they have biased
503 -- representation. The reason is that the value in either case basically
504 -- represents an unsigned value.
505
506 -- For example, consider:
507
508 -- type W is range 0 .. 2**32 - 1;
509 -- for W'Size use 32;
510
511 -- This is a signed type, but the representation is unsigned, and may
512 -- be outside the range of a 32-bit signed integer, so this must be
513 -- treated as 32-bit unsigned.
514
515 -- Similarly, if we have
516
517 -- type W is range -1 .. +254;
518 -- for W'Size use 8;
519
520 -- then the representation is unsigned
521
522 elsif not Is_Unsigned_Type (FST)
523 and then
524 (Is_Fixed_Point_Type (U_Type)
525 or else
526 Is_Enumeration_Type (U_Type)
527 or else
528 (Is_Signed_Integer_Type (U_Type)
529 and then not Has_Biased_Representation (FST)))
530 then
531 if P_Size <= Standard_Short_Short_Integer_Size then
532 Lib_RE := RE_I_SSI;
533
534 elsif P_Size <= Standard_Short_Integer_Size then
535 Lib_RE := RE_I_SI;
536
537 elsif P_Size <= Standard_Integer_Size then
538 Lib_RE := RE_I_I;
539
540 elsif P_Size <= Standard_Long_Integer_Size then
541 Lib_RE := RE_I_LI;
542
543 else
544 Lib_RE := RE_I_LLI;
545 end if;
546
547 -- Unsigned integer types, also includes unsigned fixed-point types
548 -- and enumeration types with an unsigned representation (note that
549 -- we know they are unsigned because we already tested for signed).
550
551 -- Also includes signed integer types that are unsigned in the sense
552 -- that they do not include negative numbers. See above for details.
553
554 elsif Is_Modular_Integer_Type (U_Type)
555 or else Is_Fixed_Point_Type (U_Type)
556 or else Is_Enumeration_Type (U_Type)
557 or else Is_Signed_Integer_Type (U_Type)
558 then
559 if P_Size <= Standard_Short_Short_Integer_Size then
560 Lib_RE := RE_I_SSU;
561
562 elsif P_Size <= Standard_Short_Integer_Size then
563 Lib_RE := RE_I_SU;
564
565 elsif P_Size <= Standard_Integer_Size then
566 Lib_RE := RE_I_U;
567
568 elsif P_Size <= Standard_Long_Integer_Size then
569 Lib_RE := RE_I_LU;
570
571 else
572 Lib_RE := RE_I_LLU;
573 end if;
574
575 else pragma Assert (Is_Access_Type (U_Type));
576 if P_Size > System_Address_Size then
577 Lib_RE := RE_I_AD;
578 else
579 Lib_RE := RE_I_AS;
580 end if;
581 end if;
582
583 -- Call the function, and do an unchecked conversion of the result
584 -- to the actual type of the prefix.
585
586 return
587 Unchecked_Convert_To (P_Type,
588 Make_Function_Call (Loc,
589 Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
590 Parameter_Associations => New_List (
591 Relocate_Node (Strm))));
592
593 end Build_Elementary_Input_Call;
594
595 ---------------------------------
596 -- Build_Elementary_Write_Call --
597 ---------------------------------
598
599 function Build_Elementary_Write_Call (N : Node_Id) return Node_Id is
600 Loc : constant Source_Ptr := Sloc (N);
601 P_Type : constant Entity_Id := Entity (Prefix (N));
602 U_Type : constant Entity_Id := Underlying_Type (P_Type);
603 Rt_Type : constant Entity_Id := Root_Type (U_Type);
604 FST : constant Entity_Id := First_Subtype (U_Type);
605 P_Size : constant Uint := Esize (FST);
606 Strm : constant Node_Id := First (Expressions (N));
607 Item : constant Node_Id := Next (Strm);
608 Lib_RE : RE_Id;
609 Libent : Entity_Id;
610
611 begin
612 -- Find the routine to be called
613
614 -- Check for First Boolean and Character. These are enumeration types,
615 -- but we treat them specially, since they may require special handling
616 -- in the transfer protocol. However, this special handling only applies
617 -- if they have standard representation, otherwise they are treated like
618 -- any other enumeration type.
619
620 if Rt_Type = Standard_Boolean
621 and then Has_Stream_Standard_Rep (U_Type)
622 then
623 Lib_RE := RE_W_B;
624
625 elsif Rt_Type = Standard_Character
626 and then Has_Stream_Standard_Rep (U_Type)
627 then
628 Lib_RE := RE_W_C;
629
630 elsif Rt_Type = Standard_Wide_Character
631 and then Has_Stream_Standard_Rep (U_Type)
632 then
633 Lib_RE := RE_W_WC;
634
635 -- Floating point types
636
637 elsif Is_Floating_Point_Type (U_Type) then
638
639 if Rt_Type = Standard_Short_Float then
640 Lib_RE := RE_W_SF;
641
642 elsif Rt_Type = Standard_Float then
643 Lib_RE := RE_W_F;
644
645 elsif Rt_Type = Standard_Long_Float then
646 Lib_RE := RE_W_LF;
647
648 else pragma Assert (Rt_Type = Standard_Long_Long_Float);
649 Lib_RE := RE_W_LLF;
650 end if;
651
652 -- Signed integer types. Also includes signed fixed-point types and
653 -- signed enumeration types share this circuitry.
654
655 -- Note on signed integer types. We do not consider types as signed for
656 -- this purpose if they have no negative numbers, or if they have biased
657 -- representation. The reason is that the value in either case basically
658 -- represents an unsigned value.
659
660 -- For example, consider:
661
662 -- type W is range 0 .. 2**32 - 1;
663 -- for W'Size use 32;
664
665 -- This is a signed type, but the representation is unsigned, and may
666 -- be outside the range of a 32-bit signed integer, so this must be
667 -- treated as 32-bit unsigned.
668
669 -- Similarly, if we have
670
671 -- type W is range -1 .. +254;
672 -- for W'Size use 8;
673
674 -- then the representation is also unsigned.
675
676 elsif not Is_Unsigned_Type (FST)
677 and then
678 (Is_Fixed_Point_Type (U_Type)
679 or else
680 Is_Enumeration_Type (U_Type)
681 or else
682 (Is_Signed_Integer_Type (U_Type)
683 and then not Has_Biased_Representation (FST)))
684 then
685 if P_Size <= Standard_Short_Short_Integer_Size then
686 Lib_RE := RE_W_SSI;
687
688 elsif P_Size <= Standard_Short_Integer_Size then
689 Lib_RE := RE_W_SI;
690
691 elsif P_Size <= Standard_Integer_Size then
692 Lib_RE := RE_W_I;
693
694 elsif P_Size <= Standard_Long_Integer_Size then
695 Lib_RE := RE_W_LI;
696
697 else
698 Lib_RE := RE_W_LLI;
699 end if;
700
701 -- Unsigned integer types, also includes unsigned fixed-point types
702 -- and unsigned enumeration types (note we know they are unsigned
703 -- because we already tested for signed above).
704
705 -- Also includes signed integer types that are unsigned in the sense
706 -- that they do not include negative numbers. See above for details.
707
708 elsif Is_Modular_Integer_Type (U_Type)
709 or else Is_Fixed_Point_Type (U_Type)
710 or else Is_Enumeration_Type (U_Type)
711 or else Is_Signed_Integer_Type (U_Type)
712 then
713 if P_Size <= Standard_Short_Short_Integer_Size then
714 Lib_RE := RE_W_SSU;
715
716 elsif P_Size <= Standard_Short_Integer_Size then
717 Lib_RE := RE_W_SU;
718
719 elsif P_Size <= Standard_Integer_Size then
720 Lib_RE := RE_W_U;
721
722 elsif P_Size <= Standard_Long_Integer_Size then
723 Lib_RE := RE_W_LU;
724
725 else
726 Lib_RE := RE_W_LLU;
727 end if;
728
729 else pragma Assert (Is_Access_Type (U_Type));
730
731 if P_Size > System_Address_Size then
732 Lib_RE := RE_W_AD;
733 else
734 Lib_RE := RE_W_AS;
735 end if;
736 end if;
737
738 -- Unchecked-convert parameter to the required type (i.e. the type of
739 -- the corresponding parameter, and call the appropriate routine.
740
741 Libent := RTE (Lib_RE);
742
743 return
744 Make_Procedure_Call_Statement (Loc,
745 Name => New_Occurrence_Of (Libent, Loc),
746 Parameter_Associations => New_List (
747 Relocate_Node (Strm),
748 Unchecked_Convert_To (Etype (Next_Formal (First_Formal (Libent))),
749 Relocate_Node (Item))));
750
751 end Build_Elementary_Write_Call;
752
753 -----------------------------------------
754 -- Build_Mutable_Record_Read_Procedure --
755 -----------------------------------------
756
757 procedure Build_Mutable_Record_Read_Procedure
758 (Loc : Source_Ptr;
759 Typ : Entity_Id;
760 Decl : out Node_Id;
761 Pnam : out Entity_Id)
762 is
763 Stms : List_Id;
764 Disc : Entity_Id;
765 Comp : Node_Id;
766
767 begin
768 Stms := New_List;
769 Disc := First_Discriminant (Typ);
770
771 -- Generate Reads for the discriminants of the type.
772
773 while Present (Disc) loop
774 Comp :=
775 Make_Selected_Component (Loc,
776 Prefix => Make_Identifier (Loc, Name_V),
777 Selector_Name => New_Occurrence_Of (Disc, Loc));
778
779 Set_Assignment_OK (Comp);
780
781 Append_To (Stms,
782 Make_Attribute_Reference (Loc,
783 Prefix => New_Occurrence_Of (Etype (Disc), Loc),
784 Attribute_Name => Name_Read,
785 Expressions => New_List (
786 Make_Identifier (Loc, Name_S),
787 Comp)));
788
789 Next_Discriminant (Disc);
790 end loop;
791
792 -- A mutable type cannot be a tagged type, so we generate a new name
793 -- for the stream procedure.
794
795 Pnam :=
796 Make_Defining_Identifier (Loc,
797 Chars =>
798 New_External_Name (Name_uRead, ' ', Increment_Serial_Number));
799
800 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
801
802 -- Read the discriminants before the rest of the components, so
803 -- that discriminant values are properly set of variants, etc.
804 -- If this is an empty record with discriminants, there are no
805 -- previous statements. If this is an unchecked union, the stream
806 -- procedure is erroneous, because there are no discriminants to read.
807
808 if Is_Unchecked_Union (Typ) then
809 Stms :=
810 New_List (
811 Make_Raise_Program_Error (Loc,
812 Reason => PE_Unchecked_Union_Restriction));
813 end if;
814
815 if Is_Non_Empty_List (
816 Statements (Handled_Statement_Sequence (Decl)))
817 then
818 Insert_List_Before
819 (First (Statements (Handled_Statement_Sequence (Decl))), Stms);
820 else
821 Set_Statements (Handled_Statement_Sequence (Decl), Stms);
822 end if;
823 end Build_Mutable_Record_Read_Procedure;
824
825 ------------------------------------------
826 -- Build_Mutable_Record_Write_Procedure --
827 ------------------------------------------
828
829 procedure Build_Mutable_Record_Write_Procedure
830 (Loc : Source_Ptr;
831 Typ : Entity_Id;
832 Decl : out Node_Id;
833 Pnam : out Entity_Id)
834 is
835 Stms : List_Id;
836 Disc : Entity_Id;
837
838 begin
839 Stms := New_List;
840 Disc := First_Discriminant (Typ);
841
842 -- Generate Writes for the discriminants of the type.
843
844 while Present (Disc) loop
845
846 Append_To (Stms,
847 Make_Attribute_Reference (Loc,
848 Prefix => New_Occurrence_Of (Etype (Disc), Loc),
849 Attribute_Name => Name_Write,
850 Expressions => New_List (
851 Make_Identifier (Loc, Name_S),
852 Make_Selected_Component (Loc,
853 Prefix => Make_Identifier (Loc, Name_V),
854 Selector_Name => New_Occurrence_Of (Disc, Loc)))));
855
856 Next_Discriminant (Disc);
857 end loop;
858
859 -- A mutable type cannot be a tagged type, so we generate a new name
860 -- for the stream procedure.
861
862 Pnam :=
863 Make_Defining_Identifier (Loc,
864 Chars =>
865 New_External_Name (Name_uWrite, ' ', Increment_Serial_Number));
866
867 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
868
869 -- Write the discriminants before the rest of the components, so
870 -- that discriminant values are properly set of variants, etc.
871 -- If this is an unchecked union, the stream procedure is erroneous
872 -- because there are no discriminants to write.
873
874 if Is_Unchecked_Union (Typ) then
875 Stms :=
876 New_List (
877 Make_Raise_Program_Error (Loc,
878 Reason => PE_Unchecked_Union_Restriction));
879 end if;
880
881 if Is_Non_Empty_List (
882 Statements (Handled_Statement_Sequence (Decl)))
883 then
884 Insert_List_Before
885 (First (Statements (Handled_Statement_Sequence (Decl))), Stms);
886 else
887 Set_Statements (Handled_Statement_Sequence (Decl), Stms);
888 end if;
889 end Build_Mutable_Record_Write_Procedure;
890
891 -----------------------------------------------
892 -- Build_Record_Or_Elementary_Input_Function --
893 -----------------------------------------------
894
895 -- The function we build looks like
896
897 -- function InputN (S : access RST) return Typ is
898 -- C1 : constant Disc_Type_1;
899 -- Discr_Type_1'Read (S, C1);
900 -- C2 : constant Disc_Type_2;
901 -- Discr_Type_2'Read (S, C2);
902 -- ...
903 -- Cn : constant Disc_Type_n;
904 -- Discr_Type_n'Read (S, Cn);
905 -- V : Typ (C1, C2, .. Cn)
906
907 -- begin
908 -- Typ'Read (S, V);
909 -- return V;
910 -- end InputN
911
912 -- The discriminants are of course only present in the case of a record
913 -- with discriminants. In the case of a record with no discriminants, or
914 -- an elementary type, then no Cn constants are defined.
915
916 procedure Build_Record_Or_Elementary_Input_Function
917 (Loc : Source_Ptr;
918 Typ : Entity_Id;
919 Decl : out Node_Id;
920 Fnam : out Entity_Id)
921 is
922 Cn : Name_Id;
923 J : Pos;
924 Decls : List_Id;
925 Constr : List_Id;
926 Stms : List_Id;
927 Discr : Entity_Id;
928 Odef : Node_Id;
929
930 begin
931 Decls := New_List;
932 Constr := New_List;
933
934 J := 1;
935
936 if Has_Discriminants (Typ) then
937 Discr := First_Discriminant (Typ);
938
939 while Present (Discr) loop
940 Cn := New_External_Name ('C', J);
941
942 Append_To (Decls,
943 Make_Object_Declaration (Loc,
944 Defining_Identifier => Make_Defining_Identifier (Loc, Cn),
945 Object_Definition =>
946 New_Occurrence_Of (Etype (Discr), Loc)));
947
948 Append_To (Decls,
949 Make_Attribute_Reference (Loc,
950 Prefix => New_Occurrence_Of (Etype (Discr), Loc),
951 Attribute_Name => Name_Read,
952 Expressions => New_List (
953 Make_Identifier (Loc, Name_S),
954 Make_Identifier (Loc, Cn))));
955
956 Append_To (Constr, Make_Identifier (Loc, Cn));
957
958 Next_Discriminant (Discr);
959 J := J + 1;
960 end loop;
961
962 Odef :=
963 Make_Subtype_Indication (Loc,
964 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
965 Constraint =>
966 Make_Index_Or_Discriminant_Constraint (Loc,
967 Constraints => Constr));
968
969 -- If no discriminants, then just use the type with no constraint
970
971 else
972 Odef := New_Occurrence_Of (Typ, Loc);
973 end if;
974
975 Append_To (Decls,
976 Make_Object_Declaration (Loc,
977 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
978 Object_Definition => Odef));
979
980 Stms := New_List (
981 Make_Attribute_Reference (Loc,
982 Prefix => New_Occurrence_Of (Typ, Loc),
983 Attribute_Name => Name_Read,
984 Expressions => New_List (
985 Make_Identifier (Loc, Name_S),
986 Make_Identifier (Loc, Name_V))),
987
988 Make_Return_Statement (Loc,
989 Expression => Make_Identifier (Loc, Name_V)));
990
991 -- For tagged types, we use a canonical name so that it matches the
992 -- primitive spec. For all other cases, we use a serialized name so
993 -- that multiple generations of the same procedure do not clash.
994
995 if Is_Tagged_Type (Typ) then
996 Fnam := Make_Defining_Identifier (Loc, Name_uInput);
997 else
998 Fnam :=
999 Make_Defining_Identifier (Loc,
1000 Chars =>
1001 New_External_Name (Name_uInput, ' ', Increment_Serial_Number));
1002 end if;
1003
1004 Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
1005 end Build_Record_Or_Elementary_Input_Function;
1006
1007 -------------------------------------------------
1008 -- Build_Record_Or_Elementary_Output_Procedure --
1009 -------------------------------------------------
1010
1011 procedure Build_Record_Or_Elementary_Output_Procedure
1012 (Loc : Source_Ptr;
1013 Typ : Entity_Id;
1014 Decl : out Node_Id;
1015 Pnam : out Entity_Id)
1016 is
1017 Stms : List_Id;
1018 Disc : Entity_Id;
1019
1020 begin
1021 Stms := New_List;
1022
1023 -- Note that of course there will be no discriminants for the
1024 -- elementary type case, so Has_Discriminants will be False.
1025
1026 if Has_Discriminants (Typ) then
1027 Disc := First_Discriminant (Typ);
1028
1029 while Present (Disc) loop
1030 Append_To (Stms,
1031 Make_Attribute_Reference (Loc,
1032 Prefix =>
1033 New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc),
1034 Attribute_Name => Name_Write,
1035 Expressions => New_List (
1036 Make_Identifier (Loc, Name_S),
1037 Make_Selected_Component (Loc,
1038 Prefix => Make_Identifier (Loc, Name_V),
1039 Selector_Name => New_Occurrence_Of (Disc, Loc)))));
1040
1041 Next_Discriminant (Disc);
1042 end loop;
1043 end if;
1044
1045 Append_To (Stms,
1046 Make_Attribute_Reference (Loc,
1047 Prefix => New_Occurrence_Of (Typ, Loc),
1048 Attribute_Name => Name_Write,
1049 Expressions => New_List (
1050 Make_Identifier (Loc, Name_S),
1051 Make_Identifier (Loc, Name_V))));
1052
1053 -- For tagged types, we use a canonical name so that it matches the
1054 -- primitive spec. For all other cases, we use a serialized name so
1055 -- that multiple generations of the same procedure do not clash.
1056
1057 if Is_Tagged_Type (Typ) then
1058 Pnam := Make_Defining_Identifier (Loc, Name_uOutput);
1059 else
1060 Pnam :=
1061 Make_Defining_Identifier (Loc,
1062 Chars =>
1063 New_External_Name
1064 (Name_uOutput, ' ', Increment_Serial_Number));
1065 end if;
1066
1067 Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
1068 end Build_Record_Or_Elementary_Output_Procedure;
1069
1070 ---------------------------------
1071 -- Build_Record_Read_Procedure --
1072 ---------------------------------
1073
1074 procedure Build_Record_Read_Procedure
1075 (Loc : Source_Ptr;
1076 Typ : Entity_Id;
1077 Decl : out Node_Id;
1078 Pnam : out Entity_Id)
1079 is
1080 begin
1081 -- For tagged types, we use a canonical name so that it matches the
1082 -- primitive spec. For all other cases, we use a serialized name so
1083 -- that multiple generations of the same procedure do not clash.
1084
1085 if Is_Tagged_Type (Typ) then
1086 Pnam := Make_Defining_Identifier (Loc, Name_uRead);
1087 else
1088 Pnam :=
1089 Make_Defining_Identifier (Loc,
1090 Chars =>
1091 New_External_Name (Name_uRead, ' ', Increment_Serial_Number));
1092 end if;
1093
1094 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
1095 end Build_Record_Read_Procedure;
1096
1097 ---------------------------------------
1098 -- Build_Record_Read_Write_Procedure --
1099 ---------------------------------------
1100
1101 -- The form of the record read/write procedure is as shown by the
1102 -- following example for a case with one discriminant case variant:
1103
1104 -- procedure pnam (S : access RST, V : [out] Typ) is
1105 -- begin
1106 -- Component_Type'Read/Write (S, V.component);
1107 -- Component_Type'Read/Write (S, V.component);
1108 -- ...
1109 -- Component_Type'Read/Write (S, V.component);
1110 --
1111 -- case V.discriminant is
1112 -- when choices =>
1113 -- Component_Type'Read/Write (S, V.component);
1114 -- Component_Type'Read/Write (S, V.component);
1115 -- ...
1116 -- Component_Type'Read/Write (S, V.component);
1117 --
1118 -- when choices =>
1119 -- Component_Type'Read/Write (S, V.component);
1120 -- Component_Type'Read/Write (S, V.component);
1121 -- ...
1122 -- Component_Type'Read/Write (S, V.component);
1123 -- ...
1124 -- end case;
1125 -- end pnam;
1126
1127 -- The out keyword for V is supplied in the Read case
1128
1129 procedure Build_Record_Read_Write_Procedure
1130 (Loc : Source_Ptr;
1131 Typ : Entity_Id;
1132 Decl : out Node_Id;
1133 Pnam : Entity_Id;
1134 Nam : Name_Id)
1135 is
1136 Rdef : Node_Id;
1137 Stms : List_Id;
1138 Typt : Entity_Id;
1139
1140 function Make_Component_List_Attributes (CL : Node_Id) return List_Id;
1141 -- Returns a sequence of attributes to process the components that
1142 -- are referenced in the given component list.
1143
1144 function Make_Field_Attribute (C : Entity_Id) return Node_Id;
1145 -- Given C, the entity for a discriminant or component, build
1146 -- an attribute for the corresponding field values.
1147
1148 function Make_Field_Attributes (Clist : List_Id) return List_Id;
1149 -- Given Clist, a component items list, construct series of attributes
1150 -- for fieldwise processing of the corresponding components.
1151
1152 ------------------------------------
1153 -- Make_Component_List_Attributes --
1154 ------------------------------------
1155
1156 function Make_Component_List_Attributes (CL : Node_Id) return List_Id is
1157 CI : constant List_Id := Component_Items (CL);
1158 VP : constant Node_Id := Variant_Part (CL);
1159
1160 Result : List_Id;
1161 Alts : List_Id;
1162 V : Node_Id;
1163 DC : Node_Id;
1164 DCH : List_Id;
1165
1166 begin
1167 Result := Make_Field_Attributes (CI);
1168
1169 -- If a component is an unchecked union, there is no discriminant
1170 -- and we cannot generate a read/write procedure for it.
1171
1172 if Present (VP) then
1173 if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then
1174 return New_List (
1175 Make_Raise_Program_Error (Sloc (VP),
1176 Reason => PE_Unchecked_Union_Restriction));
1177 end if;
1178
1179 V := First_Non_Pragma (Variants (VP));
1180 Alts := New_List;
1181 while Present (V) loop
1182
1183 DCH := New_List;
1184 DC := First (Discrete_Choices (V));
1185 while Present (DC) loop
1186 Append_To (DCH, New_Copy_Tree (DC));
1187 Next (DC);
1188 end loop;
1189
1190 Append_To (Alts,
1191 Make_Case_Statement_Alternative (Loc,
1192 Discrete_Choices => DCH,
1193 Statements =>
1194 Make_Component_List_Attributes (Component_List (V))));
1195 Next_Non_Pragma (V);
1196 end loop;
1197
1198 -- Note: in the following, we make sure that we use new occurrence
1199 -- of for the selector, since there are cases in which we make a
1200 -- reference to a hidden discriminant that is not visible.
1201
1202 Append_To (Result,
1203 Make_Case_Statement (Loc,
1204 Expression =>
1205 Make_Selected_Component (Loc,
1206 Prefix => Make_Identifier (Loc, Name_V),
1207 Selector_Name =>
1208 New_Occurrence_Of (Entity (Name (VP)), Loc)),
1209 Alternatives => Alts));
1210
1211 end if;
1212
1213 return Result;
1214 end Make_Component_List_Attributes;
1215
1216 --------------------------
1217 -- Make_Field_Attribute --
1218 --------------------------
1219
1220 function Make_Field_Attribute (C : Entity_Id) return Node_Id is
1221 begin
1222 return
1223 Make_Attribute_Reference (Loc,
1224 Prefix =>
1225 New_Occurrence_Of (Stream_Base_Type (Etype (C)), Loc),
1226 Attribute_Name => Nam,
1227 Expressions => New_List (
1228 Make_Identifier (Loc, Name_S),
1229 Make_Selected_Component (Loc,
1230 Prefix => Make_Identifier (Loc, Name_V),
1231 Selector_Name => New_Occurrence_Of (C, Loc))));
1232 end Make_Field_Attribute;
1233
1234 ---------------------------
1235 -- Make_Field_Attributes --
1236 ---------------------------
1237
1238 function Make_Field_Attributes (Clist : List_Id) return List_Id is
1239 Item : Node_Id;
1240 Result : List_Id;
1241
1242 begin
1243 Result := New_List;
1244
1245 if Present (Clist) then
1246 Item := First (Clist);
1247
1248 -- Loop through components, skipping all internal components,
1249 -- which are not part of the value (e.g. _Tag), except that we
1250 -- don't skip the _Parent, since we do want to process that
1251 -- recursively.
1252
1253 while Present (Item) loop
1254 if Nkind (Item) = N_Component_Declaration
1255 and then
1256 (Chars (Defining_Identifier (Item)) = Name_uParent
1257 or else
1258 not Is_Internal_Name (Chars (Defining_Identifier (Item))))
1259 then
1260 Append_To
1261 (Result,
1262 Make_Field_Attribute (Defining_Identifier (Item)));
1263 end if;
1264
1265 Next (Item);
1266 end loop;
1267 end if;
1268
1269 return Result;
1270 end Make_Field_Attributes;
1271
1272 -- Start of processing for Build_Record_Read_Write_Procedure
1273
1274 begin
1275 -- For the protected type case, use corresponding record
1276
1277 if Is_Protected_Type (Typ) then
1278 Typt := Corresponding_Record_Type (Typ);
1279 else
1280 Typt := Typ;
1281 end if;
1282
1283 -- Note that we do nothing with the discriminants, since Read and
1284 -- Write do not read or write the discriminant values. All handling
1285 -- of discriminants occurs in the Input and Output subprograms.
1286
1287 Rdef := Type_Definition (Declaration_Node (Underlying_Type (Typt)));
1288 Stms := Empty_List;
1289
1290 -- In record extension case, the fields we want, including the _Parent
1291 -- field representing the parent type, are to be found in the extension.
1292 -- Note that we will naturally process the _Parent field using the type
1293 -- of the parent, and hence its stream attributes, which is appropriate.
1294
1295 if Nkind (Rdef) = N_Derived_Type_Definition then
1296 Rdef := Record_Extension_Part (Rdef);
1297 end if;
1298
1299 if Present (Component_List (Rdef)) then
1300 Append_List_To (Stms,
1301 Make_Component_List_Attributes (Component_List (Rdef)));
1302 end if;
1303
1304 Build_Stream_Procedure
1305 (Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read);
1306
1307 end Build_Record_Read_Write_Procedure;
1308
1309 ----------------------------------
1310 -- Build_Record_Write_Procedure --
1311 ----------------------------------
1312
1313 procedure Build_Record_Write_Procedure
1314 (Loc : Source_Ptr;
1315 Typ : Entity_Id;
1316 Decl : out Node_Id;
1317 Pnam : out Entity_Id)
1318 is
1319 begin
1320 -- For tagged types, we use a canonical name so that it matches the
1321 -- primitive spec. For all other cases, we use a serialized name so
1322 -- that multiple generations of the same procedure do not clash.
1323
1324 if Is_Tagged_Type (Typ) then
1325 Pnam := Make_Defining_Identifier (Loc, Name_uWrite);
1326 else
1327 Pnam :=
1328 Make_Defining_Identifier (Loc,
1329 Chars =>
1330 New_External_Name (Name_uWrite, ' ', Increment_Serial_Number));
1331 end if;
1332
1333 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
1334 end Build_Record_Write_Procedure;
1335
1336 -------------------------------
1337 -- Build_Stream_Attr_Profile --
1338 -------------------------------
1339
1340 function Build_Stream_Attr_Profile
1341 (Loc : Source_Ptr;
1342 Typ : Entity_Id;
1343 Nam : Name_Id)
1344 return List_Id
1345 is
1346 Profile : List_Id;
1347
1348 begin
1349 Profile := New_List (
1350 Make_Parameter_Specification (Loc,
1351 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1352 Parameter_Type =>
1353 Make_Access_Definition (Loc,
1354 Subtype_Mark => New_Reference_To (
1355 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))));
1356
1357 if Nam /= Name_uInput then
1358 Append_To (Profile,
1359 Make_Parameter_Specification (Loc,
1360 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1361 Out_Present => (Nam = Name_uRead),
1362 Parameter_Type => New_Reference_To (Typ, Loc)));
1363 end if;
1364
1365 return Profile;
1366 end Build_Stream_Attr_Profile;
1367
1368 ---------------------------
1369 -- Build_Stream_Function --
1370 ---------------------------
1371
1372 procedure Build_Stream_Function
1373 (Loc : Source_Ptr;
1374 Typ : Entity_Id;
1375 Decl : out Node_Id;
1376 Fnam : Entity_Id;
1377 Decls : List_Id;
1378 Stms : List_Id)
1379 is
1380 Spec : Node_Id;
1381
1382 begin
1383 -- Construct function specification
1384
1385 Spec :=
1386 Make_Function_Specification (Loc,
1387 Defining_Unit_Name => Fnam,
1388
1389 Parameter_Specifications => New_List (
1390 Make_Parameter_Specification (Loc,
1391 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1392 Parameter_Type =>
1393 Make_Access_Definition (Loc,
1394 Subtype_Mark => New_Reference_To (
1395 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))),
1396
1397 Subtype_Mark => New_Occurrence_Of (Typ, Loc));
1398
1399 Decl :=
1400 Make_Subprogram_Body (Loc,
1401 Specification => Spec,
1402 Declarations => Decls,
1403 Handled_Statement_Sequence =>
1404 Make_Handled_Sequence_Of_Statements (Loc,
1405 Statements => Stms));
1406
1407 end Build_Stream_Function;
1408
1409 ----------------------------
1410 -- Build_Stream_Procedure --
1411 ----------------------------
1412
1413 procedure Build_Stream_Procedure
1414 (Loc : Source_Ptr;
1415 Typ : Entity_Id;
1416 Decl : out Node_Id;
1417 Pnam : Entity_Id;
1418 Stms : List_Id;
1419 Outp : Boolean)
1420 is
1421 Spec : Node_Id;
1422
1423 begin
1424 -- Construct procedure specification
1425
1426 Spec :=
1427 Make_Procedure_Specification (Loc,
1428 Defining_Unit_Name => Pnam,
1429
1430 Parameter_Specifications => New_List (
1431 Make_Parameter_Specification (Loc,
1432 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1433 Parameter_Type =>
1434 Make_Access_Definition (Loc,
1435 Subtype_Mark => New_Reference_To (
1436 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))),
1437
1438 Make_Parameter_Specification (Loc,
1439 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1440 Out_Present => Outp,
1441 Parameter_Type => New_Occurrence_Of (Typ, Loc))));
1442
1443 Decl :=
1444 Make_Subprogram_Body (Loc,
1445 Specification => Spec,
1446 Declarations => Empty_List,
1447 Handled_Statement_Sequence =>
1448 Make_Handled_Sequence_Of_Statements (Loc,
1449 Statements => Stms));
1450
1451 end Build_Stream_Procedure;
1452
1453 -----------------------------
1454 -- Has_Stream_Standard_Rep --
1455 -----------------------------
1456
1457 function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean is
1458 begin
1459 if Has_Non_Standard_Rep (U_Type) then
1460 return False;
1461
1462 else
1463 return
1464 Esize (First_Subtype (U_Type)) = Esize (Root_Type (U_Type));
1465 end if;
1466 end Has_Stream_Standard_Rep;
1467
1468 ----------------------
1469 -- Stream_Base_Type --
1470 ----------------------
1471
1472 function Stream_Base_Type (E : Entity_Id) return Entity_Id is
1473 begin
1474 if Is_Array_Type (E)
1475 and then Is_First_Subtype (E)
1476 then
1477 return E;
1478
1479 else
1480 return Base_Type (E);
1481 end if;
1482 end Stream_Base_Type;
1483
1484 end Exp_Strm;
Mirror of the offical gcc git repository hosted at gcc.gnu.org