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;