1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, 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 Elists
; use Elists
;
29 with Exp_Util
; use Exp_Util
;
30 with Namet
; use Namet
;
31 with Nlists
; use Nlists
;
32 with Nmake
; use Nmake
;
33 with Rtsfind
; use Rtsfind
;
34 with Sem_Aux
; use Sem_Aux
;
35 with Sem_Util
; use Sem_Util
;
36 with Sinfo
; use Sinfo
;
37 with Snames
; use Snames
;
38 with Stand
; use Stand
;
39 with Tbuild
; use Tbuild
;
40 with Ttypes
; use Ttypes
;
41 with Uintp
; use Uintp
;
43 package body Exp_Strm
is
45 -----------------------
46 -- Local Subprograms --
47 -----------------------
49 procedure Build_Array_Read_Write_Procedure
55 -- Common routine shared to build either an array Read procedure or an
56 -- array Write procedure, Nam is Name_Read or Name_Write to select which.
57 -- Pnam is the defining identifier for the constructed procedure. The
58 -- other parameters are as for Build_Array_Read_Procedure except that
59 -- the first parameter Nod supplies the Sloc to be used to generate code.
61 procedure Build_Record_Read_Write_Procedure
67 -- Common routine shared to build a record Read Write procedure, Nam
68 -- is Name_Read or Name_Write to select which. Pnam is the defining
69 -- identifier for the constructed procedure. The other parameters are
70 -- as for Build_Record_Read_Procedure.
72 procedure Build_Stream_Function
79 -- Called to build an array or record stream function. The first three
80 -- arguments are the same as Build_Record_Or_Elementary_Input_Function.
81 -- Decls and Stms are the declarations and statements for the body and
82 -- The parameter Fnam is the name of the constructed function.
84 function Has_Stream_Standard_Rep
(U_Type
: Entity_Id
) return Boolean;
85 -- This function is used to test the type U_Type, to determine if it has
86 -- a standard representation from a streaming point of view. Standard means
87 -- that it has a standard representation (e.g. no enumeration rep clause),
88 -- and the size of the root type is the same as the streaming size (which
89 -- is defined as value specified by a Stream_Size clause if present, or
90 -- the Esize of U_Type if not).
92 function Make_Stream_Subprogram_Name
95 Nam
: TSS_Name_Type
) return Entity_Id
;
96 -- Return the entity that identifies the stream subprogram for type Typ
97 -- that is identified by the given Nam. This procedure deals with the
98 -- difference between tagged types (where a single subprogram associated
99 -- with the type is generated) and all other cases (where a subprogram
100 -- is generated at the point of the stream attribute reference). The
101 -- Loc parameter is used as the Sloc of the created entity.
103 function Stream_Base_Type
(E
: Entity_Id
) return Entity_Id
;
104 -- Stream attributes work on the basis of the base type except for the
105 -- array case. For the array case, we do not go to the base type, but
106 -- to the first subtype if it is constrained. This avoids problems with
107 -- incorrect conversions in the packed array case. Stream_Base_Type is
108 -- exactly this function (returns the base type, unless we have an array
109 -- type whose first subtype is constrained, in which case it returns the
112 --------------------------------
113 -- Build_Array_Input_Function --
114 --------------------------------
116 -- The function we build looks like
118 -- function typSI[_nnn] (S : access RST) return Typ is
119 -- L1 : constant Index_Type_1 := Index_Type_1'Input (S);
120 -- H1 : constant Index_Type_1 := Index_Type_1'Input (S);
121 -- L2 : constant Index_Type_2 := Index_Type_2'Input (S);
122 -- H2 : constant Index_Type_2 := Index_Type_2'Input (S);
124 -- Ln : constant Index_Type_n := Index_Type_n'Input (S);
125 -- Hn : constant Index_Type_n := Index_Type_n'Input (S);
127 -- V : Typ'Base (L1 .. H1, L2 .. H2, ... Ln .. Hn)
134 -- Note: the suffix [_nnn] is present for untagged types, where we generate
135 -- a local subprogram at the point of the occurrence of the attribute
136 -- reference, so the name must be unique.
138 procedure Build_Array_Input_Function
142 Fnam
: out Entity_Id
)
144 Dim
: constant Pos
:= Number_Dimensions
(Typ
);
157 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 type is constrained, use it directly. Otherwise build a
196 -- subtype indication with the proper bounds.
198 if Is_Constrained
(Typ
) then
200 Make_Object_Declaration
(Loc
,
201 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
202 Object_Definition
=> New_Occurrence_Of
(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
, Ranges
)));
217 Make_Attribute_Reference
(Loc
,
218 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
219 Attribute_Name
=> Name_Read
,
220 Expressions
=> New_List
(
221 Make_Identifier
(Loc
, Name_S
),
222 Make_Identifier
(Loc
, Name_V
)));
225 Make_Extended_Return_Statement
(Loc
,
226 Return_Object_Declarations
=> New_List
(Odecl
),
227 Handled_Statement_Sequence
=>
228 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Rstmt
))));
231 Make_Defining_Identifier
(Loc
,
232 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Input
));
234 Build_Stream_Function
(Loc
, Typ
, Decl
, Fnam
, Decls
, Stms
);
235 end Build_Array_Input_Function
;
237 ----------------------------------
238 -- Build_Array_Output_Procedure --
239 ----------------------------------
241 procedure Build_Array_Output_Procedure
245 Pnam
: out Entity_Id
)
251 -- Build series of statements to output bounds
253 Indx
:= First_Index
(Typ
);
256 for J
in 1 .. Number_Dimensions
(Typ
) loop
258 Make_Attribute_Reference
(Loc
,
260 New_Occurrence_Of
(Stream_Base_Type
(Etype
(Indx
)), Loc
),
261 Attribute_Name
=> Name_Write
,
262 Expressions
=> New_List
(
263 Make_Identifier
(Loc
, Name_S
),
264 Make_Attribute_Reference
(Loc
,
265 Prefix
=> Make_Identifier
(Loc
, Name_V
),
266 Attribute_Name
=> Name_First
,
267 Expressions
=> New_List
(
268 Make_Integer_Literal
(Loc
, J
))))));
271 Make_Attribute_Reference
(Loc
,
273 New_Occurrence_Of
(Stream_Base_Type
(Etype
(Indx
)), Loc
),
274 Attribute_Name
=> Name_Write
,
275 Expressions
=> New_List
(
276 Make_Identifier
(Loc
, Name_S
),
277 Make_Attribute_Reference
(Loc
,
278 Prefix
=> Make_Identifier
(Loc
, Name_V
),
279 Attribute_Name
=> Name_Last
,
280 Expressions
=> New_List
(
281 Make_Integer_Literal
(Loc
, J
))))));
286 -- Append Write attribute to write array elements
289 Make_Attribute_Reference
(Loc
,
290 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
291 Attribute_Name
=> Name_Write
,
292 Expressions
=> New_List
(
293 Make_Identifier
(Loc
, Name_S
),
294 Make_Identifier
(Loc
, Name_V
))));
297 Make_Defining_Identifier
(Loc
,
298 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Output
));
300 Build_Stream_Procedure
(Loc
, Typ
, Decl
, Pnam
, Stms
, False);
301 end Build_Array_Output_Procedure
;
303 --------------------------------
304 -- Build_Array_Read_Procedure --
305 --------------------------------
307 procedure Build_Array_Read_Procedure
311 Pnam
: out Entity_Id
)
313 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
317 Make_Defining_Identifier
(Loc
,
318 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Read
));
319 Build_Array_Read_Write_Procedure
(Nod
, Typ
, Decl
, Pnam
, Name_Read
);
320 end Build_Array_Read_Procedure
;
322 --------------------------------------
323 -- Build_Array_Read_Write_Procedure --
324 --------------------------------------
326 -- The form of the array read/write procedure is as follows:
328 -- procedure pnam (S : access RST, V : [out] Typ) is
330 -- for L1 in V'Range (1) loop
331 -- for L2 in V'Range (2) loop
333 -- for Ln in V'Range (n) loop
334 -- Component_Type'Read/Write (S, V (L1, L2, .. Ln));
341 -- The out keyword for V is supplied in the Read case
343 procedure Build_Array_Read_Write_Procedure
350 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
351 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
352 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
359 -- First build the inner attribute call
363 for J
in 1 .. Ndim
loop
364 Append_To
(Exl
, Make_Identifier
(Loc
, New_External_Name
('L', J
)));
368 Make_Attribute_Reference
(Loc
,
369 Prefix
=> New_Occurrence_Of
(Stream_Base_Type
(Ctyp
), Loc
),
370 Attribute_Name
=> Nam
,
371 Expressions
=> New_List
(
372 Make_Identifier
(Loc
, Name_S
),
373 Make_Indexed_Component
(Loc
,
374 Prefix
=> Make_Identifier
(Loc
, Name_V
),
375 Expressions
=> Exl
)));
377 -- The corresponding stream attribute for the component type of the
378 -- array may be user-defined, and be frozen after the type for which
379 -- we are generating the stream subprogram. In that case, freeze the
380 -- stream attribute of the component type, whose declaration could not
381 -- generate any additional freezing actions in any case.
383 if Nam
= Name_Read
then
384 RW
:= TSS
(Base_Type
(Ctyp
), TSS_Stream_Read
);
386 RW
:= TSS
(Base_Type
(Ctyp
), TSS_Stream_Write
);
390 and then not Is_Frozen
(RW
)
395 -- Now this is the big loop to wrap that statement up in a sequence
396 -- of loops. The first time around, Stm is the attribute call. The
397 -- second and subsequent times, Stm is an inner loop.
399 for J
in 1 .. Ndim
loop
401 Make_Implicit_Loop_Statement
(Nod
,
403 Make_Iteration_Scheme
(Loc
,
404 Loop_Parameter_Specification
=>
405 Make_Loop_Parameter_Specification
(Loc
,
406 Defining_Identifier
=>
407 Make_Defining_Identifier
(Loc
,
408 Chars
=> New_External_Name
('L', Ndim
- J
+ 1)),
410 Discrete_Subtype_Definition
=>
411 Make_Attribute_Reference
(Loc
,
412 Prefix
=> Make_Identifier
(Loc
, Name_V
),
413 Attribute_Name
=> Name_Range
,
415 Expressions
=> New_List
(
416 Make_Integer_Literal
(Loc
, Ndim
- J
+ 1))))),
418 Statements
=> New_List
(Stm
));
422 Build_Stream_Procedure
423 (Loc
, Typ
, Decl
, Pnam
, New_List
(Stm
), Nam
= Name_Read
);
424 end Build_Array_Read_Write_Procedure
;
426 ---------------------------------
427 -- Build_Array_Write_Procedure --
428 ---------------------------------
430 procedure Build_Array_Write_Procedure
434 Pnam
: out Entity_Id
)
436 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
439 Make_Defining_Identifier
(Loc
,
440 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Write
));
441 Build_Array_Read_Write_Procedure
(Nod
, Typ
, Decl
, Pnam
, Name_Write
);
442 end Build_Array_Write_Procedure
;
444 ---------------------------------
445 -- Build_Elementary_Input_Call --
446 ---------------------------------
448 function Build_Elementary_Input_Call
(N
: Node_Id
) return Node_Id
is
449 Loc
: constant Source_Ptr
:= Sloc
(N
);
450 P_Type
: constant Entity_Id
:= Entity
(Prefix
(N
));
451 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
452 Rt_Type
: constant Entity_Id
:= Root_Type
(U_Type
);
453 FST
: constant Entity_Id
:= First_Subtype
(U_Type
);
454 Strm
: constant Node_Id
:= First
(Expressions
(N
));
455 Targ
: constant Node_Id
:= Next
(Strm
);
456 P_Size
: constant Uint
:= Get_Stream_Size
(FST
);
462 -- Check first for Boolean and Character. These are enumeration types,
463 -- but we treat them specially, since they may require special handling
464 -- in the transfer protocol. However, this special handling only applies
465 -- if they have standard representation, otherwise they are treated like
466 -- any other enumeration type.
468 if Rt_Type
= Standard_Boolean
469 and then Has_Stream_Standard_Rep
(U_Type
)
473 elsif Rt_Type
= Standard_Character
474 and then Has_Stream_Standard_Rep
(U_Type
)
478 elsif Rt_Type
= Standard_Wide_Character
479 and then Has_Stream_Standard_Rep
(U_Type
)
483 elsif Rt_Type
= Standard_Wide_Wide_Character
484 and then Has_Stream_Standard_Rep
(U_Type
)
488 -- Floating point types
490 elsif Is_Floating_Point_Type
(U_Type
) then
492 -- Question: should we use P_Size or Rt_Type to distinguish between
493 -- possible floating point types? If a non-standard size or a stream
494 -- size is specified, then we should certainly use the size. But if
495 -- we have two types the same (notably Short_Float_Size = Float_Size
496 -- which is close to universally true, and Long_Long_Float_Size =
497 -- Long_Float_Size, true on most targets except the x86), then we
498 -- would really rather use the root type, so that if people want to
499 -- fiddle with System.Stream_Attributes to get inter-target portable
500 -- streams, they get the size they expect. Consider in particular the
501 -- case of a stream written on an x86, with 96-bit Long_Long_Float
502 -- being read into a non-x86 target with 64 bit Long_Long_Float. A
503 -- special version of System.Stream_Attributes can deal with this
504 -- provided the proper type is always used.
506 -- To deal with these two requirements we add the special checks
507 -- on equal sizes and use the root type to distinguish.
509 if P_Size
<= Standard_Short_Float_Size
510 and then (Standard_Short_Float_Size
/= Standard_Float_Size
511 or else Rt_Type
= Standard_Short_Float
)
515 elsif P_Size
<= Standard_Float_Size
then
518 elsif P_Size
<= Standard_Long_Float_Size
519 and then (Standard_Long_Float_Size
/= Standard_Long_Long_Float_Size
520 or else Rt_Type
= Standard_Long_Float
)
528 -- Signed integer types. Also includes signed fixed-point types and
529 -- enumeration types with a signed representation.
531 -- Note on signed integer types. We do not consider types as signed for
532 -- this purpose if they have no negative numbers, or if they have biased
533 -- representation. The reason is that the value in either case basically
534 -- represents an unsigned value.
536 -- For example, consider:
538 -- type W is range 0 .. 2**32 - 1;
539 -- for W'Size use 32;
541 -- This is a signed type, but the representation is unsigned, and may
542 -- be outside the range of a 32-bit signed integer, so this must be
543 -- treated as 32-bit unsigned.
545 -- Similarly, if we have
547 -- type W is range -1 .. +254;
550 -- then the representation is unsigned
552 elsif not Is_Unsigned_Type
(FST
)
554 -- The following set of tests gets repeated many times, we should
555 -- have an abstraction defined ???
558 (Is_Fixed_Point_Type
(U_Type
)
560 Is_Enumeration_Type
(U_Type
)
562 (Is_Signed_Integer_Type
(U_Type
)
563 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
);
638 if Base_Type
(P_Type
) /= Base_Type
(U_Type
) then
639 Res
:= Unchecked_Convert_To
(Base_Type
(P_Type
), Res
);
646 Unchecked_Convert_To
(P_Type
,
647 Make_Function_Call
(Loc
,
648 Name
=> New_Occurrence_Of
(RTE
(Lib_RE
), Loc
),
649 Parameter_Associations
=> New_List
(
650 Relocate_Node
(Strm
))));
652 end Build_Elementary_Input_Call
;
654 ---------------------------------
655 -- Build_Elementary_Write_Call --
656 ---------------------------------
658 function Build_Elementary_Write_Call
(N
: Node_Id
) return Node_Id
is
659 Loc
: constant Source_Ptr
:= Sloc
(N
);
660 P_Type
: constant Entity_Id
:= Entity
(Prefix
(N
));
661 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
662 Rt_Type
: constant Entity_Id
:= Root_Type
(U_Type
);
663 FST
: constant Entity_Id
:= First_Subtype
(U_Type
);
664 Strm
: constant Node_Id
:= First
(Expressions
(N
));
665 Item
: constant Node_Id
:= Next
(Strm
);
672 -- Compute the size of the stream element. This is either the size of
673 -- the first subtype or if given the size of the Stream_Size attribute.
675 if Has_Stream_Size_Clause
(FST
) then
676 P_Size
:= Static_Integer
(Expression
(Stream_Size_Clause
(FST
)));
678 P_Size
:= Esize
(FST
);
681 -- Find the routine to be called
683 -- Check for First Boolean and Character. These are enumeration types,
684 -- but we treat them specially, since they may require special handling
685 -- in the transfer protocol. However, this special handling only applies
686 -- if they have standard representation, otherwise they are treated like
687 -- any other enumeration type.
689 if Rt_Type
= Standard_Boolean
690 and then Has_Stream_Standard_Rep
(U_Type
)
694 elsif Rt_Type
= Standard_Character
695 and then Has_Stream_Standard_Rep
(U_Type
)
699 elsif Rt_Type
= Standard_Wide_Character
700 and then Has_Stream_Standard_Rep
(U_Type
)
704 elsif Rt_Type
= Standard_Wide_Wide_Character
705 and then Has_Stream_Standard_Rep
(U_Type
)
709 -- Floating point types
711 elsif Is_Floating_Point_Type
(U_Type
) then
713 -- Question: should we use P_Size or Rt_Type to distinguish between
714 -- possible floating point types? If a non-standard size or a stream
715 -- size is specified, then we should certainly use the size. But if
716 -- we have two types the same (notably Short_Float_Size = Float_Size
717 -- which is close to universally true, and Long_Long_Float_Size =
718 -- Long_Float_Size, true on most targets except the x86), then we
719 -- would really rather use the root type, so that if people want to
720 -- fiddle with System.Stream_Attributes to get inter-target portable
721 -- streams, they get the size they expect. Consider in particular the
722 -- case of a stream written on an x86, with 96-bit Long_Long_Float
723 -- being read into a non-x86 target with 64 bit Long_Long_Float. A
724 -- special version of System.Stream_Attributes can deal with this
725 -- provided the proper type is always used.
727 -- To deal with these two requirements we add the special checks
728 -- on equal sizes and use the root type to distinguish.
730 if P_Size
<= Standard_Short_Float_Size
731 and then (Standard_Short_Float_Size
/= Standard_Float_Size
732 or else Rt_Type
= Standard_Short_Float
)
736 elsif P_Size
<= Standard_Float_Size
then
739 elsif P_Size
<= Standard_Long_Float_Size
740 and then (Standard_Long_Float_Size
/= Standard_Long_Long_Float_Size
741 or else Rt_Type
= Standard_Long_Float
)
749 -- Signed integer types. Also includes signed fixed-point types and
750 -- signed enumeration types share this circuitry.
752 -- Note on signed integer types. We do not consider types as signed for
753 -- this purpose if they have no negative numbers, or if they have biased
754 -- representation. The reason is that the value in either case basically
755 -- represents an unsigned value.
757 -- For example, consider:
759 -- type W is range 0 .. 2**32 - 1;
760 -- for W'Size use 32;
762 -- This is a signed type, but the representation is unsigned, and may
763 -- be outside the range of a 32-bit signed integer, so this must be
764 -- treated as 32-bit unsigned.
766 -- Similarly, the representation is also unsigned if we have:
768 -- type W is range -1 .. +254;
771 -- forcing a biased and unsigned representation
773 elsif not Is_Unsigned_Type
(FST
)
775 (Is_Fixed_Point_Type
(U_Type
)
777 Is_Enumeration_Type
(U_Type
)
779 (Is_Signed_Integer_Type
(U_Type
)
780 and then not Has_Biased_Representation
(FST
)))
782 if P_Size
<= Standard_Short_Short_Integer_Size
then
784 elsif P_Size
<= Standard_Short_Integer_Size
then
786 elsif P_Size
<= Standard_Integer_Size
then
788 elsif P_Size
<= Standard_Long_Integer_Size
then
794 -- Unsigned integer types, also includes unsigned fixed-point types
795 -- and unsigned enumeration types (note we know they are unsigned
796 -- because we already tested for signed above).
798 -- Also includes signed integer types that are unsigned in the sense
799 -- that they do not include negative numbers. See above for details.
801 elsif Is_Modular_Integer_Type
(U_Type
)
802 or else Is_Fixed_Point_Type
(U_Type
)
803 or else Is_Enumeration_Type
(U_Type
)
804 or else Is_Signed_Integer_Type
(U_Type
)
806 if P_Size
<= Standard_Short_Short_Integer_Size
then
808 elsif P_Size
<= Standard_Short_Integer_Size
then
810 elsif P_Size
<= Standard_Integer_Size
then
812 elsif P_Size
<= Standard_Long_Integer_Size
then
818 else pragma Assert
(Is_Access_Type
(U_Type
));
820 if P_Size
> System_Address_Size
then
827 -- Unchecked-convert parameter to the required type (i.e. the type of
828 -- the corresponding parameter, and call the appropriate routine.
830 Libent
:= RTE
(Lib_RE
);
833 Make_Procedure_Call_Statement
(Loc
,
834 Name
=> New_Occurrence_Of
(Libent
, Loc
),
835 Parameter_Associations
=> New_List
(
836 Relocate_Node
(Strm
),
837 Unchecked_Convert_To
(Etype
(Next_Formal
(First_Formal
(Libent
))),
838 Relocate_Node
(Item
))));
839 end Build_Elementary_Write_Call
;
841 -----------------------------------------
842 -- Build_Mutable_Record_Read_Procedure --
843 -----------------------------------------
845 procedure Build_Mutable_Record_Read_Procedure
849 Pnam
: out Entity_Id
)
851 Out_Formal
: Node_Id
;
852 -- Expression denoting the out formal parameter
854 Dcls
: constant List_Id
:= New_List
;
855 -- Declarations for the 'Read body
857 Stms
: constant List_Id
:= New_List
;
858 -- Statements for the 'Read body
861 -- Entity of the discriminant being processed
863 Tmp_For_Disc
: Entity_Id
;
864 -- Temporary object used to read the value of Disc
866 Tmps_For_Discs
: constant List_Id
:= New_List
;
867 -- List of object declarations for temporaries holding the read values
868 -- for the discriminants.
870 Cstr
: constant List_Id
:= New_List
;
871 -- List of constraints to be applied on temporary record
873 Discriminant_Checks
: constant List_Id
:= New_List
;
874 -- List of discriminant checks to be performed if the actual object
877 Tmp
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_V
);
878 -- Temporary record must hide formal (assignments to components of the
879 -- record are always generated with V as the identifier for the record).
881 Constrained_Stms
: List_Id
:= New_List
;
882 -- Statements within the block where we have the constrained temporary
885 -- A mutable type cannot be a tagged type, so we generate a new name
886 -- for the stream procedure.
889 Make_Defining_Identifier
(Loc
,
890 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Read
));
892 if Is_Unchecked_Union
(Typ
) then
894 -- If this is an unchecked union, the stream procedure is erroneous,
895 -- because there are no discriminants to read.
897 -- This should generate a warning ???
900 Make_Raise_Program_Error
(Loc
,
901 Reason
=> PE_Unchecked_Union_Restriction
));
903 Build_Stream_Procedure
(Loc
, Typ
, Decl
, Pnam
, Stms
, Outp
=> True);
907 Disc
:= First_Discriminant
(Typ
);
910 Make_Selected_Component
(Loc
,
911 Prefix
=> New_Occurrence_Of
(Pnam
, Loc
),
912 Selector_Name
=> Make_Identifier
(Loc
, Name_V
));
914 -- Generate Reads for the discriminants of the type. The discriminants
915 -- need to be read before the rest of the components, so that variants
916 -- are initialized correctly. The discriminants must be read into temp
917 -- variables so an incomplete Read (interrupted by an exception, for
918 -- example) does not alter the passed object.
920 while Present
(Disc
) loop
921 Tmp_For_Disc
:= Make_Defining_Identifier
(Loc
,
922 New_External_Name
(Chars
(Disc
), "D"));
924 Append_To
(Tmps_For_Discs
,
925 Make_Object_Declaration
(Loc
,
926 Defining_Identifier
=> Tmp_For_Disc
,
927 Object_Definition
=> New_Occurrence_Of
(Etype
(Disc
), Loc
)));
928 Set_No_Initialization
(Last
(Tmps_For_Discs
));
931 Make_Attribute_Reference
(Loc
,
932 Prefix
=> New_Occurrence_Of
(Etype
(Disc
), Loc
),
933 Attribute_Name
=> Name_Read
,
934 Expressions
=> New_List
(
935 Make_Identifier
(Loc
, Name_S
),
936 New_Occurrence_Of
(Tmp_For_Disc
, Loc
))));
939 Make_Discriminant_Association
(Loc
,
940 Selector_Names
=> New_List
(New_Occurrence_Of
(Disc
, Loc
)),
941 Expression
=> New_Occurrence_Of
(Tmp_For_Disc
, Loc
)));
943 Append_To
(Discriminant_Checks
,
944 Make_Raise_Constraint_Error
(Loc
,
947 Left_Opnd
=> New_Occurrence_Of
(Tmp_For_Disc
, Loc
),
949 Make_Selected_Component
(Loc
,
950 Prefix
=> New_Copy_Tree
(Out_Formal
),
951 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
))),
952 Reason
=> CE_Discriminant_Check_Failed
));
953 Next_Discriminant
(Disc
);
956 -- Generate reads for the components of the record (including those
957 -- that depend on discriminants).
959 Build_Record_Read_Write_Procedure
(Loc
, Typ
, Decl
, Pnam
, Name_Read
);
961 -- Save original statement sequence for component assignments, and
962 -- replace it with Stms.
964 Constrained_Stms
:= Statements
(Handled_Statement_Sequence
(Decl
));
965 Set_Handled_Statement_Sequence
(Decl
,
966 Make_Handled_Sequence_Of_Statements
(Loc
,
967 Statements
=> Stms
));
969 -- If Typ has controlled components (i.e. if it is classwide or
970 -- Has_Controlled), or components constrained using the discriminants
971 -- of Typ, then we need to ensure that all component assignments are
972 -- performed on an object that has been appropriately constrained
973 -- prior to being initialized. To this effect, we wrap the component
974 -- assignments in a block where V is a constrained temporary.
977 Make_Object_Declaration
(Loc
,
978 Defining_Identifier
=> Tmp
,
980 Make_Subtype_Indication
(Loc
,
981 Subtype_Mark
=> New_Occurrence_Of
(Base_Type
(Typ
), Loc
),
983 Make_Index_Or_Discriminant_Constraint
(Loc
,
984 Constraints
=> Cstr
))));
986 -- AI05-023-1: Insert discriminant check prior to initialization of the
987 -- constrained temporary.
990 Make_Implicit_If_Statement
(Pnam
,
992 Make_Attribute_Reference
(Loc
,
993 Prefix
=> New_Copy_Tree
(Out_Formal
),
994 Attribute_Name
=> Name_Constrained
),
995 Then_Statements
=> Discriminant_Checks
));
997 -- Now insert back original component assignments, wrapped in a block
998 -- in which V is the constrained temporary.
1001 Make_Block_Statement
(Loc
,
1002 Declarations
=> Dcls
,
1003 Handled_Statement_Sequence
=> Parent
(Constrained_Stms
)));
1005 Append_To
(Constrained_Stms
,
1006 Make_Assignment_Statement
(Loc
,
1008 Expression
=> Make_Identifier
(Loc
, Name_V
)));
1010 Set_Declarations
(Decl
, Tmps_For_Discs
);
1011 end Build_Mutable_Record_Read_Procedure
;
1013 ------------------------------------------
1014 -- Build_Mutable_Record_Write_Procedure --
1015 ------------------------------------------
1017 procedure Build_Mutable_Record_Write_Procedure
1021 Pnam
: out Entity_Id
)
1029 Disc
:= First_Discriminant
(Typ
);
1031 -- Generate Writes for the discriminants of the type
1032 -- If the type is an unchecked union, use the default values of
1033 -- the discriminants, because they are not stored.
1035 while Present
(Disc
) loop
1036 if Is_Unchecked_Union
(Typ
) then
1038 New_Copy_Tree
(Discriminant_Default_Value
(Disc
));
1041 Make_Selected_Component
(Loc
,
1042 Prefix
=> Make_Identifier
(Loc
, Name_V
),
1043 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
));
1047 Make_Attribute_Reference
(Loc
,
1048 Prefix
=> New_Occurrence_Of
(Etype
(Disc
), Loc
),
1049 Attribute_Name
=> Name_Write
,
1050 Expressions
=> New_List
(
1051 Make_Identifier
(Loc
, Name_S
),
1054 Next_Discriminant
(Disc
);
1057 -- A mutable type cannot be a tagged type, so we generate a new name
1058 -- for the stream procedure.
1061 Make_Defining_Identifier
(Loc
,
1062 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Stream_Write
));
1063 Build_Record_Read_Write_Procedure
(Loc
, Typ
, Decl
, Pnam
, Name_Write
);
1065 -- Write the discriminants before the rest of the components, so
1066 -- that discriminant values are properly set of variants, etc.
1068 if Is_Non_Empty_List
(
1069 Statements
(Handled_Statement_Sequence
(Decl
)))
1072 (First
(Statements
(Handled_Statement_Sequence
(Decl
))), Stms
);
1074 Set_Statements
(Handled_Statement_Sequence
(Decl
), Stms
);
1076 end Build_Mutable_Record_Write_Procedure
;
1078 -----------------------------------------------
1079 -- Build_Record_Or_Elementary_Input_Function --
1080 -----------------------------------------------
1082 -- The function we build looks like
1084 -- function InputN (S : access RST) return Typ is
1085 -- C1 : constant Disc_Type_1;
1086 -- Discr_Type_1'Read (S, C1);
1087 -- C2 : constant Disc_Type_2;
1088 -- Discr_Type_2'Read (S, C2);
1090 -- Cn : constant Disc_Type_n;
1091 -- Discr_Type_n'Read (S, Cn);
1092 -- V : Typ (C1, C2, .. Cn)
1099 -- The discriminants are of course only present in the case of a record
1100 -- with discriminants. In the case of a record with no discriminants, or
1101 -- an elementary type, then no Cn constants are defined.
1103 procedure Build_Record_Or_Elementary_Input_Function
1107 Fnam
: out Entity_Id
)
1109 B_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
1114 Discr_Elmt
: Elmt_Id
:= No_Elmt
;
1126 -- In the presence of multiple instantiations (as in uses of the Booch
1127 -- components) the base type may be private, and the underlying type
1128 -- already constrained, in which case there's no discriminant constraint
1131 if Has_Discriminants
(Typ
)
1132 and then No
(Discriminant_Default_Value
(First_Discriminant
(Typ
)))
1133 and then not Is_Constrained
(Underlying_Type
(B_Typ
))
1135 Discr
:= First_Discriminant
(B_Typ
);
1137 -- If the prefix subtype is constrained, then retrieve the first
1138 -- element of its constraint.
1140 if Is_Constrained
(Typ
) then
1141 Discr_Elmt
:= First_Elmt
(Discriminant_Constraint
(Typ
));
1144 while Present
(Discr
) loop
1145 Cn
:= New_External_Name
('C', J
);
1148 Make_Object_Declaration
(Loc
,
1149 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Cn
),
1150 Object_Definition
=>
1151 New_Occurrence_Of
(Etype
(Discr
), Loc
));
1153 -- If this is an access discriminant, do not perform default
1154 -- initialization. The discriminant is about to get its value
1155 -- from Read, and if the type is null excluding we do not want
1156 -- spurious warnings on an initial null value.
1158 if Is_Access_Type
(Etype
(Discr
)) then
1159 Set_No_Initialization
(Decl
);
1162 Append_To
(Decls
, Decl
);
1164 Make_Attribute_Reference
(Loc
,
1165 Prefix
=> New_Occurrence_Of
(Etype
(Discr
), Loc
),
1166 Attribute_Name
=> Name_Read
,
1167 Expressions
=> New_List
(
1168 Make_Identifier
(Loc
, Name_S
),
1169 Make_Identifier
(Loc
, Cn
))));
1171 Append_To
(Constr
, Make_Identifier
(Loc
, Cn
));
1173 -- If the prefix subtype imposes a discriminant constraint, then
1174 -- check that each discriminant value equals the value read.
1176 if Present
(Discr_Elmt
) then
1178 Make_Raise_Constraint_Error
(Loc
,
1179 Condition
=> Make_Op_Ne
(Loc
,
1182 (Defining_Identifier
(Decl
), Loc
),
1184 New_Copy_Tree
(Node
(Discr_Elmt
))),
1185 Reason
=> CE_Discriminant_Check_Failed
));
1187 Next_Elmt
(Discr_Elmt
);
1190 Next_Discriminant
(Discr
);
1195 Make_Subtype_Indication
(Loc
,
1196 Subtype_Mark
=> New_Occurrence_Of
(B_Typ
, Loc
),
1198 Make_Index_Or_Discriminant_Constraint
(Loc
,
1199 Constraints
=> Constr
));
1201 -- If no discriminants, then just use the type with no constraint
1204 Odef
:= New_Occurrence_Of
(B_Typ
, Loc
);
1207 -- Create an extended return statement encapsulating the result object
1208 -- and 'Read call, which is needed in general for proper handling of
1209 -- build-in-place results (such as when the result type is inherently
1213 Make_Object_Declaration
(Loc
,
1214 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
1215 Object_Definition
=> Odef
);
1217 -- If the type is an access type, do not perform default initialization.
1218 -- The object is about to get its value from Read, and if the type is
1219 -- null excluding we do not want spurious warnings on an initial null.
1221 if Is_Access_Type
(B_Typ
) then
1222 Set_No_Initialization
(Obj_Decl
);
1226 Make_Extended_Return_Statement
(Loc
,
1227 Return_Object_Declarations
=> New_List
(Obj_Decl
),
1228 Handled_Statement_Sequence
=>
1229 Make_Handled_Sequence_Of_Statements
(Loc
,
1230 Statements
=> New_List
(
1231 Make_Attribute_Reference
(Loc
,
1232 Prefix
=> New_Occurrence_Of
(B_Typ
, Loc
),
1233 Attribute_Name
=> Name_Read
,
1234 Expressions
=> New_List
(
1235 Make_Identifier
(Loc
, Name_S
),
1236 Make_Identifier
(Loc
, Name_V
)))))));
1238 Fnam
:= Make_Stream_Subprogram_Name
(Loc
, B_Typ
, TSS_Stream_Input
);
1240 Build_Stream_Function
(Loc
, B_Typ
, Decl
, Fnam
, Decls
, Stms
);
1241 end Build_Record_Or_Elementary_Input_Function
;
1243 -------------------------------------------------
1244 -- Build_Record_Or_Elementary_Output_Procedure --
1245 -------------------------------------------------
1247 procedure Build_Record_Or_Elementary_Output_Procedure
1251 Pnam
: out Entity_Id
)
1260 -- Note that of course there will be no discriminants for the elementary
1261 -- type case, so Has_Discriminants will be False. Note that the language
1262 -- rules do not allow writing the discriminants in the defaulted case,
1263 -- because those are written by 'Write.
1265 if Has_Discriminants
(Typ
)
1266 and then No
(Discriminant_Default_Value
(First_Discriminant
(Typ
)))
1268 Disc
:= First_Discriminant
(Typ
);
1269 while Present
(Disc
) loop
1271 -- If the type is an unchecked union, it must have default
1272 -- discriminants (this is checked earlier), and those defaults
1273 -- are written out to the stream.
1275 if Is_Unchecked_Union
(Typ
) then
1276 Disc_Ref
:= New_Copy_Tree
(Discriminant_Default_Value
(Disc
));
1280 Make_Selected_Component
(Loc
,
1281 Prefix
=> Make_Identifier
(Loc
, Name_V
),
1282 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
));
1286 Make_Attribute_Reference
(Loc
,
1288 New_Occurrence_Of
(Stream_Base_Type
(Etype
(Disc
)), Loc
),
1289 Attribute_Name
=> Name_Write
,
1290 Expressions
=> New_List
(
1291 Make_Identifier
(Loc
, Name_S
),
1294 Next_Discriminant
(Disc
);
1299 Make_Attribute_Reference
(Loc
,
1300 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
1301 Attribute_Name
=> Name_Write
,
1302 Expressions
=> New_List
(
1303 Make_Identifier
(Loc
, Name_S
),
1304 Make_Identifier
(Loc
, Name_V
))));
1306 Pnam
:= Make_Stream_Subprogram_Name
(Loc
, Typ
, TSS_Stream_Output
);
1308 Build_Stream_Procedure
(Loc
, Typ
, Decl
, Pnam
, Stms
, False);
1309 end Build_Record_Or_Elementary_Output_Procedure
;
1311 ---------------------------------
1312 -- Build_Record_Read_Procedure --
1313 ---------------------------------
1315 procedure Build_Record_Read_Procedure
1319 Pnam
: out Entity_Id
)
1322 Pnam
:= Make_Stream_Subprogram_Name
(Loc
, Typ
, TSS_Stream_Read
);
1323 Build_Record_Read_Write_Procedure
(Loc
, Typ
, Decl
, Pnam
, Name_Read
);
1324 end Build_Record_Read_Procedure
;
1326 ---------------------------------------
1327 -- Build_Record_Read_Write_Procedure --
1328 ---------------------------------------
1330 -- The form of the record read/write procedure is as shown by the
1331 -- following example for a case with one discriminant case variant:
1333 -- procedure pnam (S : access RST, V : [out] Typ) is
1335 -- Component_Type'Read/Write (S, V.component);
1336 -- Component_Type'Read/Write (S, V.component);
1338 -- Component_Type'Read/Write (S, V.component);
1340 -- case V.discriminant is
1342 -- Component_Type'Read/Write (S, V.component);
1343 -- Component_Type'Read/Write (S, V.component);
1345 -- Component_Type'Read/Write (S, V.component);
1348 -- Component_Type'Read/Write (S, V.component);
1349 -- Component_Type'Read/Write (S, V.component);
1351 -- Component_Type'Read/Write (S, V.component);
1356 -- The out keyword for V is supplied in the Read case
1358 procedure Build_Record_Read_Write_Procedure
1369 In_Limited_Extension
: Boolean := False;
1370 -- Set to True while processing the record extension definition
1371 -- for an extension of a limited type (for which an ancestor type
1372 -- has an explicit Nam attribute definition).
1374 function Make_Component_List_Attributes
(CL
: Node_Id
) return List_Id
;
1375 -- Returns a sequence of attributes to process the components that
1376 -- are referenced in the given component list.
1378 function Make_Field_Attribute
(C
: Entity_Id
) return Node_Id
;
1379 -- Given C, the entity for a discriminant or component, build
1380 -- an attribute for the corresponding field values.
1382 function Make_Field_Attributes
(Clist
: List_Id
) return List_Id
;
1383 -- Given Clist, a component items list, construct series of attributes
1384 -- for fieldwise processing of the corresponding components.
1386 ------------------------------------
1387 -- Make_Component_List_Attributes --
1388 ------------------------------------
1390 function Make_Component_List_Attributes
(CL
: Node_Id
) return List_Id
is
1391 CI
: constant List_Id
:= Component_Items
(CL
);
1392 VP
: constant Node_Id
:= Variant_Part
(CL
);
1402 Result
:= Make_Field_Attributes
(CI
);
1404 if Present
(VP
) then
1407 V
:= First_Non_Pragma
(Variants
(VP
));
1408 while Present
(V
) loop
1411 DC
:= First
(Discrete_Choices
(V
));
1412 while Present
(DC
) loop
1413 Append_To
(DCH
, New_Copy_Tree
(DC
));
1418 Make_Case_Statement_Alternative
(Loc
,
1419 Discrete_Choices
=> DCH
,
1421 Make_Component_List_Attributes
(Component_List
(V
))));
1422 Next_Non_Pragma
(V
);
1425 -- Note: in the following, we make sure that we use new occurrence
1426 -- of for the selector, since there are cases in which we make a
1427 -- reference to a hidden discriminant that is not visible.
1429 -- If the enclosing record is an unchecked_union, we use the
1430 -- default expressions for the discriminant (it must exist)
1431 -- because we cannot generate a reference to it, given that
1432 -- it is not stored.
1434 if Is_Unchecked_Union
(Scope
(Entity
(Name
(VP
)))) then
1437 (Discriminant_Default_Value
(Entity
(Name
(VP
))));
1440 Make_Selected_Component
(Loc
,
1441 Prefix
=> Make_Identifier
(Loc
, Name_V
),
1443 New_Occurrence_Of
(Entity
(Name
(VP
)), Loc
));
1447 Make_Case_Statement
(Loc
,
1448 Expression
=> D_Ref
,
1449 Alternatives
=> Alts
));
1453 end Make_Component_List_Attributes
;
1455 --------------------------
1456 -- Make_Field_Attribute --
1457 --------------------------
1459 function Make_Field_Attribute
(C
: Entity_Id
) return Node_Id
is
1460 Field_Typ
: constant Entity_Id
:= Stream_Base_Type
(Etype
(C
));
1462 TSS_Names
: constant array (Name_Input
.. Name_Write
) of
1464 (Name_Read
=> TSS_Stream_Read
,
1465 Name_Write
=> TSS_Stream_Write
,
1466 Name_Input
=> TSS_Stream_Input
,
1467 Name_Output
=> TSS_Stream_Output
,
1468 others => TSS_Null
);
1469 pragma Assert
(TSS_Names
(Nam
) /= TSS_Null
);
1472 if In_Limited_Extension
1473 and then Is_Limited_Type
(Field_Typ
)
1474 and then No
(Find_Inherited_TSS
(Field_Typ
, TSS_Names
(Nam
)))
1476 -- The declaration is illegal per 13.13.2(9/1), and this is
1477 -- enforced in Exp_Ch3.Check_Stream_Attributes. Keep the caller
1478 -- happy by returning a null statement.
1480 return Make_Null_Statement
(Loc
);
1484 Make_Attribute_Reference
(Loc
,
1485 Prefix
=> New_Occurrence_Of
(Field_Typ
, Loc
),
1486 Attribute_Name
=> Nam
,
1487 Expressions
=> New_List
(
1488 Make_Identifier
(Loc
, Name_S
),
1489 Make_Selected_Component
(Loc
,
1490 Prefix
=> Make_Identifier
(Loc
, Name_V
),
1491 Selector_Name
=> New_Occurrence_Of
(C
, Loc
))));
1492 end Make_Field_Attribute
;
1494 ---------------------------
1495 -- Make_Field_Attributes --
1496 ---------------------------
1498 function Make_Field_Attributes
(Clist
: List_Id
) return List_Id
is
1505 if Present
(Clist
) then
1506 Item
:= First
(Clist
);
1508 -- Loop through components, skipping all internal components,
1509 -- which are not part of the value (e.g. _Tag), except that we
1510 -- don't skip the _Parent, since we do want to process that
1511 -- recursively. If _Parent is an interface type, being abstract
1512 -- with no components there is no need to handle it.
1514 while Present
(Item
) loop
1515 if Nkind
(Item
) = N_Component_Declaration
1517 ((Chars
(Defining_Identifier
(Item
)) = Name_uParent
1518 and then not Is_Interface
1519 (Etype
(Defining_Identifier
(Item
))))
1521 not Is_Internal_Name
(Chars
(Defining_Identifier
(Item
))))
1525 Make_Field_Attribute
(Defining_Identifier
(Item
)));
1533 end Make_Field_Attributes
;
1535 -- Start of processing for Build_Record_Read_Write_Procedure
1538 -- For the protected type case, use corresponding record
1540 if Is_Protected_Type
(Typ
) then
1541 Typt
:= Corresponding_Record_Type
(Typ
);
1546 -- Note that we do nothing with the discriminants, since Read and
1547 -- Write do not read or write the discriminant values. All handling
1548 -- of discriminants occurs in the Input and Output subprograms.
1550 Rdef
:= Type_Definition
1551 (Declaration_Node
(Base_Type
(Underlying_Type
(Typt
))));
1554 -- In record extension case, the fields we want, including the _Parent
1555 -- field representing the parent type, are to be found in the extension.
1556 -- Note that we will naturally process the _Parent field using the type
1557 -- of the parent, and hence its stream attributes, which is appropriate.
1559 if Nkind
(Rdef
) = N_Derived_Type_Definition
then
1560 Rdef
:= Record_Extension_Part
(Rdef
);
1562 if Is_Limited_Type
(Typt
) then
1563 In_Limited_Extension
:= True;
1567 if Present
(Component_List
(Rdef
)) then
1568 Append_List_To
(Stms
,
1569 Make_Component_List_Attributes
(Component_List
(Rdef
)));
1572 Build_Stream_Procedure
1573 (Loc
, Typ
, Decl
, Pnam
, Stms
, Nam
= Name_Read
);
1574 end Build_Record_Read_Write_Procedure
;
1576 ----------------------------------
1577 -- Build_Record_Write_Procedure --
1578 ----------------------------------
1580 procedure Build_Record_Write_Procedure
1584 Pnam
: out Entity_Id
)
1587 Pnam
:= Make_Stream_Subprogram_Name
(Loc
, Typ
, TSS_Stream_Write
);
1588 Build_Record_Read_Write_Procedure
(Loc
, Typ
, Decl
, Pnam
, Name_Write
);
1589 end Build_Record_Write_Procedure
;
1591 -------------------------------
1592 -- Build_Stream_Attr_Profile --
1593 -------------------------------
1595 function Build_Stream_Attr_Profile
1598 Nam
: TSS_Name_Type
) return List_Id
1603 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has
1604 -- no semantic meaning in Ada 95 but it is a requirement in Ada 2005.
1606 Profile
:= New_List
(
1607 Make_Parameter_Specification
(Loc
,
1608 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_S
),
1610 Make_Access_Definition
(Loc
,
1611 Null_Exclusion_Present
=> True,
1612 Subtype_Mark
=> New_Occurrence_Of
(
1613 Class_Wide_Type
(RTE
(RE_Root_Stream_Type
)), Loc
))));
1615 if Nam
/= TSS_Stream_Input
then
1617 Make_Parameter_Specification
(Loc
,
1618 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
1619 Out_Present
=> (Nam
= TSS_Stream_Read
),
1620 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
1624 end Build_Stream_Attr_Profile
;
1626 ---------------------------
1627 -- Build_Stream_Function --
1628 ---------------------------
1630 procedure Build_Stream_Function
1641 -- Construct function specification
1643 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has
1644 -- no semantic meaning in Ada 95 but it is a requirement in Ada 2005.
1647 Make_Function_Specification
(Loc
,
1648 Defining_Unit_Name
=> Fnam
,
1650 Parameter_Specifications
=> New_List
(
1651 Make_Parameter_Specification
(Loc
,
1652 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_S
),
1654 Make_Access_Definition
(Loc
,
1655 Null_Exclusion_Present
=> True,
1658 (Class_Wide_Type
(RTE
(RE_Root_Stream_Type
)), Loc
)))),
1660 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
1663 Make_Subprogram_Body
(Loc
,
1664 Specification
=> Spec
,
1665 Declarations
=> Decls
,
1666 Handled_Statement_Sequence
=>
1667 Make_Handled_Sequence_Of_Statements
(Loc
,
1668 Statements
=> Stms
));
1669 end Build_Stream_Function
;
1671 ----------------------------
1672 -- Build_Stream_Procedure --
1673 ----------------------------
1675 procedure Build_Stream_Procedure
1686 -- Construct procedure specification
1688 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has
1689 -- no semantic meaning in Ada 95 but it is a requirement in Ada 2005.
1692 Make_Procedure_Specification
(Loc
,
1693 Defining_Unit_Name
=> Pnam
,
1695 Parameter_Specifications
=> New_List
(
1696 Make_Parameter_Specification
(Loc
,
1697 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_S
),
1699 Make_Access_Definition
(Loc
,
1700 Null_Exclusion_Present
=> True,
1703 (Class_Wide_Type
(RTE
(RE_Root_Stream_Type
)), Loc
))),
1705 Make_Parameter_Specification
(Loc
,
1706 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
1707 Out_Present
=> Outp
,
1708 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))));
1711 Make_Subprogram_Body
(Loc
,
1712 Specification
=> Spec
,
1713 Declarations
=> Empty_List
,
1714 Handled_Statement_Sequence
=>
1715 Make_Handled_Sequence_Of_Statements
(Loc
,
1716 Statements
=> Stms
));
1717 end Build_Stream_Procedure
;
1719 -----------------------------
1720 -- Has_Stream_Standard_Rep --
1721 -----------------------------
1723 function Has_Stream_Standard_Rep
(U_Type
: Entity_Id
) return Boolean is
1727 if Has_Non_Standard_Rep
(U_Type
) then
1731 if Has_Stream_Size_Clause
(U_Type
) then
1732 Siz
:= Static_Integer
(Expression
(Stream_Size_Clause
(U_Type
)));
1734 Siz
:= Esize
(First_Subtype
(U_Type
));
1737 return Siz
= Esize
(Root_Type
(U_Type
));
1738 end Has_Stream_Standard_Rep
;
1740 ---------------------------------
1741 -- Make_Stream_Subprogram_Name --
1742 ---------------------------------
1744 function Make_Stream_Subprogram_Name
1747 Nam
: TSS_Name_Type
) return Entity_Id
1752 -- For tagged types, we are dealing with a TSS associated with the
1753 -- declaration, so we use the standard primitive function name. For
1754 -- other types, generate a local TSS name since we are generating
1755 -- the subprogram at the point of use.
1757 if Is_Tagged_Type
(Typ
) then
1758 Sname
:= Make_TSS_Name
(Typ
, Nam
);
1760 Sname
:= Make_TSS_Name_Local
(Typ
, Nam
);
1763 return Make_Defining_Identifier
(Loc
, Sname
);
1764 end Make_Stream_Subprogram_Name
;
1766 ----------------------
1767 -- Stream_Base_Type --
1768 ----------------------
1770 function Stream_Base_Type
(E
: Entity_Id
) return Entity_Id
is
1772 if Is_Array_Type
(E
)
1773 and then Is_First_Subtype
(E
)
1777 return Base_Type
(E
);
1779 end Stream_Base_Type
;