1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, 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
;
32 with Rtsfind
; use Rtsfind
;
33 with Sem_Util
; use Sem_Util
;
34 with Sinfo
; use Sinfo
;
35 with Snames
; use Snames
;
36 with Stand
; use Stand
;
37 with Tbuild
; use Tbuild
;
38 with Ttypes
; use Ttypes
;
39 with Uintp
; use Uintp
;
41 package body Exp_Strm
is
43 -----------------------
44 -- Local Subprograms --
45 -----------------------
47 procedure Build_Array_Read_Write_Procedure
53 -- Common routine shared to build either an array Read procedure or an
54 -- array Write procedure, Nam is Name_Read or Name_Write to select which.
55 -- Pnam is the defining identifier for the constructed procedure. The
56 -- other parameters are as for Build_Array_Read_Procedure except that
57 -- the first parameter Nod supplies the Sloc to be used to generate code.
59 procedure Build_Record_Read_Write_Procedure
65 -- Common routine shared to build a record Read Write procedure, Nam
66 -- is Name_Read or Name_Write to select which. Pnam is the defining
67 -- identifier for the constructed procedure. The other parameters are
68 -- as for Build_Record_Read_Procedure.
70 procedure Build_Stream_Function
77 -- Called to build an array or record stream function. The first three
78 -- arguments are the same as Build_Record_Or_Elementary_Input_Function.
79 -- Decls and Stms are the declarations and statements for the body and
80 -- The parameter Fnam is the name of the constructed function.
82 function Has_Stream_Standard_Rep
(U_Type
: Entity_Id
) return Boolean;
83 -- This function is used to test U_Type, which is a type
84 -- Returns True if U_Type has a standard representation for stream
85 -- purposes, i.e. there is no non-standard enumeration representation
86 -- clause, and the size of the first subtype is the same as the size
89 function Make_Stream_Subprogram_Name
92 Nam
: TSS_Name_Type
) return Entity_Id
;
93 -- Return the entity that identifies the stream subprogram for type Typ
94 -- that is identified by the given Nam. This procedure deals with the
95 -- difference between tagged types (where a single subprogram associated
96 -- with the type is generated) and all other cases (where a subprogram
97 -- is generated at the point of the stream attribute reference). The
98 -- Loc parameter is used as the Sloc of the created entity.
100 function Stream_Base_Type
(E
: Entity_Id
) return Entity_Id
;
101 -- Stream attributes work on the basis of the base type except for the
102 -- array case. For the array case, we do not go to the base type, but
103 -- to the first subtype if it is constrained. This avoids problems with
104 -- incorrect conversions in the packed array case. Stream_Base_Type is
105 -- exactly this function (returns the base type, unless we have an array
106 -- type whose first subtype is constrained, in which case it returns the
109 --------------------------------
110 -- Build_Array_Input_Function --
111 --------------------------------
113 -- The function we build looks like
115 -- function typSI[_nnn] (S : access RST) return Typ is
116 -- L1 : constant Index_Type_1 := Index_Type_1'Input (S);
117 -- H1 : constant Index_Type_1 := Index_Type_1'Input (S);
118 -- L2 : constant Index_Type_2 := Index_Type_2'Input (S);
119 -- H2 : constant Index_Type_2 := Index_Type_2'Input (S);
121 -- Ln : constant Index_Type_n := Index_Type_n'Input (S);
122 -- Hn : constant Index_Type_n := Index_Type_n'Input (S);
124 -- V : Typ'Base (L1 .. H1, L2 .. H2, ... Ln .. Hn)
131 -- Note: the suffix [_nnn] is present for non-tagged types, where we
132 -- generate a local subprogram at the point of the occurrence of the
133 -- attribute reference, so the name must be unique.
135 procedure Build_Array_Input_Function
139 Fnam
: out Entity_Id
)
141 Dim
: constant Pos
:= Number_Dimensions
(Typ
);
152 Indx
:= First_Index
(Typ
);
154 for J
in 1 .. Dim
loop
155 Lnam
:= New_External_Name
('L', J
);
156 Hnam
:= New_External_Name
('H', J
);
159 Make_Object_Declaration
(Loc
,
160 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Lnam
),
161 Constant_Present
=> True,
162 Object_Definition
=> New_Occurrence_Of
(Etype
(Indx
), Loc
),
164 Make_Attribute_Reference
(Loc
,
166 New_Occurrence_Of
(Stream_Base_Type
(Etype
(Indx
)), Loc
),
167 Attribute_Name
=> Name_Input
,
168 Expressions
=> New_List
(Make_Identifier
(Loc
, Name_S
)))));
171 Make_Object_Declaration
(Loc
,
172 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Hnam
),
173 Constant_Present
=> True,
175 New_Occurrence_Of
(Stream_Base_Type
(Etype
(Indx
)), Loc
),
177 Make_Attribute_Reference
(Loc
,
179 New_Occurrence_Of
(Stream_Base_Type
(Etype
(Indx
)), Loc
),
180 Attribute_Name
=> Name_Input
,
181 Expressions
=> New_List
(Make_Identifier
(Loc
, Name_S
)))));
185 Low_Bound
=> Make_Identifier
(Loc
, Lnam
),
186 High_Bound
=> Make_Identifier
(Loc
, Hnam
)));
191 -- If the first subtype is constrained, use it directly. Otherwise
192 -- build a subtype indication with the proper bounds.
194 if Is_Constrained
(Stream_Base_Type
(Typ
)) then
196 Make_Object_Declaration
(Loc
,
197 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
199 New_Occurrence_Of
(Stream_Base_Type
(Typ
), Loc
)));
202 Make_Object_Declaration
(Loc
,
203 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
205 Make_Subtype_Indication
(Loc
,
207 New_Occurrence_Of
(Stream_Base_Type
(Typ
), Loc
),
209 Make_Index_Or_Discriminant_Constraint
(Loc
,
210 Constraints
=> Ranges
))));
214 Make_Attribute_Reference
(Loc
,
215 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
216 Attribute_Name
=> Name_Read
,
217 Expressions
=> New_List
(
218 Make_Identifier
(Loc
, Name_S
),
219 Make_Identifier
(Loc
, Name_V
))),
221 Make_Return_Statement
(Loc
,
222 Expression
=> Make_Identifier
(Loc
, Name_V
)));
225 Make_Defining_Identifier
(Loc
,
226 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Input
));
228 Build_Stream_Function
(Loc
, Typ
, Decl
, Fnam
, Decls
, Stms
);
229 end Build_Array_Input_Function
;
231 ----------------------------------
232 -- Build_Array_Output_Procedure --
233 ----------------------------------
235 procedure Build_Array_Output_Procedure
239 Pnam
: out Entity_Id
)
245 -- Build series of statements to output bounds
247 Indx
:= First_Index
(Typ
);
250 for J
in 1 .. Number_Dimensions
(Typ
) loop
252 Make_Attribute_Reference
(Loc
,
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
))))));
265 Make_Attribute_Reference
(Loc
,
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
))))));
280 -- Append Write attribute to write array elements
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
))));
291 Make_Defining_Identifier
(Loc
,
292 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Output
));
294 Build_Stream_Procedure
(Loc
, Typ
, Decl
, Pnam
, Stms
, False);
295 end Build_Array_Output_Procedure
;
297 --------------------------------
298 -- Build_Array_Read_Procedure --
299 --------------------------------
301 procedure Build_Array_Read_Procedure
305 Pnam
: out Entity_Id
)
307 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
311 Make_Defining_Identifier
(Loc
,
312 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Read
));
313 Build_Array_Read_Write_Procedure
(Nod
, Typ
, Decl
, Pnam
, Name_Read
);
314 end Build_Array_Read_Procedure
;
316 --------------------------------------
317 -- Build_Array_Read_Write_Procedure --
318 --------------------------------------
320 -- The form of the array read/write procedure is as follows:
322 -- procedure pnam (S : access RST, V : [out] Typ) is
324 -- for L1 in V'Range (1) loop
325 -- for L2 in V'Range (2) loop
327 -- for Ln in V'Range (n) loop
328 -- Component_Type'Read/Write (S, V (L1, L2, .. Ln));
335 -- The out keyword for V is supplied in the Read case
337 procedure Build_Array_Read_Write_Procedure
344 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
345 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
346 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
353 -- First build the inner attribute call
357 for J
in 1 .. Ndim
loop
358 Append_To
(Exl
, Make_Identifier
(Loc
, New_External_Name
('L', J
)));
362 Make_Attribute_Reference
(Loc
,
363 Prefix
=> New_Occurrence_Of
(Stream_Base_Type
(Ctyp
), Loc
),
364 Attribute_Name
=> Nam
,
365 Expressions
=> New_List
(
366 Make_Identifier
(Loc
, Name_S
),
367 Make_Indexed_Component
(Loc
,
368 Prefix
=> Make_Identifier
(Loc
, Name_V
),
369 Expressions
=> Exl
)));
371 -- The corresponding stream attribute for the component type of the
372 -- array may be user-defined, and be frozen after the type for which
373 -- we are generating the stream subprogram. In that case, freeze the
374 -- stream attribute of the component type, whose declaration could not
375 -- generate any additional freezing actions in any case. See 5509-003.
377 if Nam
= Name_Read
then
378 RW
:= TSS
(Base_Type
(Ctyp
), TSS_Stream_Read
);
380 RW
:= TSS
(Base_Type
(Ctyp
), TSS_Stream_Write
);
384 and then not Is_Frozen
(RW
)
389 -- Now this is the big loop to wrap that statement up in a sequence
390 -- of loops. The first time around, Stm is the attribute call. The
391 -- second and subsequent times, Stm is an inner loop.
393 for J
in 1 .. Ndim
loop
395 Make_Implicit_Loop_Statement
(Nod
,
397 Make_Iteration_Scheme
(Loc
,
398 Loop_Parameter_Specification
=>
399 Make_Loop_Parameter_Specification
(Loc
,
400 Defining_Identifier
=>
401 Make_Defining_Identifier
(Loc
,
402 Chars
=> New_External_Name
('L', Ndim
- J
+ 1)),
404 Discrete_Subtype_Definition
=>
405 Make_Attribute_Reference
(Loc
,
406 Prefix
=> Make_Identifier
(Loc
, Name_V
),
407 Attribute_Name
=> Name_Range
,
409 Expressions
=> New_List
(
410 Make_Integer_Literal
(Loc
, Ndim
- J
+ 1))))),
412 Statements
=> New_List
(Stm
));
416 Build_Stream_Procedure
417 (Loc
, Typ
, Decl
, Pnam
, New_List
(Stm
), Nam
= Name_Read
);
418 end Build_Array_Read_Write_Procedure
;
420 ---------------------------------
421 -- Build_Array_Write_Procedure --
422 ---------------------------------
424 procedure Build_Array_Write_Procedure
428 Pnam
: out Entity_Id
)
430 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
434 Make_Defining_Identifier
(Loc
,
435 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Write
));
436 Build_Array_Read_Write_Procedure
(Nod
, Typ
, Decl
, Pnam
, Name_Write
);
437 end Build_Array_Write_Procedure
;
439 ---------------------------------
440 -- Build_Elementary_Input_Call --
441 ---------------------------------
443 function Build_Elementary_Input_Call
(N
: Node_Id
) return Node_Id
is
444 Loc
: constant Source_Ptr
:= Sloc
(N
);
445 P_Type
: constant Entity_Id
:= Entity
(Prefix
(N
));
446 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
447 Rt_Type
: constant Entity_Id
:= Root_Type
(U_Type
);
448 FST
: constant Entity_Id
:= First_Subtype
(U_Type
);
449 Strm
: constant Node_Id
:= First
(Expressions
(N
));
450 Targ
: constant Node_Id
:= Next
(Strm
);
456 -- Compute the size of the stream element. This is either the size of
457 -- the first subtype or if given the size of the Stream_Size attribute.
459 if Is_Elementary_Type
(FST
) and then Has_Stream_Size_Clause
(FST
) then
460 P_Size
:= Static_Integer
(Expression
(Stream_Size_Clause
(FST
)));
462 P_Size
:= Esize
(FST
);
465 -- Check first for Boolean and Character. These are enumeration types,
466 -- but we treat them specially, since they may require special handling
467 -- in the transfer protocol. However, this special handling only applies
468 -- if they have standard representation, otherwise they are treated like
469 -- any other enumeration type.
471 if Rt_Type
= Standard_Boolean
472 and then Has_Stream_Standard_Rep
(U_Type
)
476 elsif Rt_Type
= Standard_Character
477 and then Has_Stream_Standard_Rep
(U_Type
)
481 elsif Rt_Type
= Standard_Wide_Character
482 and then Has_Stream_Standard_Rep
(U_Type
)
486 elsif Rt_Type
= Standard_Wide_Wide_Character
487 and then Has_Stream_Standard_Rep
(U_Type
)
491 -- Floating point types
493 elsif Is_Floating_Point_Type
(U_Type
) then
494 if P_Size
<= Standard_Short_Float_Size
then
497 elsif P_Size
<= Standard_Float_Size
then
500 elsif P_Size
<= Standard_Long_Float_Size
then
507 -- Signed integer types. Also includes signed fixed-point types and
508 -- enumeration types with a signed representation.
510 -- Note on signed integer types. We do not consider types as signed for
511 -- this purpose if they have no negative numbers, or if they have biased
512 -- representation. The reason is that the value in either case basically
513 -- represents an unsigned value.
515 -- For example, consider:
517 -- type W is range 0 .. 2**32 - 1;
518 -- for W'Size use 32;
520 -- This is a signed type, but the representation is unsigned, and may
521 -- be outside the range of a 32-bit signed integer, so this must be
522 -- treated as 32-bit unsigned.
524 -- Similarly, if we have
526 -- type W is range -1 .. +254;
529 -- then the representation is unsigned
531 elsif not Is_Unsigned_Type
(FST
)
533 (Is_Fixed_Point_Type
(U_Type
)
535 Is_Enumeration_Type
(U_Type
)
537 (Is_Signed_Integer_Type
(U_Type
)
538 and then not Has_Biased_Representation
(FST
)))
540 if P_Size
<= Standard_Short_Short_Integer_Size
then
543 elsif P_Size
<= Standard_Short_Integer_Size
then
546 elsif P_Size
<= Standard_Integer_Size
then
549 elsif P_Size
<= Standard_Long_Integer_Size
then
556 -- Unsigned integer types, also includes unsigned fixed-point types
557 -- and enumeration types with an unsigned representation (note that
558 -- we know they are unsigned because we already tested for signed).
560 -- Also includes signed integer types that are unsigned in the sense
561 -- that they do not include negative numbers. See above for details.
563 elsif Is_Modular_Integer_Type
(U_Type
)
564 or else Is_Fixed_Point_Type
(U_Type
)
565 or else Is_Enumeration_Type
(U_Type
)
566 or else Is_Signed_Integer_Type
(U_Type
)
568 if P_Size
<= Standard_Short_Short_Integer_Size
then
571 elsif P_Size
<= Standard_Short_Integer_Size
then
574 elsif P_Size
<= Standard_Integer_Size
then
577 elsif P_Size
<= Standard_Long_Integer_Size
then
584 else pragma Assert
(Is_Access_Type
(U_Type
));
585 if P_Size
> System_Address_Size
then
592 -- Call the function, and do an unchecked conversion of the result
593 -- to the actual type of the prefix. If the target is a discriminant,
594 -- and we are in the body of the default implementation of a 'Read
595 -- attribute, set target type to force a constraint check (13.13.2(35)).
596 -- If the type of the discriminant is currently private, add another
597 -- unchecked conversion from the full view.
599 if Nkind
(Targ
) = N_Identifier
600 and then Is_Internal_Name
(Chars
(Targ
))
601 and then Is_TSS
(Scope
(Entity
(Targ
)), TSS_Stream_Read
)
604 Unchecked_Convert_To
(Base_Type
(U_Type
),
605 Make_Function_Call
(Loc
,
606 Name
=> New_Occurrence_Of
(RTE
(Lib_RE
), Loc
),
607 Parameter_Associations
=> New_List
(
608 Relocate_Node
(Strm
))));
610 Set_Do_Range_Check
(Res
);
611 if Base_Type
(P_Type
) /= Base_Type
(U_Type
) then
612 Res
:= Unchecked_Convert_To
(Base_Type
(P_Type
), Res
);
619 Unchecked_Convert_To
(P_Type
,
620 Make_Function_Call
(Loc
,
621 Name
=> New_Occurrence_Of
(RTE
(Lib_RE
), Loc
),
622 Parameter_Associations
=> New_List
(
623 Relocate_Node
(Strm
))));
625 end Build_Elementary_Input_Call
;
627 ---------------------------------
628 -- Build_Elementary_Write_Call --
629 ---------------------------------
631 function Build_Elementary_Write_Call
(N
: Node_Id
) return Node_Id
is
632 Loc
: constant Source_Ptr
:= Sloc
(N
);
633 P_Type
: constant Entity_Id
:= Entity
(Prefix
(N
));
634 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
635 Rt_Type
: constant Entity_Id
:= Root_Type
(U_Type
);
636 FST
: constant Entity_Id
:= First_Subtype
(U_Type
);
637 Strm
: constant Node_Id
:= First
(Expressions
(N
));
638 Item
: constant Node_Id
:= Next
(Strm
);
644 -- Compute the size of the stream element. This is either the size of
645 -- the first subtype or if given the size of the Stream_Size attribute.
647 if Is_Elementary_Type
(FST
) and then Has_Stream_Size_Clause
(FST
) then
648 P_Size
:= Static_Integer
(Expression
(Stream_Size_Clause
(FST
)));
650 P_Size
:= Esize
(FST
);
653 -- Find the routine to be called
655 -- Check for First Boolean and Character. These are enumeration types,
656 -- but we treat them specially, since they may require special handling
657 -- in the transfer protocol. However, this special handling only applies
658 -- if they have standard representation, otherwise they are treated like
659 -- any other enumeration type.
661 if Rt_Type
= Standard_Boolean
662 and then Has_Stream_Standard_Rep
(U_Type
)
666 elsif Rt_Type
= Standard_Character
667 and then Has_Stream_Standard_Rep
(U_Type
)
671 elsif Rt_Type
= Standard_Wide_Character
672 and then Has_Stream_Standard_Rep
(U_Type
)
676 elsif Rt_Type
= Standard_Wide_Wide_Character
677 and then Has_Stream_Standard_Rep
(U_Type
)
681 -- Floating point types
683 elsif Is_Floating_Point_Type
(U_Type
) then
684 if P_Size
<= Standard_Short_Float_Size
then
686 elsif P_Size
<= Standard_Float_Size
then
688 elsif P_Size
<= Standard_Long_Float_Size
then
694 -- Signed integer types. Also includes signed fixed-point types and
695 -- signed enumeration types share this circuitry.
697 -- Note on signed integer types. We do not consider types as signed for
698 -- this purpose if they have no negative numbers, or if they have biased
699 -- representation. The reason is that the value in either case basically
700 -- represents an unsigned value.
702 -- For example, consider:
704 -- type W is range 0 .. 2**32 - 1;
705 -- for W'Size use 32;
707 -- This is a signed type, but the representation is unsigned, and may
708 -- be outside the range of a 32-bit signed integer, so this must be
709 -- treated as 32-bit unsigned.
711 -- Similarly, the representation is also unsigned if we have:
713 -- type W is range -1 .. +254;
716 elsif not Is_Unsigned_Type
(FST
)
718 (Is_Fixed_Point_Type
(U_Type
)
720 Is_Enumeration_Type
(U_Type
)
722 (Is_Signed_Integer_Type
(U_Type
)
723 and then not Has_Biased_Representation
(FST
)))
725 if P_Size
<= Standard_Short_Short_Integer_Size
then
727 elsif P_Size
<= Standard_Short_Integer_Size
then
729 elsif P_Size
<= Standard_Integer_Size
then
731 elsif P_Size
<= Standard_Long_Integer_Size
then
737 -- Unsigned integer types, also includes unsigned fixed-point types
738 -- and unsigned enumeration types (note we know they are unsigned
739 -- because we already tested for signed above).
741 -- Also includes signed integer types that are unsigned in the sense
742 -- that they do not include negative numbers. See above for details.
744 elsif Is_Modular_Integer_Type
(U_Type
)
745 or else Is_Fixed_Point_Type
(U_Type
)
746 or else Is_Enumeration_Type
(U_Type
)
747 or else Is_Signed_Integer_Type
(U_Type
)
749 if P_Size
<= Standard_Short_Short_Integer_Size
then
751 elsif P_Size
<= Standard_Short_Integer_Size
then
753 elsif P_Size
<= Standard_Integer_Size
then
755 elsif P_Size
<= Standard_Long_Integer_Size
then
761 else pragma Assert
(Is_Access_Type
(U_Type
));
763 if P_Size
> System_Address_Size
then
770 -- Unchecked-convert parameter to the required type (i.e. the type of
771 -- the corresponding parameter, and call the appropriate routine.
773 Libent
:= RTE
(Lib_RE
);
776 Make_Procedure_Call_Statement
(Loc
,
777 Name
=> New_Occurrence_Of
(Libent
, Loc
),
778 Parameter_Associations
=> New_List
(
779 Relocate_Node
(Strm
),
780 Unchecked_Convert_To
(Etype
(Next_Formal
(First_Formal
(Libent
))),
781 Relocate_Node
(Item
))));
782 end Build_Elementary_Write_Call
;
784 -----------------------------------------
785 -- Build_Mutable_Record_Read_Procedure --
786 -----------------------------------------
788 procedure Build_Mutable_Record_Read_Procedure
792 Pnam
: out Entity_Id
)
794 Out_Formal
: Node_Id
;
795 -- Expression denoting the out formal parameter
797 Dcls
: constant List_Id
:= New_List
;
798 -- Declarations for the 'Read body
800 Stms
: List_Id
:= New_List
;
801 -- Statements for the 'Read body
804 -- Entity of the discriminant being processed
806 Tmp_For_Disc
: Entity_Id
;
807 -- Temporary object used to read the value of Disc
809 Tmps_For_Discs
: constant List_Id
:= New_List
;
810 -- List of object declarations for temporaries holding the read values
811 -- for the discriminants.
813 Cstr
: constant List_Id
:= New_List
;
814 -- List of constraints to be applied on temporary record
816 Discriminant_Checks
: constant List_Id
:= New_List
;
817 -- List of discriminant checks to be performed if the actual object
820 Tmp
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_V
);
821 -- Temporary record must hide formal (assignments to components of the
822 -- record are always generated with V as the identifier for the record).
824 Constrained_Stms
: List_Id
:= New_List
;
825 -- Statements within the block where we have the constrained temporary
829 Disc
:= First_Discriminant
(Typ
);
831 -- A mutable type cannot be a tagged type, so we generate a new name
832 -- for the stream procedure.
835 Make_Defining_Identifier
(Loc
,
836 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Read
));
839 Make_Selected_Component
(Loc
,
840 Prefix
=> New_Occurrence_Of
(Pnam
, Loc
),
841 Selector_Name
=> Make_Identifier
(Loc
, Name_V
));
843 -- Generate Reads for the discriminants of the type. The discriminants
844 -- need to be read before the rest of the components, so that
845 -- variants are initialized correctly. The discriminants must be read
846 -- into temporary variables so an incomplete Read (interrupted by an
847 -- exception, for example) does not alter the passed object.
849 while Present
(Disc
) loop
850 Tmp_For_Disc
:= Make_Defining_Identifier
(Loc
,
851 New_External_Name
(Chars
(Disc
), "D"));
853 Append_To
(Tmps_For_Discs
,
854 Make_Object_Declaration
(Loc
,
855 Defining_Identifier
=> Tmp_For_Disc
,
856 Object_Definition
=> New_Occurrence_Of
(Etype
(Disc
), Loc
)));
857 Set_No_Initialization
(Last
(Tmps_For_Discs
));
860 Make_Attribute_Reference
(Loc
,
861 Prefix
=> New_Occurrence_Of
(Etype
(Disc
), Loc
),
862 Attribute_Name
=> Name_Read
,
863 Expressions
=> New_List
(
864 Make_Identifier
(Loc
, Name_S
),
865 New_Occurrence_Of
(Tmp_For_Disc
, Loc
))));
868 Make_Discriminant_Association
(Loc
,
869 Selector_Names
=> New_List
(New_Occurrence_Of
(Disc
, Loc
)),
870 Expression
=> New_Occurrence_Of
(Tmp_For_Disc
, Loc
)));
872 Append_To
(Discriminant_Checks
,
873 Make_Raise_Constraint_Error
(Loc
,
876 Left_Opnd
=> New_Occurrence_Of
(Tmp_For_Disc
, Loc
),
878 Make_Selected_Component
(Loc
,
879 Prefix
=> New_Copy_Tree
(Out_Formal
),
880 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
))),
881 Reason
=> CE_Discriminant_Check_Failed
));
882 Next_Discriminant
(Disc
);
885 -- Generate reads for the components of the record (including
886 -- those that depend on discriminants).
888 Build_Record_Read_Write_Procedure
(Loc
, Typ
, Decl
, Pnam
, Name_Read
);
890 -- If Typ has controlled components (i.e. if it is classwide
891 -- or Has_Controlled), or components constrained using the discriminants
892 -- of Typ, then we need to ensure that all component assignments
893 -- are performed on an object that has been appropriately constrained
894 -- prior to being initialized. To this effect, we wrap the component
895 -- assignments in a block where V is a constrained temporary.
898 Make_Object_Declaration
(Loc
,
899 Defining_Identifier
=> Tmp
,
901 Make_Subtype_Indication
(Loc
,
902 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
904 Make_Index_Or_Discriminant_Constraint
(Loc
,
905 Constraints
=> Cstr
))));
907 Constrained_Stms
:= Statements
(Handled_Statement_Sequence
(Decl
));
909 Make_Block_Statement
(Loc
,
910 Declarations
=> Dcls
,
911 Handled_Statement_Sequence
=> Parent
(Constrained_Stms
)));
913 Append_To
(Constrained_Stms
,
914 Make_Implicit_If_Statement
(Pnam
,
916 Make_Attribute_Reference
(Loc
,
917 Prefix
=> New_Copy_Tree
(Out_Formal
),
918 Attribute_Name
=> Name_Constrained
),
919 Then_Statements
=> Discriminant_Checks
));
921 Append_To
(Constrained_Stms
,
922 Make_Assignment_Statement
(Loc
,
924 Expression
=> Make_Identifier
(Loc
, Name_V
)));
926 if Is_Unchecked_Union
(Typ
) then
928 -- If this is an unchecked union, the stream procedure is erroneous,
929 -- because there are no discriminants to read.
931 -- This should generate a warning ???
935 Make_Raise_Program_Error
(Loc
,
936 Reason
=> PE_Unchecked_Union_Restriction
));
939 Set_Declarations
(Decl
, Tmps_For_Discs
);
940 Set_Handled_Statement_Sequence
(Decl
,
941 Make_Handled_Sequence_Of_Statements
(Loc
,
942 Statements
=> Stms
));
943 end Build_Mutable_Record_Read_Procedure
;
945 ------------------------------------------
946 -- Build_Mutable_Record_Write_Procedure --
947 ------------------------------------------
949 procedure Build_Mutable_Record_Write_Procedure
953 Pnam
: out Entity_Id
)
960 Disc
:= First_Discriminant
(Typ
);
962 -- Generate Writes for the discriminants of the type
964 while Present
(Disc
) loop
967 Make_Attribute_Reference
(Loc
,
968 Prefix
=> New_Occurrence_Of
(Etype
(Disc
), Loc
),
969 Attribute_Name
=> Name_Write
,
970 Expressions
=> New_List
(
971 Make_Identifier
(Loc
, Name_S
),
972 Make_Selected_Component
(Loc
,
973 Prefix
=> Make_Identifier
(Loc
, Name_V
),
974 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
)))));
976 Next_Discriminant
(Disc
);
979 -- A mutable type cannot be a tagged type, so we generate a new name
980 -- for the stream procedure.
983 Make_Defining_Identifier
(Loc
,
984 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Write
));
985 Build_Record_Read_Write_Procedure
(Loc
, Typ
, Decl
, Pnam
, Name_Write
);
987 -- Write the discriminants before the rest of the components, so
988 -- that discriminant values are properly set of variants, etc.
989 -- If this is an unchecked union, the stream procedure is erroneous
990 -- because there are no discriminants to write.
992 if Is_Unchecked_Union
(Typ
) then
995 Make_Raise_Program_Error
(Loc
,
996 Reason
=> PE_Unchecked_Union_Restriction
));
999 if Is_Non_Empty_List
(
1000 Statements
(Handled_Statement_Sequence
(Decl
)))
1003 (First
(Statements
(Handled_Statement_Sequence
(Decl
))), Stms
);
1005 Set_Statements
(Handled_Statement_Sequence
(Decl
), Stms
);
1007 end Build_Mutable_Record_Write_Procedure
;
1009 -----------------------------------------------
1010 -- Build_Record_Or_Elementary_Input_Function --
1011 -----------------------------------------------
1013 -- The function we build looks like
1015 -- function InputN (S : access RST) return Typ is
1016 -- C1 : constant Disc_Type_1;
1017 -- Discr_Type_1'Read (S, C1);
1018 -- C2 : constant Disc_Type_2;
1019 -- Discr_Type_2'Read (S, C2);
1021 -- Cn : constant Disc_Type_n;
1022 -- Discr_Type_n'Read (S, Cn);
1023 -- V : Typ (C1, C2, .. Cn)
1030 -- The discriminants are of course only present in the case of a record
1031 -- with discriminants. In the case of a record with no discriminants, or
1032 -- an elementary type, then no Cn constants are defined.
1034 procedure Build_Record_Or_Elementary_Input_Function
1038 Fnam
: out Entity_Id
)
1054 if Has_Discriminants
(Typ
) then
1055 Discr
:= First_Discriminant
(Typ
);
1057 while Present
(Discr
) loop
1058 Cn
:= New_External_Name
('C', J
);
1061 Make_Object_Declaration
(Loc
,
1062 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Cn
),
1063 Object_Definition
=>
1064 New_Occurrence_Of
(Etype
(Discr
), Loc
)));
1067 Make_Attribute_Reference
(Loc
,
1068 Prefix
=> New_Occurrence_Of
(Etype
(Discr
), Loc
),
1069 Attribute_Name
=> Name_Read
,
1070 Expressions
=> New_List
(
1071 Make_Identifier
(Loc
, Name_S
),
1072 Make_Identifier
(Loc
, Cn
))));
1074 Append_To
(Constr
, Make_Identifier
(Loc
, Cn
));
1076 Next_Discriminant
(Discr
);
1081 Make_Subtype_Indication
(Loc
,
1082 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
1084 Make_Index_Or_Discriminant_Constraint
(Loc
,
1085 Constraints
=> Constr
));
1087 -- If no discriminants, then just use the type with no constraint
1090 Odef
:= New_Occurrence_Of
(Typ
, Loc
);
1094 Make_Object_Declaration
(Loc
,
1095 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
1096 Object_Definition
=> Odef
));
1099 Make_Attribute_Reference
(Loc
,
1100 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
1101 Attribute_Name
=> Name_Read
,
1102 Expressions
=> New_List
(
1103 Make_Identifier
(Loc
, Name_S
),
1104 Make_Identifier
(Loc
, Name_V
))),
1106 Make_Return_Statement
(Loc
,
1107 Expression
=> Make_Identifier
(Loc
, Name_V
)));
1109 Fnam
:= Make_Stream_Subprogram_Name
(Loc
, Typ
, TSS_Stream_Input
);
1111 Build_Stream_Function
(Loc
, Typ
, Decl
, Fnam
, Decls
, Stms
);
1112 end Build_Record_Or_Elementary_Input_Function
;
1114 -------------------------------------------------
1115 -- Build_Record_Or_Elementary_Output_Procedure --
1116 -------------------------------------------------
1118 procedure Build_Record_Or_Elementary_Output_Procedure
1122 Pnam
: out Entity_Id
)
1130 -- Note that of course there will be no discriminants for the
1131 -- elementary type case, so Has_Discriminants will be False.
1133 if Has_Discriminants
(Typ
) then
1134 Disc
:= First_Discriminant
(Typ
);
1136 while Present
(Disc
) loop
1138 Make_Attribute_Reference
(Loc
,
1140 New_Occurrence_Of
(Stream_Base_Type
(Etype
(Disc
)), Loc
),
1141 Attribute_Name
=> Name_Write
,
1142 Expressions
=> New_List
(
1143 Make_Identifier
(Loc
, Name_S
),
1144 Make_Selected_Component
(Loc
,
1145 Prefix
=> Make_Identifier
(Loc
, Name_V
),
1146 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
)))));
1148 Next_Discriminant
(Disc
);
1153 Make_Attribute_Reference
(Loc
,
1154 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
1155 Attribute_Name
=> Name_Write
,
1156 Expressions
=> New_List
(
1157 Make_Identifier
(Loc
, Name_S
),
1158 Make_Identifier
(Loc
, Name_V
))));
1160 Pnam
:= Make_Stream_Subprogram_Name
(Loc
, Typ
, TSS_Stream_Output
);
1162 Build_Stream_Procedure
(Loc
, Typ
, Decl
, Pnam
, Stms
, False);
1163 end Build_Record_Or_Elementary_Output_Procedure
;
1165 ---------------------------------
1166 -- Build_Record_Read_Procedure --
1167 ---------------------------------
1169 procedure Build_Record_Read_Procedure
1173 Pnam
: out Entity_Id
)
1176 Pnam
:= Make_Stream_Subprogram_Name
(Loc
, Typ
, TSS_Stream_Read
);
1177 Build_Record_Read_Write_Procedure
(Loc
, Typ
, Decl
, Pnam
, Name_Read
);
1178 end Build_Record_Read_Procedure
;
1180 ---------------------------------------
1181 -- Build_Record_Read_Write_Procedure --
1182 ---------------------------------------
1184 -- The form of the record read/write procedure is as shown by the
1185 -- following example for a case with one discriminant case variant:
1187 -- procedure pnam (S : access RST, V : [out] Typ) is
1189 -- Component_Type'Read/Write (S, V.component);
1190 -- Component_Type'Read/Write (S, V.component);
1192 -- Component_Type'Read/Write (S, V.component);
1194 -- case V.discriminant is
1196 -- Component_Type'Read/Write (S, V.component);
1197 -- Component_Type'Read/Write (S, V.component);
1199 -- Component_Type'Read/Write (S, V.component);
1202 -- Component_Type'Read/Write (S, V.component);
1203 -- Component_Type'Read/Write (S, V.component);
1205 -- Component_Type'Read/Write (S, V.component);
1210 -- The out keyword for V is supplied in the Read case
1212 procedure Build_Record_Read_Write_Procedure
1223 In_Limited_Extension
: Boolean := False;
1224 -- Set to True while processing the record extension definition
1225 -- for an extension of a limited type (for which an ancestor type
1226 -- has an explicit Nam attribute definition).
1228 function Make_Component_List_Attributes
(CL
: Node_Id
) return List_Id
;
1229 -- Returns a sequence of attributes to process the components that
1230 -- are referenced in the given component list.
1232 function Make_Field_Attribute
(C
: Entity_Id
) return Node_Id
;
1233 -- Given C, the entity for a discriminant or component, build
1234 -- an attribute for the corresponding field values.
1236 function Make_Field_Attributes
(Clist
: List_Id
) return List_Id
;
1237 -- Given Clist, a component items list, construct series of attributes
1238 -- for fieldwise processing of the corresponding components.
1240 ------------------------------------
1241 -- Make_Component_List_Attributes --
1242 ------------------------------------
1244 function Make_Component_List_Attributes
(CL
: Node_Id
) return List_Id
is
1245 CI
: constant List_Id
:= Component_Items
(CL
);
1246 VP
: constant Node_Id
:= Variant_Part
(CL
);
1255 Result
:= Make_Field_Attributes
(CI
);
1257 -- If a component is an unchecked union, there is no discriminant
1258 -- and we cannot generate a read/write procedure for it.
1260 if Present
(VP
) then
1261 if Is_Unchecked_Union
(Scope
(Entity
(Name
(VP
)))) then
1263 Make_Raise_Program_Error
(Sloc
(VP
),
1264 Reason
=> PE_Unchecked_Union_Restriction
));
1267 V
:= First_Non_Pragma
(Variants
(VP
));
1269 while Present
(V
) loop
1272 DC
:= First
(Discrete_Choices
(V
));
1273 while Present
(DC
) loop
1274 Append_To
(DCH
, New_Copy_Tree
(DC
));
1279 Make_Case_Statement_Alternative
(Loc
,
1280 Discrete_Choices
=> DCH
,
1282 Make_Component_List_Attributes
(Component_List
(V
))));
1283 Next_Non_Pragma
(V
);
1286 -- Note: in the following, we make sure that we use new occurrence
1287 -- of for the selector, since there are cases in which we make a
1288 -- reference to a hidden discriminant that is not visible.
1291 Make_Case_Statement
(Loc
,
1293 Make_Selected_Component
(Loc
,
1294 Prefix
=> Make_Identifier
(Loc
, Name_V
),
1296 New_Occurrence_Of
(Entity
(Name
(VP
)), Loc
)),
1297 Alternatives
=> Alts
));
1302 end Make_Component_List_Attributes
;
1304 --------------------------
1305 -- Make_Field_Attribute --
1306 --------------------------
1308 function Make_Field_Attribute
(C
: Entity_Id
) return Node_Id
is
1309 Field_Typ
: constant Entity_Id
:= Stream_Base_Type
(Etype
(C
));
1311 TSS_Names
: constant array (Name_Input
.. Name_Write
) of
1313 (Name_Read
=> TSS_Stream_Read
,
1314 Name_Write
=> TSS_Stream_Write
,
1315 Name_Input
=> TSS_Stream_Input
,
1316 Name_Output
=> TSS_Stream_Output
,
1317 others => TSS_Null
);
1318 pragma Assert
(TSS_Names
(Nam
) /= TSS_Null
);
1321 if In_Limited_Extension
1322 and then Is_Limited_Type
(Field_Typ
)
1323 and then No
(Find_Inherited_TSS
(Field_Typ
, TSS_Names
(Nam
)))
1325 -- The declaration is illegal per 13.13.2(9/1), and this is
1326 -- enforced in Exp_Ch3.Check_Stream_Attributes. Keep the
1327 -- caller happy by returning a null statement.
1329 return Make_Null_Statement
(Loc
);
1333 Make_Attribute_Reference
(Loc
,
1335 New_Occurrence_Of
(Field_Typ
, Loc
),
1336 Attribute_Name
=> Nam
,
1337 Expressions
=> New_List
(
1338 Make_Identifier
(Loc
, Name_S
),
1339 Make_Selected_Component
(Loc
,
1340 Prefix
=> Make_Identifier
(Loc
, Name_V
),
1341 Selector_Name
=> New_Occurrence_Of
(C
, Loc
))));
1342 end Make_Field_Attribute
;
1344 ---------------------------
1345 -- Make_Field_Attributes --
1346 ---------------------------
1348 function Make_Field_Attributes
(Clist
: List_Id
) return List_Id
is
1355 if Present
(Clist
) then
1356 Item
:= First
(Clist
);
1358 -- Loop through components, skipping all internal components,
1359 -- which are not part of the value (e.g. _Tag), except that we
1360 -- don't skip the _Parent, since we do want to process that
1363 while Present
(Item
) loop
1364 if Nkind
(Item
) = N_Component_Declaration
1366 (Chars
(Defining_Identifier
(Item
)) = Name_uParent
1368 not Is_Internal_Name
(Chars
(Defining_Identifier
(Item
))))
1372 Make_Field_Attribute
(Defining_Identifier
(Item
)));
1380 end Make_Field_Attributes
;
1382 -- Start of processing for Build_Record_Read_Write_Procedure
1385 -- For the protected type case, use corresponding record
1387 if Is_Protected_Type
(Typ
) then
1388 Typt
:= Corresponding_Record_Type
(Typ
);
1393 -- Note that we do nothing with the discriminants, since Read and
1394 -- Write do not read or write the discriminant values. All handling
1395 -- of discriminants occurs in the Input and Output subprograms.
1397 Rdef
:= Type_Definition
1398 (Declaration_Node
(Base_Type
(Underlying_Type
(Typt
))));
1401 -- In record extension case, the fields we want, including the _Parent
1402 -- field representing the parent type, are to be found in the extension.
1403 -- Note that we will naturally process the _Parent field using the type
1404 -- of the parent, and hence its stream attributes, which is appropriate.
1406 if Nkind
(Rdef
) = N_Derived_Type_Definition
then
1407 Rdef
:= Record_Extension_Part
(Rdef
);
1409 if Is_Limited_Type
(Typt
) then
1410 In_Limited_Extension
:= True;
1414 if Present
(Component_List
(Rdef
)) then
1415 Append_List_To
(Stms
,
1416 Make_Component_List_Attributes
(Component_List
(Rdef
)));
1419 Build_Stream_Procedure
1420 (Loc
, Typ
, Decl
, Pnam
, Stms
, Nam
= Name_Read
);
1421 end Build_Record_Read_Write_Procedure
;
1423 ----------------------------------
1424 -- Build_Record_Write_Procedure --
1425 ----------------------------------
1427 procedure Build_Record_Write_Procedure
1431 Pnam
: out Entity_Id
)
1434 Pnam
:= Make_Stream_Subprogram_Name
(Loc
, Typ
, TSS_Stream_Write
);
1435 Build_Record_Read_Write_Procedure
(Loc
, Typ
, Decl
, Pnam
, Name_Write
);
1436 end Build_Record_Write_Procedure
;
1438 -------------------------------
1439 -- Build_Stream_Attr_Profile --
1440 -------------------------------
1442 function Build_Stream_Attr_Profile
1445 Nam
: TSS_Name_Type
) return List_Id
1450 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has
1451 -- no semantic meaning in Ada 95 but it is a requirement in Ada2005.
1453 Profile
:= New_List
(
1454 Make_Parameter_Specification
(Loc
,
1455 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_S
),
1457 Make_Access_Definition
(Loc
,
1458 Null_Exclusion_Present
=> True,
1459 Subtype_Mark
=> New_Reference_To
(
1460 Class_Wide_Type
(RTE
(RE_Root_Stream_Type
)), Loc
))));
1462 if Nam
/= TSS_Stream_Input
then
1464 Make_Parameter_Specification
(Loc
,
1465 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
1466 Out_Present
=> (Nam
= TSS_Stream_Read
),
1467 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
1471 end Build_Stream_Attr_Profile
;
1473 ---------------------------
1474 -- Build_Stream_Function --
1475 ---------------------------
1477 procedure Build_Stream_Function
1488 -- Construct function specification
1490 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has
1491 -- no semantic meaning in Ada 95 but it is a requirement in Ada2005.
1494 Make_Function_Specification
(Loc
,
1495 Defining_Unit_Name
=> Fnam
,
1497 Parameter_Specifications
=> New_List
(
1498 Make_Parameter_Specification
(Loc
,
1499 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_S
),
1501 Make_Access_Definition
(Loc
,
1502 Null_Exclusion_Present
=> True,
1503 Subtype_Mark
=> New_Reference_To
(
1504 Class_Wide_Type
(RTE
(RE_Root_Stream_Type
)), Loc
)))),
1506 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
1509 Make_Subprogram_Body
(Loc
,
1510 Specification
=> Spec
,
1511 Declarations
=> Decls
,
1512 Handled_Statement_Sequence
=>
1513 Make_Handled_Sequence_Of_Statements
(Loc
,
1514 Statements
=> Stms
));
1515 end Build_Stream_Function
;
1517 ----------------------------
1518 -- Build_Stream_Procedure --
1519 ----------------------------
1521 procedure Build_Stream_Procedure
1532 -- Construct procedure specification
1534 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has
1535 -- no semantic meaning in Ada 95 but it is a requirement in Ada2005.
1538 Make_Procedure_Specification
(Loc
,
1539 Defining_Unit_Name
=> Pnam
,
1541 Parameter_Specifications
=> New_List
(
1542 Make_Parameter_Specification
(Loc
,
1543 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_S
),
1545 Make_Access_Definition
(Loc
,
1546 Null_Exclusion_Present
=> True,
1547 Subtype_Mark
=> New_Reference_To
(
1548 Class_Wide_Type
(RTE
(RE_Root_Stream_Type
)), Loc
))),
1550 Make_Parameter_Specification
(Loc
,
1551 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
1552 Out_Present
=> Outp
,
1553 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))));
1556 Make_Subprogram_Body
(Loc
,
1557 Specification
=> Spec
,
1558 Declarations
=> Empty_List
,
1559 Handled_Statement_Sequence
=>
1560 Make_Handled_Sequence_Of_Statements
(Loc
,
1561 Statements
=> Stms
));
1562 end Build_Stream_Procedure
;
1564 -----------------------------
1565 -- Has_Stream_Standard_Rep --
1566 -----------------------------
1568 function Has_Stream_Standard_Rep
(U_Type
: Entity_Id
) return Boolean is
1570 if Has_Non_Standard_Rep
(U_Type
) then
1574 Esize
(First_Subtype
(U_Type
)) = Esize
(Root_Type
(U_Type
));
1576 end Has_Stream_Standard_Rep
;
1578 ---------------------------------
1579 -- Make_Stream_Subprogram_Name --
1580 ---------------------------------
1582 function Make_Stream_Subprogram_Name
1585 Nam
: TSS_Name_Type
) return Entity_Id
1590 -- For tagged types, we are dealing with a TSS associated with the
1591 -- declaration, so we use the standard primitive function name. For
1592 -- other types, generate a local TSS name since we are generating
1593 -- the subprogram at the point of use.
1595 if Is_Tagged_Type
(Typ
) then
1596 Sname
:= Make_TSS_Name
(Typ
, Nam
);
1598 Sname
:= Make_TSS_Name_Local
(Typ
, Nam
);
1601 return Make_Defining_Identifier
(Loc
, Sname
);
1602 end Make_Stream_Subprogram_Name
;
1604 ----------------------
1605 -- Stream_Base_Type --
1606 ----------------------
1608 function Stream_Base_Type
(E
: Entity_Id
) return Entity_Id
is
1610 if Is_Array_Type
(E
)
1611 and then Is_First_Subtype
(E
)
1615 return Base_Type
(E
);
1617 end Stream_Base_Type
;