1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Namet; use Namet;
30 with Nlists; use Nlists;
31 with Nmake; use Nmake;
33 with Rtsfind; use Rtsfind;
34 with Sem_Util; use Sem_Util;
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 Uintp; use Uintp;
42 package body Exp_Strm is
44 -----------------------
45 -- Local Subprograms --
46 -----------------------
48 procedure Build_Array_Read_Write_Procedure
54 -- Common routine shared to build either an array Read procedure or an
55 -- array Write procedure, Nam is Name_Read or Name_Write to select which.
56 -- Pnam is the defining identifier for the constructed procedure. The
57 -- other parameters are as for Build_Array_Read_Procedure except that
58 -- the first parameter Nod supplies the Sloc to be used to generate code.
60 procedure Build_Record_Read_Write_Procedure
66 -- Common routine shared to build a record Read Write procedure, Nam
67 -- is Name_Read or Name_Write to select which. Pnam is the defining
68 -- identifier for the constructed procedure. The other parameters are
69 -- as for Build_Record_Read_Procedure.
71 procedure Build_Stream_Function
78 -- Called to build an array or record stream function. The first three
79 -- arguments are the same as Build_Record_Or_Elementary_Input_Function.
80 -- Decls and Stms are the declarations and statements for the body and
81 -- The parameter Fnam is the name of the constructed function.
83 function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean;
84 -- This function is used to test the type U_Type, to determine if it has
85 -- a standard representation from a streaming point of view. Standard means
86 -- that it has a standard representation (e.g. no enumeration rep clause),
87 -- and the size of the root type is the same as the streaming size (which
88 -- is defined as value specified by a Stream_Size clause if present, or
89 -- the Esize of U_Type if not).
91 function Make_Stream_Subprogram_Name
94 Nam : TSS_Name_Type) return Entity_Id;
95 -- Return the entity that identifies the stream subprogram for type Typ
96 -- that is identified by the given Nam. This procedure deals with the
97 -- difference between tagged types (where a single subprogram associated
98 -- with the type is generated) and all other cases (where a subprogram
99 -- is generated at the point of the stream attribute reference). The
100 -- Loc parameter is used as the Sloc of the created entity.
102 function Stream_Base_Type (E : Entity_Id) return Entity_Id;
103 -- Stream attributes work on the basis of the base type except for the
104 -- array case. For the array case, we do not go to the base type, but
105 -- to the first subtype if it is constrained. This avoids problems with
106 -- incorrect conversions in the packed array case. Stream_Base_Type is
107 -- exactly this function (returns the base type, unless we have an array
108 -- type whose first subtype is constrained, in which case it returns the
111 --------------------------------
112 -- Build_Array_Input_Function --
113 --------------------------------
115 -- The function we build looks like
117 -- function typSI[_nnn] (S : access RST) return Typ is
118 -- L1 : constant Index_Type_1 := Index_Type_1'Input (S);
119 -- H1 : constant Index_Type_1 := Index_Type_1'Input (S);
120 -- L2 : constant Index_Type_2 := Index_Type_2'Input (S);
121 -- H2 : constant Index_Type_2 := Index_Type_2'Input (S);
123 -- Ln : constant Index_Type_n := Index_Type_n'Input (S);
124 -- Hn : constant Index_Type_n := Index_Type_n'Input (S);
126 -- V : Typ'Base (L1 .. H1, L2 .. H2, ... Ln .. Hn)
133 -- Note: the suffix [_nnn] is present for non-tagged types, where we
134 -- generate a local subprogram at the point of the occurrence of the
135 -- attribute reference, so the name must be unique.
137 procedure Build_Array_Input_Function
141 Fnam : out Entity_Id)
143 Dim : constant Pos := Number_Dimensions (Typ);
154 Indx := First_Index (Typ);
156 for J in 1 .. Dim loop
157 Lnam := New_External_Name ('L', J);
158 Hnam := New_External_Name ('H', J);
161 Make_Object_Declaration (Loc,
162 Defining_Identifier => Make_Defining_Identifier (Loc, Lnam),
163 Constant_Present => True,
164 Object_Definition => New_Occurrence_Of (Etype (Indx), Loc),
166 Make_Attribute_Reference (Loc,
168 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
169 Attribute_Name => Name_Input,
170 Expressions => New_List (Make_Identifier (Loc, Name_S)))));
173 Make_Object_Declaration (Loc,
174 Defining_Identifier => Make_Defining_Identifier (Loc, Hnam),
175 Constant_Present => True,
177 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
179 Make_Attribute_Reference (Loc,
181 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
182 Attribute_Name => Name_Input,
183 Expressions => New_List (Make_Identifier (Loc, Name_S)))));
187 Low_Bound => Make_Identifier (Loc, Lnam),
188 High_Bound => Make_Identifier (Loc, Hnam)));
193 -- If the first subtype is constrained, use it directly. Otherwise
194 -- build a subtype indication with the proper bounds.
196 if Is_Constrained (Stream_Base_Type (Typ)) then
198 Make_Object_Declaration (Loc,
199 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
201 New_Occurrence_Of (Stream_Base_Type (Typ), Loc)));
204 Make_Object_Declaration (Loc,
205 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
207 Make_Subtype_Indication (Loc,
209 New_Occurrence_Of (Stream_Base_Type (Typ), Loc),
211 Make_Index_Or_Discriminant_Constraint (Loc,
212 Constraints => Ranges))));
216 Make_Attribute_Reference (Loc,
217 Prefix => New_Occurrence_Of (Typ, Loc),
218 Attribute_Name => Name_Read,
219 Expressions => New_List (
220 Make_Identifier (Loc, Name_S),
221 Make_Identifier (Loc, Name_V))),
223 Make_Simple_Return_Statement (Loc,
224 Expression => Make_Identifier (Loc, Name_V)));
227 Make_Defining_Identifier (Loc,
228 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Input));
230 Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
231 end Build_Array_Input_Function;
233 ----------------------------------
234 -- Build_Array_Output_Procedure --
235 ----------------------------------
237 procedure Build_Array_Output_Procedure
241 Pnam : out Entity_Id)
247 -- Build series of statements to output bounds
249 Indx := First_Index (Typ);
252 for J in 1 .. Number_Dimensions (Typ) loop
254 Make_Attribute_Reference (Loc,
256 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
257 Attribute_Name => Name_Write,
258 Expressions => New_List (
259 Make_Identifier (Loc, Name_S),
260 Make_Attribute_Reference (Loc,
261 Prefix => Make_Identifier (Loc, Name_V),
262 Attribute_Name => Name_First,
263 Expressions => New_List (
264 Make_Integer_Literal (Loc, J))))));
267 Make_Attribute_Reference (Loc,
269 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
270 Attribute_Name => Name_Write,
271 Expressions => New_List (
272 Make_Identifier (Loc, Name_S),
273 Make_Attribute_Reference (Loc,
274 Prefix => Make_Identifier (Loc, Name_V),
275 Attribute_Name => Name_Last,
276 Expressions => New_List (
277 Make_Integer_Literal (Loc, J))))));
282 -- Append Write attribute to write array elements
285 Make_Attribute_Reference (Loc,
286 Prefix => New_Occurrence_Of (Typ, Loc),
287 Attribute_Name => Name_Write,
288 Expressions => New_List (
289 Make_Identifier (Loc, Name_S),
290 Make_Identifier (Loc, Name_V))));
293 Make_Defining_Identifier (Loc,
294 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Output));
296 Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
297 end Build_Array_Output_Procedure;
299 --------------------------------
300 -- Build_Array_Read_Procedure --
301 --------------------------------
303 procedure Build_Array_Read_Procedure
307 Pnam : out Entity_Id)
309 Loc : constant Source_Ptr := Sloc (Nod);
313 Make_Defining_Identifier (Loc,
314 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
315 Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Read);
316 end Build_Array_Read_Procedure;
318 --------------------------------------
319 -- Build_Array_Read_Write_Procedure --
320 --------------------------------------
322 -- The form of the array read/write procedure is as follows:
324 -- procedure pnam (S : access RST, V : [out] Typ) is
326 -- for L1 in V'Range (1) loop
327 -- for L2 in V'Range (2) loop
329 -- for Ln in V'Range (n) loop
330 -- Component_Type'Read/Write (S, V (L1, L2, .. Ln));
337 -- The out keyword for V is supplied in the Read case
339 procedure Build_Array_Read_Write_Procedure
346 Loc : constant Source_Ptr := Sloc (Nod);
347 Ndim : constant Pos := Number_Dimensions (Typ);
348 Ctyp : constant Entity_Id := Component_Type (Typ);
355 -- First build the inner attribute call
359 for J in 1 .. Ndim loop
360 Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', J)));
364 Make_Attribute_Reference (Loc,
365 Prefix => New_Occurrence_Of (Stream_Base_Type (Ctyp), Loc),
366 Attribute_Name => Nam,
367 Expressions => New_List (
368 Make_Identifier (Loc, Name_S),
369 Make_Indexed_Component (Loc,
370 Prefix => Make_Identifier (Loc, Name_V),
371 Expressions => Exl)));
373 -- The corresponding stream attribute for the component type of the
374 -- array may be user-defined, and be frozen after the type for which
375 -- we are generating the stream subprogram. In that case, freeze the
376 -- stream attribute of the component type, whose declaration could not
377 -- generate any additional freezing actions in any case. See 5509-003.
379 if Nam = Name_Read then
380 RW := TSS (Base_Type (Ctyp), TSS_Stream_Read);
382 RW := TSS (Base_Type (Ctyp), TSS_Stream_Write);
386 and then not Is_Frozen (RW)
391 -- Now this is the big loop to wrap that statement up in a sequence
392 -- of loops. The first time around, Stm is the attribute call. The
393 -- second and subsequent times, Stm is an inner loop.
395 for J in 1 .. Ndim loop
397 Make_Implicit_Loop_Statement (Nod,
399 Make_Iteration_Scheme (Loc,
400 Loop_Parameter_Specification =>
401 Make_Loop_Parameter_Specification (Loc,
402 Defining_Identifier =>
403 Make_Defining_Identifier (Loc,
404 Chars => New_External_Name ('L', Ndim - J + 1)),
406 Discrete_Subtype_Definition =>
407 Make_Attribute_Reference (Loc,
408 Prefix => Make_Identifier (Loc, Name_V),
409 Attribute_Name => Name_Range,
411 Expressions => New_List (
412 Make_Integer_Literal (Loc, Ndim - J + 1))))),
414 Statements => New_List (Stm));
418 Build_Stream_Procedure
419 (Loc, Typ, Decl, Pnam, New_List (Stm), Nam = Name_Read);
420 end Build_Array_Read_Write_Procedure;
422 ---------------------------------
423 -- Build_Array_Write_Procedure --
424 ---------------------------------
426 procedure Build_Array_Write_Procedure
430 Pnam : out Entity_Id)
432 Loc : constant Source_Ptr := Sloc (Nod);
436 Make_Defining_Identifier (Loc,
437 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
438 Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Write);
439 end Build_Array_Write_Procedure;
441 ---------------------------------
442 -- Build_Elementary_Input_Call --
443 ---------------------------------
445 function Build_Elementary_Input_Call (N : Node_Id) return Node_Id is
446 Loc : constant Source_Ptr := Sloc (N);
447 P_Type : constant Entity_Id := Entity (Prefix (N));
448 U_Type : constant Entity_Id := Underlying_Type (P_Type);
449 Rt_Type : constant Entity_Id := Root_Type (U_Type);
450 FST : constant Entity_Id := First_Subtype (U_Type);
451 Strm : constant Node_Id := First (Expressions (N));
452 Targ : constant Node_Id := Next (Strm);
458 -- Compute the size of the stream element. This is either the size of
459 -- the first subtype or if given the size of the Stream_Size attribute.
461 if Has_Stream_Size_Clause (FST) then
462 P_Size := Static_Integer (Expression (Stream_Size_Clause (FST)));
464 P_Size := Esize (FST);
467 -- Check first for Boolean and Character. These are enumeration types,
468 -- but we treat them specially, since they may require special handling
469 -- in the transfer protocol. However, this special handling only applies
470 -- if they have standard representation, otherwise they are treated like
471 -- any other enumeration type.
473 if Rt_Type = Standard_Boolean
474 and then Has_Stream_Standard_Rep (U_Type)
478 elsif Rt_Type = Standard_Character
479 and then Has_Stream_Standard_Rep (U_Type)
483 elsif Rt_Type = Standard_Wide_Character
484 and then Has_Stream_Standard_Rep (U_Type)
488 elsif Rt_Type = Standard_Wide_Wide_Character
489 and then Has_Stream_Standard_Rep (U_Type)
493 -- Floating point types
495 elsif Is_Floating_Point_Type (U_Type) then
497 -- Question: should we use P_Size or Rt_Type to distinguish between
498 -- possible floating point types? If a non-standard size or a stream
499 -- size is specified, then we should certainly use the size. But if
500 -- we have two types the same (notably Short_Float_Size = Float_Size
501 -- which is close to universally true, and Long_Long_Float_Size =
502 -- Long_Float_Size, true on most targets except the x86), then we
503 -- would really rather use the root type, so that if people want to
504 -- fiddle with System.Stream_Attributes to get inter-target portable
505 -- streams, they get the size they expect. Consider in particular the
506 -- case of a stream written on an x86, with 96-bit Long_Long_Float
507 -- being read into a non-x86 target with 64 bit Long_Long_Float. A
508 -- special version of System.Stream_Attributes can deal with this
509 -- provided the proper type is always used.
511 -- To deal with these two requirements we add the special checks
512 -- on equal sizes and use the root type to distinguish.
514 if P_Size <= Standard_Short_Float_Size
515 and then (Standard_Short_Float_Size /= Standard_Float_Size
516 or else Rt_Type = Standard_Short_Float)
520 elsif P_Size <= Standard_Float_Size then
523 elsif P_Size <= Standard_Long_Float_Size
524 and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size
525 or else Rt_Type = Standard_Float)
533 -- Signed integer types. Also includes signed fixed-point types and
534 -- enumeration types with a signed representation.
536 -- Note on signed integer types. We do not consider types as signed for
537 -- this purpose if they have no negative numbers, or if they have biased
538 -- representation. The reason is that the value in either case basically
539 -- represents an unsigned value.
541 -- For example, consider:
543 -- type W is range 0 .. 2**32 - 1;
544 -- for W'Size use 32;
546 -- This is a signed type, but the representation is unsigned, and may
547 -- be outside the range of a 32-bit signed integer, so this must be
548 -- treated as 32-bit unsigned.
550 -- Similarly, if we have
552 -- type W is range -1 .. +254;
555 -- then the representation is unsigned
557 elsif not Is_Unsigned_Type (FST)
559 (Is_Fixed_Point_Type (U_Type)
561 Is_Enumeration_Type (U_Type)
563 (Is_Signed_Integer_Type (U_Type)
564 and then not Has_Biased_Representation (FST)))
566 if P_Size <= Standard_Short_Short_Integer_Size then
569 elsif P_Size <= Standard_Short_Integer_Size then
572 elsif P_Size <= Standard_Integer_Size then
575 elsif P_Size <= Standard_Long_Integer_Size then
582 -- Unsigned integer types, also includes unsigned fixed-point types
583 -- and enumeration types with an unsigned representation (note that
584 -- we know they are unsigned because we already tested for signed).
586 -- Also includes signed integer types that are unsigned in the sense
587 -- that they do not include negative numbers. See above for details.
589 elsif Is_Modular_Integer_Type (U_Type)
590 or else Is_Fixed_Point_Type (U_Type)
591 or else Is_Enumeration_Type (U_Type)
592 or else Is_Signed_Integer_Type (U_Type)
594 if P_Size <= Standard_Short_Short_Integer_Size then
597 elsif P_Size <= Standard_Short_Integer_Size then
600 elsif P_Size <= Standard_Integer_Size then
603 elsif P_Size <= Standard_Long_Integer_Size then
610 else pragma Assert (Is_Access_Type (U_Type));
611 if P_Size > System_Address_Size then
618 -- Call the function, and do an unchecked conversion of the result
619 -- to the actual type of the prefix. If the target is a discriminant,
620 -- and we are in the body of the default implementation of a 'Read
621 -- attribute, set target type to force a constraint check (13.13.2(35)).
622 -- If the type of the discriminant is currently private, add another
623 -- unchecked conversion from the full view.
625 if Nkind (Targ) = N_Identifier
626 and then Is_Internal_Name (Chars (Targ))
627 and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read)
630 Unchecked_Convert_To (Base_Type (U_Type),
631 Make_Function_Call (Loc,
632 Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
633 Parameter_Associations => New_List (
634 Relocate_Node (Strm))));
636 Set_Do_Range_Check (Res);
637 if Base_Type (P_Type) /= Base_Type (U_Type) then
638 Res := Unchecked_Convert_To (Base_Type (P_Type), Res);
645 Unchecked_Convert_To (P_Type,
646 Make_Function_Call (Loc,
647 Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
648 Parameter_Associations => New_List (
649 Relocate_Node (Strm))));
651 end Build_Elementary_Input_Call;
653 ---------------------------------
654 -- Build_Elementary_Write_Call --
655 ---------------------------------
657 function Build_Elementary_Write_Call (N : Node_Id) return Node_Id is
658 Loc : constant Source_Ptr := Sloc (N);
659 P_Type : constant Entity_Id := Entity (Prefix (N));
660 U_Type : constant Entity_Id := Underlying_Type (P_Type);
661 Rt_Type : constant Entity_Id := Root_Type (U_Type);
662 FST : constant Entity_Id := First_Subtype (U_Type);
663 Strm : constant Node_Id := First (Expressions (N));
664 Item : constant Node_Id := Next (Strm);
670 -- Compute the size of the stream element. This is either the size of
671 -- the first subtype or if given the size of the Stream_Size attribute.
673 if Has_Stream_Size_Clause (FST) then
674 P_Size := Static_Integer (Expression (Stream_Size_Clause (FST)));
676 P_Size := Esize (FST);
679 -- Find the routine to be called
681 -- Check for First Boolean and Character. These are enumeration types,
682 -- but we treat them specially, since they may require special handling
683 -- in the transfer protocol. However, this special handling only applies
684 -- if they have standard representation, otherwise they are treated like
685 -- any other enumeration type.
687 if Rt_Type = Standard_Boolean
688 and then Has_Stream_Standard_Rep (U_Type)
692 elsif Rt_Type = Standard_Character
693 and then Has_Stream_Standard_Rep (U_Type)
697 elsif Rt_Type = Standard_Wide_Character
698 and then Has_Stream_Standard_Rep (U_Type)
702 elsif Rt_Type = Standard_Wide_Wide_Character
703 and then Has_Stream_Standard_Rep (U_Type)
707 -- Floating point types
709 elsif Is_Floating_Point_Type (U_Type) then
711 -- Question: should we use P_Size or Rt_Type to distinguish between
712 -- possible floating point types? If a non-standard size or a stream
713 -- size is specified, then we should certainly use the size. But if
714 -- we have two types the same (notably Short_Float_Size = Float_Size
715 -- which is close to universally true, and Long_Long_Float_Size =
716 -- Long_Float_Size, true on most targets except the x86), then we
717 -- would really rather use the root type, so that if people want to
718 -- fiddle with System.Stream_Attributes to get inter-target portable
719 -- streams, they get the size they expect. Consider in particular the
720 -- case of a stream written on an x86, with 96-bit Long_Long_Float
721 -- being read into a non-x86 target with 64 bit Long_Long_Float. A
722 -- special version of System.Stream_Attributes can deal with this
723 -- provided the proper type is always used.
725 -- To deal with these two requirements we add the special checks
726 -- on equal sizes and use the root type to distinguish.
728 if P_Size <= Standard_Short_Float_Size
729 and then (Standard_Short_Float_Size /= Standard_Float_Size
730 or else Rt_Type = Standard_Short_Float)
734 elsif P_Size <= Standard_Float_Size then
737 elsif P_Size <= Standard_Long_Float_Size
738 and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size
739 or else Rt_Type = Standard_Float)
747 -- Signed integer types. Also includes signed fixed-point types and
748 -- signed enumeration types share this circuitry.
750 -- Note on signed integer types. We do not consider types as signed for
751 -- this purpose if they have no negative numbers, or if they have biased
752 -- representation. The reason is that the value in either case basically
753 -- represents an unsigned value.
755 -- For example, consider:
757 -- type W is range 0 .. 2**32 - 1;
758 -- for W'Size use 32;
760 -- This is a signed type, but the representation is unsigned, and may
761 -- be outside the range of a 32-bit signed integer, so this must be
762 -- treated as 32-bit unsigned.
764 -- Similarly, the representation is also unsigned if we have:
766 -- type W is range -1 .. +254;
769 -- forcing a biased and unsigned representation
771 elsif not Is_Unsigned_Type (FST)
773 (Is_Fixed_Point_Type (U_Type)
775 Is_Enumeration_Type (U_Type)
777 (Is_Signed_Integer_Type (U_Type)
778 and then not Has_Biased_Representation (FST)))
780 if P_Size <= Standard_Short_Short_Integer_Size then
782 elsif P_Size <= Standard_Short_Integer_Size then
784 elsif P_Size <= Standard_Integer_Size then
786 elsif P_Size <= Standard_Long_Integer_Size then
792 -- Unsigned integer types, also includes unsigned fixed-point types
793 -- and unsigned enumeration types (note we know they are unsigned
794 -- because we already tested for signed above).
796 -- Also includes signed integer types that are unsigned in the sense
797 -- that they do not include negative numbers. See above for details.
799 elsif Is_Modular_Integer_Type (U_Type)
800 or else Is_Fixed_Point_Type (U_Type)
801 or else Is_Enumeration_Type (U_Type)
802 or else Is_Signed_Integer_Type (U_Type)
804 if P_Size <= Standard_Short_Short_Integer_Size then
806 elsif P_Size <= Standard_Short_Integer_Size then
808 elsif P_Size <= Standard_Integer_Size then
810 elsif P_Size <= Standard_Long_Integer_Size then
816 else pragma Assert (Is_Access_Type (U_Type));
818 if P_Size > System_Address_Size then
825 -- Unchecked-convert parameter to the required type (i.e. the type of
826 -- the corresponding parameter, and call the appropriate routine.
828 Libent := RTE (Lib_RE);
831 Make_Procedure_Call_Statement (Loc,
832 Name => New_Occurrence_Of (Libent, Loc),
833 Parameter_Associations => New_List (
834 Relocate_Node (Strm),
835 Unchecked_Convert_To (Etype (Next_Formal (First_Formal (Libent))),
836 Relocate_Node (Item))));
837 end Build_Elementary_Write_Call;
839 -----------------------------------------
840 -- Build_Mutable_Record_Read_Procedure --
841 -----------------------------------------
843 procedure Build_Mutable_Record_Read_Procedure
847 Pnam : out Entity_Id)
849 Out_Formal : Node_Id;
850 -- Expression denoting the out formal parameter
852 Dcls : constant List_Id := New_List;
853 -- Declarations for the 'Read body
855 Stms : List_Id := New_List;
856 -- Statements for the 'Read body
859 -- Entity of the discriminant being processed
861 Tmp_For_Disc : Entity_Id;
862 -- Temporary object used to read the value of Disc
864 Tmps_For_Discs : constant List_Id := New_List;
865 -- List of object declarations for temporaries holding the read values
866 -- for the discriminants.
868 Cstr : constant List_Id := New_List;
869 -- List of constraints to be applied on temporary record
871 Discriminant_Checks : constant List_Id := New_List;
872 -- List of discriminant checks to be performed if the actual object
875 Tmp : constant Entity_Id := Make_Defining_Identifier (Loc, Name_V);
876 -- Temporary record must hide formal (assignments to components of the
877 -- record are always generated with V as the identifier for the record).
879 Constrained_Stms : List_Id := New_List;
880 -- Statements within the block where we have the constrained temporary
884 Disc := First_Discriminant (Typ);
886 -- A mutable type cannot be a tagged type, so we generate a new name
887 -- for the stream procedure.
890 Make_Defining_Identifier (Loc,
891 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
894 Make_Selected_Component (Loc,
895 Prefix => New_Occurrence_Of (Pnam, Loc),
896 Selector_Name => Make_Identifier (Loc, Name_V));
898 -- Generate Reads for the discriminants of the type. The discriminants
899 -- need to be read before the rest of the components, so that
900 -- variants are initialized correctly. The discriminants must be read
901 -- into temporary variables so an incomplete Read (interrupted by an
902 -- exception, for example) does not alter the passed object.
904 while Present (Disc) loop
905 Tmp_For_Disc := Make_Defining_Identifier (Loc,
906 New_External_Name (Chars (Disc), "D"));
908 Append_To (Tmps_For_Discs,
909 Make_Object_Declaration (Loc,
910 Defining_Identifier => Tmp_For_Disc,
911 Object_Definition => New_Occurrence_Of (Etype (Disc), Loc)));
912 Set_No_Initialization (Last (Tmps_For_Discs));
915 Make_Attribute_Reference (Loc,
916 Prefix => New_Occurrence_Of (Etype (Disc), Loc),
917 Attribute_Name => Name_Read,
918 Expressions => New_List (
919 Make_Identifier (Loc, Name_S),
920 New_Occurrence_Of (Tmp_For_Disc, Loc))));
923 Make_Discriminant_Association (Loc,
924 Selector_Names => New_List (New_Occurrence_Of (Disc, Loc)),
925 Expression => New_Occurrence_Of (Tmp_For_Disc, Loc)));
927 Append_To (Discriminant_Checks,
928 Make_Raise_Constraint_Error (Loc,
931 Left_Opnd => New_Occurrence_Of (Tmp_For_Disc, Loc),
933 Make_Selected_Component (Loc,
934 Prefix => New_Copy_Tree (Out_Formal),
935 Selector_Name => New_Occurrence_Of (Disc, Loc))),
936 Reason => CE_Discriminant_Check_Failed));
937 Next_Discriminant (Disc);
940 -- Generate reads for the components of the record (including
941 -- those that depend on discriminants).
943 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
945 -- If Typ has controlled components (i.e. if it is classwide
946 -- or Has_Controlled), or components constrained using the discriminants
947 -- of Typ, then we need to ensure that all component assignments
948 -- are performed on an object that has been appropriately constrained
949 -- prior to being initialized. To this effect, we wrap the component
950 -- assignments in a block where V is a constrained temporary.
953 Make_Object_Declaration (Loc,
954 Defining_Identifier => Tmp,
956 Make_Subtype_Indication (Loc,
957 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
959 Make_Index_Or_Discriminant_Constraint (Loc,
960 Constraints => Cstr))));
962 Constrained_Stms := Statements (Handled_Statement_Sequence (Decl));
964 Make_Block_Statement (Loc,
965 Declarations => Dcls,
966 Handled_Statement_Sequence => Parent (Constrained_Stms)));
968 Append_To (Constrained_Stms,
969 Make_Implicit_If_Statement (Pnam,
971 Make_Attribute_Reference (Loc,
972 Prefix => New_Copy_Tree (Out_Formal),
973 Attribute_Name => Name_Constrained),
974 Then_Statements => Discriminant_Checks));
976 Append_To (Constrained_Stms,
977 Make_Assignment_Statement (Loc,
979 Expression => Make_Identifier (Loc, Name_V)));
981 if Is_Unchecked_Union (Typ) then
983 -- If this is an unchecked union, the stream procedure is erroneous,
984 -- because there are no discriminants to read.
986 -- This should generate a warning ???
990 Make_Raise_Program_Error (Loc,
991 Reason => PE_Unchecked_Union_Restriction));
994 Set_Declarations (Decl, Tmps_For_Discs);
995 Set_Handled_Statement_Sequence (Decl,
996 Make_Handled_Sequence_Of_Statements (Loc,
997 Statements => Stms));
998 end Build_Mutable_Record_Read_Procedure;
1000 ------------------------------------------
1001 -- Build_Mutable_Record_Write_Procedure --
1002 ------------------------------------------
1004 procedure Build_Mutable_Record_Write_Procedure
1008 Pnam : out Entity_Id)
1016 Disc := First_Discriminant (Typ);
1018 -- Generate Writes for the discriminants of the type
1019 -- If the type is an unchecked union, use the default values of
1020 -- the discriminants, because they are not stored.
1022 while Present (Disc) loop
1023 if Is_Unchecked_Union (Typ) then
1025 New_Copy_Tree (Discriminant_Default_Value (Disc));
1028 Make_Selected_Component (Loc,
1029 Prefix => Make_Identifier (Loc, Name_V),
1030 Selector_Name => New_Occurrence_Of (Disc, Loc));
1034 Make_Attribute_Reference (Loc,
1035 Prefix => New_Occurrence_Of (Etype (Disc), Loc),
1036 Attribute_Name => Name_Write,
1037 Expressions => New_List (
1038 Make_Identifier (Loc, Name_S),
1041 Next_Discriminant (Disc);
1044 -- A mutable type cannot be a tagged type, so we generate a new name
1045 -- for the stream procedure.
1048 Make_Defining_Identifier (Loc,
1049 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
1050 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
1052 -- Write the discriminants before the rest of the components, so
1053 -- that discriminant values are properly set of variants, etc.
1055 if Is_Non_Empty_List (
1056 Statements (Handled_Statement_Sequence (Decl)))
1059 (First (Statements (Handled_Statement_Sequence (Decl))), Stms);
1061 Set_Statements (Handled_Statement_Sequence (Decl), Stms);
1063 end Build_Mutable_Record_Write_Procedure;
1065 -----------------------------------------------
1066 -- Build_Record_Or_Elementary_Input_Function --
1067 -----------------------------------------------
1069 -- The function we build looks like
1071 -- function InputN (S : access RST) return Typ is
1072 -- C1 : constant Disc_Type_1;
1073 -- Discr_Type_1'Read (S, C1);
1074 -- C2 : constant Disc_Type_2;
1075 -- Discr_Type_2'Read (S, C2);
1077 -- Cn : constant Disc_Type_n;
1078 -- Discr_Type_n'Read (S, Cn);
1079 -- V : Typ (C1, C2, .. Cn)
1086 -- The discriminants are of course only present in the case of a record
1087 -- with discriminants. In the case of a record with no discriminants, or
1088 -- an elementary type, then no Cn constants are defined.
1090 procedure Build_Record_Or_Elementary_Input_Function
1094 Fnam : out Entity_Id)
1110 if Has_Discriminants (Typ) then
1111 Discr := First_Discriminant (Typ);
1113 while Present (Discr) loop
1114 Cn := New_External_Name ('C', J);
1117 Make_Object_Declaration (Loc,
1118 Defining_Identifier => Make_Defining_Identifier (Loc, Cn),
1119 Object_Definition =>
1120 New_Occurrence_Of (Etype (Discr), Loc)));
1123 Make_Attribute_Reference (Loc,
1124 Prefix => New_Occurrence_Of (Etype (Discr), Loc),
1125 Attribute_Name => Name_Read,
1126 Expressions => New_List (
1127 Make_Identifier (Loc, Name_S),
1128 Make_Identifier (Loc, Cn))));
1130 Append_To (Constr, Make_Identifier (Loc, Cn));
1132 Next_Discriminant (Discr);
1137 Make_Subtype_Indication (Loc,
1138 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
1140 Make_Index_Or_Discriminant_Constraint (Loc,
1141 Constraints => Constr));
1143 -- If no discriminants, then just use the type with no constraint
1146 Odef := New_Occurrence_Of (Typ, Loc);
1149 -- For Ada 2005 we create an extended return statement encapsulating
1150 -- the result object and 'Read call, which is needed in general for
1151 -- proper handling of build-in-place results (such as when the result
1152 -- type is inherently limited).
1154 -- Perhaps we should just generate an extended return in all cases???
1156 if Ada_Version >= Ada_05 then
1158 Make_Extended_Return_Statement (Loc,
1159 Return_Object_Declarations =>
1160 New_List (Make_Object_Declaration (Loc,
1161 Defining_Identifier =>
1162 Make_Defining_Identifier (Loc, Name_V),
1163 Object_Definition => Odef)),
1164 Handled_Statement_Sequence =>
1165 Make_Handled_Sequence_Of_Statements (Loc,
1166 New_List (Make_Attribute_Reference (Loc,
1167 Prefix => New_Occurrence_Of (Typ, Loc),
1168 Attribute_Name => Name_Read,
1169 Expressions => New_List (
1170 Make_Identifier (Loc, Name_S),
1171 Make_Identifier (Loc, Name_V)))))));
1175 Make_Object_Declaration (Loc,
1176 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1177 Object_Definition => Odef));
1180 Make_Attribute_Reference (Loc,
1181 Prefix => New_Occurrence_Of (Typ, Loc),
1182 Attribute_Name => Name_Read,
1183 Expressions => New_List (
1184 Make_Identifier (Loc, Name_S),
1185 Make_Identifier (Loc, Name_V))),
1187 Make_Simple_Return_Statement (Loc,
1188 Expression => Make_Identifier (Loc, Name_V)));
1191 Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input);
1193 Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
1194 end Build_Record_Or_Elementary_Input_Function;
1196 -------------------------------------------------
1197 -- Build_Record_Or_Elementary_Output_Procedure --
1198 -------------------------------------------------
1200 procedure Build_Record_Or_Elementary_Output_Procedure
1204 Pnam : out Entity_Id)
1213 -- Note that of course there will be no discriminants for the
1214 -- elementary type case, so Has_Discriminants will be False.
1216 if Has_Discriminants (Typ) then
1217 Disc := First_Discriminant (Typ);
1219 while Present (Disc) loop
1221 -- If the type is an unchecked union, it must have default
1222 -- discriminants (this is checked earlier), and those defaults
1223 -- are written out to the stream.
1225 if Is_Unchecked_Union (Typ) then
1226 Disc_Ref := New_Copy_Tree (Discriminant_Default_Value (Disc));
1230 Make_Selected_Component (Loc,
1231 Prefix => Make_Identifier (Loc, Name_V),
1232 Selector_Name => New_Occurrence_Of (Disc, Loc));
1236 Make_Attribute_Reference (Loc,
1238 New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc),
1239 Attribute_Name => Name_Write,
1240 Expressions => New_List (
1241 Make_Identifier (Loc, Name_S),
1244 Next_Discriminant (Disc);
1249 Make_Attribute_Reference (Loc,
1250 Prefix => New_Occurrence_Of (Typ, Loc),
1251 Attribute_Name => Name_Write,
1252 Expressions => New_List (
1253 Make_Identifier (Loc, Name_S),
1254 Make_Identifier (Loc, Name_V))));
1256 Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output);
1258 Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
1259 end Build_Record_Or_Elementary_Output_Procedure;
1261 ---------------------------------
1262 -- Build_Record_Read_Procedure --
1263 ---------------------------------
1265 procedure Build_Record_Read_Procedure
1269 Pnam : out Entity_Id)
1272 Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Read);
1273 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
1274 end Build_Record_Read_Procedure;
1276 ---------------------------------------
1277 -- Build_Record_Read_Write_Procedure --
1278 ---------------------------------------
1280 -- The form of the record read/write procedure is as shown by the
1281 -- following example for a case with one discriminant case variant:
1283 -- procedure pnam (S : access RST, V : [out] Typ) is
1285 -- Component_Type'Read/Write (S, V.component);
1286 -- Component_Type'Read/Write (S, V.component);
1288 -- Component_Type'Read/Write (S, V.component);
1290 -- case V.discriminant is
1292 -- Component_Type'Read/Write (S, V.component);
1293 -- Component_Type'Read/Write (S, V.component);
1295 -- Component_Type'Read/Write (S, V.component);
1298 -- Component_Type'Read/Write (S, V.component);
1299 -- Component_Type'Read/Write (S, V.component);
1301 -- Component_Type'Read/Write (S, V.component);
1306 -- The out keyword for V is supplied in the Read case
1308 procedure Build_Record_Read_Write_Procedure
1319 In_Limited_Extension : Boolean := False;
1320 -- Set to True while processing the record extension definition
1321 -- for an extension of a limited type (for which an ancestor type
1322 -- has an explicit Nam attribute definition).
1324 function Make_Component_List_Attributes (CL : Node_Id) return List_Id;
1325 -- Returns a sequence of attributes to process the components that
1326 -- are referenced in the given component list.
1328 function Make_Field_Attribute (C : Entity_Id) return Node_Id;
1329 -- Given C, the entity for a discriminant or component, build
1330 -- an attribute for the corresponding field values.
1332 function Make_Field_Attributes (Clist : List_Id) return List_Id;
1333 -- Given Clist, a component items list, construct series of attributes
1334 -- for fieldwise processing of the corresponding components.
1336 ------------------------------------
1337 -- Make_Component_List_Attributes --
1338 ------------------------------------
1340 function Make_Component_List_Attributes (CL : Node_Id) return List_Id is
1341 CI : constant List_Id := Component_Items (CL);
1342 VP : constant Node_Id := Variant_Part (CL);
1352 Result := Make_Field_Attributes (CI);
1354 if Present (VP) then
1357 V := First_Non_Pragma (Variants (VP));
1358 while Present (V) loop
1361 DC := First (Discrete_Choices (V));
1362 while Present (DC) loop
1363 Append_To (DCH, New_Copy_Tree (DC));
1368 Make_Case_Statement_Alternative (Loc,
1369 Discrete_Choices => DCH,
1371 Make_Component_List_Attributes (Component_List (V))));
1372 Next_Non_Pragma (V);
1375 -- Note: in the following, we make sure that we use new occurrence
1376 -- of for the selector, since there are cases in which we make a
1377 -- reference to a hidden discriminant that is not visible.
1379 -- If the enclosing record is an unchecked_union, we use the
1380 -- default expressions for the discriminant (it must exist)
1381 -- because we cannot generate a reference to it, given that
1382 -- it is not stored..
1384 if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then
1387 (Discriminant_Default_Value (Entity (Name (VP))));
1390 Make_Selected_Component (Loc,
1391 Prefix => Make_Identifier (Loc, Name_V),
1393 New_Occurrence_Of (Entity (Name (VP)), Loc));
1397 Make_Case_Statement (Loc,
1398 Expression => D_Ref,
1399 Alternatives => Alts));
1403 end Make_Component_List_Attributes;
1405 --------------------------
1406 -- Make_Field_Attribute --
1407 --------------------------
1409 function Make_Field_Attribute (C : Entity_Id) return Node_Id is
1410 Field_Typ : constant Entity_Id := Stream_Base_Type (Etype (C));
1412 TSS_Names : constant array (Name_Input .. Name_Write) of
1414 (Name_Read => TSS_Stream_Read,
1415 Name_Write => TSS_Stream_Write,
1416 Name_Input => TSS_Stream_Input,
1417 Name_Output => TSS_Stream_Output,
1418 others => TSS_Null);
1419 pragma Assert (TSS_Names (Nam) /= TSS_Null);
1422 if In_Limited_Extension
1423 and then Is_Limited_Type (Field_Typ)
1424 and then No (Find_Inherited_TSS (Field_Typ, TSS_Names (Nam)))
1426 -- The declaration is illegal per 13.13.2(9/1), and this is
1427 -- enforced in Exp_Ch3.Check_Stream_Attributes. Keep the caller
1428 -- happy by returning a null statement.
1430 return Make_Null_Statement (Loc);
1434 Make_Attribute_Reference (Loc,
1436 New_Occurrence_Of (Field_Typ, Loc),
1437 Attribute_Name => Nam,
1438 Expressions => New_List (
1439 Make_Identifier (Loc, Name_S),
1440 Make_Selected_Component (Loc,
1441 Prefix => Make_Identifier (Loc, Name_V),
1442 Selector_Name => New_Occurrence_Of (C, Loc))));
1443 end Make_Field_Attribute;
1445 ---------------------------
1446 -- Make_Field_Attributes --
1447 ---------------------------
1449 function Make_Field_Attributes (Clist : List_Id) return List_Id is
1456 if Present (Clist) then
1457 Item := First (Clist);
1459 -- Loop through components, skipping all internal components,
1460 -- which are not part of the value (e.g. _Tag), except that we
1461 -- don't skip the _Parent, since we do want to process that
1462 -- recursively. If _Parent is an interface type, being abstract
1463 -- with no components there is no need to handle it.
1465 while Present (Item) loop
1466 if Nkind (Item) = N_Component_Declaration
1468 ((Chars (Defining_Identifier (Item)) = Name_uParent
1469 and then not Is_Interface
1470 (Etype (Defining_Identifier (Item))))
1472 not Is_Internal_Name (Chars (Defining_Identifier (Item))))
1476 Make_Field_Attribute (Defining_Identifier (Item)));
1484 end Make_Field_Attributes;
1486 -- Start of processing for Build_Record_Read_Write_Procedure
1489 -- For the protected type case, use corresponding record
1491 if Is_Protected_Type (Typ) then
1492 Typt := Corresponding_Record_Type (Typ);
1497 -- Note that we do nothing with the discriminants, since Read and
1498 -- Write do not read or write the discriminant values. All handling
1499 -- of discriminants occurs in the Input and Output subprograms.
1501 Rdef := Type_Definition
1502 (Declaration_Node (Base_Type (Underlying_Type (Typt))));
1505 -- In record extension case, the fields we want, including the _Parent
1506 -- field representing the parent type, are to be found in the extension.
1507 -- Note that we will naturally process the _Parent field using the type
1508 -- of the parent, and hence its stream attributes, which is appropriate.
1510 if Nkind (Rdef) = N_Derived_Type_Definition then
1511 Rdef := Record_Extension_Part (Rdef);
1513 if Is_Limited_Type (Typt) then
1514 In_Limited_Extension := True;
1518 if Present (Component_List (Rdef)) then
1519 Append_List_To (Stms,
1520 Make_Component_List_Attributes (Component_List (Rdef)));
1523 Build_Stream_Procedure
1524 (Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read);
1525 end Build_Record_Read_Write_Procedure;
1527 ----------------------------------
1528 -- Build_Record_Write_Procedure --
1529 ----------------------------------
1531 procedure Build_Record_Write_Procedure
1535 Pnam : out Entity_Id)
1538 Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Write);
1539 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
1540 end Build_Record_Write_Procedure;
1542 -------------------------------
1543 -- Build_Stream_Attr_Profile --
1544 -------------------------------
1546 function Build_Stream_Attr_Profile
1549 Nam : TSS_Name_Type) return List_Id
1554 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has
1555 -- no semantic meaning in Ada 95 but it is a requirement in Ada2005.
1557 Profile := New_List (
1558 Make_Parameter_Specification (Loc,
1559 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1561 Make_Access_Definition (Loc,
1562 Null_Exclusion_Present => True,
1563 Subtype_Mark => New_Reference_To (
1564 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))));
1566 if Nam /= TSS_Stream_Input then
1568 Make_Parameter_Specification (Loc,
1569 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1570 Out_Present => (Nam = TSS_Stream_Read),
1571 Parameter_Type => New_Reference_To (Typ, Loc)));
1575 end Build_Stream_Attr_Profile;
1577 ---------------------------
1578 -- Build_Stream_Function --
1579 ---------------------------
1581 procedure Build_Stream_Function
1592 -- Construct function specification
1594 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has
1595 -- no semantic meaning in Ada 95 but it is a requirement in Ada2005.
1598 Make_Function_Specification (Loc,
1599 Defining_Unit_Name => Fnam,
1601 Parameter_Specifications => New_List (
1602 Make_Parameter_Specification (Loc,
1603 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1605 Make_Access_Definition (Loc,
1606 Null_Exclusion_Present => True,
1607 Subtype_Mark => New_Reference_To (
1608 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))),
1610 Result_Definition => New_Occurrence_Of (Typ, Loc));
1613 Make_Subprogram_Body (Loc,
1614 Specification => Spec,
1615 Declarations => Decls,
1616 Handled_Statement_Sequence =>
1617 Make_Handled_Sequence_Of_Statements (Loc,
1618 Statements => Stms));
1619 end Build_Stream_Function;
1621 ----------------------------
1622 -- Build_Stream_Procedure --
1623 ----------------------------
1625 procedure Build_Stream_Procedure
1636 -- Construct procedure specification
1638 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has
1639 -- no semantic meaning in Ada 95 but it is a requirement in Ada2005.
1642 Make_Procedure_Specification (Loc,
1643 Defining_Unit_Name => Pnam,
1645 Parameter_Specifications => New_List (
1646 Make_Parameter_Specification (Loc,
1647 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1649 Make_Access_Definition (Loc,
1650 Null_Exclusion_Present => True,
1651 Subtype_Mark => New_Reference_To (
1652 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))),
1654 Make_Parameter_Specification (Loc,
1655 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1656 Out_Present => Outp,
1657 Parameter_Type => New_Occurrence_Of (Typ, Loc))));
1660 Make_Subprogram_Body (Loc,
1661 Specification => Spec,
1662 Declarations => Empty_List,
1663 Handled_Statement_Sequence =>
1664 Make_Handled_Sequence_Of_Statements (Loc,
1665 Statements => Stms));
1666 end Build_Stream_Procedure;
1668 -----------------------------
1669 -- Has_Stream_Standard_Rep --
1670 -----------------------------
1672 function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean is
1676 if Has_Non_Standard_Rep (U_Type) then
1680 if Has_Stream_Size_Clause (U_Type) then
1681 Siz := Static_Integer (Expression (Stream_Size_Clause (U_Type)));
1683 Siz := Esize (First_Subtype (U_Type));
1686 return Siz = Esize (Root_Type (U_Type));
1687 end Has_Stream_Standard_Rep;
1689 ---------------------------------
1690 -- Make_Stream_Subprogram_Name --
1691 ---------------------------------
1693 function Make_Stream_Subprogram_Name
1696 Nam : TSS_Name_Type) return Entity_Id
1701 -- For tagged types, we are dealing with a TSS associated with the
1702 -- declaration, so we use the standard primitive function name. For
1703 -- other types, generate a local TSS name since we are generating
1704 -- the subprogram at the point of use.
1706 if Is_Tagged_Type (Typ) then
1707 Sname := Make_TSS_Name (Typ, Nam);
1709 Sname := Make_TSS_Name_Local (Typ, Nam);
1712 return Make_Defining_Identifier (Loc, Sname);
1713 end Make_Stream_Subprogram_Name;
1715 ----------------------
1716 -- Stream_Base_Type --
1717 ----------------------
1719 function Stream_Base_Type (E : Entity_Id) return Entity_Id is
1721 if Is_Array_Type (E)
1722 and then Is_First_Subtype (E)
1726 return Base_Type (E);
1728 end Stream_Base_Type;