1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Exp_Tss; use Exp_Tss;
30 with Namet; use Namet;
31 with Nlists; use Nlists;
32 with Nmake; use Nmake;
33 with Rtsfind; use Rtsfind;
34 with Sem_Util; use Sem_Util;
35 with Sinfo; use Sinfo;
36 with Snames; use Snames;
37 with Stand; use Stand;
38 with Tbuild; use Tbuild;
39 with Ttypes; use Ttypes;
40 with Uintp; use Uintp;
42 package body Exp_Strm is
44 -----------------------
45 -- Local Subprograms --
46 -----------------------
48 procedure Build_Array_Read_Write_Procedure
54 -- Common routine shared to build either an array Read procedure or an
55 -- array Write procedure, Nam is Name_Read or Name_Write to select which.
56 -- Pnam is the defining identifier for the constructed procedure. The
57 -- other parameters are as for Build_Array_Read_Procedure except that
58 -- the first parameter Nod supplies the Sloc to be used to generate code.
60 procedure Build_Record_Read_Write_Procedure
66 -- Common routine shared to build a record Read Write procedure, Nam
67 -- is Name_Read or Name_Write to select which. Pnam is the defining
68 -- identifier for the constructed procedure. The other parameters are
69 -- as for Build_Record_Read_Procedure.
71 procedure Build_Stream_Function
78 -- Called to build an array or record stream function. The first three
79 -- arguments are the same as Build_Record_Or_Elementary_Input_Function.
80 -- Decls and Stms are the declarations and statements for the body and
81 -- The parameter Fnam is the name of the constructed function.
83 function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean;
84 -- This function is used to test U_Type, which is a type
85 -- Returns True if U_Type has a standard representation for stream
86 -- purposes, i.e. there is no non-standard enumeration representation
87 -- clause, and the size of the first subtype is the same as the size
90 function Make_Stream_Subprogram_Name
93 Nam : TSS_Name_Type) return Entity_Id;
94 -- Return the entity that identifies the stream subprogram for type Typ
95 -- that is identified by the given Nam. This procedure deals with the
96 -- difference between tagged types (where a single subprogram associated
97 -- with the type is generated) and all other cases (where a subprogram
98 -- is generated at the point of the stream attribute reference). The
99 -- Loc parameter is used as the Sloc of the created entity.
101 function Stream_Base_Type (E : Entity_Id) return Entity_Id;
102 -- Stream attributes work on the basis of the base type except for the
103 -- array case. For the array case, we do not go to the base type, but
104 -- to the first subtype if it is constrained. This avoids problems with
105 -- incorrect conversions in the packed array case. Stream_Base_Type is
106 -- exactly this function (returns the base type, unless we have an array
107 -- type whose first subtype is constrained, in which case it returns the
110 --------------------------------
111 -- Build_Array_Input_Function --
112 --------------------------------
114 -- The function we build looks like
116 -- function typSI[_nnn] (S : access RST) return Typ is
117 -- L1 : constant Index_Type_1 := Index_Type_1'Input (S);
118 -- H1 : constant Index_Type_1 := Index_Type_1'Input (S);
119 -- L2 : constant Index_Type_2 := Index_Type_2'Input (S);
120 -- H2 : constant Index_Type_2 := Index_Type_2'Input (S);
122 -- Ln : constant Index_Type_n := Index_Type_n'Input (S);
123 -- Hn : constant Index_Type_n := Index_Type_n'Input (S);
125 -- V : Typ'Base (L1 .. H1, L2 .. H2, ... Ln .. Hn)
132 -- Note: the suffix [_nnn] is present for non-tagged types, where we
133 -- generate a local subprogram at the point of the occurrence of the
134 -- attribute reference, so the name must be unique.
136 procedure Build_Array_Input_Function
140 Fnam : out Entity_Id)
142 Dim : constant Pos := Number_Dimensions (Typ);
153 Indx := First_Index (Typ);
155 for J in 1 .. Dim loop
156 Lnam := New_External_Name ('L', J);
157 Hnam := New_External_Name ('H', J);
160 Make_Object_Declaration (Loc,
161 Defining_Identifier => Make_Defining_Identifier (Loc, Lnam),
162 Constant_Present => True,
163 Object_Definition => New_Occurrence_Of (Etype (Indx), Loc),
165 Make_Attribute_Reference (Loc,
167 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
168 Attribute_Name => Name_Input,
169 Expressions => New_List (Make_Identifier (Loc, Name_S)))));
172 Make_Object_Declaration (Loc,
173 Defining_Identifier => Make_Defining_Identifier (Loc, Hnam),
174 Constant_Present => True,
176 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
178 Make_Attribute_Reference (Loc,
180 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
181 Attribute_Name => Name_Input,
182 Expressions => New_List (Make_Identifier (Loc, Name_S)))));
186 Low_Bound => Make_Identifier (Loc, Lnam),
187 High_Bound => Make_Identifier (Loc, Hnam)));
192 -- If the first subtype is constrained, use it directly. Otherwise
193 -- build a subtype indication with the proper bounds.
195 if Is_Constrained (Stream_Base_Type (Typ)) then
197 Make_Object_Declaration (Loc,
198 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
200 New_Occurrence_Of (Stream_Base_Type (Typ), Loc)));
203 Make_Object_Declaration (Loc,
204 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
206 Make_Subtype_Indication (Loc,
208 New_Occurrence_Of (Stream_Base_Type (Typ), Loc),
210 Make_Index_Or_Discriminant_Constraint (Loc,
211 Constraints => Ranges))));
215 Make_Attribute_Reference (Loc,
216 Prefix => New_Occurrence_Of (Typ, Loc),
217 Attribute_Name => Name_Read,
218 Expressions => New_List (
219 Make_Identifier (Loc, Name_S),
220 Make_Identifier (Loc, Name_V))),
222 Make_Return_Statement (Loc,
223 Expression => Make_Identifier (Loc, Name_V)));
226 Make_Defining_Identifier (Loc,
227 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Input));
229 Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
230 end Build_Array_Input_Function;
232 ----------------------------------
233 -- Build_Array_Output_Procedure --
234 ----------------------------------
236 procedure Build_Array_Output_Procedure
240 Pnam : out Entity_Id)
246 -- Build series of statements to output bounds
248 Indx := First_Index (Typ);
251 for J in 1 .. Number_Dimensions (Typ) loop
253 Make_Attribute_Reference (Loc,
255 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
256 Attribute_Name => Name_Write,
257 Expressions => New_List (
258 Make_Identifier (Loc, Name_S),
259 Make_Attribute_Reference (Loc,
260 Prefix => Make_Identifier (Loc, Name_V),
261 Attribute_Name => Name_First,
262 Expressions => New_List (
263 Make_Integer_Literal (Loc, J))))));
266 Make_Attribute_Reference (Loc,
268 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
269 Attribute_Name => Name_Write,
270 Expressions => New_List (
271 Make_Identifier (Loc, Name_S),
272 Make_Attribute_Reference (Loc,
273 Prefix => Make_Identifier (Loc, Name_V),
274 Attribute_Name => Name_Last,
275 Expressions => New_List (
276 Make_Integer_Literal (Loc, J))))));
281 -- Append Write attribute to write array elements
284 Make_Attribute_Reference (Loc,
285 Prefix => New_Occurrence_Of (Typ, Loc),
286 Attribute_Name => Name_Write,
287 Expressions => New_List (
288 Make_Identifier (Loc, Name_S),
289 Make_Identifier (Loc, Name_V))));
292 Make_Defining_Identifier (Loc,
293 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Output));
295 Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
296 end Build_Array_Output_Procedure;
298 --------------------------------
299 -- Build_Array_Read_Procedure --
300 --------------------------------
302 procedure Build_Array_Read_Procedure
306 Pnam : out Entity_Id)
308 Loc : constant Source_Ptr := Sloc (Nod);
312 Make_Defining_Identifier (Loc,
313 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
314 Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Read);
315 end Build_Array_Read_Procedure;
317 --------------------------------------
318 -- Build_Array_Read_Write_Procedure --
319 --------------------------------------
321 -- The form of the array read/write procedure is as follows:
323 -- procedure pnam (S : access RST, V : [out] Typ) is
325 -- for L1 in V'Range (1) loop
326 -- for L2 in V'Range (2) loop
328 -- for Ln in V'Range (n) loop
329 -- Component_Type'Read/Write (S, V (L1, L2, .. Ln));
336 -- The out keyword for V is supplied in the Read case
338 procedure Build_Array_Read_Write_Procedure
345 Loc : constant Source_Ptr := Sloc (Nod);
346 Ndim : constant Pos := Number_Dimensions (Typ);
347 Ctyp : constant Entity_Id := Component_Type (Typ);
354 -- First build the inner attribute call
358 for J in 1 .. Ndim loop
359 Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', J)));
363 Make_Attribute_Reference (Loc,
364 Prefix => New_Occurrence_Of (Stream_Base_Type (Ctyp), Loc),
365 Attribute_Name => Nam,
366 Expressions => New_List (
367 Make_Identifier (Loc, Name_S),
368 Make_Indexed_Component (Loc,
369 Prefix => Make_Identifier (Loc, Name_V),
370 Expressions => Exl)));
372 -- The corresponding stream attribute for the component type of the
373 -- array may be user-defined, and be frozen after the type for which
374 -- we are generating the stream subprogram. In that case, freeze the
375 -- stream attribute of the component type, whose declaration could not
376 -- generate any additional freezing actions in any case. See 5509-003.
378 if Nam = Name_Read then
379 RW := TSS (Base_Type (Ctyp), TSS_Stream_Read);
381 RW := TSS (Base_Type (Ctyp), TSS_Stream_Write);
385 and then not Is_Frozen (RW)
390 -- Now this is the big loop to wrap that statement up in a sequence
391 -- of loops. The first time around, Stm is the attribute call. The
392 -- second and subsequent times, Stm is an inner loop.
394 for J in 1 .. Ndim loop
396 Make_Implicit_Loop_Statement (Nod,
398 Make_Iteration_Scheme (Loc,
399 Loop_Parameter_Specification =>
400 Make_Loop_Parameter_Specification (Loc,
401 Defining_Identifier =>
402 Make_Defining_Identifier (Loc,
403 Chars => New_External_Name ('L', Ndim - J + 1)),
405 Discrete_Subtype_Definition =>
406 Make_Attribute_Reference (Loc,
407 Prefix => Make_Identifier (Loc, Name_V),
408 Attribute_Name => Name_Range,
410 Expressions => New_List (
411 Make_Integer_Literal (Loc, Ndim - J + 1))))),
413 Statements => New_List (Stm));
417 Build_Stream_Procedure
418 (Loc, Typ, Decl, Pnam, New_List (Stm), Nam = Name_Read);
419 end Build_Array_Read_Write_Procedure;
421 ---------------------------------
422 -- Build_Array_Write_Procedure --
423 ---------------------------------
425 procedure Build_Array_Write_Procedure
429 Pnam : out Entity_Id)
431 Loc : constant Source_Ptr := Sloc (Nod);
435 Make_Defining_Identifier (Loc,
436 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
437 Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Write);
438 end Build_Array_Write_Procedure;
440 ---------------------------------
441 -- Build_Elementary_Input_Call --
442 ---------------------------------
444 function Build_Elementary_Input_Call (N : Node_Id) return Node_Id is
445 Loc : constant Source_Ptr := Sloc (N);
446 P_Type : constant Entity_Id := Entity (Prefix (N));
447 U_Type : constant Entity_Id := Underlying_Type (P_Type);
448 Rt_Type : constant Entity_Id := Root_Type (U_Type);
449 FST : constant Entity_Id := First_Subtype (U_Type);
450 Strm : constant Node_Id := First (Expressions (N));
451 Targ : constant Node_Id := Next (Strm);
457 -- Compute the size of the stream element. This is either the size of
458 -- the first subtype or if given the size of the Stream_Size attribute.
460 if Is_Elementary_Type (FST) and then Has_Stream_Size_Clause (FST) then
461 P_Size := Static_Integer (Expression (Stream_Size_Clause (FST)));
463 P_Size := Esize (FST);
466 -- Check first for Boolean and Character. These are enumeration types,
467 -- but we treat them specially, since they may require special handling
468 -- in the transfer protocol. However, this special handling only applies
469 -- if they have standard representation, otherwise they are treated like
470 -- any other enumeration type.
472 if Rt_Type = Standard_Boolean
473 and then Has_Stream_Standard_Rep (U_Type)
477 elsif Rt_Type = Standard_Character
478 and then Has_Stream_Standard_Rep (U_Type)
482 elsif Rt_Type = Standard_Wide_Character
483 and then Has_Stream_Standard_Rep (U_Type)
487 elsif Rt_Type = Standard_Wide_Wide_Character
488 and then Has_Stream_Standard_Rep (U_Type)
492 -- Floating point types
494 elsif Is_Floating_Point_Type (U_Type) then
495 if P_Size <= Standard_Short_Float_Size then
498 elsif P_Size <= Standard_Float_Size then
501 elsif P_Size <= Standard_Long_Float_Size then
508 -- Signed integer types. Also includes signed fixed-point types and
509 -- enumeration types with a signed representation.
511 -- Note on signed integer types. We do not consider types as signed for
512 -- this purpose if they have no negative numbers, or if they have biased
513 -- representation. The reason is that the value in either case basically
514 -- represents an unsigned value.
516 -- For example, consider:
518 -- type W is range 0 .. 2**32 - 1;
519 -- for W'Size use 32;
521 -- This is a signed type, but the representation is unsigned, and may
522 -- be outside the range of a 32-bit signed integer, so this must be
523 -- treated as 32-bit unsigned.
525 -- Similarly, if we have
527 -- type W is range -1 .. +254;
530 -- then the representation is unsigned
532 elsif not Is_Unsigned_Type (FST)
534 (Is_Fixed_Point_Type (U_Type)
536 Is_Enumeration_Type (U_Type)
538 (Is_Signed_Integer_Type (U_Type)
539 and then not Has_Biased_Representation (FST)))
541 if P_Size <= Standard_Short_Short_Integer_Size then
544 elsif P_Size <= Standard_Short_Integer_Size then
547 elsif P_Size <= Standard_Integer_Size then
550 elsif P_Size <= Standard_Long_Integer_Size then
557 -- Unsigned integer types, also includes unsigned fixed-point types
558 -- and enumeration types with an unsigned representation (note that
559 -- we know they are unsigned because we already tested for signed).
561 -- Also includes signed integer types that are unsigned in the sense
562 -- that they do not include negative numbers. See above for details.
564 elsif Is_Modular_Integer_Type (U_Type)
565 or else Is_Fixed_Point_Type (U_Type)
566 or else Is_Enumeration_Type (U_Type)
567 or else Is_Signed_Integer_Type (U_Type)
569 if P_Size <= Standard_Short_Short_Integer_Size then
572 elsif P_Size <= Standard_Short_Integer_Size then
575 elsif P_Size <= Standard_Integer_Size then
578 elsif P_Size <= Standard_Long_Integer_Size then
585 else pragma Assert (Is_Access_Type (U_Type));
586 if P_Size > System_Address_Size then
593 -- Call the function, and do an unchecked conversion of the result
594 -- to the actual type of the prefix. If the target is a discriminant,
595 -- set target type to force a constraint check (13.13.2 (35)).
597 if Nkind (Targ) = N_Selected_Component
598 and then Present (Entity (Selector_Name (Targ)))
599 and then Ekind (Entity (Selector_Name (Targ)))
603 Unchecked_Convert_To (Base_Type (P_Type),
604 Make_Function_Call (Loc,
605 Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
606 Parameter_Associations => New_List (
607 Relocate_Node (Strm))));
609 Set_Do_Range_Check (Res);
614 Unchecked_Convert_To (P_Type,
615 Make_Function_Call (Loc,
616 Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
617 Parameter_Associations => New_List (
618 Relocate_Node (Strm))));
620 end Build_Elementary_Input_Call;
622 ---------------------------------
623 -- Build_Elementary_Write_Call --
624 ---------------------------------
626 function Build_Elementary_Write_Call (N : Node_Id) return Node_Id is
627 Loc : constant Source_Ptr := Sloc (N);
628 P_Type : constant Entity_Id := Entity (Prefix (N));
629 U_Type : constant Entity_Id := Underlying_Type (P_Type);
630 Rt_Type : constant Entity_Id := Root_Type (U_Type);
631 FST : constant Entity_Id := First_Subtype (U_Type);
632 Strm : constant Node_Id := First (Expressions (N));
633 Item : constant Node_Id := Next (Strm);
639 -- Compute the size of the stream element. This is either the size of
640 -- the first subtype or if given the size of the Stream_Size attribute.
642 if Is_Elementary_Type (FST) and then Has_Stream_Size_Clause (FST) then
643 P_Size := Static_Integer (Expression (Stream_Size_Clause (FST)));
645 P_Size := Esize (FST);
648 -- Find the routine to be called
650 -- Check for First Boolean and Character. These are enumeration types,
651 -- but we treat them specially, since they may require special handling
652 -- in the transfer protocol. However, this special handling only applies
653 -- if they have standard representation, otherwise they are treated like
654 -- any other enumeration type.
656 if Rt_Type = Standard_Boolean
657 and then Has_Stream_Standard_Rep (U_Type)
661 elsif Rt_Type = Standard_Character
662 and then Has_Stream_Standard_Rep (U_Type)
666 elsif Rt_Type = Standard_Wide_Character
667 and then Has_Stream_Standard_Rep (U_Type)
671 elsif Rt_Type = Standard_Wide_Wide_Character
672 and then Has_Stream_Standard_Rep (U_Type)
676 -- Floating point types
678 elsif Is_Floating_Point_Type (U_Type) then
679 if P_Size <= Standard_Short_Float_Size then
681 elsif P_Size <= Standard_Float_Size then
683 elsif P_Size <= Standard_Long_Float_Size then
689 -- Signed integer types. Also includes signed fixed-point types and
690 -- signed enumeration types share this circuitry.
692 -- Note on signed integer types. We do not consider types as signed for
693 -- this purpose if they have no negative numbers, or if they have biased
694 -- representation. The reason is that the value in either case basically
695 -- represents an unsigned value.
697 -- For example, consider:
699 -- type W is range 0 .. 2**32 - 1;
700 -- for W'Size use 32;
702 -- This is a signed type, but the representation is unsigned, and may
703 -- be outside the range of a 32-bit signed integer, so this must be
704 -- treated as 32-bit unsigned.
706 -- Similarly, the representation is also unsigned if we have:
708 -- type W is range -1 .. +254;
711 elsif not Is_Unsigned_Type (FST)
713 (Is_Fixed_Point_Type (U_Type)
715 Is_Enumeration_Type (U_Type)
717 (Is_Signed_Integer_Type (U_Type)
718 and then not Has_Biased_Representation (FST)))
720 if P_Size <= Standard_Short_Short_Integer_Size then
722 elsif P_Size <= Standard_Short_Integer_Size then
724 elsif P_Size <= Standard_Integer_Size then
726 elsif P_Size <= Standard_Long_Integer_Size then
732 -- Unsigned integer types, also includes unsigned fixed-point types
733 -- and unsigned enumeration types (note we know they are unsigned
734 -- because we already tested for signed above).
736 -- Also includes signed integer types that are unsigned in the sense
737 -- that they do not include negative numbers. See above for details.
739 elsif Is_Modular_Integer_Type (U_Type)
740 or else Is_Fixed_Point_Type (U_Type)
741 or else Is_Enumeration_Type (U_Type)
742 or else Is_Signed_Integer_Type (U_Type)
744 if P_Size <= Standard_Short_Short_Integer_Size then
746 elsif P_Size <= Standard_Short_Integer_Size then
748 elsif P_Size <= Standard_Integer_Size then
750 elsif P_Size <= Standard_Long_Integer_Size then
756 else pragma Assert (Is_Access_Type (U_Type));
758 if P_Size > System_Address_Size then
765 -- Unchecked-convert parameter to the required type (i.e. the type of
766 -- the corresponding parameter, and call the appropriate routine.
768 Libent := RTE (Lib_RE);
771 Make_Procedure_Call_Statement (Loc,
772 Name => New_Occurrence_Of (Libent, Loc),
773 Parameter_Associations => New_List (
774 Relocate_Node (Strm),
775 Unchecked_Convert_To (Etype (Next_Formal (First_Formal (Libent))),
776 Relocate_Node (Item))));
777 end Build_Elementary_Write_Call;
779 -----------------------------------------
780 -- Build_Mutable_Record_Read_Procedure --
781 -----------------------------------------
783 procedure Build_Mutable_Record_Read_Procedure
787 Pnam : out Entity_Id)
790 -- Statements for the 'Read body
792 Tmp : constant Entity_Id := Make_Defining_Identifier (Loc, Name_V);
793 -- Temporary, must hide formal (assignments to components of the
794 -- record are always generated with V as the identifier for the record).
797 -- List of constraints to be applied on temporary
806 Disc := First_Discriminant (Typ);
808 -- A mutable type cannot be a tagged type, so we generate a new name
809 -- for the stream procedure.
812 Make_Defining_Identifier (Loc,
813 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
815 -- Generate Reads for the discriminants of the type. The discriminants
816 -- need to be read before the rest of the components, so that
817 -- variants are initialized correctly.
819 while Present (Disc) loop
821 Make_Selected_Component (Loc,
822 Prefix => Make_Selected_Component (Loc,
823 Prefix => New_Occurrence_Of (Pnam, Loc),
825 Make_Identifier (Loc, Name_V)),
826 Selector_Name => New_Occurrence_Of (Disc, Loc));
828 Set_Assignment_OK (Disc_Ref);
831 Make_Attribute_Reference (Loc,
832 Prefix => New_Occurrence_Of (Etype (Disc), Loc),
833 Attribute_Name => Name_Read,
834 Expressions => New_List (
835 Make_Identifier (Loc, Name_S),
839 Make_Discriminant_Association (Loc,
840 Selector_Names => New_List (New_Occurrence_Of (Disc, Loc)),
841 Expression => New_Copy_Tree (Disc_Ref)));
842 Next_Discriminant (Disc);
845 -- Generate reads for the components of the record (including
846 -- those that depend on discriminants).
848 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
850 -- If Typ has controlled components (i.e. if it is classwide
851 -- or Has_Controlled), or components constrained using the discriminants
852 -- of Typ, then we need to ensure that all component assignments
853 -- are performed on an object that has been appropriately constrained
854 -- prior to being initialized. To this effect, we wrap the component
855 -- assignments in a block where V is a constrained temporary.
858 Make_Block_Statement (Loc,
859 Declarations => New_List (
860 Make_Object_Declaration (Loc,
861 Defining_Identifier => Tmp,
863 Make_Subtype_Indication (Loc,
864 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
866 Make_Index_Or_Discriminant_Constraint (Loc,
867 Constraints => Cstr)))),
868 Handled_Statement_Sequence =>
869 Handled_Statement_Sequence (Decl));
871 Append_To (Stms, Block);
873 Append_To (Statements (Handled_Statement_Sequence (Block)),
874 Make_Assignment_Statement (Loc,
875 Name => Make_Selected_Component (Loc,
876 Prefix => New_Occurrence_Of (Pnam, Loc),
877 Selector_Name => Make_Identifier (Loc, Name_V)),
878 Expression => Make_Identifier (Loc, Name_V)));
880 if Is_Unchecked_Union (Typ) then
882 -- If this is an unchecked union, the stream procedure is erroneous,
883 -- because there are no discriminants to read.
885 -- This should generate a warning ???
889 Make_Raise_Program_Error (Loc,
890 Reason => PE_Unchecked_Union_Restriction));
893 Set_Handled_Statement_Sequence (Decl,
894 Make_Handled_Sequence_Of_Statements (Loc,
895 Statements => Stms));
896 end Build_Mutable_Record_Read_Procedure;
898 ------------------------------------------
899 -- Build_Mutable_Record_Write_Procedure --
900 ------------------------------------------
902 procedure Build_Mutable_Record_Write_Procedure
906 Pnam : out Entity_Id)
913 Disc := First_Discriminant (Typ);
915 -- Generate Writes for the discriminants of the type
917 while Present (Disc) loop
920 Make_Attribute_Reference (Loc,
921 Prefix => New_Occurrence_Of (Etype (Disc), Loc),
922 Attribute_Name => Name_Write,
923 Expressions => New_List (
924 Make_Identifier (Loc, Name_S),
925 Make_Selected_Component (Loc,
926 Prefix => Make_Identifier (Loc, Name_V),
927 Selector_Name => New_Occurrence_Of (Disc, Loc)))));
929 Next_Discriminant (Disc);
932 -- A mutable type cannot be a tagged type, so we generate a new name
933 -- for the stream procedure.
936 Make_Defining_Identifier (Loc,
937 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
938 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
940 -- Write the discriminants before the rest of the components, so
941 -- that discriminant values are properly set of variants, etc.
942 -- If this is an unchecked union, the stream procedure is erroneous
943 -- because there are no discriminants to write.
945 if Is_Unchecked_Union (Typ) then
948 Make_Raise_Program_Error (Loc,
949 Reason => PE_Unchecked_Union_Restriction));
952 if Is_Non_Empty_List (
953 Statements (Handled_Statement_Sequence (Decl)))
956 (First (Statements (Handled_Statement_Sequence (Decl))), Stms);
958 Set_Statements (Handled_Statement_Sequence (Decl), Stms);
960 end Build_Mutable_Record_Write_Procedure;
962 -----------------------------------------------
963 -- Build_Record_Or_Elementary_Input_Function --
964 -----------------------------------------------
966 -- The function we build looks like
968 -- function InputN (S : access RST) return Typ is
969 -- C1 : constant Disc_Type_1;
970 -- Discr_Type_1'Read (S, C1);
971 -- C2 : constant Disc_Type_2;
972 -- Discr_Type_2'Read (S, C2);
974 -- Cn : constant Disc_Type_n;
975 -- Discr_Type_n'Read (S, Cn);
976 -- V : Typ (C1, C2, .. Cn)
983 -- The discriminants are of course only present in the case of a record
984 -- with discriminants. In the case of a record with no discriminants, or
985 -- an elementary type, then no Cn constants are defined.
987 procedure Build_Record_Or_Elementary_Input_Function
991 Fnam : out Entity_Id)
1007 if Has_Discriminants (Typ) then
1008 Discr := First_Discriminant (Typ);
1010 while Present (Discr) loop
1011 Cn := New_External_Name ('C', J);
1014 Make_Object_Declaration (Loc,
1015 Defining_Identifier => Make_Defining_Identifier (Loc, Cn),
1016 Object_Definition =>
1017 New_Occurrence_Of (Etype (Discr), Loc)));
1020 Make_Attribute_Reference (Loc,
1021 Prefix => New_Occurrence_Of (Etype (Discr), Loc),
1022 Attribute_Name => Name_Read,
1023 Expressions => New_List (
1024 Make_Identifier (Loc, Name_S),
1025 Make_Identifier (Loc, Cn))));
1027 Append_To (Constr, Make_Identifier (Loc, Cn));
1029 Next_Discriminant (Discr);
1034 Make_Subtype_Indication (Loc,
1035 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
1037 Make_Index_Or_Discriminant_Constraint (Loc,
1038 Constraints => Constr));
1040 -- If no discriminants, then just use the type with no constraint
1043 Odef := New_Occurrence_Of (Typ, Loc);
1047 Make_Object_Declaration (Loc,
1048 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1049 Object_Definition => Odef));
1052 Make_Attribute_Reference (Loc,
1053 Prefix => New_Occurrence_Of (Typ, Loc),
1054 Attribute_Name => Name_Read,
1055 Expressions => New_List (
1056 Make_Identifier (Loc, Name_S),
1057 Make_Identifier (Loc, Name_V))),
1059 Make_Return_Statement (Loc,
1060 Expression => Make_Identifier (Loc, Name_V)));
1062 Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input);
1064 Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
1065 end Build_Record_Or_Elementary_Input_Function;
1067 -------------------------------------------------
1068 -- Build_Record_Or_Elementary_Output_Procedure --
1069 -------------------------------------------------
1071 procedure Build_Record_Or_Elementary_Output_Procedure
1075 Pnam : out Entity_Id)
1083 -- Note that of course there will be no discriminants for the
1084 -- elementary type case, so Has_Discriminants will be False.
1086 if Has_Discriminants (Typ) then
1087 Disc := First_Discriminant (Typ);
1089 while Present (Disc) loop
1091 Make_Attribute_Reference (Loc,
1093 New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc),
1094 Attribute_Name => Name_Write,
1095 Expressions => New_List (
1096 Make_Identifier (Loc, Name_S),
1097 Make_Selected_Component (Loc,
1098 Prefix => Make_Identifier (Loc, Name_V),
1099 Selector_Name => New_Occurrence_Of (Disc, Loc)))));
1101 Next_Discriminant (Disc);
1106 Make_Attribute_Reference (Loc,
1107 Prefix => New_Occurrence_Of (Typ, Loc),
1108 Attribute_Name => Name_Write,
1109 Expressions => New_List (
1110 Make_Identifier (Loc, Name_S),
1111 Make_Identifier (Loc, Name_V))));
1113 Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output);
1115 Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
1116 end Build_Record_Or_Elementary_Output_Procedure;
1118 ---------------------------------
1119 -- Build_Record_Read_Procedure --
1120 ---------------------------------
1122 procedure Build_Record_Read_Procedure
1126 Pnam : out Entity_Id)
1129 Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Read);
1130 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
1131 end Build_Record_Read_Procedure;
1133 ---------------------------------------
1134 -- Build_Record_Read_Write_Procedure --
1135 ---------------------------------------
1137 -- The form of the record read/write procedure is as shown by the
1138 -- following example for a case with one discriminant case variant:
1140 -- procedure pnam (S : access RST, V : [out] Typ) is
1142 -- Component_Type'Read/Write (S, V.component);
1143 -- Component_Type'Read/Write (S, V.component);
1145 -- Component_Type'Read/Write (S, V.component);
1147 -- case V.discriminant is
1149 -- Component_Type'Read/Write (S, V.component);
1150 -- Component_Type'Read/Write (S, V.component);
1152 -- Component_Type'Read/Write (S, V.component);
1155 -- Component_Type'Read/Write (S, V.component);
1156 -- Component_Type'Read/Write (S, V.component);
1158 -- Component_Type'Read/Write (S, V.component);
1163 -- The out keyword for V is supplied in the Read case
1165 procedure Build_Record_Read_Write_Procedure
1176 In_Limited_Extension : Boolean := False;
1177 -- Set to True while processing the record extension definition
1178 -- for an extension of a limited type (for which an ancestor type
1179 -- has an explicit Nam attribute definition).
1181 function Make_Component_List_Attributes (CL : Node_Id) return List_Id;
1182 -- Returns a sequence of attributes to process the components that
1183 -- are referenced in the given component list.
1185 function Make_Field_Attribute (C : Entity_Id) return Node_Id;
1186 -- Given C, the entity for a discriminant or component, build
1187 -- an attribute for the corresponding field values.
1189 function Make_Field_Attributes (Clist : List_Id) return List_Id;
1190 -- Given Clist, a component items list, construct series of attributes
1191 -- for fieldwise processing of the corresponding components.
1193 ------------------------------------
1194 -- Make_Component_List_Attributes --
1195 ------------------------------------
1197 function Make_Component_List_Attributes (CL : Node_Id) return List_Id is
1198 CI : constant List_Id := Component_Items (CL);
1199 VP : constant Node_Id := Variant_Part (CL);
1208 Result := Make_Field_Attributes (CI);
1210 -- If a component is an unchecked union, there is no discriminant
1211 -- and we cannot generate a read/write procedure for it.
1213 if Present (VP) then
1214 if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then
1216 Make_Raise_Program_Error (Sloc (VP),
1217 Reason => PE_Unchecked_Union_Restriction));
1220 V := First_Non_Pragma (Variants (VP));
1222 while Present (V) loop
1225 DC := First (Discrete_Choices (V));
1226 while Present (DC) loop
1227 Append_To (DCH, New_Copy_Tree (DC));
1232 Make_Case_Statement_Alternative (Loc,
1233 Discrete_Choices => DCH,
1235 Make_Component_List_Attributes (Component_List (V))));
1236 Next_Non_Pragma (V);
1239 -- Note: in the following, we make sure that we use new occurrence
1240 -- of for the selector, since there are cases in which we make a
1241 -- reference to a hidden discriminant that is not visible.
1244 Make_Case_Statement (Loc,
1246 Make_Selected_Component (Loc,
1247 Prefix => Make_Identifier (Loc, Name_V),
1249 New_Occurrence_Of (Entity (Name (VP)), Loc)),
1250 Alternatives => Alts));
1255 end Make_Component_List_Attributes;
1257 --------------------------
1258 -- Make_Field_Attribute --
1259 --------------------------
1261 function Make_Field_Attribute (C : Entity_Id) return Node_Id is
1262 Field_Typ : constant Entity_Id := Stream_Base_Type (Etype (C));
1264 TSS_Names : constant array (Name_Input .. Name_Write) of
1266 (Name_Read => TSS_Stream_Read,
1267 Name_Write => TSS_Stream_Write,
1268 Name_Input => TSS_Stream_Input,
1269 Name_Output => TSS_Stream_Output,
1270 others => TSS_Null);
1271 pragma Assert (TSS_Names (Nam) /= TSS_Null);
1274 if In_Limited_Extension
1275 and then Is_Limited_Type (Field_Typ)
1276 and then No (Find_Inherited_TSS (Field_Typ, TSS_Names (Nam)))
1278 -- The declaration is illegal per 13.13.2(9/1), and this is
1279 -- enforced in Exp_Ch3.Check_Stream_Attributes. Keep the
1280 -- caller happy by returning a null statement.
1282 return Make_Null_Statement (Loc);
1286 Make_Attribute_Reference (Loc,
1288 New_Occurrence_Of (Stream_Base_Type (Etype (C)), Loc),
1289 Attribute_Name => Nam,
1290 Expressions => New_List (
1291 Make_Identifier (Loc, Name_S),
1292 Make_Selected_Component (Loc,
1293 Prefix => Make_Identifier (Loc, Name_V),
1294 Selector_Name => New_Occurrence_Of (C, Loc))));
1295 end Make_Field_Attribute;
1297 ---------------------------
1298 -- Make_Field_Attributes --
1299 ---------------------------
1301 function Make_Field_Attributes (Clist : List_Id) return List_Id is
1308 if Present (Clist) then
1309 Item := First (Clist);
1311 -- Loop through components, skipping all internal components,
1312 -- which are not part of the value (e.g. _Tag), except that we
1313 -- don't skip the _Parent, since we do want to process that
1316 while Present (Item) loop
1317 if Nkind (Item) = N_Component_Declaration
1319 (Chars (Defining_Identifier (Item)) = Name_uParent
1321 not Is_Internal_Name (Chars (Defining_Identifier (Item))))
1325 Make_Field_Attribute (Defining_Identifier (Item)));
1333 end Make_Field_Attributes;
1335 -- Start of processing for Build_Record_Read_Write_Procedure
1338 -- For the protected type case, use corresponding record
1340 if Is_Protected_Type (Typ) then
1341 Typt := Corresponding_Record_Type (Typ);
1346 -- Note that we do nothing with the discriminants, since Read and
1347 -- Write do not read or write the discriminant values. All handling
1348 -- of discriminants occurs in the Input and Output subprograms.
1350 Rdef := Type_Definition
1351 (Declaration_Node (Base_Type (Underlying_Type (Typt))));
1354 -- In record extension case, the fields we want, including the _Parent
1355 -- field representing the parent type, are to be found in the extension.
1356 -- Note that we will naturally process the _Parent field using the type
1357 -- of the parent, and hence its stream attributes, which is appropriate.
1359 if Nkind (Rdef) = N_Derived_Type_Definition then
1360 Rdef := Record_Extension_Part (Rdef);
1362 if Is_Limited_Type (Typt) then
1363 In_Limited_Extension := True;
1367 if Present (Component_List (Rdef)) then
1368 Append_List_To (Stms,
1369 Make_Component_List_Attributes (Component_List (Rdef)));
1372 Build_Stream_Procedure
1373 (Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read);
1374 end Build_Record_Read_Write_Procedure;
1376 ----------------------------------
1377 -- Build_Record_Write_Procedure --
1378 ----------------------------------
1380 procedure Build_Record_Write_Procedure
1384 Pnam : out Entity_Id)
1387 Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Write);
1388 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
1389 end Build_Record_Write_Procedure;
1391 -------------------------------
1392 -- Build_Stream_Attr_Profile --
1393 -------------------------------
1395 function Build_Stream_Attr_Profile
1398 Nam : TSS_Name_Type) return List_Id
1403 Profile := New_List (
1404 Make_Parameter_Specification (Loc,
1405 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1407 Make_Access_Definition (Loc,
1408 Subtype_Mark => New_Reference_To (
1409 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))));
1411 if Nam /= TSS_Stream_Input then
1413 Make_Parameter_Specification (Loc,
1414 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1415 Out_Present => (Nam = TSS_Stream_Read),
1416 Parameter_Type => New_Reference_To (Typ, Loc)));
1420 end Build_Stream_Attr_Profile;
1422 ---------------------------
1423 -- Build_Stream_Function --
1424 ---------------------------
1426 procedure Build_Stream_Function
1437 -- Construct function specification
1440 Make_Function_Specification (Loc,
1441 Defining_Unit_Name => Fnam,
1443 Parameter_Specifications => New_List (
1444 Make_Parameter_Specification (Loc,
1445 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1447 Make_Access_Definition (Loc,
1448 Subtype_Mark => New_Reference_To (
1449 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))),
1451 Subtype_Mark => New_Occurrence_Of (Typ, Loc));
1454 Make_Subprogram_Body (Loc,
1455 Specification => Spec,
1456 Declarations => Decls,
1457 Handled_Statement_Sequence =>
1458 Make_Handled_Sequence_Of_Statements (Loc,
1459 Statements => Stms));
1460 end Build_Stream_Function;
1462 ----------------------------
1463 -- Build_Stream_Procedure --
1464 ----------------------------
1466 procedure Build_Stream_Procedure
1477 -- Construct procedure specification
1480 Make_Procedure_Specification (Loc,
1481 Defining_Unit_Name => Pnam,
1483 Parameter_Specifications => New_List (
1484 Make_Parameter_Specification (Loc,
1485 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1487 Make_Access_Definition (Loc,
1488 Subtype_Mark => New_Reference_To (
1489 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))),
1491 Make_Parameter_Specification (Loc,
1492 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1493 Out_Present => Outp,
1494 Parameter_Type => New_Occurrence_Of (Typ, Loc))));
1497 Make_Subprogram_Body (Loc,
1498 Specification => Spec,
1499 Declarations => Empty_List,
1500 Handled_Statement_Sequence =>
1501 Make_Handled_Sequence_Of_Statements (Loc,
1502 Statements => Stms));
1503 end Build_Stream_Procedure;
1505 -----------------------------
1506 -- Has_Stream_Standard_Rep --
1507 -----------------------------
1509 function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean is
1511 if Has_Non_Standard_Rep (U_Type) then
1515 Esize (First_Subtype (U_Type)) = Esize (Root_Type (U_Type));
1517 end Has_Stream_Standard_Rep;
1519 ---------------------------------
1520 -- Make_Stream_Subprogram_Name --
1521 ---------------------------------
1523 function Make_Stream_Subprogram_Name
1526 Nam : TSS_Name_Type) return Entity_Id
1531 -- For tagged types, we are dealing with a TSS associated with the
1532 -- declaration, so we use the standard primitive function name. For
1533 -- other types, generate a local TSS name since we are generating
1534 -- the subprogram at the point of use.
1536 if Is_Tagged_Type (Typ) then
1537 Sname := Make_TSS_Name (Typ, Nam);
1539 Sname := Make_TSS_Name_Local (Typ, Nam);
1542 return Make_Defining_Identifier (Loc, Sname);
1543 end Make_Stream_Subprogram_Name;
1545 ----------------------
1546 -- Stream_Base_Type --
1547 ----------------------
1549 function Stream_Base_Type (E : Entity_Id) return Entity_Id is
1551 if Is_Array_Type (E)
1552 and then Is_First_Subtype (E)
1556 return Base_Type (E);
1558 end Stream_Base_Type;