1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
28 with Atree; use Atree;
29 with Einfo; use Einfo;
31 with Namet; use Namet;
32 with Nlists; use Nlists;
33 with Nmake; use Nmake;
34 with Rtsfind; use Rtsfind;
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 Exp_Tss; use Exp_Tss;
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 procedure Build_Stream_Procedure
91 -- Called to build an array or record stream procedure. The first three
92 -- arguments are the same as Build_Record_Or_Elementary_Output_Procedure.
93 -- Stms is the list of statements for the body (the declaration list is
94 -- always null), and Pnam is the name of the constructed procedure.
96 function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean;
97 -- This function is used to test U_Type, which is a type
98 -- Returns True if U_Type has a standard representation for stream
99 -- purposes, i.e. there is no non-standard enumeration representation
100 -- clause, and the size of the first subtype is the same as the size
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 InputN (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 procedure Build_Array_Input_Function
138 Fnam : out Entity_Id)
140 Dim : constant Pos := Number_Dimensions (Typ);
151 Indx := First_Index (Typ);
153 for J in 1 .. Dim loop
154 Lnam := New_External_Name ('L', J);
155 Hnam := New_External_Name ('H', J);
158 Make_Object_Declaration (Loc,
159 Defining_Identifier => Make_Defining_Identifier (Loc, Lnam),
160 Constant_Present => True,
161 Object_Definition => New_Occurrence_Of (Etype (Indx), Loc),
163 Make_Attribute_Reference (Loc,
165 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
166 Attribute_Name => Name_Input,
167 Expressions => New_List (Make_Identifier (Loc, Name_S)))));
170 Make_Object_Declaration (Loc,
171 Defining_Identifier => Make_Defining_Identifier (Loc, Hnam),
172 Constant_Present => True,
174 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
176 Make_Attribute_Reference (Loc,
178 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
179 Attribute_Name => Name_Input,
180 Expressions => New_List (Make_Identifier (Loc, Name_S)))));
184 Low_Bound => Make_Identifier (Loc, Lnam),
185 High_Bound => Make_Identifier (Loc, Hnam)));
190 -- If the first subtype is constrained, use it directly. Otherwise
191 -- build a subtype indication with the proper bounds.
193 if Is_Constrained (Stream_Base_Type (Typ)) then
195 Make_Object_Declaration (Loc,
196 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
198 New_Occurrence_Of (Stream_Base_Type (Typ), Loc)));
201 Make_Object_Declaration (Loc,
202 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
204 Make_Subtype_Indication (Loc,
206 New_Occurrence_Of (Stream_Base_Type (Typ), Loc),
208 Make_Index_Or_Discriminant_Constraint (Loc,
209 Constraints => Ranges))));
213 Make_Attribute_Reference (Loc,
214 Prefix => New_Occurrence_Of (Typ, Loc),
215 Attribute_Name => Name_Read,
216 Expressions => New_List (
217 Make_Identifier (Loc, Name_S),
218 Make_Identifier (Loc, Name_V))),
220 Make_Return_Statement (Loc,
221 Expression => Make_Identifier (Loc, Name_V)));
224 Make_Defining_Identifier (Loc,
226 New_External_Name (Name_uInput, ' ', Increment_Serial_Number));
228 Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
229 end Build_Array_Input_Function;
231 ----------------------------------
232 -- Build_Array_Output_Procedure --
233 ----------------------------------
235 procedure Build_Array_Output_Procedure
239 Pnam : out Entity_Id)
245 -- Build series of statements to output bounds
247 Indx := First_Index (Typ);
250 for J in 1 .. Number_Dimensions (Typ) loop
252 Make_Attribute_Reference (Loc,
254 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
255 Attribute_Name => Name_Write,
256 Expressions => New_List (
257 Make_Identifier (Loc, Name_S),
258 Make_Attribute_Reference (Loc,
259 Prefix => Make_Identifier (Loc, Name_V),
260 Attribute_Name => Name_First,
261 Expressions => New_List (
262 Make_Integer_Literal (Loc, J))))));
265 Make_Attribute_Reference (Loc,
267 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
268 Attribute_Name => Name_Write,
269 Expressions => New_List (
270 Make_Identifier (Loc, Name_S),
271 Make_Attribute_Reference (Loc,
272 Prefix => Make_Identifier (Loc, Name_V),
273 Attribute_Name => Name_Last,
274 Expressions => New_List (
275 Make_Integer_Literal (Loc, J))))));
280 -- Append Write attribute to write array elements
283 Make_Attribute_Reference (Loc,
284 Prefix => New_Occurrence_Of (Typ, Loc),
285 Attribute_Name => Name_Write,
286 Expressions => New_List (
287 Make_Identifier (Loc, Name_S),
288 Make_Identifier (Loc, Name_V))));
291 Make_Defining_Identifier (Loc,
293 New_External_Name (Name_uOutput, ' ', Increment_Serial_Number));
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,
314 (Name_uRead, ' ', Increment_Serial_Number));
316 Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Read);
317 end Build_Array_Read_Procedure;
319 --------------------------------------
320 -- Build_Array_Read_Write_Procedure --
321 --------------------------------------
323 -- The form of the array read/write procedure is as follows:
325 -- procedure pnam (S : access RST, V : [out] Typ) is
327 -- for L1 in V'Range (1) loop
328 -- for L2 in V'Range (2) loop
330 -- for Ln in V'Range (n) loop
331 -- Component_Type'Read/Write (S, V (L1, L2, .. Ln));
338 -- The out keyword for V is supplied in the Read case
340 procedure Build_Array_Read_Write_Procedure
347 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. See 5509-003.
381 if Nam = Name_Read then
382 RW := TSS (Base_Type (Ctyp), Name_uRead);
384 RW := TSS (Base_Type (Ctyp), Name_uWrite);
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,
440 New_External_Name (Name_uWrite, ' ', Increment_Serial_Number));
442 Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Write);
443 end Build_Array_Write_Procedure;
445 ---------------------------------
446 -- Build_Elementary_Input_Call --
447 ---------------------------------
449 function Build_Elementary_Input_Call (N : Node_Id) return Node_Id is
450 Loc : constant Source_Ptr := Sloc (N);
451 P_Type : constant Entity_Id := Entity (Prefix (N));
452 U_Type : constant Entity_Id := Underlying_Type (P_Type);
453 Rt_Type : constant Entity_Id := Root_Type (U_Type);
454 FST : constant Entity_Id := First_Subtype (U_Type);
455 P_Size : constant Uint := Esize (FST);
456 Strm : constant Node_Id := First (Expressions (N));
460 -- Check first for Boolean and Character. These are enumeration types,
461 -- but we treat them specially, since they may require special handling
462 -- in the transfer protocol. However, this special handling only applies
463 -- if they have standard representation, otherwise they are treated like
464 -- any other enumeration type.
466 if Rt_Type = Standard_Boolean
467 and then Has_Stream_Standard_Rep (U_Type)
471 elsif Rt_Type = Standard_Character
472 and then Has_Stream_Standard_Rep (U_Type)
476 elsif Rt_Type = Standard_Wide_Character
477 and then Has_Stream_Standard_Rep (U_Type)
481 -- Floating point types
483 elsif Is_Floating_Point_Type (U_Type) then
485 if Rt_Type = Standard_Short_Float then
488 elsif Rt_Type = Standard_Float then
491 elsif Rt_Type = Standard_Long_Float then
494 else pragma Assert (Rt_Type = Standard_Long_Long_Float);
498 -- Signed integer types. Also includes signed fixed-point types and
499 -- enumeration types with a signed representation.
501 -- Note on signed integer types. We do not consider types as signed for
502 -- this purpose if they have no negative numbers, or if they have biased
503 -- representation. The reason is that the value in either case basically
504 -- represents an unsigned value.
506 -- For example, consider:
508 -- type W is range 0 .. 2**32 - 1;
509 -- for W'Size use 32;
511 -- This is a signed type, but the representation is unsigned, and may
512 -- be outside the range of a 32-bit signed integer, so this must be
513 -- treated as 32-bit unsigned.
515 -- Similarly, if we have
517 -- type W is range -1 .. +254;
520 -- then the representation is unsigned
522 elsif not Is_Unsigned_Type (FST)
524 (Is_Fixed_Point_Type (U_Type)
526 Is_Enumeration_Type (U_Type)
528 (Is_Signed_Integer_Type (U_Type)
529 and then not Has_Biased_Representation (FST)))
531 if P_Size <= Standard_Short_Short_Integer_Size then
534 elsif P_Size <= Standard_Short_Integer_Size then
537 elsif P_Size <= Standard_Integer_Size then
540 elsif P_Size <= Standard_Long_Integer_Size then
547 -- Unsigned integer types, also includes unsigned fixed-point types
548 -- and enumeration types with an unsigned representation (note that
549 -- we know they are unsigned because we already tested for signed).
551 -- Also includes signed integer types that are unsigned in the sense
552 -- that they do not include negative numbers. See above for details.
554 elsif Is_Modular_Integer_Type (U_Type)
555 or else Is_Fixed_Point_Type (U_Type)
556 or else Is_Enumeration_Type (U_Type)
557 or else Is_Signed_Integer_Type (U_Type)
559 if P_Size <= Standard_Short_Short_Integer_Size then
562 elsif P_Size <= Standard_Short_Integer_Size then
565 elsif P_Size <= Standard_Integer_Size then
568 elsif P_Size <= Standard_Long_Integer_Size then
575 else pragma Assert (Is_Access_Type (U_Type));
576 if P_Size > System_Address_Size then
583 -- Call the function, and do an unchecked conversion of the result
584 -- to the actual type of the prefix.
587 Unchecked_Convert_To (P_Type,
588 Make_Function_Call (Loc,
589 Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
590 Parameter_Associations => New_List (
591 Relocate_Node (Strm))));
593 end Build_Elementary_Input_Call;
595 ---------------------------------
596 -- Build_Elementary_Write_Call --
597 ---------------------------------
599 function Build_Elementary_Write_Call (N : Node_Id) return Node_Id is
600 Loc : constant Source_Ptr := Sloc (N);
601 P_Type : constant Entity_Id := Entity (Prefix (N));
602 U_Type : constant Entity_Id := Underlying_Type (P_Type);
603 Rt_Type : constant Entity_Id := Root_Type (U_Type);
604 FST : constant Entity_Id := First_Subtype (U_Type);
605 P_Size : constant Uint := Esize (FST);
606 Strm : constant Node_Id := First (Expressions (N));
607 Item : constant Node_Id := Next (Strm);
612 -- Find the routine to be called
614 -- Check for First Boolean and Character. These are enumeration types,
615 -- but we treat them specially, since they may require special handling
616 -- in the transfer protocol. However, this special handling only applies
617 -- if they have standard representation, otherwise they are treated like
618 -- any other enumeration type.
620 if Rt_Type = Standard_Boolean
621 and then Has_Stream_Standard_Rep (U_Type)
625 elsif Rt_Type = Standard_Character
626 and then Has_Stream_Standard_Rep (U_Type)
630 elsif Rt_Type = Standard_Wide_Character
631 and then Has_Stream_Standard_Rep (U_Type)
635 -- Floating point types
637 elsif Is_Floating_Point_Type (U_Type) then
639 if Rt_Type = Standard_Short_Float then
642 elsif Rt_Type = Standard_Float then
645 elsif Rt_Type = Standard_Long_Float then
648 else pragma Assert (Rt_Type = Standard_Long_Long_Float);
652 -- Signed integer types. Also includes signed fixed-point types and
653 -- signed enumeration types share this circuitry.
655 -- Note on signed integer types. We do not consider types as signed for
656 -- this purpose if they have no negative numbers, or if they have biased
657 -- representation. The reason is that the value in either case basically
658 -- represents an unsigned value.
660 -- For example, consider:
662 -- type W is range 0 .. 2**32 - 1;
663 -- for W'Size use 32;
665 -- This is a signed type, but the representation is unsigned, and may
666 -- be outside the range of a 32-bit signed integer, so this must be
667 -- treated as 32-bit unsigned.
669 -- Similarly, if we have
671 -- type W is range -1 .. +254;
674 -- then the representation is also unsigned.
676 elsif not Is_Unsigned_Type (FST)
678 (Is_Fixed_Point_Type (U_Type)
680 Is_Enumeration_Type (U_Type)
682 (Is_Signed_Integer_Type (U_Type)
683 and then not Has_Biased_Representation (FST)))
685 if P_Size <= Standard_Short_Short_Integer_Size then
688 elsif P_Size <= Standard_Short_Integer_Size then
691 elsif P_Size <= Standard_Integer_Size then
694 elsif P_Size <= Standard_Long_Integer_Size then
701 -- Unsigned integer types, also includes unsigned fixed-point types
702 -- and unsigned enumeration types (note we know they are unsigned
703 -- because we already tested for signed above).
705 -- Also includes signed integer types that are unsigned in the sense
706 -- that they do not include negative numbers. See above for details.
708 elsif Is_Modular_Integer_Type (U_Type)
709 or else Is_Fixed_Point_Type (U_Type)
710 or else Is_Enumeration_Type (U_Type)
711 or else Is_Signed_Integer_Type (U_Type)
713 if P_Size <= Standard_Short_Short_Integer_Size then
716 elsif P_Size <= Standard_Short_Integer_Size then
719 elsif P_Size <= Standard_Integer_Size then
722 elsif P_Size <= Standard_Long_Integer_Size then
729 else pragma Assert (Is_Access_Type (U_Type));
731 if P_Size > System_Address_Size then
738 -- Unchecked-convert parameter to the required type (i.e. the type of
739 -- the corresponding parameter, and call the appropriate routine.
741 Libent := RTE (Lib_RE);
744 Make_Procedure_Call_Statement (Loc,
745 Name => New_Occurrence_Of (Libent, Loc),
746 Parameter_Associations => New_List (
747 Relocate_Node (Strm),
748 Unchecked_Convert_To (Etype (Next_Formal (First_Formal (Libent))),
749 Relocate_Node (Item))));
751 end Build_Elementary_Write_Call;
753 -----------------------------------------
754 -- Build_Mutable_Record_Read_Procedure --
755 -----------------------------------------
757 procedure Build_Mutable_Record_Read_Procedure
761 Pnam : out Entity_Id)
769 Disc := First_Discriminant (Typ);
771 -- Generate Reads for the discriminants of the type.
773 while Present (Disc) loop
775 Make_Selected_Component (Loc,
776 Prefix => Make_Identifier (Loc, Name_V),
777 Selector_Name => New_Occurrence_Of (Disc, Loc));
779 Set_Assignment_OK (Comp);
782 Make_Attribute_Reference (Loc,
783 Prefix => New_Occurrence_Of (Etype (Disc), Loc),
784 Attribute_Name => Name_Read,
785 Expressions => New_List (
786 Make_Identifier (Loc, Name_S),
789 Next_Discriminant (Disc);
792 -- A mutable type cannot be a tagged type, so we generate a new name
793 -- for the stream procedure.
796 Make_Defining_Identifier (Loc,
798 New_External_Name (Name_uRead, ' ', Increment_Serial_Number));
800 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
802 -- Read the discriminants before the rest of the components, so
803 -- that discriminant values are properly set of variants, etc.
804 -- If this is an empty record with discriminants, there are no
805 -- previous statements. If this is an unchecked union, the stream
806 -- procedure is erroneous, because there are no discriminants to read.
808 if Is_Unchecked_Union (Typ) then
811 Make_Raise_Program_Error (Loc,
812 Reason => PE_Unchecked_Union_Restriction));
815 if Is_Non_Empty_List (
816 Statements (Handled_Statement_Sequence (Decl)))
819 (First (Statements (Handled_Statement_Sequence (Decl))), Stms);
821 Set_Statements (Handled_Statement_Sequence (Decl), Stms);
823 end Build_Mutable_Record_Read_Procedure;
825 ------------------------------------------
826 -- Build_Mutable_Record_Write_Procedure --
827 ------------------------------------------
829 procedure Build_Mutable_Record_Write_Procedure
833 Pnam : out Entity_Id)
840 Disc := First_Discriminant (Typ);
842 -- Generate Writes for the discriminants of the type.
844 while Present (Disc) loop
847 Make_Attribute_Reference (Loc,
848 Prefix => New_Occurrence_Of (Etype (Disc), Loc),
849 Attribute_Name => Name_Write,
850 Expressions => New_List (
851 Make_Identifier (Loc, Name_S),
852 Make_Selected_Component (Loc,
853 Prefix => Make_Identifier (Loc, Name_V),
854 Selector_Name => New_Occurrence_Of (Disc, Loc)))));
856 Next_Discriminant (Disc);
859 -- A mutable type cannot be a tagged type, so we generate a new name
860 -- for the stream procedure.
863 Make_Defining_Identifier (Loc,
865 New_External_Name (Name_uWrite, ' ', Increment_Serial_Number));
867 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
869 -- Write the discriminants before the rest of the components, so
870 -- that discriminant values are properly set of variants, etc.
871 -- If this is an unchecked union, the stream procedure is erroneous
872 -- because there are no discriminants to write.
874 if Is_Unchecked_Union (Typ) then
877 Make_Raise_Program_Error (Loc,
878 Reason => PE_Unchecked_Union_Restriction));
881 if Is_Non_Empty_List (
882 Statements (Handled_Statement_Sequence (Decl)))
885 (First (Statements (Handled_Statement_Sequence (Decl))), Stms);
887 Set_Statements (Handled_Statement_Sequence (Decl), Stms);
889 end Build_Mutable_Record_Write_Procedure;
891 -----------------------------------------------
892 -- Build_Record_Or_Elementary_Input_Function --
893 -----------------------------------------------
895 -- The function we build looks like
897 -- function InputN (S : access RST) return Typ is
898 -- C1 : constant Disc_Type_1;
899 -- Discr_Type_1'Read (S, C1);
900 -- C2 : constant Disc_Type_2;
901 -- Discr_Type_2'Read (S, C2);
903 -- Cn : constant Disc_Type_n;
904 -- Discr_Type_n'Read (S, Cn);
905 -- V : Typ (C1, C2, .. Cn)
912 -- The discriminants are of course only present in the case of a record
913 -- with discriminants. In the case of a record with no discriminants, or
914 -- an elementary type, then no Cn constants are defined.
916 procedure Build_Record_Or_Elementary_Input_Function
920 Fnam : out Entity_Id)
936 if Has_Discriminants (Typ) then
937 Discr := First_Discriminant (Typ);
939 while Present (Discr) loop
940 Cn := New_External_Name ('C', J);
943 Make_Object_Declaration (Loc,
944 Defining_Identifier => Make_Defining_Identifier (Loc, Cn),
946 New_Occurrence_Of (Etype (Discr), Loc)));
949 Make_Attribute_Reference (Loc,
950 Prefix => New_Occurrence_Of (Etype (Discr), Loc),
951 Attribute_Name => Name_Read,
952 Expressions => New_List (
953 Make_Identifier (Loc, Name_S),
954 Make_Identifier (Loc, Cn))));
956 Append_To (Constr, Make_Identifier (Loc, Cn));
958 Next_Discriminant (Discr);
963 Make_Subtype_Indication (Loc,
964 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
966 Make_Index_Or_Discriminant_Constraint (Loc,
967 Constraints => Constr));
969 -- If no discriminants, then just use the type with no constraint
972 Odef := New_Occurrence_Of (Typ, Loc);
976 Make_Object_Declaration (Loc,
977 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
978 Object_Definition => Odef));
981 Make_Attribute_Reference (Loc,
982 Prefix => New_Occurrence_Of (Typ, Loc),
983 Attribute_Name => Name_Read,
984 Expressions => New_List (
985 Make_Identifier (Loc, Name_S),
986 Make_Identifier (Loc, Name_V))),
988 Make_Return_Statement (Loc,
989 Expression => Make_Identifier (Loc, Name_V)));
991 -- For tagged types, we use a canonical name so that it matches the
992 -- primitive spec. For all other cases, we use a serialized name so
993 -- that multiple generations of the same procedure do not clash.
995 if Is_Tagged_Type (Typ) then
996 Fnam := Make_Defining_Identifier (Loc, Name_uInput);
999 Make_Defining_Identifier (Loc,
1001 New_External_Name (Name_uInput, ' ', Increment_Serial_Number));
1004 Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
1005 end Build_Record_Or_Elementary_Input_Function;
1007 -------------------------------------------------
1008 -- Build_Record_Or_Elementary_Output_Procedure --
1009 -------------------------------------------------
1011 procedure Build_Record_Or_Elementary_Output_Procedure
1015 Pnam : out Entity_Id)
1023 -- Note that of course there will be no discriminants for the
1024 -- elementary type case, so Has_Discriminants will be False.
1026 if Has_Discriminants (Typ) then
1027 Disc := First_Discriminant (Typ);
1029 while Present (Disc) loop
1031 Make_Attribute_Reference (Loc,
1033 New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc),
1034 Attribute_Name => Name_Write,
1035 Expressions => New_List (
1036 Make_Identifier (Loc, Name_S),
1037 Make_Selected_Component (Loc,
1038 Prefix => Make_Identifier (Loc, Name_V),
1039 Selector_Name => New_Occurrence_Of (Disc, Loc)))));
1041 Next_Discriminant (Disc);
1046 Make_Attribute_Reference (Loc,
1047 Prefix => New_Occurrence_Of (Typ, Loc),
1048 Attribute_Name => Name_Write,
1049 Expressions => New_List (
1050 Make_Identifier (Loc, Name_S),
1051 Make_Identifier (Loc, Name_V))));
1053 -- For tagged types, we use a canonical name so that it matches the
1054 -- primitive spec. For all other cases, we use a serialized name so
1055 -- that multiple generations of the same procedure do not clash.
1057 if Is_Tagged_Type (Typ) then
1058 Pnam := Make_Defining_Identifier (Loc, Name_uOutput);
1061 Make_Defining_Identifier (Loc,
1064 (Name_uOutput, ' ', Increment_Serial_Number));
1067 Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
1068 end Build_Record_Or_Elementary_Output_Procedure;
1070 ---------------------------------
1071 -- Build_Record_Read_Procedure --
1072 ---------------------------------
1074 procedure Build_Record_Read_Procedure
1078 Pnam : out Entity_Id)
1081 -- For tagged types, we use a canonical name so that it matches the
1082 -- primitive spec. For all other cases, we use a serialized name so
1083 -- that multiple generations of the same procedure do not clash.
1085 if Is_Tagged_Type (Typ) then
1086 Pnam := Make_Defining_Identifier (Loc, Name_uRead);
1089 Make_Defining_Identifier (Loc,
1091 New_External_Name (Name_uRead, ' ', Increment_Serial_Number));
1094 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
1095 end Build_Record_Read_Procedure;
1097 ---------------------------------------
1098 -- Build_Record_Read_Write_Procedure --
1099 ---------------------------------------
1101 -- The form of the record read/write procedure is as shown by the
1102 -- following example for a case with one discriminant case variant:
1104 -- procedure pnam (S : access RST, V : [out] Typ) is
1106 -- Component_Type'Read/Write (S, V.component);
1107 -- Component_Type'Read/Write (S, V.component);
1109 -- Component_Type'Read/Write (S, V.component);
1111 -- case V.discriminant is
1113 -- Component_Type'Read/Write (S, V.component);
1114 -- Component_Type'Read/Write (S, V.component);
1116 -- Component_Type'Read/Write (S, V.component);
1119 -- Component_Type'Read/Write (S, V.component);
1120 -- Component_Type'Read/Write (S, V.component);
1122 -- Component_Type'Read/Write (S, V.component);
1127 -- The out keyword for V is supplied in the Read case
1129 procedure Build_Record_Read_Write_Procedure
1140 function Make_Component_List_Attributes (CL : Node_Id) return List_Id;
1141 -- Returns a sequence of attributes to process the components that
1142 -- are referenced in the given component list.
1144 function Make_Field_Attribute (C : Entity_Id) return Node_Id;
1145 -- Given C, the entity for a discriminant or component, build
1146 -- an attribute for the corresponding field values.
1148 function Make_Field_Attributes (Clist : List_Id) return List_Id;
1149 -- Given Clist, a component items list, construct series of attributes
1150 -- for fieldwise processing of the corresponding components.
1152 ------------------------------------
1153 -- Make_Component_List_Attributes --
1154 ------------------------------------
1156 function Make_Component_List_Attributes (CL : Node_Id) return List_Id is
1157 CI : constant List_Id := Component_Items (CL);
1158 VP : constant Node_Id := Variant_Part (CL);
1167 Result := Make_Field_Attributes (CI);
1169 -- If a component is an unchecked union, there is no discriminant
1170 -- and we cannot generate a read/write procedure for it.
1172 if Present (VP) then
1173 if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then
1175 Make_Raise_Program_Error (Sloc (VP),
1176 Reason => PE_Unchecked_Union_Restriction));
1179 V := First_Non_Pragma (Variants (VP));
1181 while Present (V) loop
1184 DC := First (Discrete_Choices (V));
1185 while Present (DC) loop
1186 Append_To (DCH, New_Copy_Tree (DC));
1191 Make_Case_Statement_Alternative (Loc,
1192 Discrete_Choices => DCH,
1194 Make_Component_List_Attributes (Component_List (V))));
1195 Next_Non_Pragma (V);
1198 -- Note: in the following, we make sure that we use new occurrence
1199 -- of for the selector, since there are cases in which we make a
1200 -- reference to a hidden discriminant that is not visible.
1203 Make_Case_Statement (Loc,
1205 Make_Selected_Component (Loc,
1206 Prefix => Make_Identifier (Loc, Name_V),
1208 New_Occurrence_Of (Entity (Name (VP)), Loc)),
1209 Alternatives => Alts));
1214 end Make_Component_List_Attributes;
1216 --------------------------
1217 -- Make_Field_Attribute --
1218 --------------------------
1220 function Make_Field_Attribute (C : Entity_Id) return Node_Id is
1223 Make_Attribute_Reference (Loc,
1225 New_Occurrence_Of (Stream_Base_Type (Etype (C)), Loc),
1226 Attribute_Name => Nam,
1227 Expressions => New_List (
1228 Make_Identifier (Loc, Name_S),
1229 Make_Selected_Component (Loc,
1230 Prefix => Make_Identifier (Loc, Name_V),
1231 Selector_Name => New_Occurrence_Of (C, Loc))));
1232 end Make_Field_Attribute;
1234 ---------------------------
1235 -- Make_Field_Attributes --
1236 ---------------------------
1238 function Make_Field_Attributes (Clist : List_Id) return List_Id is
1245 if Present (Clist) then
1246 Item := First (Clist);
1248 -- Loop through components, skipping all internal components,
1249 -- which are not part of the value (e.g. _Tag), except that we
1250 -- don't skip the _Parent, since we do want to process that
1253 while Present (Item) loop
1254 if Nkind (Item) = N_Component_Declaration
1256 (Chars (Defining_Identifier (Item)) = Name_uParent
1258 not Is_Internal_Name (Chars (Defining_Identifier (Item))))
1262 Make_Field_Attribute (Defining_Identifier (Item)));
1270 end Make_Field_Attributes;
1272 -- Start of processing for Build_Record_Read_Write_Procedure
1275 -- For the protected type case, use corresponding record
1277 if Is_Protected_Type (Typ) then
1278 Typt := Corresponding_Record_Type (Typ);
1283 -- Note that we do nothing with the discriminants, since Read and
1284 -- Write do not read or write the discriminant values. All handling
1285 -- of discriminants occurs in the Input and Output subprograms.
1287 Rdef := Type_Definition (Declaration_Node (Underlying_Type (Typt)));
1290 -- In record extension case, the fields we want, including the _Parent
1291 -- field representing the parent type, are to be found in the extension.
1292 -- Note that we will naturally process the _Parent field using the type
1293 -- of the parent, and hence its stream attributes, which is appropriate.
1295 if Nkind (Rdef) = N_Derived_Type_Definition then
1296 Rdef := Record_Extension_Part (Rdef);
1299 if Present (Component_List (Rdef)) then
1300 Append_List_To (Stms,
1301 Make_Component_List_Attributes (Component_List (Rdef)));
1304 Build_Stream_Procedure
1305 (Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read);
1307 end Build_Record_Read_Write_Procedure;
1309 ----------------------------------
1310 -- Build_Record_Write_Procedure --
1311 ----------------------------------
1313 procedure Build_Record_Write_Procedure
1317 Pnam : out Entity_Id)
1320 -- For tagged types, we use a canonical name so that it matches the
1321 -- primitive spec. For all other cases, we use a serialized name so
1322 -- that multiple generations of the same procedure do not clash.
1324 if Is_Tagged_Type (Typ) then
1325 Pnam := Make_Defining_Identifier (Loc, Name_uWrite);
1328 Make_Defining_Identifier (Loc,
1330 New_External_Name (Name_uWrite, ' ', Increment_Serial_Number));
1333 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
1334 end Build_Record_Write_Procedure;
1336 -------------------------------
1337 -- Build_Stream_Attr_Profile --
1338 -------------------------------
1340 function Build_Stream_Attr_Profile
1349 Profile := New_List (
1350 Make_Parameter_Specification (Loc,
1351 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1353 Make_Access_Definition (Loc,
1354 Subtype_Mark => New_Reference_To (
1355 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))));
1357 if Nam /= Name_uInput then
1359 Make_Parameter_Specification (Loc,
1360 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1361 Out_Present => (Nam = Name_uRead),
1362 Parameter_Type => New_Reference_To (Typ, Loc)));
1366 end Build_Stream_Attr_Profile;
1368 ---------------------------
1369 -- Build_Stream_Function --
1370 ---------------------------
1372 procedure Build_Stream_Function
1383 -- Construct function specification
1386 Make_Function_Specification (Loc,
1387 Defining_Unit_Name => Fnam,
1389 Parameter_Specifications => New_List (
1390 Make_Parameter_Specification (Loc,
1391 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1393 Make_Access_Definition (Loc,
1394 Subtype_Mark => New_Reference_To (
1395 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))),
1397 Subtype_Mark => New_Occurrence_Of (Typ, Loc));
1400 Make_Subprogram_Body (Loc,
1401 Specification => Spec,
1402 Declarations => Decls,
1403 Handled_Statement_Sequence =>
1404 Make_Handled_Sequence_Of_Statements (Loc,
1405 Statements => Stms));
1407 end Build_Stream_Function;
1409 ----------------------------
1410 -- Build_Stream_Procedure --
1411 ----------------------------
1413 procedure Build_Stream_Procedure
1424 -- Construct procedure specification
1427 Make_Procedure_Specification (Loc,
1428 Defining_Unit_Name => Pnam,
1430 Parameter_Specifications => New_List (
1431 Make_Parameter_Specification (Loc,
1432 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1434 Make_Access_Definition (Loc,
1435 Subtype_Mark => New_Reference_To (
1436 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))),
1438 Make_Parameter_Specification (Loc,
1439 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1440 Out_Present => Outp,
1441 Parameter_Type => New_Occurrence_Of (Typ, Loc))));
1444 Make_Subprogram_Body (Loc,
1445 Specification => Spec,
1446 Declarations => Empty_List,
1447 Handled_Statement_Sequence =>
1448 Make_Handled_Sequence_Of_Statements (Loc,
1449 Statements => Stms));
1451 end Build_Stream_Procedure;
1453 -----------------------------
1454 -- Has_Stream_Standard_Rep --
1455 -----------------------------
1457 function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean is
1459 if Has_Non_Standard_Rep (U_Type) then
1464 Esize (First_Subtype (U_Type)) = Esize (Root_Type (U_Type));
1466 end Has_Stream_Standard_Rep;
1468 ----------------------
1469 -- Stream_Base_Type --
1470 ----------------------
1472 function Stream_Base_Type (E : Entity_Id) return Entity_Id is
1474 if Is_Array_Type (E)
1475 and then Is_First_Subtype (E)
1480 return Base_Type (E);
1482 end Stream_Base_Type;