1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Einfo
; use Einfo
;
28 with Namet
; use Namet
;
29 with Nlists
; use Nlists
;
30 with Nmake
; use Nmake
;
32 with Restrict
; use Restrict
;
33 with Rident
; use Rident
;
34 with Rtsfind
; use Rtsfind
;
35 with Sem_Aux
; use Sem_Aux
;
36 with Sem_Util
; use Sem_Util
;
37 with Sinfo
; use Sinfo
;
38 with Snames
; use Snames
;
39 with Stand
; use Stand
;
40 with Tbuild
; use Tbuild
;
41 with Ttypes
; use Ttypes
;
42 with Uintp
; use Uintp
;
44 package body Exp_Strm
is
46 -----------------------
47 -- Local Subprograms --
48 -----------------------
50 procedure Build_Array_Read_Write_Procedure
56 -- Common routine shared to build either an array Read procedure or an
57 -- array Write procedure, Nam is Name_Read or Name_Write to select which.
58 -- Pnam is the defining identifier for the constructed procedure. The
59 -- other parameters are as for Build_Array_Read_Procedure except that
60 -- the first parameter Nod supplies the Sloc to be used to generate code.
62 procedure Build_Record_Read_Write_Procedure
68 -- Common routine shared to build a record Read Write procedure, Nam
69 -- is Name_Read or Name_Write to select which. Pnam is the defining
70 -- identifier for the constructed procedure. The other parameters are
71 -- as for Build_Record_Read_Procedure.
73 procedure Build_Stream_Function
80 -- Called to build an array or record stream function. The first three
81 -- arguments are the same as Build_Record_Or_Elementary_Input_Function.
82 -- Decls and Stms are the declarations and statements for the body and
83 -- The parameter Fnam is the name of the constructed function.
85 function Has_Stream_Standard_Rep
(U_Type
: Entity_Id
) return Boolean;
86 -- This function is used to test the type U_Type, to determine if it has
87 -- a standard representation from a streaming point of view. Standard means
88 -- that it has a standard representation (e.g. no enumeration rep clause),
89 -- and the size of the root type is the same as the streaming size (which
90 -- is defined as value specified by a Stream_Size clause if present, or
91 -- the Esize of U_Type if not).
93 function Make_Stream_Subprogram_Name
96 Nam
: TSS_Name_Type
) return Entity_Id
;
97 -- Return the entity that identifies the stream subprogram for type Typ
98 -- that is identified by the given Nam. This procedure deals with the
99 -- difference between tagged types (where a single subprogram associated
100 -- with the type is generated) and all other cases (where a subprogram
101 -- is generated at the point of the stream attribute reference). The
102 -- Loc parameter is used as the Sloc of the created entity.
104 function Stream_Base_Type
(E
: Entity_Id
) return Entity_Id
;
105 -- Stream attributes work on the basis of the base type except for the
106 -- array case. For the array case, we do not go to the base type, but
107 -- to the first subtype if it is constrained. This avoids problems with
108 -- incorrect conversions in the packed array case. Stream_Base_Type is
109 -- exactly this function (returns the base type, unless we have an array
110 -- type whose first subtype is constrained, in which case it returns the
113 --------------------------------
114 -- Build_Array_Input_Function --
115 --------------------------------
117 -- The function we build looks like
119 -- function typSI[_nnn] (S : access RST) return Typ is
120 -- L1 : constant Index_Type_1 := Index_Type_1'Input (S);
121 -- H1 : constant Index_Type_1 := Index_Type_1'Input (S);
122 -- L2 : constant Index_Type_2 := Index_Type_2'Input (S);
123 -- H2 : constant Index_Type_2 := Index_Type_2'Input (S);
125 -- Ln : constant Index_Type_n := Index_Type_n'Input (S);
126 -- Hn : constant Index_Type_n := Index_Type_n'Input (S);
128 -- V : Typ'Base (L1 .. H1, L2 .. H2, ... Ln .. Hn)
135 -- Note: the suffix [_nnn] is present for non-tagged types, where we
136 -- generate a local subprogram at the point of the occurrence of the
137 -- attribute reference, so the name must be unique.
139 procedure Build_Array_Input_Function
143 Fnam
: out Entity_Id
)
145 Dim
: constant Pos
:= Number_Dimensions
(Typ
);
156 Indx
:= First_Index
(Typ
);
158 for J
in 1 .. Dim
loop
159 Lnam
:= New_External_Name
('L', J
);
160 Hnam
:= New_External_Name
('H', J
);
163 Make_Object_Declaration
(Loc
,
164 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Lnam
),
165 Constant_Present
=> True,
166 Object_Definition
=> New_Occurrence_Of
(Etype
(Indx
), Loc
),
168 Make_Attribute_Reference
(Loc
,
170 New_Occurrence_Of
(Stream_Base_Type
(Etype
(Indx
)), Loc
),
171 Attribute_Name
=> Name_Input
,
172 Expressions
=> New_List
(Make_Identifier
(Loc
, Name_S
)))));
175 Make_Object_Declaration
(Loc
,
176 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Hnam
),
177 Constant_Present
=> True,
179 New_Occurrence_Of
(Stream_Base_Type
(Etype
(Indx
)), Loc
),
181 Make_Attribute_Reference
(Loc
,
183 New_Occurrence_Of
(Stream_Base_Type
(Etype
(Indx
)), Loc
),
184 Attribute_Name
=> Name_Input
,
185 Expressions
=> New_List
(Make_Identifier
(Loc
, Name_S
)))));
189 Low_Bound
=> Make_Identifier
(Loc
, Lnam
),
190 High_Bound
=> Make_Identifier
(Loc
, Hnam
)));
195 -- If the first subtype is constrained, use it directly. Otherwise
196 -- build a subtype indication with the proper bounds.
198 if Is_Constrained
(Stream_Base_Type
(Typ
)) then
200 Make_Object_Declaration
(Loc
,
201 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
203 New_Occurrence_Of
(Stream_Base_Type
(Typ
), Loc
)));
206 Make_Object_Declaration
(Loc
,
207 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
209 Make_Subtype_Indication
(Loc
,
211 New_Occurrence_Of
(Stream_Base_Type
(Typ
), Loc
),
213 Make_Index_Or_Discriminant_Constraint
(Loc
,
214 Constraints
=> Ranges
))));
218 Make_Attribute_Reference
(Loc
,
219 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
220 Attribute_Name
=> Name_Read
,
221 Expressions
=> New_List
(
222 Make_Identifier
(Loc
, Name_S
),
223 Make_Identifier
(Loc
, Name_V
))),
225 Make_Simple_Return_Statement
(Loc
,
226 Expression
=> Make_Identifier
(Loc
, Name_V
)));
229 Make_Defining_Identifier
(Loc
,
230 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Input
));
232 Build_Stream_Function
(Loc
, Typ
, Decl
, Fnam
, Decls
, Stms
);
233 end Build_Array_Input_Function
;
235 ----------------------------------
236 -- Build_Array_Output_Procedure --
237 ----------------------------------
239 procedure Build_Array_Output_Procedure
243 Pnam
: out Entity_Id
)
249 -- Build series of statements to output bounds
251 Indx
:= First_Index
(Typ
);
254 for J
in 1 .. Number_Dimensions
(Typ
) loop
256 Make_Attribute_Reference
(Loc
,
258 New_Occurrence_Of
(Stream_Base_Type
(Etype
(Indx
)), Loc
),
259 Attribute_Name
=> Name_Write
,
260 Expressions
=> New_List
(
261 Make_Identifier
(Loc
, Name_S
),
262 Make_Attribute_Reference
(Loc
,
263 Prefix
=> Make_Identifier
(Loc
, Name_V
),
264 Attribute_Name
=> Name_First
,
265 Expressions
=> New_List
(
266 Make_Integer_Literal
(Loc
, J
))))));
269 Make_Attribute_Reference
(Loc
,
271 New_Occurrence_Of
(Stream_Base_Type
(Etype
(Indx
)), Loc
),
272 Attribute_Name
=> Name_Write
,
273 Expressions
=> New_List
(
274 Make_Identifier
(Loc
, Name_S
),
275 Make_Attribute_Reference
(Loc
,
276 Prefix
=> Make_Identifier
(Loc
, Name_V
),
277 Attribute_Name
=> Name_Last
,
278 Expressions
=> New_List
(
279 Make_Integer_Literal
(Loc
, J
))))));
284 -- Append Write attribute to write array elements
287 Make_Attribute_Reference
(Loc
,
288 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
289 Attribute_Name
=> Name_Write
,
290 Expressions
=> New_List
(
291 Make_Identifier
(Loc
, Name_S
),
292 Make_Identifier
(Loc
, Name_V
))));
295 Make_Defining_Identifier
(Loc
,
296 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Output
));
298 Build_Stream_Procedure
(Loc
, Typ
, Decl
, Pnam
, Stms
, False);
299 end Build_Array_Output_Procedure
;
301 --------------------------------
302 -- Build_Array_Read_Procedure --
303 --------------------------------
305 procedure Build_Array_Read_Procedure
309 Pnam
: out Entity_Id
)
311 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
315 Make_Defining_Identifier
(Loc
,
316 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Read
));
317 Build_Array_Read_Write_Procedure
(Nod
, Typ
, Decl
, Pnam
, Name_Read
);
318 end Build_Array_Read_Procedure
;
320 --------------------------------------
321 -- Build_Array_Read_Write_Procedure --
322 --------------------------------------
324 -- The form of the array read/write procedure is as follows:
326 -- procedure pnam (S : access RST, V : [out] Typ) is
328 -- for L1 in V'Range (1) loop
329 -- for L2 in V'Range (2) loop
331 -- for Ln in V'Range (n) loop
332 -- Component_Type'Read/Write (S, V (L1, L2, .. Ln));
339 -- The out keyword for V is supplied in the Read case
341 procedure Build_Array_Read_Write_Procedure
348 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
349 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
350 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
357 -- First build the inner attribute call
361 for J
in 1 .. Ndim
loop
362 Append_To
(Exl
, Make_Identifier
(Loc
, New_External_Name
('L', J
)));
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
)));
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.
381 if Nam
= Name_Read
then
382 RW
:= TSS
(Base_Type
(Ctyp
), TSS_Stream_Read
);
384 RW
:= TSS
(Base_Type
(Ctyp
), TSS_Stream_Write
);
388 and then not Is_Frozen
(RW
)
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.
397 for J
in 1 .. Ndim
loop
399 Make_Implicit_Loop_Statement
(Nod
,
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)),
408 Discrete_Subtype_Definition
=>
409 Make_Attribute_Reference
(Loc
,
410 Prefix
=> Make_Identifier
(Loc
, Name_V
),
411 Attribute_Name
=> Name_Range
,
413 Expressions
=> New_List
(
414 Make_Integer_Literal
(Loc
, Ndim
- J
+ 1))))),
416 Statements
=> New_List
(Stm
));
420 Build_Stream_Procedure
421 (Loc
, Typ
, Decl
, Pnam
, New_List
(Stm
), Nam
= Name_Read
);
422 end Build_Array_Read_Write_Procedure
;
424 ---------------------------------
425 -- Build_Array_Write_Procedure --
426 ---------------------------------
428 procedure Build_Array_Write_Procedure
432 Pnam
: out Entity_Id
)
434 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
438 Make_Defining_Identifier
(Loc
,
439 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Write
));
440 Build_Array_Read_Write_Procedure
(Nod
, Typ
, Decl
, Pnam
, Name_Write
);
441 end Build_Array_Write_Procedure
;
443 ---------------------------------
444 -- Build_Elementary_Input_Call --
445 ---------------------------------
447 function Build_Elementary_Input_Call
(N
: Node_Id
) return Node_Id
is
448 Loc
: constant Source_Ptr
:= Sloc
(N
);
449 P_Type
: constant Entity_Id
:= Entity
(Prefix
(N
));
450 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
451 Rt_Type
: constant Entity_Id
:= Root_Type
(U_Type
);
452 FST
: constant Entity_Id
:= First_Subtype
(U_Type
);
453 Strm
: constant Node_Id
:= First
(Expressions
(N
));
454 Targ
: constant Node_Id
:= Next
(Strm
);
460 Check_Restriction
(No_Default_Stream_Attributes
, N
);
462 -- Compute the size of the stream element. This is either the size of
463 -- the first subtype or if given the size of the Stream_Size attribute.
465 if Has_Stream_Size_Clause
(FST
) then
466 P_Size
:= Static_Integer
(Expression
(Stream_Size_Clause
(FST
)));
468 P_Size
:= Esize
(FST
);
471 -- Check first for Boolean and Character. These are enumeration types,
472 -- but we treat them specially, since they may require special handling
473 -- in the transfer protocol. However, this special handling only applies
474 -- if they have standard representation, otherwise they are treated like
475 -- any other enumeration type.
477 if Rt_Type
= Standard_Boolean
478 and then Has_Stream_Standard_Rep
(U_Type
)
482 elsif Rt_Type
= Standard_Character
483 and then Has_Stream_Standard_Rep
(U_Type
)
487 elsif Rt_Type
= Standard_Wide_Character
488 and then Has_Stream_Standard_Rep
(U_Type
)
492 elsif Rt_Type
= Standard_Wide_Wide_Character
493 and then Has_Stream_Standard_Rep
(U_Type
)
497 -- Floating point types
499 elsif Is_Floating_Point_Type
(U_Type
) then
501 -- Question: should we use P_Size or Rt_Type to distinguish between
502 -- possible floating point types? If a non-standard size or a stream
503 -- size is specified, then we should certainly use the size. But if
504 -- we have two types the same (notably Short_Float_Size = Float_Size
505 -- which is close to universally true, and Long_Long_Float_Size =
506 -- Long_Float_Size, true on most targets except the x86), then we
507 -- would really rather use the root type, so that if people want to
508 -- fiddle with System.Stream_Attributes to get inter-target portable
509 -- streams, they get the size they expect. Consider in particular the
510 -- case of a stream written on an x86, with 96-bit Long_Long_Float
511 -- being read into a non-x86 target with 64 bit Long_Long_Float. A
512 -- special version of System.Stream_Attributes can deal with this
513 -- provided the proper type is always used.
515 -- To deal with these two requirements we add the special checks
516 -- on equal sizes and use the root type to distinguish.
518 if P_Size
<= Standard_Short_Float_Size
519 and then (Standard_Short_Float_Size
/= Standard_Float_Size
520 or else Rt_Type
= Standard_Short_Float
)
524 elsif P_Size
<= Standard_Float_Size
then
527 elsif P_Size
<= Standard_Long_Float_Size
528 and then (Standard_Long_Float_Size
/= Standard_Long_Long_Float_Size
529 or else Rt_Type
= Standard_Long_Float
)
537 -- Signed integer types. Also includes signed fixed-point types and
538 -- enumeration types with a signed representation.
540 -- Note on signed integer types. We do not consider types as signed for
541 -- this purpose if they have no negative numbers, or if they have biased
542 -- representation. The reason is that the value in either case basically
543 -- represents an unsigned value.
545 -- For example, consider:
547 -- type W is range 0 .. 2**32 - 1;
548 -- for W'Size use 32;
550 -- This is a signed type, but the representation is unsigned, and may
551 -- be outside the range of a 32-bit signed integer, so this must be
552 -- treated as 32-bit unsigned.
554 -- Similarly, if we have
556 -- type W is range -1 .. +254;
559 -- then the representation is unsigned
561 elsif not Is_Unsigned_Type
(FST
)
563 (Is_Fixed_Point_Type
(U_Type
)
565 Is_Enumeration_Type
(U_Type
)
567 (Is_Signed_Integer_Type
(U_Type
)
568 and then not Has_Biased_Representation
(FST
)))
570 if P_Size
<= Standard_Short_Short_Integer_Size
then
573 elsif P_Size
<= Standard_Short_Integer_Size
then
576 elsif P_Size
<= Standard_Integer_Size
then
579 elsif P_Size
<= Standard_Long_Integer_Size
then
586 -- Unsigned integer types, also includes unsigned fixed-point types
587 -- and enumeration types with an unsigned representation (note that
588 -- we know they are unsigned because we already tested for signed).
590 -- Also includes signed integer types that are unsigned in the sense
591 -- that they do not include negative numbers. See above for details.
593 elsif Is_Modular_Integer_Type
(U_Type
)
594 or else Is_Fixed_Point_Type
(U_Type
)
595 or else Is_Enumeration_Type
(U_Type
)
596 or else Is_Signed_Integer_Type
(U_Type
)
598 if P_Size
<= Standard_Short_Short_Integer_Size
then
601 elsif P_Size
<= Standard_Short_Integer_Size
then
604 elsif P_Size
<= Standard_Integer_Size
then
607 elsif P_Size
<= Standard_Long_Integer_Size
then
614 else pragma Assert
(Is_Access_Type
(U_Type
));
615 if P_Size
> System_Address_Size
then
622 -- Call the function, and do an unchecked conversion of the result
623 -- to the actual type of the prefix. If the target is a discriminant,
624 -- and we are in the body of the default implementation of a 'Read
625 -- attribute, set target type to force a constraint check (13.13.2(35)).
626 -- If the type of the discriminant is currently private, add another
627 -- unchecked conversion from the full view.
629 if Nkind
(Targ
) = N_Identifier
630 and then Is_Internal_Name
(Chars
(Targ
))
631 and then Is_TSS
(Scope
(Entity
(Targ
)), TSS_Stream_Read
)
634 Unchecked_Convert_To
(Base_Type
(U_Type
),
635 Make_Function_Call
(Loc
,
636 Name
=> New_Occurrence_Of
(RTE
(Lib_RE
), Loc
),
637 Parameter_Associations
=> New_List
(
638 Relocate_Node
(Strm
))));
640 Set_Do_Range_Check
(Res
);
641 if Base_Type
(P_Type
) /= Base_Type
(U_Type
) then
642 Res
:= Unchecked_Convert_To
(Base_Type
(P_Type
), Res
);
649 Unchecked_Convert_To
(P_Type
,
650 Make_Function_Call
(Loc
,
651 Name
=> New_Occurrence_Of
(RTE
(Lib_RE
), Loc
),
652 Parameter_Associations
=> New_List
(
653 Relocate_Node
(Strm
))));
655 end Build_Elementary_Input_Call
;
657 ---------------------------------
658 -- Build_Elementary_Write_Call --
659 ---------------------------------
661 function Build_Elementary_Write_Call
(N
: Node_Id
) return Node_Id
is
662 Loc
: constant Source_Ptr
:= Sloc
(N
);
663 P_Type
: constant Entity_Id
:= Entity
(Prefix
(N
));
664 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
665 Rt_Type
: constant Entity_Id
:= Root_Type
(U_Type
);
666 FST
: constant Entity_Id
:= First_Subtype
(U_Type
);
667 Strm
: constant Node_Id
:= First
(Expressions
(N
));
668 Item
: constant Node_Id
:= Next
(Strm
);
674 Check_Restriction
(No_Default_Stream_Attributes
, N
);
676 -- Compute the size of the stream element. This is either the size of
677 -- the first subtype or if given the size of the Stream_Size attribute.
679 if Has_Stream_Size_Clause
(FST
) then
680 P_Size
:= Static_Integer
(Expression
(Stream_Size_Clause
(FST
)));
682 P_Size
:= Esize
(FST
);
685 -- Find the routine to be called
687 -- Check for First Boolean and Character. These are enumeration types,
688 -- but we treat them specially, since they may require special handling
689 -- in the transfer protocol. However, this special handling only applies
690 -- if they have standard representation, otherwise they are treated like
691 -- any other enumeration type.
693 if Rt_Type
= Standard_Boolean
694 and then Has_Stream_Standard_Rep
(U_Type
)
698 elsif Rt_Type
= Standard_Character
699 and then Has_Stream_Standard_Rep
(U_Type
)
703 elsif Rt_Type
= Standard_Wide_Character
704 and then Has_Stream_Standard_Rep
(U_Type
)
708 elsif Rt_Type
= Standard_Wide_Wide_Character
709 and then Has_Stream_Standard_Rep
(U_Type
)
713 -- Floating point types
715 elsif Is_Floating_Point_Type
(U_Type
) then
717 -- Question: should we use P_Size or Rt_Type to distinguish between
718 -- possible floating point types? If a non-standard size or a stream
719 -- size is specified, then we should certainly use the size. But if
720 -- we have two types the same (notably Short_Float_Size = Float_Size
721 -- which is close to universally true, and Long_Long_Float_Size =
722 -- Long_Float_Size, true on most targets except the x86), then we
723 -- would really rather use the root type, so that if people want to
724 -- fiddle with System.Stream_Attributes to get inter-target portable
725 -- streams, they get the size they expect. Consider in particular the
726 -- case of a stream written on an x86, with 96-bit Long_Long_Float
727 -- being read into a non-x86 target with 64 bit Long_Long_Float. A
728 -- special version of System.Stream_Attributes can deal with this
729 -- provided the proper type is always used.
731 -- To deal with these two requirements we add the special checks
732 -- on equal sizes and use the root type to distinguish.
734 if P_Size
<= Standard_Short_Float_Size
735 and then (Standard_Short_Float_Size
/= Standard_Float_Size
736 or else Rt_Type
= Standard_Short_Float
)
740 elsif P_Size
<= Standard_Float_Size
then
743 elsif P_Size
<= Standard_Long_Float_Size
744 and then (Standard_Long_Float_Size
/= Standard_Long_Long_Float_Size
745 or else Rt_Type
= Standard_Long_Float
)
753 -- Signed integer types. Also includes signed fixed-point types and
754 -- signed enumeration types share this circuitry.
756 -- Note on signed integer types. We do not consider types as signed for
757 -- this purpose if they have no negative numbers, or if they have biased
758 -- representation. The reason is that the value in either case basically
759 -- represents an unsigned value.
761 -- For example, consider:
763 -- type W is range 0 .. 2**32 - 1;
764 -- for W'Size use 32;
766 -- This is a signed type, but the representation is unsigned, and may
767 -- be outside the range of a 32-bit signed integer, so this must be
768 -- treated as 32-bit unsigned.
770 -- Similarly, the representation is also unsigned if we have:
772 -- type W is range -1 .. +254;
775 -- forcing a biased and unsigned representation
777 elsif not Is_Unsigned_Type
(FST
)
779 (Is_Fixed_Point_Type
(U_Type
)
781 Is_Enumeration_Type
(U_Type
)
783 (Is_Signed_Integer_Type
(U_Type
)
784 and then not Has_Biased_Representation
(FST
)))
786 if P_Size
<= Standard_Short_Short_Integer_Size
then
788 elsif P_Size
<= Standard_Short_Integer_Size
then
790 elsif P_Size
<= Standard_Integer_Size
then
792 elsif P_Size
<= Standard_Long_Integer_Size
then
798 -- Unsigned integer types, also includes unsigned fixed-point types
799 -- and unsigned enumeration types (note we know they are unsigned
800 -- because we already tested for signed above).
802 -- Also includes signed integer types that are unsigned in the sense
803 -- that they do not include negative numbers. See above for details.
805 elsif Is_Modular_Integer_Type
(U_Type
)
806 or else Is_Fixed_Point_Type
(U_Type
)
807 or else Is_Enumeration_Type
(U_Type
)
808 or else Is_Signed_Integer_Type
(U_Type
)
810 if P_Size
<= Standard_Short_Short_Integer_Size
then
812 elsif P_Size
<= Standard_Short_Integer_Size
then
814 elsif P_Size
<= Standard_Integer_Size
then
816 elsif P_Size
<= Standard_Long_Integer_Size
then
822 else pragma Assert
(Is_Access_Type
(U_Type
));
824 if P_Size
> System_Address_Size
then
831 -- Unchecked-convert parameter to the required type (i.e. the type of
832 -- the corresponding parameter, and call the appropriate routine.
834 Libent
:= RTE
(Lib_RE
);
837 Make_Procedure_Call_Statement
(Loc
,
838 Name
=> New_Occurrence_Of
(Libent
, Loc
),
839 Parameter_Associations
=> New_List
(
840 Relocate_Node
(Strm
),
841 Unchecked_Convert_To
(Etype
(Next_Formal
(First_Formal
(Libent
))),
842 Relocate_Node
(Item
))));
843 end Build_Elementary_Write_Call
;
845 -----------------------------------------
846 -- Build_Mutable_Record_Read_Procedure --
847 -----------------------------------------
849 procedure Build_Mutable_Record_Read_Procedure
853 Pnam
: out Entity_Id
)
855 Out_Formal
: Node_Id
;
856 -- Expression denoting the out formal parameter
858 Dcls
: constant List_Id
:= New_List
;
859 -- Declarations for the 'Read body
861 Stms
: List_Id
:= New_List
;
862 -- Statements for the 'Read body
865 -- Entity of the discriminant being processed
867 Tmp_For_Disc
: Entity_Id
;
868 -- Temporary object used to read the value of Disc
870 Tmps_For_Discs
: constant List_Id
:= New_List
;
871 -- List of object declarations for temporaries holding the read values
872 -- for the discriminants.
874 Cstr
: constant List_Id
:= New_List
;
875 -- List of constraints to be applied on temporary record
877 Discriminant_Checks
: constant List_Id
:= New_List
;
878 -- List of discriminant checks to be performed if the actual object
881 Tmp
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_V
);
882 -- Temporary record must hide formal (assignments to components of the
883 -- record are always generated with V as the identifier for the record).
885 Constrained_Stms
: List_Id
:= New_List
;
886 -- Statements within the block where we have the constrained temporary
890 Disc
:= First_Discriminant
(Typ
);
892 -- A mutable type cannot be a tagged type, so we generate a new name
893 -- for the stream procedure.
896 Make_Defining_Identifier
(Loc
,
897 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Read
));
900 Make_Selected_Component
(Loc
,
901 Prefix
=> New_Occurrence_Of
(Pnam
, Loc
),
902 Selector_Name
=> Make_Identifier
(Loc
, Name_V
));
904 -- Generate Reads for the discriminants of the type. The discriminants
905 -- need to be read before the rest of the components, so that
906 -- variants are initialized correctly. The discriminants must be read
907 -- into temporary variables so an incomplete Read (interrupted by an
908 -- exception, for example) does not alter the passed object.
910 while Present
(Disc
) loop
911 Tmp_For_Disc
:= Make_Defining_Identifier
(Loc
,
912 New_External_Name
(Chars
(Disc
), "D"));
914 Append_To
(Tmps_For_Discs
,
915 Make_Object_Declaration
(Loc
,
916 Defining_Identifier
=> Tmp_For_Disc
,
917 Object_Definition
=> New_Occurrence_Of
(Etype
(Disc
), Loc
)));
918 Set_No_Initialization
(Last
(Tmps_For_Discs
));
921 Make_Attribute_Reference
(Loc
,
922 Prefix
=> New_Occurrence_Of
(Etype
(Disc
), Loc
),
923 Attribute_Name
=> Name_Read
,
924 Expressions
=> New_List
(
925 Make_Identifier
(Loc
, Name_S
),
926 New_Occurrence_Of
(Tmp_For_Disc
, Loc
))));
929 Make_Discriminant_Association
(Loc
,
930 Selector_Names
=> New_List
(New_Occurrence_Of
(Disc
, Loc
)),
931 Expression
=> New_Occurrence_Of
(Tmp_For_Disc
, Loc
)));
933 Append_To
(Discriminant_Checks
,
934 Make_Raise_Constraint_Error
(Loc
,
937 Left_Opnd
=> New_Occurrence_Of
(Tmp_For_Disc
, Loc
),
939 Make_Selected_Component
(Loc
,
940 Prefix
=> New_Copy_Tree
(Out_Formal
),
941 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
))),
942 Reason
=> CE_Discriminant_Check_Failed
));
943 Next_Discriminant
(Disc
);
946 -- Generate reads for the components of the record (including
947 -- those that depend on discriminants).
949 Build_Record_Read_Write_Procedure
(Loc
, Typ
, Decl
, Pnam
, Name_Read
);
951 -- If Typ has controlled components (i.e. if it is classwide
952 -- or Has_Controlled), or components constrained using the discriminants
953 -- of Typ, then we need to ensure that all component assignments
954 -- are performed on an object that has been appropriately constrained
955 -- prior to being initialized. To this effect, we wrap the component
956 -- assignments in a block where V is a constrained temporary.
959 Make_Object_Declaration
(Loc
,
960 Defining_Identifier
=> Tmp
,
962 Make_Subtype_Indication
(Loc
,
963 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
965 Make_Index_Or_Discriminant_Constraint
(Loc
,
966 Constraints
=> Cstr
))));
968 Constrained_Stms
:= Statements
(Handled_Statement_Sequence
(Decl
));
970 Make_Block_Statement
(Loc
,
971 Declarations
=> Dcls
,
972 Handled_Statement_Sequence
=> Parent
(Constrained_Stms
)));
974 Append_To
(Constrained_Stms
,
975 Make_Implicit_If_Statement
(Pnam
,
977 Make_Attribute_Reference
(Loc
,
978 Prefix
=> New_Copy_Tree
(Out_Formal
),
979 Attribute_Name
=> Name_Constrained
),
980 Then_Statements
=> Discriminant_Checks
));
982 Append_To
(Constrained_Stms
,
983 Make_Assignment_Statement
(Loc
,
985 Expression
=> Make_Identifier
(Loc
, Name_V
)));
987 if Is_Unchecked_Union
(Typ
) then
989 -- If this is an unchecked union, the stream procedure is erroneous,
990 -- because there are no discriminants to read.
992 -- This should generate a warning ???
996 Make_Raise_Program_Error
(Loc
,
997 Reason
=> PE_Unchecked_Union_Restriction
));
1000 Set_Declarations
(Decl
, Tmps_For_Discs
);
1001 Set_Handled_Statement_Sequence
(Decl
,
1002 Make_Handled_Sequence_Of_Statements
(Loc
,
1003 Statements
=> Stms
));
1004 end Build_Mutable_Record_Read_Procedure
;
1006 ------------------------------------------
1007 -- Build_Mutable_Record_Write_Procedure --
1008 ------------------------------------------
1010 procedure Build_Mutable_Record_Write_Procedure
1014 Pnam
: out Entity_Id
)
1022 Disc
:= First_Discriminant
(Typ
);
1024 -- Generate Writes for the discriminants of the type
1025 -- If the type is an unchecked union, use the default values of
1026 -- the discriminants, because they are not stored.
1028 while Present
(Disc
) loop
1029 if Is_Unchecked_Union
(Typ
) then
1031 New_Copy_Tree
(Discriminant_Default_Value
(Disc
));
1034 Make_Selected_Component
(Loc
,
1035 Prefix
=> Make_Identifier
(Loc
, Name_V
),
1036 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
));
1040 Make_Attribute_Reference
(Loc
,
1041 Prefix
=> New_Occurrence_Of
(Etype
(Disc
), Loc
),
1042 Attribute_Name
=> Name_Write
,
1043 Expressions
=> New_List
(
1044 Make_Identifier
(Loc
, Name_S
),
1047 Next_Discriminant
(Disc
);
1050 -- A mutable type cannot be a tagged type, so we generate a new name
1051 -- for the stream procedure.
1054 Make_Defining_Identifier
(Loc
,
1055 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Write
));
1056 Build_Record_Read_Write_Procedure
(Loc
, Typ
, Decl
, Pnam
, Name_Write
);
1058 -- Write the discriminants before the rest of the components, so
1059 -- that discriminant values are properly set of variants, etc.
1061 if Is_Non_Empty_List
(
1062 Statements
(Handled_Statement_Sequence
(Decl
)))
1065 (First
(Statements
(Handled_Statement_Sequence
(Decl
))), Stms
);
1067 Set_Statements
(Handled_Statement_Sequence
(Decl
), Stms
);
1069 end Build_Mutable_Record_Write_Procedure
;
1071 -----------------------------------------------
1072 -- Build_Record_Or_Elementary_Input_Function --
1073 -----------------------------------------------
1075 -- The function we build looks like
1077 -- function InputN (S : access RST) return Typ is
1078 -- C1 : constant Disc_Type_1;
1079 -- Discr_Type_1'Read (S, C1);
1080 -- C2 : constant Disc_Type_2;
1081 -- Discr_Type_2'Read (S, C2);
1083 -- Cn : constant Disc_Type_n;
1084 -- Discr_Type_n'Read (S, Cn);
1085 -- V : Typ (C1, C2, .. Cn)
1092 -- The discriminants are of course only present in the case of a record
1093 -- with discriminants. In the case of a record with no discriminants, or
1094 -- an elementary type, then no Cn constants are defined.
1096 procedure Build_Record_Or_Elementary_Input_Function
1100 Fnam
: out Entity_Id
)
1117 if Has_Discriminants
(Typ
) then
1118 Discr
:= First_Discriminant
(Typ
);
1120 while Present
(Discr
) loop
1121 Cn
:= New_External_Name
('C', J
);
1124 Make_Object_Declaration
(Loc
,
1125 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Cn
),
1126 Object_Definition
=>
1127 New_Occurrence_Of
(Etype
(Discr
), Loc
));
1129 -- If this is an access discriminant, do not perform default
1130 -- initialization. The discriminant is about to get its value
1131 -- from Read, and if the type is null excluding we do not want
1132 -- spurious warnings on an initial null value.
1134 if Is_Access_Type
(Etype
(Discr
)) then
1135 Set_No_Initialization
(Decl
);
1138 Append_To
(Decls
, Decl
);
1140 Make_Attribute_Reference
(Loc
,
1141 Prefix
=> New_Occurrence_Of
(Etype
(Discr
), Loc
),
1142 Attribute_Name
=> Name_Read
,
1143 Expressions
=> New_List
(
1144 Make_Identifier
(Loc
, Name_S
),
1145 Make_Identifier
(Loc
, Cn
))));
1147 Append_To
(Constr
, Make_Identifier
(Loc
, Cn
));
1149 Next_Discriminant
(Discr
);
1154 Make_Subtype_Indication
(Loc
,
1155 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
1157 Make_Index_Or_Discriminant_Constraint
(Loc
,
1158 Constraints
=> Constr
));
1160 -- If no discriminants, then just use the type with no constraint
1163 Odef
:= New_Occurrence_Of
(Typ
, Loc
);
1166 -- For Ada 2005 we create an extended return statement encapsulating
1167 -- the result object and 'Read call, which is needed in general for
1168 -- proper handling of build-in-place results (such as when the result
1169 -- type is inherently limited).
1171 -- Perhaps we should just generate an extended return in all cases???
1174 Make_Object_Declaration
(Loc
,
1175 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
1176 Object_Definition
=> Odef
);
1178 -- If the type is an access type, do not perform default initialization.
1179 -- The object is about to get its value from Read, and if the type is
1180 -- null excluding we do not want spurious warnings on an initial null.
1182 if Is_Access_Type
(Typ
) then
1183 Set_No_Initialization
(Obj_Decl
);
1186 if Ada_Version
>= Ada_2005
then
1188 Make_Extended_Return_Statement
(Loc
,
1189 Return_Object_Declarations
=> New_List
(Obj_Decl
),
1190 Handled_Statement_Sequence
=>
1191 Make_Handled_Sequence_Of_Statements
(Loc
,
1192 New_List
(Make_Attribute_Reference
(Loc
,
1193 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
1194 Attribute_Name
=> Name_Read
,
1195 Expressions
=> New_List
(
1196 Make_Identifier
(Loc
, Name_S
),
1197 Make_Identifier
(Loc
, Name_V
)))))));
1200 Append_To
(Decls
, Obj_Decl
);
1203 Make_Attribute_Reference
(Loc
,
1204 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
1205 Attribute_Name
=> Name_Read
,
1206 Expressions
=> New_List
(
1207 Make_Identifier
(Loc
, Name_S
),
1208 Make_Identifier
(Loc
, Name_V
))),
1210 Make_Simple_Return_Statement
(Loc
,
1211 Expression
=> Make_Identifier
(Loc
, Name_V
)));
1214 Fnam
:= Make_Stream_Subprogram_Name
(Loc
, Typ
, TSS_Stream_Input
);
1216 Build_Stream_Function
(Loc
, Typ
, Decl
, Fnam
, Decls
, Stms
);
1217 end Build_Record_Or_Elementary_Input_Function
;
1219 -------------------------------------------------
1220 -- Build_Record_Or_Elementary_Output_Procedure --
1221 -------------------------------------------------
1223 procedure Build_Record_Or_Elementary_Output_Procedure
1227 Pnam
: out Entity_Id
)
1236 -- Note that of course there will be no discriminants for the
1237 -- elementary type case, so Has_Discriminants will be False.
1239 if Has_Discriminants
(Typ
) then
1240 Disc
:= First_Discriminant
(Typ
);
1242 while Present
(Disc
) loop
1244 -- If the type is an unchecked union, it must have default
1245 -- discriminants (this is checked earlier), and those defaults
1246 -- are written out to the stream.
1248 if Is_Unchecked_Union
(Typ
) then
1249 Disc_Ref
:= New_Copy_Tree
(Discriminant_Default_Value
(Disc
));
1253 Make_Selected_Component
(Loc
,
1254 Prefix
=> Make_Identifier
(Loc
, Name_V
),
1255 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
));
1259 Make_Attribute_Reference
(Loc
,
1261 New_Occurrence_Of
(Stream_Base_Type
(Etype
(Disc
)), Loc
),
1262 Attribute_Name
=> Name_Write
,
1263 Expressions
=> New_List
(
1264 Make_Identifier
(Loc
, Name_S
),
1267 Next_Discriminant
(Disc
);
1272 Make_Attribute_Reference
(Loc
,
1273 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
1274 Attribute_Name
=> Name_Write
,
1275 Expressions
=> New_List
(
1276 Make_Identifier
(Loc
, Name_S
),
1277 Make_Identifier
(Loc
, Name_V
))));
1279 Pnam
:= Make_Stream_Subprogram_Name
(Loc
, Typ
, TSS_Stream_Output
);
1281 Build_Stream_Procedure
(Loc
, Typ
, Decl
, Pnam
, Stms
, False);
1282 end Build_Record_Or_Elementary_Output_Procedure
;
1284 ---------------------------------
1285 -- Build_Record_Read_Procedure --
1286 ---------------------------------
1288 procedure Build_Record_Read_Procedure
1292 Pnam
: out Entity_Id
)
1295 Pnam
:= Make_Stream_Subprogram_Name
(Loc
, Typ
, TSS_Stream_Read
);
1296 Build_Record_Read_Write_Procedure
(Loc
, Typ
, Decl
, Pnam
, Name_Read
);
1297 end Build_Record_Read_Procedure
;
1299 ---------------------------------------
1300 -- Build_Record_Read_Write_Procedure --
1301 ---------------------------------------
1303 -- The form of the record read/write procedure is as shown by the
1304 -- following example for a case with one discriminant case variant:
1306 -- procedure pnam (S : access RST, V : [out] Typ) is
1308 -- Component_Type'Read/Write (S, V.component);
1309 -- Component_Type'Read/Write (S, V.component);
1311 -- Component_Type'Read/Write (S, V.component);
1313 -- case V.discriminant is
1315 -- Component_Type'Read/Write (S, V.component);
1316 -- Component_Type'Read/Write (S, V.component);
1318 -- Component_Type'Read/Write (S, V.component);
1321 -- Component_Type'Read/Write (S, V.component);
1322 -- Component_Type'Read/Write (S, V.component);
1324 -- Component_Type'Read/Write (S, V.component);
1329 -- The out keyword for V is supplied in the Read case
1331 procedure Build_Record_Read_Write_Procedure
1342 In_Limited_Extension
: Boolean := False;
1343 -- Set to True while processing the record extension definition
1344 -- for an extension of a limited type (for which an ancestor type
1345 -- has an explicit Nam attribute definition).
1347 function Make_Component_List_Attributes
(CL
: Node_Id
) return List_Id
;
1348 -- Returns a sequence of attributes to process the components that
1349 -- are referenced in the given component list.
1351 function Make_Field_Attribute
(C
: Entity_Id
) return Node_Id
;
1352 -- Given C, the entity for a discriminant or component, build
1353 -- an attribute for the corresponding field values.
1355 function Make_Field_Attributes
(Clist
: List_Id
) return List_Id
;
1356 -- Given Clist, a component items list, construct series of attributes
1357 -- for fieldwise processing of the corresponding components.
1359 ------------------------------------
1360 -- Make_Component_List_Attributes --
1361 ------------------------------------
1363 function Make_Component_List_Attributes
(CL
: Node_Id
) return List_Id
is
1364 CI
: constant List_Id
:= Component_Items
(CL
);
1365 VP
: constant Node_Id
:= Variant_Part
(CL
);
1375 Result
:= Make_Field_Attributes
(CI
);
1377 if Present
(VP
) then
1380 V
:= First_Non_Pragma
(Variants
(VP
));
1381 while Present
(V
) loop
1384 DC
:= First
(Discrete_Choices
(V
));
1385 while Present
(DC
) loop
1386 Append_To
(DCH
, New_Copy_Tree
(DC
));
1391 Make_Case_Statement_Alternative
(Loc
,
1392 Discrete_Choices
=> DCH
,
1394 Make_Component_List_Attributes
(Component_List
(V
))));
1395 Next_Non_Pragma
(V
);
1398 -- Note: in the following, we make sure that we use new occurrence
1399 -- of for the selector, since there are cases in which we make a
1400 -- reference to a hidden discriminant that is not visible.
1402 -- If the enclosing record is an unchecked_union, we use the
1403 -- default expressions for the discriminant (it must exist)
1404 -- because we cannot generate a reference to it, given that
1405 -- it is not stored.
1407 if Is_Unchecked_Union
(Scope
(Entity
(Name
(VP
)))) then
1410 (Discriminant_Default_Value
(Entity
(Name
(VP
))));
1413 Make_Selected_Component
(Loc
,
1414 Prefix
=> Make_Identifier
(Loc
, Name_V
),
1416 New_Occurrence_Of
(Entity
(Name
(VP
)), Loc
));
1420 Make_Case_Statement
(Loc
,
1421 Expression
=> D_Ref
,
1422 Alternatives
=> Alts
));
1426 end Make_Component_List_Attributes
;
1428 --------------------------
1429 -- Make_Field_Attribute --
1430 --------------------------
1432 function Make_Field_Attribute
(C
: Entity_Id
) return Node_Id
is
1433 Field_Typ
: constant Entity_Id
:= Stream_Base_Type
(Etype
(C
));
1435 TSS_Names
: constant array (Name_Input
.. Name_Write
) of
1437 (Name_Read
=> TSS_Stream_Read
,
1438 Name_Write
=> TSS_Stream_Write
,
1439 Name_Input
=> TSS_Stream_Input
,
1440 Name_Output
=> TSS_Stream_Output
,
1441 others => TSS_Null
);
1442 pragma Assert
(TSS_Names
(Nam
) /= TSS_Null
);
1445 if In_Limited_Extension
1446 and then Is_Limited_Type
(Field_Typ
)
1447 and then No
(Find_Inherited_TSS
(Field_Typ
, TSS_Names
(Nam
)))
1449 -- The declaration is illegal per 13.13.2(9/1), and this is
1450 -- enforced in Exp_Ch3.Check_Stream_Attributes. Keep the caller
1451 -- happy by returning a null statement.
1453 return Make_Null_Statement
(Loc
);
1457 Make_Attribute_Reference
(Loc
,
1459 New_Occurrence_Of
(Field_Typ
, Loc
),
1460 Attribute_Name
=> Nam
,
1461 Expressions
=> New_List
(
1462 Make_Identifier
(Loc
, Name_S
),
1463 Make_Selected_Component
(Loc
,
1464 Prefix
=> Make_Identifier
(Loc
, Name_V
),
1465 Selector_Name
=> New_Occurrence_Of
(C
, Loc
))));
1466 end Make_Field_Attribute
;
1468 ---------------------------
1469 -- Make_Field_Attributes --
1470 ---------------------------
1472 function Make_Field_Attributes
(Clist
: List_Id
) return List_Id
is
1479 if Present
(Clist
) then
1480 Item
:= First
(Clist
);
1482 -- Loop through components, skipping all internal components,
1483 -- which are not part of the value (e.g. _Tag), except that we
1484 -- don't skip the _Parent, since we do want to process that
1485 -- recursively. If _Parent is an interface type, being abstract
1486 -- with no components there is no need to handle it.
1488 while Present
(Item
) loop
1489 if Nkind
(Item
) = N_Component_Declaration
1491 ((Chars
(Defining_Identifier
(Item
)) = Name_uParent
1492 and then not Is_Interface
1493 (Etype
(Defining_Identifier
(Item
))))
1495 not Is_Internal_Name
(Chars
(Defining_Identifier
(Item
))))
1499 Make_Field_Attribute
(Defining_Identifier
(Item
)));
1507 end Make_Field_Attributes
;
1509 -- Start of processing for Build_Record_Read_Write_Procedure
1512 -- For the protected type case, use corresponding record
1514 if Is_Protected_Type
(Typ
) then
1515 Typt
:= Corresponding_Record_Type
(Typ
);
1520 -- Note that we do nothing with the discriminants, since Read and
1521 -- Write do not read or write the discriminant values. All handling
1522 -- of discriminants occurs in the Input and Output subprograms.
1524 Rdef
:= Type_Definition
1525 (Declaration_Node
(Base_Type
(Underlying_Type
(Typt
))));
1528 -- In record extension case, the fields we want, including the _Parent
1529 -- field representing the parent type, are to be found in the extension.
1530 -- Note that we will naturally process the _Parent field using the type
1531 -- of the parent, and hence its stream attributes, which is appropriate.
1533 if Nkind
(Rdef
) = N_Derived_Type_Definition
then
1534 Rdef
:= Record_Extension_Part
(Rdef
);
1536 if Is_Limited_Type
(Typt
) then
1537 In_Limited_Extension
:= True;
1541 if Present
(Component_List
(Rdef
)) then
1542 Append_List_To
(Stms
,
1543 Make_Component_List_Attributes
(Component_List
(Rdef
)));
1546 Build_Stream_Procedure
1547 (Loc
, Typ
, Decl
, Pnam
, Stms
, Nam
= Name_Read
);
1548 end Build_Record_Read_Write_Procedure
;
1550 ----------------------------------
1551 -- Build_Record_Write_Procedure --
1552 ----------------------------------
1554 procedure Build_Record_Write_Procedure
1558 Pnam
: out Entity_Id
)
1561 Pnam
:= Make_Stream_Subprogram_Name
(Loc
, Typ
, TSS_Stream_Write
);
1562 Build_Record_Read_Write_Procedure
(Loc
, Typ
, Decl
, Pnam
, Name_Write
);
1563 end Build_Record_Write_Procedure
;
1565 -------------------------------
1566 -- Build_Stream_Attr_Profile --
1567 -------------------------------
1569 function Build_Stream_Attr_Profile
1572 Nam
: TSS_Name_Type
) return List_Id
1577 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has
1578 -- no semantic meaning in Ada 95 but it is a requirement in Ada2005.
1580 Profile
:= New_List
(
1581 Make_Parameter_Specification
(Loc
,
1582 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_S
),
1584 Make_Access_Definition
(Loc
,
1585 Null_Exclusion_Present
=> True,
1586 Subtype_Mark
=> New_Reference_To
(
1587 Class_Wide_Type
(RTE
(RE_Root_Stream_Type
)), Loc
))));
1589 if Nam
/= TSS_Stream_Input
then
1591 Make_Parameter_Specification
(Loc
,
1592 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
1593 Out_Present
=> (Nam
= TSS_Stream_Read
),
1594 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
1598 end Build_Stream_Attr_Profile
;
1600 ---------------------------
1601 -- Build_Stream_Function --
1602 ---------------------------
1604 procedure Build_Stream_Function
1615 -- Construct function specification
1617 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has
1618 -- no semantic meaning in Ada 95 but it is a requirement in Ada2005.
1621 Make_Function_Specification
(Loc
,
1622 Defining_Unit_Name
=> Fnam
,
1624 Parameter_Specifications
=> New_List
(
1625 Make_Parameter_Specification
(Loc
,
1626 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_S
),
1628 Make_Access_Definition
(Loc
,
1629 Null_Exclusion_Present
=> True,
1630 Subtype_Mark
=> New_Reference_To
(
1631 Class_Wide_Type
(RTE
(RE_Root_Stream_Type
)), Loc
)))),
1633 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
1636 Make_Subprogram_Body
(Loc
,
1637 Specification
=> Spec
,
1638 Declarations
=> Decls
,
1639 Handled_Statement_Sequence
=>
1640 Make_Handled_Sequence_Of_Statements
(Loc
,
1641 Statements
=> Stms
));
1642 end Build_Stream_Function
;
1644 ----------------------------
1645 -- Build_Stream_Procedure --
1646 ----------------------------
1648 procedure Build_Stream_Procedure
1659 -- Construct procedure specification
1661 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has
1662 -- no semantic meaning in Ada 95 but it is a requirement in Ada2005.
1665 Make_Procedure_Specification
(Loc
,
1666 Defining_Unit_Name
=> Pnam
,
1668 Parameter_Specifications
=> New_List
(
1669 Make_Parameter_Specification
(Loc
,
1670 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_S
),
1672 Make_Access_Definition
(Loc
,
1673 Null_Exclusion_Present
=> True,
1674 Subtype_Mark
=> New_Reference_To
(
1675 Class_Wide_Type
(RTE
(RE_Root_Stream_Type
)), Loc
))),
1677 Make_Parameter_Specification
(Loc
,
1678 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
1679 Out_Present
=> Outp
,
1680 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))));
1683 Make_Subprogram_Body
(Loc
,
1684 Specification
=> Spec
,
1685 Declarations
=> Empty_List
,
1686 Handled_Statement_Sequence
=>
1687 Make_Handled_Sequence_Of_Statements
(Loc
,
1688 Statements
=> Stms
));
1689 end Build_Stream_Procedure
;
1691 -----------------------------
1692 -- Has_Stream_Standard_Rep --
1693 -----------------------------
1695 function Has_Stream_Standard_Rep
(U_Type
: Entity_Id
) return Boolean is
1699 if Has_Non_Standard_Rep
(U_Type
) then
1703 if Has_Stream_Size_Clause
(U_Type
) then
1704 Siz
:= Static_Integer
(Expression
(Stream_Size_Clause
(U_Type
)));
1706 Siz
:= Esize
(First_Subtype
(U_Type
));
1709 return Siz
= Esize
(Root_Type
(U_Type
));
1710 end Has_Stream_Standard_Rep
;
1712 ---------------------------------
1713 -- Make_Stream_Subprogram_Name --
1714 ---------------------------------
1716 function Make_Stream_Subprogram_Name
1719 Nam
: TSS_Name_Type
) return Entity_Id
1724 -- For tagged types, we are dealing with a TSS associated with the
1725 -- declaration, so we use the standard primitive function name. For
1726 -- other types, generate a local TSS name since we are generating
1727 -- the subprogram at the point of use.
1729 if Is_Tagged_Type
(Typ
) then
1730 Sname
:= Make_TSS_Name
(Typ
, Nam
);
1732 Sname
:= Make_TSS_Name_Local
(Typ
, Nam
);
1735 return Make_Defining_Identifier
(Loc
, Sname
);
1736 end Make_Stream_Subprogram_Name
;
1738 ----------------------
1739 -- Stream_Base_Type --
1740 ----------------------
1742 function Stream_Base_Type
(E
: Entity_Id
) return Entity_Id
is
1744 if Is_Array_Type
(E
)
1745 and then Is_First_Subtype
(E
)
1749 return Base_Type
(E
);
1751 end Stream_Base_Type
;